packages feed

swarm (empty) → 0.1.0.0

raw patch · 145 files changed

+24973/−0 lines, 145 filesdep +QuickCheckdep +aesondep +array

Dependencies added: QuickCheck, aeson, array, base, brick, bytestring, clock, containers, criterion, directory, dotgen, either, entropy, extra, filepath, fused-effects, fused-effects-lens, githash, hashable, hsnoise, http-client, http-client-tls, http-types, lens, linear, lsp, megaparsec, minimorph, mtl, murmur3, optparse-applicative, parser-combinators, prettyprinter, random, servant, servant-server, simple-enumeration, split, stm, swarm, syb, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, template-haskell, text, time, transformers, unification-fd, unordered-containers, vector, vty, wai, warp, witch, word-wrap, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# Revision history for swarm++## **0.1.0.0** - 2022-10-06++First Swarm release! Swarm already has:++- a programming language based on the polymorphic+  lambda calculus + recursion, with a command monad for describing+  first-class imperative actions+- scenarios which can be loaded from YAML files+  - the release comes with official challenges and an in-game tutorial+  - the default Classic and Creative modes use the same YAML syntax+  - we include JSON schemas for editor support when writing scenarios +- procedural 2D world generation+- LSP server built into the Swarm executable+- Terminal UI interface+  - running the executable opens the Main menu by default+  - game screen with a world view, inventory and REPL+    - popup windows for messages, challenge descriptions, etc.
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Brent Yorgey 2021-2022+SPDX-License-Identifier: BSD-3-Clause++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 Swarm team 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.
+ app/Main.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Foldable qualified+import Data.Text (Text, pack)+import Data.Text.IO qualified as Text+import Options.Applicative+import Swarm.App (appMain)+import Swarm.DocGen (EditorType (..), GenerateDocs (..), SheetType (..), generateDocs)+import Swarm.Language.LSP (lspMain)+import Swarm.Language.Pipeline (processTerm)+import Swarm.TUI.Model (AppOpts (..))+import Swarm.Version+import Swarm.Web (defaultPort)+import System.Exit (exitFailure, exitSuccess)+import System.IO (hPrint, stderr)++data CLI+  = Run AppOpts+  | Format Input+  | DocGen GenerateDocs+  | LSP+  | Version++cliParser :: Parser CLI+cliParser =+  subparser+    ( mconcat+        [ command "format" (info (format <**> helper) (progDesc "Format a file"))+        , command "generate" (info (DocGen <$> docgen <**> helper) (progDesc "Generate docs"))+        , command "lsp" (info (pure LSP) (progDesc "Start the LSP"))+        , command "version" (info (pure Version) (progDesc "Get current and upstream version."))+        ]+    )+    <|> Run <$> (AppOpts <$> seed <*> scenario <*> run <*> cheat <*> webPort)+ where+  format :: Parser CLI+  format =+    (Format Stdin <$ switch (long "stdin" <> help "Read code from stdin"))+      <|> (Format . File <$> strArgument (metavar "FILE"))+  docgen :: Parser GenerateDocs+  docgen =+    subparser . mconcat $+      [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")+      , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords")+      , command "cheatsheet" (info (pure $ CheatSheet $ Just Commands) $ progDesc "Output nice Wiki tables")+      ]+  editor :: Parser (Maybe EditorType)+  editor =+    Data.Foldable.asum+      [ pure Nothing+      , Just VSCode <$ switch (long "code" <> help "Generate for the VS Code editor")+      , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor")+      ]+  seed :: Parser (Maybe Int)+  seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation")+  webPort :: Parser (Maybe Int)+  webPort =+    optional $+      option+        auto+        ( long "web"+            <> metavar "PORT"+            <> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".")+        )+  scenario :: Parser (Maybe String)+  scenario = optional $ strOption (long "scenario" <> short 'c' <> metavar "FILE" <> help "Name of a scenario to load")+  run :: Parser (Maybe String)+  run = optional $ strOption (long "run" <> short 'r' <> metavar "FILE" <> help "Run the commands in a file at startup")+  cheat :: Parser Bool+  cheat = switch (long "cheat" <> short 'x' <> help "Enable cheat mode")++cliInfo :: ParserInfo CLI+cliInfo =+  info+    (cliParser <**> helper)+    ( header ("Swarm game - " <> version <> commitInfo)+        <> progDesc "To play the game simply run without any command."+        <> fullDesc+    )++data Input = Stdin | File FilePath++getInput :: Input -> IO Text+getInput Stdin = Text.getContents+getInput (File fp) = Text.readFile fp++showInput :: Input -> Text+showInput Stdin = "(input)"+showInput (File fp) = pack fp++-- | Utility function to validate and format swarm-lang code+formatFile :: Input -> IO ()+formatFile input = do+  content <- getInput input+  case processTerm content of+    Right _ -> do+      Text.putStrLn content+      exitSuccess+    Left e -> do+      Text.hPutStrLn stderr $ showInput input <> ":" <> e+      exitFailure++showVersion :: IO ()+showVersion = do+  putStrLn $ "Swarm game - " <> version <> commitInfo+  up <- getNewerReleaseVersion+  either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up++main :: IO ()+main = do+  cli <- execParser cliInfo+  case cli of+    Run opts -> appMain opts+    DocGen g -> generateDocs g+    Format fo -> formatFile fo+    LSP -> lspMain+    Version -> showVersion
+ bench/Benchmark.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Main where++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.Int (Int64)+import Linear.V2 (V2 (V2))+import Swarm.Game.CESK (emptyStore, initMachine)+import Swarm.Game.Display (defaultRobotDisplay)+import Swarm.Game.Robot (TRobot, mkRobot)+import Swarm.Game.State (GameState, addTRobot, classicGame0, creativeMode, world)+import Swarm.Game.Step (gameTick)+import Swarm.Game.Terrain (TerrainType (DirtT))+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)++-- | The program of a robot that does nothing.+idleProgram :: ProcessedTerm+idleProgram = [tmQ| {} |]++-- | The program of a robot which waits a random number of ticks, changes its+--   appearence, then waits another random number of ticks, places a tree, and+--   then self-destructs.+treeProgram :: ProcessedTerm+treeProgram =+  [tmQ|+  {+    r <- random 100;+    wait (r + 300);+    appear "|";+    r <- random 100;+    wait (r + 300);+    place "tree";+    selfdestruct+  }+  |]++-- | The program of a robot that moves forward forever.+moverProgram :: ProcessedTerm+moverProgram =+  [tmQ|+    let forever : cmd unit -> cmd unit = \c. c; forever c+    in forever move+  |]++-- | The program of a robot that moves in circles forever.+circlerProgram :: ProcessedTerm+circlerProgram =+  [tmQ|+    let forever : cmd unit -> cmd unit = \c. c; forever c+    in forever (+      move;+      turn right;+      move;+      turn right;+      move;+      turn right;+      move;+      turn right;+    )+  |]++-- | Initializes a robot with program prog at location loc facing north.+initRobot :: ProcessedTerm -> V2 Int64 -> TRobot+initRobot prog loc = mkRobot () Nothing "" [] (Just north) loc 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 :: (V2 Int64 -> TRobot) -> Int -> IO GameState+mkGameState robotMaker numRobots = do+  let robots = [robotMaker (V2 (fromIntegral x) 0) | x <- [0 .. numRobots - 1]]+  Right initState <- runExceptT classicGame0+  execStateT+    (mapM addTRobot robots)+    ( initState+        & creativeMode .~ True+        & world .~ newWorld (WF $ const (fromEnum DirtT, Nothing))+    )++-- | Runs numGameTicks ticks of the game.+runGame :: Int -> GameState -> IO ()+runGame numGameTicks = evalStateT (replicateM_ numGameTicks gameTick)++main :: IO ()+main = do+  idlers <- mkGameStates idleProgram [10, 20 .. 40]+  trees <- mkGameStates treeProgram [10, 20 .. 40]+  circlers <- mkGameStates circlerProgram [10, 20 .. 40]+  movers <- mkGameStates moverProgram [10, 20 .. 40]+  -- In theory we should force the evaluation of these game states to normal+  -- form before running the benchmarks. In practice, the first of the many+  -- criterion runs for each of these benchmarks doesn't look like an outlier.+  defaultMainWith+    (defaultConfig {timeLimit = 10})+    [ bgroup+        "run 1000 game ticks"+        [ bgroup "idlers" (toBenchmarks idlers)+        , bgroup "trees" (toBenchmarks trees)+        , bgroup "circlers" (toBenchmarks circlers)+        , bgroup "movers" (toBenchmarks movers)+        ]+    ]+ where+  mkGameStates :: ProcessedTerm -> [Int] -> IO [(Int, GameState)]+  mkGameStates prog sizes = zip sizes <$> mapM (mkGameState (initRobot prog)) sizes++  toBenchmarks :: [(Int, GameState)] -> [Benchmark]+  toBenchmarks gameStates =+    [ bench (show n) $ whnfAppIO (runGame 1000) gameState+    | (n, gameState) <- gameStates+    ]
+ data/about.txt view
@@ -0,0 +1,9 @@+Copyright 2021-2022, Brent Yorgey and other Swarm contributors+For a full list of contributors, see https://github.com/swarm-game/swarm/graphs/contributors.++Join the community!+IRC: #swarm on libera.chat+Wiki: https://github.com/swarm-game/swarm/wiki++Interested in contributing to Swarm?  All are welcome!  See+https://github.com/swarm-game/swarm/blob/main/CONTRIBUTING.md
+ data/adjectives.txt view
@@ -0,0 +1,109 @@+# Adapted from https://github.com/moby/moby/blob/master/pkg/namesgenerator/names-generator.go+admiring+adoring+affectionate+agitated+amazing+angry+awesome+beautiful+blissful+bold+boring+brave+busy+charming+clever+cool+compassionate+competent+condescending+confident+cranky+crazy+dazzling+determined+distracted+dreamy+eager+ecstatic+elastic+elated+elegant+eloquent+epic+exciting+fervent+festive+flamboyant+focused+friendly+frosty+funny+gallant+gifted+goofy+gracious+great+happy+hardcore+heuristic+hopeful+hungry+infallible+inspiring+interesting+intelligent+jolly+jovial+keen+kind+laughing+loving+lucid+magical+mystifying+modest+musing+naughty+nervous+nice+nifty+nostalgic+objective+optimistic+peaceful+pedantic+pensive+practical+priceless+quirky+quizzical+recursing+relaxed+reverent+romantic+sad+serene+sharp+silly+sleepy+stoic+strange+stupefied+suspicious+sweet+tender+thirsty+trusting+unruffled+upbeat+vibrant+vigilant+vigorous+wizardly+wonderful+xenodochial+youthful+zealous+zen
+ data/entities.yaml view
@@ -0,0 +1,1071 @@+- name: tree+  display:+    attr: plant+    char: 'T'+  description:+  - |+    A tall, living entity made of a tough cellular material called "wood".+    They regrow after being harvested and are an important raw ingredient used+    in making many different devices.+  properties: [portable, growable]+  growth: [500, 600]++- name: branch+  display:+    attr: wood+    char: 'y'+  description:+  - A branch cut from a tree.  It's as if the tree had to make a decision+    and was exploring two options.+  properties: [portable]++- name: log+  display:+    attr: wood+    char: 'l'+  description:+  - A wooden log, obtained by harvesting a tree and cutting off its branches.+  properties: [portable]++- name: board+  display:+    attr: wood+    char: 'w'+  description:+  - A wooden board, made by cutting a log into pieces.+  properties: [portable]++- name: workbench+  display:+    attr: wood+    char: 'π'+  description:+  - A plain wooden workbench, providing space to make other+    things using the `make` command.+  - 'Example:'+  - 'make "log"'+  properties: [portable]+  capabilities: [make]++- name: paper+  display:+    attr: snow+    char: '■'+  description:+  - A flat material made of pressed and dried wood fibers,+    used as a surface on which to inscribe symbols.+  properties: [portable]++- name: PhD thesis+  display:+    attr: snow+    char: 'P'+  description:+  - Perhaps writing one of these will help gain the trust and respect of+    the native inhabitants.+  properties: [portable]++- name: rock+  display:+    attr: rock+    char: 'o'+  description:+  - A medium-sized rock, picked up from the ground or created by drilling.+    Can be used to build a simple furnace, among other things.+  properties: [portable]++- name: lodestone+  display:+    attr: iron+    char: 'o'+  description:+  - A medium-sized rock... that looks a little different.+    It seems to react to iron and surprisingly also to naturally growing bits.+  properties: [portable]+  capabilities: [negation]++- name: boulder+  display:+    attr: rock+    char: '@'+  description:+  - A very large, impassable rock. A drill can be used to get rid of it and turn it into smaller rocks.+  properties: [unwalkable]++- name: mountain+  display:+    attr: snow+    char: 'A'+  description:+  - A mountain. Can be tunneled through with a drill, but it takes time.+  properties: [unwalkable]++- name: mountain tunnel+  display:+    attr: snow+    char: 'Å'+    priority: 11+  description:+  - A tunnel in a mountain through which robots can freely move.+  properties: []++- name: copper ore+  display:+    attr: copper+    char: 'C'+  description:+  - Raw copper ore, useful for making wires, pipes, and other metal things.+    Patches of copper ore can be found on the surface, but are quickly exhausted.+  - Scanners seem to indicate larger quantities of copper could be found beneath some of the+    mountains, but those would require a drill to access and mine.+  properties: [portable]++- name: copper mine+  display:+    attr: copper'+    char: 'Å'+    priority: 11+  description:+  - A copper vein that can be actively mined to produce copper ore.+  properties: []++- name: copper wire+  display:+    attr: copper+    char: '|'+  description:+  - Copper wire is very good at conducting electricity and useful for+    making various types of circuits and machines.+  properties: [portable]++- name: strange loop+  display:+    attr: copper+    char: '8'+  description:+  - Two copper wires twisted together in a strange shape that loops+    back on itself. It must be useful for something...+  properties: [portable]+  capabilities: [recursion]++- name: copper pipe+  display:+    attr: copper+    char: 'I'+  description:+  - A pipe made out of a thin sheet of copper.  Great for transmitting+    water or steam.+  properties: [portable]++- name: iron plate+  display:+    attr: iron+    char: '■'+  description:+  - Worked iron suitable for crafting resilient tools.+  - It also possess some electro-magnetic properties.+  properties: [portable]++- name: iron gear+  display:+    attr: iron+    char: '*'+  description:+  - An iron gear, suitable for constructing larger, more powerful+    machinery than a wooden gear.+  properties: [portable]++- name: iron ore+  display:+    attr: iron+    char: 'F'+  description:+  - Raw iron ore. Used to create more resilient tools than copper.+  - It can only be mined by drilling in the mountains.+  properties: [portable]++- name: iron mine+  display:+    attr: iron'+    char: 'Å'+    priority: 11+  description:+  - An iron vein that can be actively mined to produce iron ore.+  properties: []++- name: quartz+  display:+    attr: quartz+    char: 'Q'+  description:+  - Raw quartz crystals.  Useful for creating devices like clocks, and+    can be processed to extract silicon.+  - It can only be mined by drilling in the mountains.+  properties: [portable]++- name: quartz mine+  display:+    attr: quartz+    char: 'Å'+    priority: 11+  description:+  - A quartz vein that can be actively mined to produce quartz.+  properties: []++- name: silicon+  display:+    attr: quartz+    char: 'S'+  description:+  - Extracted by processing quartz at high temperatures, silicon can+    be used to construct integrated circuits.+  properties: [portable]++- name: deep mine+  display:+    attr: rock+    char: 'Å'+    priority: 11+  description:+  - A deep mine that yields rare and wonderful treasures to those who are patient.+  - But be careful lest you delve too greedily and too deep.+  properties: []++- name: silver+  display:+    attr: silver+    char: '•'+  description:+  - A shiny, metallic substance, noted for its high reflectivity when polished.+  properties: [portable]++- name: gold+  display:+    attr: gold+    char: '•'+  description:+  - A shiny, metallic substance, with applications in specialized electronics.+  - It also seems to be highly valued by local aliens.+  properties: [portable]++- name: mithril+  display:+    attr: silver+    char: 'M'+  description:+  - Mithril can be beaten like copper, and polished like glass.  One+    can also make of it a metal, light and yet harder than tempered+    steel. Its beauty is like to that of common silver, but the beauty+    of mithril does not tarnish or grow dim.+  properties: [portable]++- name: furnace+  display:+    attr: fire+    char: '#'+  description:+  - A furnace can be used to turn metal ore into various useful products.+  properties: [portable]++- name: big furnace+  display:+    attr: fire+    char: '#'+  description:+  - A big furnace can get even hotter than a normal furnace, and can be used+    to process quartz into silicon.+  properties: [portable]++- name: small motor+  display:+    attr: entity+    char: 'm'+  description:+  - A motor is useful for making devices that can turn when electric+    current is applied.+  - This one is rather small, but surprisingly efficient.+  properties: [portable]++- name: big motor+  display:+    attr: entity+    char: 'M'+  description:+  - A motor is useful for making devices that can turn when electric+    current is applied.+  - This one is huge and could be used to construct powerful machinery.+  properties: [portable]++- name: flower+  display:+    attr: flower+    char: '*'+  description:+  - A beautiful flower that grows wild in local meadows.  It is not clear+    what it might be useful for, but it looks nice.+  properties: [portable, growable]+  growth: [30, 50]++- name: cotton+  display:+    attr: silver+    char: 'i'+  description:+  - A plant with tufts of soft fibers that can be harvested and used+    to make things, including sheets of material that the local+    aliens like to drape over their bodies.+  properties: [portable, growable]+  growth: [100, 800]++- name: string+  display:+    attr: silver+    char: '~'+  description:+  - A long, flexible device for transferring either force or+    information, made of twisted cotton fibers.  Multiple strings can+    also be woven into larger configurations such as cloth or nets.+  - |+    A string device enables two commands: the first, `format : a ->+    text`, can turn any value into a suitable text representation.+    The second is the infix operator `++ : text -> text -> text`+    which can be used to concatenate two text values.  For example,+  - |+    "Number of widgets: " ++ format numWidgets+  properties: [portable]+  capabilities: [text]++- name: lambda+  display:+    attr: flower+    char: 'λ'+  description:+  - A wild lambda.  They are somewhat rare, but regrow when picked.  Lambdas+    are delicious when cooked into curry.+  - Lambdas can also be used to create functions. For example,+  - '  def thrice : cmd unit -> cmd unit = \c. c;c;c end'+  - defines the function `thrice` which repeats a command three times.+  properties: [portable, growable]+  growth: [100, 200]+  capabilities: [lambda]++- name: curry+  display:+    attr: flower+    char: 'C'+  description:+  - Delicious curry cooked from wild lambdas.+  properties: [portable]++- name: water+  display:+    attr: water+    char: ' '+  description:+  - Liquid dihydrogen monoxide, which seems to be plentiful on this planet.+  properties: [portable, infinite, liquid]++- name: wavy water+  display:+    attr: water+    char: '~'+  description:+  - A wavy section of water.  The same as normal water, but with more waves.+  properties: [portable, infinite, liquid]+  yields: water++- name: boat+  display:+    attr: wood+    char: 'B'+  description:+  - A robot with a boat installed can float on top of water without drowning.+  - |+    Note: most devices are automatically installed 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 installed on+    a robot, just add the special command `require "boat"` to the robot's program.+  properties: [portable]+  capabilities: [float]++- name: sand+  display:+    attr: sand+    char: '█'+  description:+  - A substance composed mostly of tiny rocks and mineral particles.  It+    tends to be found near water, and can be used in a furnace to make glass.+  properties: [portable, infinite]++- name: glass+  display:+    attr: entity+    char: '□'+  description:+  - A pane of a brittle, clear substance, made from melting sand in a furnace.+  properties: [portable]++- name: LaTeX+  display:+    attr: flower+    char: '$'+  description:+  - A naturally occurring substance derived from trees, useful for producing+    rubber and for typesetting mathematical documents.+  properties: [portable, growable]+  growth: [2000, 3000]++- name: rubber+  display:+    attr: rubber+    char: '%'+  description:+  - A flexible, durable material made from LaTeX.+  properties: [portable]++- name: bit (0)+  display:+    attr: entity+    char: '0'+  description:+  - A bit is used to represent the smallest possible amount of information.+    Useful for constructing various information-processing devices, as well as drills.+  properties: [portable, growable]+  growth: [200, 400]++- name: bit (1)+  display:+    attr: entity+    char: '1'+  description:+  - A bit is used to represent the smallest possible amount of information.+    Useful for constructing various information-processing devices, as well as drills.+  properties: [portable, growable]+  growth: [200, 400]++- name: pixel (R)+  display:+    attr: red+    char: '.'+  description:+  - A tiny picture element, used either to emit or detect red light.+  properties: [portable, growable]+  growth: [1000, 1500]++- name: pixel (G)+  display:+    attr: green+    char: '.'+  description:+  - A tiny picture element, used either to emit or detect green light.+  properties: [portable, growable]+  growth: [1000, 1500]++- name: pixel (B)+  display:+    attr: blue+    char: '.'+  description:+  - A tiny picture element, used either to emit or detect blue light.+  properties: [portable, growable]+  growth: [1000, 1500]++- name: camera+  display:+    attr: device+    char: '@'+  description:+  - A camera is a device for capturing images.+  properties: [portable]++- name: circuit+  display:+    attr: plant+    char: '#'+  description:+  - |+    A circuit is needed for constructing various "smart" devices.+  properties: [portable]++- name: drill bit+  display:+    attr: entity+    char: '!'+  description:+  - A drill bit is the most important component of a drill, and must be made+    out of two bits of opposite parity, for strength.+  properties: [portable]++- name: box+  display:+    attr: wood+    char: '□'+  description:+  - A wooden box.  It can hold things or be used as housing for other devices.+  properties: [portable]++- name: wooden gear+  display:+    attr: wood+    char: '*'+  description:+  - A wooden gear.  Not quite as strong or versatile as an iron gear, but easy to produce.+  properties: [portable]++- name: teeter-totter+  display:+    attr: wood+    char: '/'+  description:+  - A rotating board apparently popular with young aliens.  Perhaps it+    could also be used as a primitive balance scale.+  properties: [portable]++- name: Linux+  display:+    attr: entity+    char: 'L'+  description:+  - A copy of the Linux operating system.+  properties: [portable]++- name: gold coin+  display:+    char: '©'+    attr: gold+  description:+    - A small round shaped piece of gold metal that the aliens pass between+      each other occasionaly.+    - Besides staying shiny it does not appear to have practical use.+  properties: [portable]++############################################################+### Utility ################################################+############################################################++- name: upper left corner+  display:+    attr: entity+    char: '┌'+  description:+    - Upper left corner.+  properties: [unwalkable, known]++- name: upper right corner+  display:+    attr: entity+    char: '┐'+  description:+    - An upper right corner wall.+  properties: [unwalkable, known]++- name: lower left corner+  display:+    attr: entity+    char: '└'+  description:+    - A lower left corner wall.+  properties: [unwalkable, known]++- name: lower right corner+  display:+    attr: entity+    char: '┘'+  description:+    - A lower right corner wall.+  properties: [unwalkable, known]++- name: down and horizontal wall+  display:+    attr: entity+    char: '┬'+  description:+    - A down and horizontal wall.+  properties: [unwalkable, known]++- name: up and horizontal wall+  display:+    attr: entity+    char: '┴'+  description:+    - A up and horizontal wall.+  properties: [unwalkable, known]++- name: left and vertical wall+  display:+    attr: entity+    char: '┤'+  description:+    - A left and vertical wall.+  properties: [unwalkable, known]++- name: right and vertical wall+  display:+    attr: entity+    char: '├'+  description:+    - A right and vertical wall.+  properties: [unwalkable, known]++- name: horizontal wall+  display:+    attr: entity+    char: '─'+  description:+    - A horizontal wall.+  properties: [unwalkable, known]++- name: vertical wall+  display:+    attr: entity+    char: '│'+  description:+    - A vertical wall.+  properties: [unwalkable, known]++############################################################+### Devices ################################################+############################################################++- name: bitcoin+  display:+    char: '₿'+    attr: gold+  description:+    - A beautiful round shaped piece of metal that seems to be of great value+      to the aliens on this planet.+    - Just like the bit it has two sides and when you flip it, it lands perfectly+      randomly on one of the sides.+  properties: [portable]+  capabilities: [random]++- name: treads+  plural: treads+  display:+    attr: device+    char: '%'+  description:+  - Installing 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'+  - The `turn` command takes a direction as an argument, which+    can be either absolute (north, west, east, south) or relative+    (left, right, forward, back, down).+  - 'Example:'+  - '  move; turn left; move; turn right'+  capabilities: [move, turn]+  properties: [portable]++- name: tank treads+  plural: tank treads+  display:+    attr: device+    char: '%'+  description:+  - Tank treads work like treads, but are large enough to move even heavy robots around.+  capabilities: [move, turn, moveheavy]+  properties: [portable]++- name: grabber+  display:+    attr: device+    char: '<'+  description:+  - A grabber arm is an all-purpose, hydraulically controlled device that can+    manipulate other items and robots via the `grab`, `place`, `give`,+    and `install` commands.+  - The `grab` command takes no arguments; it simply grabs whatever is+    available, and also returns the name of the grabbed thing as a string.+    It raises an exception if run in a cell that does not contain an item.+  - The `place` command takes one argument, the name of the item to+    place.  The item is removed from the robot's inventory and placed+    in the robot's current cell (which must be empty).  Raises an+    exception if the operation fails.+  - "The `give` command takes two arguments: the robot to+    give an item to (which can be at most 1 cell away), and the name+    of the item to give. Raises an exception if the operation fails."+  - "The `install` command takes two arguments: the robot+    on which to install a device (which can be at most 1 cell away),+    and the name of the device to install."+  capabilities: [grab, give, place, install]+  properties: [portable]++- name: fast grabber+  display:+    attr: device+    char: '≪'+  description:+  - A fast grabber is an improved version of the basic grabber - not only+    can it 'grab', 'place', 'give', and 'install', it can also 'swap'.+  - The 'swap' command allows the robot to execute grab and place at the+    same time so that the location where the robot is standing does not+    become empty.+  - You can use this to prevent failures where multiple robots+    are trying to grab, place or scan a given location.+  - In addition you retain the capability to use the 'atomic' command,+    with which you can implement other commands that are safe when+    run in parallel.+  capabilities: [grab, swap, give, place, install, atomic]+  properties: [portable]++- name: harvester+  display:+    attr: device+    char: '≤'+  description:+  - A harvester can be used via the `harvest` command, which is+    almost identical to the `grab` command.  The big difference+    is that some entities, when harvested instead of grabbed,+    leave behind a seed which will eventually grow into another copy+    of the original entity.+  - For entities which do not grow, `harvest` behaves exactly the same+    as `grab`.+  capabilities: [grab, harvest, place]+  properties: [portable]++- name: toolkit+  display:+    attr: device+    char: 'Ѣ'+  description:+  - "A toolkit can be used, via the `salvage` command, to take apart old robots."+  - "`salvage` takes no arguments. It looks for an inactive+    robot (one which is not currently running a program) in the+    current cell. If an inactive robot is found, its log (if any) is+    downloaded and it is dismantled, transferring its knowledge, devices, and inventory to the+    robot running `salvage`.  If no inactive robots are found in the+    current cell, `salvage` does nothing."+  capabilities: [salvage]+  properties: [portable]++- name: solar panel+  display:+    attr: device+    char: '#'+  description:+  - An extremely efficient solar panel, capable of generating sufficient power+    from ambient starlight alone. A robot powered by one of these can operate any time,+    including on cloudy days and at night.+  capabilities: [power]+  properties: [portable]++- name: drill+  display:+    attr: device+    char: '!'+  description:+  - A drill allows robots to drill through rocks and mountains, and extract resources from mines.+  capabilities: [drill]+  properties: [portable]++- name: metal drill+  display:+    attr: iron+    char: '!'+  description:+  - A metal drill allows robots to drill through rocks and mountains,+     and extract resources from mines, faster than a regular drill.+  - A metal drill is also able to drill deeper than a regular drill.  Thus, some resources+    are only reachable using a metal drill.+  capabilities: [drill]+  properties: [portable]++- name: typewriter+  display:+    attr: device+    char: 'Д'+  description:+  - A typewriter is used to inscribe symbols on paper, thus reifying pure, platonic+    information into a physical form.+  properties: [portable]++- name: 3D printer+  display:+    attr: device+    char: '3'+  description:+  - A 3D printer gives you the capability of printing more robots! You+    can access the 3D printer via the `build` command.+  - 'Example:'+  - '  build {move; grab; turn back; move; give base "tree"}'+  - |+    builds a robot to get the tree on the cell to the+    north (if there is one) and bring it back to the base. The `build` command+    always returns a reference to the newly constructed robot. For example,+  - '  r <- build {move}; view r'+  - |+    builds a robot and then views it.++  properties: [portable]+  capabilities: [build]++- name: dictionary+  display:+    attr: device+    char: 'D'++  description:+  - |+    A dictionary allows a robot to remember definitions and reuse them+    later.  You can access this ability with either a `def` command,+    which creates a name for an expression or command that is+    available from then on, or with a `let` 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.++  properties: [portable]+  capabilities: [env]++- name: branch predictor+  display:+    attr: device+    char: 'y'+  description:+  - |+    A branch predictor is a device which allows a robot to interpret+    conditional expressions.  The syntax for a conditional expression+    is `if` followed by three arguments: a boolean test and then+    two delayed expressions (i.e. expressions in curly braces) of the same type.+  - 'Example:'+  - 'if (x > 3) {move} {turn right; move}'+  properties: [portable]+  capabilities: [cond]++- name: detonator+  display:+    attr: fire+    char: '*'+  description:+  - An explosive device which can be used to self-destruct, via the+    `selfdestruct` command.  Immediately vaporizes the robot and any+    inventory it is carrying.  Can be useful, say, if you are sending+    out some exploratory robots and don't want them cluttering up the+    world once they are done.+  properties: [portable]+  capabilities: [selfdestruct]++- name: life support system+  display:+    attr: device+    char: 'Ж'+  description:+  - A state-of-the-art life support system which maintains the+    particular temperature and mixture of gases you need to survive.+    It uses a sophisticated recirculating system and can run pretty+    much indefinitely.  Unfortunately, the atmosphere outside is+    severely toxic (why do the inhabitants of this planet need so much+    nitrogen!?), so you'll have to stay inside for now.+  properties: [portable]++- name: scanner+  display:+    attr: device+    char: '$'+  description:+  - "With a scanner device, robots can use the `scan` command to learn+    about their surroundings.  Simply give `scan` a direction in which to scan,+    and information about the scanned item (if any) will be added to the robot's+    inventory."+  - "A scanner also enables the `blocked` command, which returns a+     boolean value indicating whether the robot's path is blocked+     (i.e. whether executing a `move` command would fail)."+  - "Finally, robots can use the `upload` command to copy their accumulated+    knowledge to another nearby robot; for example, `upload base`."+  properties: [portable]+  capabilities: [scan, sensefront, sensehere]++- name: flash memory+  display:+    attr: device+    char: '§'+  description:+  - "A compact, non-volatile memory device, capable of storing+    up to 8 pZ of data."+  - "Flash memory can be used as a component of other devices.  In addition,+     a flash memory device can be used to reprogram other robots using the+     `reprogram` command."+  - "The robot being reprogrammed must be idle, and must possess enough capabilities to run the new command;+     otherwise reprogramming will fail."+  properties: [portable]+  capabilities: [reprogram]++- name: mirror+  display:+    attr: device+    char: 'U'+  description:+  - "With a mirror, robots can reflect on themselves and see their own name."+  - "A mirror enables the `whoami` command, which returns the robot's+     name as a string."+  - "It also enables the special `self` variable, which gives a robot+    a reference to itself."+  properties: [portable]+  capabilities: [whoami]++- name: logger+  display:+    attr: device+    char: 'l'+  description:+  - "Allows a robot to generate and store messages for later viewing,+    using the `log` command, which takes a string.  Log messages are+    also automatically generated by uncaught exceptions."+  properties: [portable]+  capabilities: [log]++- name: hearing aid+  display:+    attr: device+    char: '@'+  description:+  - "Allows a robot to hear what nearby robots are saying."+  - "Simply having this device installed will automatically+     add messages said by nearby robots to this robot's log,+     assuming it has a logger installed."+  - "That way you can view any heard message later either in+     the logger or the message window."+  - "To wait for a message and get the string value, use:"+  - "`l <- listen; log $ \"I have waited for someone to say \" ++ l`"+  properties: [portable]+  capabilities: [listen]++- name: counter+  display:+    attr: device+    char: 'C'+  description:+  - |+    A counter enables the command `count : string -> cmd int`,+    which counts how many occurrences of an entity are currently+    in the inventory.  This is an upgraded version of the `has`+    command, which returns a bool instead of an int and does+    not require any special device.+  properties: [portable]+  capabilities: [count]++- name: calculator+  display:+    attr: device+    char: '+'+  description:+  - "A calculator allows a robot to do basic arithmetic calculations:+    addition, subtraction, multiplication, division, and+    exponentiation."+  properties: [portable]+  capabilities: [arith]++- name: ADT calculator+  display:+    attr: device+    char: '±'+  description:+  - |+    A calculator with Advanced Display Technology (an attached+    typewriter that can print out the results).  For some reason, in+    addition to the usual arithmetic on numbers, an ADT calculator can+    also do arithmetic on types!  After all, the helpful typewritten manual+    explains, a type is just a collection of values, and a finite collection+    of values is just a fancy number.  For example, the type `bool` is+    just a fancy version of the number 2, where the two things happen to be+    labelled `false` and `true`.+  - |+    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+    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+    types, the ADT calculator provides the injection functions `inl :+    a -> a + b` and `inr : b -> a + b`, as well as the case analysis+    function `case : (a + b) -> (a -> c) -> (b -> c) -> c`.  For+    example, `case (inl 3) (\x. 2*x) (\y. 3*y) == 6`, and `case (inr+    3) (\x. 2*x) (\y. 3*y) == 9`.++  properties: [portable]+  capabilities: [arith, sum, prod]++- name: compass+  display:+    attr: device+    char: 'N'+  description:+  - "A compass gives a robot the ability to orient using cardinal directions: north, south, west, and east."+  - "Example:"+  - "turn west; move; turn north"+  properties: [portable]+  capabilities: [orient]++- name: clock+  display:+    attr: device+    char: '0'+  description:+  - A clock is a device for keeping track of time.  It enables the `wait` and `time` commands.+  - |+    `time : cmd int` returns the current time, measured in game ticks since the beginning of the game.+  - |+    `wait : int -> cmd unit` causes a robot to sleep for a specified amount of time (measured in game ticks).+  properties: [portable]+  capabilities: [time]++- name: comparator+  display:+    attr: device+    char: '>'+  description:+  - "A comparator allows comparing two values to see whether the first+    is less, equal, or greater than the second."+  - "Valid comparison operators are <, <=, >, >=, ==, and !=."+  properties: [portable]+  capabilities: [compare]++- name: I/O cable+  display:+    attr: device+    char: 'Ю'+  description:+  - An I/O cable can be used to communicate with an adjacent robot.+  properties: [portable]++- name: rubber band+  display:+    attr: device+    char: 'O'+  description:+  - "A rubber band can tie multiple commands together so that other robots can't execute+    commands in between them.  It can be used via the `atomic` command. For example, suppose+    robot A executes the following code:"+  - |+    b <- ishere "rock"; if b {grab} {}++  - "This seems like a safe way to execute `grab` only when there is a+    rock to grab.  However, it is actually possible for the `grab` to+    fail, if some other robot B snatches the rock right after robot A sensed+    it and before robot A got around to grab it on the next game tick."+  - "This will make robot A very sad and it will crash."+  - "To prevent this situation, robot A can wrap the commands in `atomic`, like so:"+  - |+    atomic (b <- ishere "rock"; if b {grab} {})++  properties: [portable]+  capabilities: [atomic]++- name: net+  display:+    attr: silver+    char: '#'+  description:+  - A net is a device woven out of many strings.  With a net+    installed, you can use the `try` command to catch errors. For example,+  - |+    `try {move} {turn left}`+  - will attempt to move, but if that fails, turn left instead.+  properties: [portable]+  capabilities: [try]
+ data/logo.txt view
@@ -0,0 +1,9 @@+                     v                                      +                                                            +   v<^vv<<@   ^^     vv    >^v^T    ^^^v<     <><      v   >+ T  ^<        >^  <  >>   v>   v<   >T   <v>  <<▒^  @><>    +    <@v^^>>   @v  >  <T  <v<T<^^>   v><v<     << <<T^ v<    +   >     >>   v@ @@> <<   ~v   <    >~  ^~    >>  @^  >v    +    >>^v^^^    < ~ T~v    v<   <~   >>T  <v   vv      ▒>    +                              ▒                             +                     ^      ^     v       >      >
+ data/names.txt view
@@ -0,0 +1,238 @@+# Adapted from https://github.com/moby/moby/blob/master/pkg/namesgenerator/names-generator.go+agnesi+albattani+allen+almeida+antonelli+archimedes+ardinghelli+aryabhata+austin+babbage+banach+banzai+bardeen+bartik+bassi+beaver+bell+benz+bhabha+bhaskara+black+blackburn+blackwell+bohr+booth+borg+bose+bouman+boyd+brahmagupta+brattain+brown+buck+burnell+cannon+carson+cartwright+carver+cerf+chandrasekhar+chaplygin+chatelet+chatterjee+chaum+chebyshev+clarke+cohen+colden+cori+cray+curran+curie+darwin+davinci+dewdney+dhawan+diffie+dijkstra+dirac+driscoll+dubinsky+easley+edison+einstein+elbakyan+elgamal+elion+ellis+engelbart+euclid+euler+faraday+feistel+fermat+fermi+feynman+franklin+gagarin+galileo+galois+ganguly+gates+gauss+germain+goldberg+goldstine+goldwasser+golick+goodall+gould+greider+grothendieck+haibt+hamilton+haslett+hawking+hellman+heisenberg+hermann+herschel+hertz+heyrovsky+hodgkin+hofstadter+hoover+hopper+hugle+hypatia+ishizaka+jackson+jang+jemison+jennings+jepsen+johnson+joliot+jones+kalam+kapitsa+kare+keldysh+keller+kepler+khayyam+khorana+kilby+kirch+knuth+kowalevski+lalande+lamarr+lamport+leakey+leavitt+lederberg+lehmann+lewin+lichterman+liskov+lovelace+lumiere+mahavira+margulis+matsumoto+maxwell+mayer+mccarthy+mcclintock+mclaren+mclean+mcnulty+mendel+mendeleev+meitner+meninsky+merkle+mestorf+mirzakhani+montalcini+moore+morse+murdock+moser+napier+nash+neumann+newton+nightingale+nobel+noether+northcutt+noyce+panini+pare+pascal+pasteur+payne+perlman+pike+poincare+poitras+proskuriakova+ptolemy+raman+ramanujan+ride+ritchie+rhodes+robinson+roentgen+rosalind+rubin+saha+sammet+sanderson+satoshi+shamir+shannon+shaw+shirley+shockley+shtern+sinoussi+snyder+solomon+spence+stonebraker+sutherland+swanson+swartz+swirles+taussig+tereshkova+tesla+tharp+thompson+torvalds+tu+turing+varahamihira+vaughan+villani+visvesvaraya+volhard+wescoff+wilbur+wiles+williams+williamson+wilson+wing+wozniak+wright+wu+yalow+yonath+zhukovsky
+ data/recipes.yaml view
@@ -0,0 +1,721 @@+#########################################+##                WOOD                 ##+#########################################++- in:+  - [1, tree]+  out:+  - [2, branch]+  - [1, log]++- in:+  - [1, log]+  out:+  - [4, board]++- in:+  - [1, log]+  - [8, water]+  out:+  - [8, paper]++- in:+  - [32, paper]+  - [1, flash memory]+  out:+  - [1, dictionary]++- in:+  - [256, paper]+  - [1, LaTeX]+  required:+  - [1, big furnace]+  out:+  - [1, PhD thesis]+  time: 65536++- in:+  - [1, log]+  out:+  - [1, logger]++- in:+  - [1, board]+  - [2, branch]+  out:+  - [1, workbench]++- in:+  - [2, branch]+  out:+  - [1, branch predictor]++- in:+  - [6, board]+  out:+  - [1, box]++- in:+  - [5, board]+  out:+  - [1, boat]++- in:+  - [2, board]+  out:+  - [1, wooden gear]++- in:+  - [1, board]+  - [2, wooden gear]+  out:+  - [1, teeter-totter]++- in:+  - [1, teeter-totter]+  - [2, copper wire]+  out:+  - [1, comparator]++- in:+  - [2, board]+  - [2, wooden gear]+  - [1, box]+  out:+  - [1, harvester]++- in:+  - [1, circuit]+  - [1, board]+  - [8, wooden gear]+  out:+  - [1, typewriter]++#########################################+##                BITS                 ##+#########################################++- in:+  - [1, bit (0)]+  - [1, bit (1)]+  out:+  - [1, drill bit]++- in:+  - [1, bit (0)]+  out:+  - [1, bit (1)]+  required:+  - [1, lodestone]++- in:+  - [1, bit (1)]+  out:+  - [1, bit (0)]+  required:+  - [1, lodestone]++- in:+  - [8, bit (0)]+  - [8, bit (1)]+  out:+  - [1, flash memory]++- in:+  - [1, flash memory]+  - [8, wooden gear]+  out:+  - [1, counter]++#########################################+##                STONE                ##+#########################################++- in:+  - [1, boulder]+  out:+  - [3, rock]+  required:+  - [1, drill]+  time: 9+  weight: 3++- in:+  - [1, boulder]+  out:+  - [4, rock]+  required:+  - [1, drill]+  time: 9+  weight: 1++- in:+  - [1, boulder]+  out:+  - [3, rock]+  required:+  - [1, metal drill]+  time: 3+  weight: 3++- in:+  - [1, boulder]+  out:+  - [4, rock]+  required:+  - [1, metal drill]+  time: 3+  weight: 3++- in:+  - [1, mountain]+  out:+  - [8, rock]+  - [1, mountain tunnel]+  required:+  - [1, drill]+  time: 90+  weight: 16++- in:+  - [1, mountain]+  out:+  - [8, lodestone]+  - [4, iron ore]+  - [1, mountain tunnel]+  required:+  - [1, drill]+  time: 90+  weight: 1++- in:+  - [1, mountain]+  out:+  - [16, rock]+  - [1, mountain tunnel]+  required:+  - [1, metal drill]+  time: 9+  weight: 160++- in:+  - [1, mountain]+  out:+  - [16, lodestone]+  - [8, iron ore]+  - [1, mountain tunnel]+  required:+  - [1, metal drill]+  time: 9+  weight: 10++- in:+  - [5, rock]+  out:+  - [1, furnace]++- in:+  - [10, rock]+  - [10, solar panel]+  out:+  - [1, big furnace]++#########################################+##                 METAL               ##+#########################################++## VEINS++- in:+  - [1, mountain]+  out:+  - [1, copper mine]+  - [1, copper ore]+  required:+  - [1, drill]+  time: 42+  weight: 2++- in:+  - [1, mountain]+  out:+  - [1, iron mine]+  - [1, iron ore]+  required:+  - [1, drill]+  time: 64+  weight: 2++- in:+  - [1, mountain]+  out:+  - [1, quartz mine]+  - [1, quartz]+  required:+  - [1, drill]+  time: 64+  weight: 1++- in:+  - [1, mountain]+  out:+  - [1, copper mine]+  - [1, copper ore]+  required:+  - [1, metal drill]+  time: 6+  weight: 10++- in:+  - [1, mountain]+  out:+  - [1, iron mine]+  - [1, iron ore]+  required:+  - [1, metal drill]+  time: 7+  weight: 10++- in:+  - [1, mountain]+  out:+  - [1, quartz mine]+  - [1, quartz]+  required:+  - [1, metal drill]+  time: 7+  weight: 10++## MINES++- in:+  - [1, copper mine]+  out:+  - [1, copper ore]+  - [1, copper mine]+  required:+  - [1, drill]+  time: 42++- in:+  - [1, iron mine]+  out:+  - [1, iron ore]+  - [1, iron mine]+  required:+  - [1, drill]+  time: 64++- in:+  - [1, quartz mine]+  out:+  - [1, quartz]+  - [1, quartz mine]+  required:+  - [1, drill]+  time: 64++- in:+  - [1, copper mine]+  out:+  - [1, copper ore]+  - [1, copper mine]+  required:+  - [1, metal drill]+  time: 6++- in:+  - [1, iron mine]+  out:+  - [1, iron ore]+  - [1, iron mine]+  required:+  - [1, metal drill]+  time: 7++- in:+  - [1, quartz mine]+  out:+  - [1, quartz]+  - [1, quartz mine]+  required:+  - [1, metal drill]+  time: 7++## SMELTING++- in:+  - [1, copper ore]+  - [1, log]+  out:+  - [10, copper wire]+  required:+  - [1, furnace]++- in:+  - [1, copper ore]+  - [1, log]+  out:+  - [2, copper pipe]+  required:+  - [1, furnace]++- in:+  - [1, iron ore]+  - [2, log]+  out:+  - [2, iron plate]+  required:+  - [1, furnace]++- in:+  - [1, copper ore]+  out:+  - [10, copper wire]+  required:+  - [1, big furnace]++- in:+  - [1, copper ore]+  out:+  - [2, copper pipe]+  required:+  - [1, big furnace]++- in:+  - [1, iron ore]+  out:+  - [2, iron plate]+  required:+  - [1, big furnace]++- in:+  - [1, iron plate]+  out:+  - [1, lodestone]+  required:+  - [2, lodestone]+  time: 64++## TOOLS++- in:+  - [1, iron plate]+  out:+  - [2, iron gear]++- in:+  - [1, iron plate]+  - [1, water]+  - [1, box]+  out:+  - [1, compass]+  required:+  - [1, lodestone]++- in:+  - [32, wooden gear]+  - [6, copper wire]+  out:+  - [1, small motor]++- in:+  - [16, iron gear]+  - [6, copper wire]+  out:+  - [1, big motor]++- in:+  - [1, box]+  - [1, drill bit]+  - [1, small motor]+  out:+  - [1, drill]++- in:+  - [1, box]+  - [3, drill bit]+  - [1, big motor]+  out:+  - [1, metal drill]++- in:+  - [1, box]+  - [2, board]+  - [4, copper pipe]+  - [2, iron plate]+  - [2, rubber]+  out:+  - [1, toolkit]++- in:+  - [2, small motor]+  - [8, iron plate]+  - [2, rubber]+  out:+  - [1, treads]++- in:+  - [4, big motor]+  - [64, iron plate]+  - [16, rubber]+  out:+  - [1, tank treads]++- in:+  - [2, copper pipe]+  - [2, iron gear]+  - [1, iron plate]+  - [1, water]+  - [1, small motor]+  out:+  - [1, grabber]++- in:+  - [2, grabber]+  - [1, rubber band]+  out:+  - [1, fast grabber]++- in:+  - [4, circuit]+  - [1, iron plate]+  - [3, copper pipe]+  - [16, iron gear]+  out:+  - [1, 3D printer]++- in:+  - [1, gold]+  out:+  - [8, gold coin]+  required:+  - [1, furnace]++- in:+  - [1, gold]+  out:+  - [8, gold coin]+  required:+  - [1, big furnace]++- in:+  - [1, gold coin]+  - [1, bit (1)]+  - [1, bit (0)]+  required:+  - [1, metal drill]+  out:+  - [1, bitcoin]++## MAGIC++- in:+  - [2, copper wire]+  out:+  - [1, strange loop]++- in:+  - [2, copper pipe]+  - [4, copper wire]+  - [1, paper]+  - [1, lodestone]+  out:+  - [2, hearing aid]+++#########################################+##           QUARTZ + SILICON          ##+#########################################++- in:+  - [4, quartz]+  out:+  - [1, silicon]+  required:+  - [1, big furnace]++- in:+  - [1, quartz]+  - [32, iron gear]+  - [1, glass]+  out:+  - [1, clock]++- in:+  - [4, silicon]+  - [1, strange loop]+  - [16, copper wire]+  - [8, bit (0)]+  - [8, bit (1)]+  out:+  - [1, circuit]++#########################################+##             DEEP MINES              ##+#########################################++- in:+  - [1, mountain]+  out:+  - [1, deep mine]+  required:+  - [1, metal drill]+  time: 512+  weight: 1++- in:+  - [1, deep mine]+  out:+  - [1, copper ore]+  - [1, deep mine]+  required:+  - [1, metal drill]+  time: 64+  weight: 1000++- in:+  - [1, deep mine]+  out:+  - [1, iron ore]+  - [1, deep mine]+  required:+  - [1, metal drill]+  time: 64+  weight: 500++- in:+  - [1, deep mine]+  out:+  - [1, silver]+  - [1, deep mine]+  required:+  - [1, metal drill]+  time: 64+  weight: 50++- in:+  - [1, deep mine]+  out:+  - [1, gold]+  - [1, deep mine]+  required:+  - [1, metal drill]+  time: 64+  weight: 20++- in:+  - [1, deep mine]+  out:+  - [1, mithril]+  - [1, deep mine]+  required:+  - [1, metal drill]+  time: 64+  weight: 1++#########################################+##               PIXELS                ##+#########################################++- in:+  - [1, glass]+  - [10, pixel (R)]+  - [10, pixel (G)]+  - [10, pixel (B)]+  out:+  - [1, camera]++- in:+  - [1, camera]+  - [1, circuit]+  out:+  - [1, scanner]++#########################################+##                  SAND               ##+#########################################++- in:+  - [1, sand]+  out:+  - [1, glass]+  required:+  - [1, furnace]++- in:+  - [1, glass]+  - [8, copper wire]+  out:+  - [1, solar panel]+  required:+  - [1, 3D printer]++- in:+  - [1, counter]+  - [1, solar panel]+  out:+  - [1, calculator]++- in:+  - [1, calculator]+  - [1, typewriter]+  - [1, I/O cable]+  out:+  - [1, ADT calculator]++- in:+  - [1, glass]+  - [1, silver]+  out:+  - [1, mirror]++#########################################+##                 LAMBDA              ##+#########################################++- in:+  - [5, lambda]+  - [1, water]+  out:+  - [1, curry]++#########################################+##                 LATEX               ##+#########################################++- in:+  - [1, LaTeX]+  - [1, log]+  out:+  - [1, rubber]+  required:+  - [1, furnace]++- in:+  - [8, copper wire]+  - [1, rubber]+  out:+  - [1, I/O cable]++- in:+  - [1, rubber]+  - [1, strange loop]+  out:+  - [1, rubber band]++#########################################+##                COTTON               ##+#########################################++- in:+  - [4, cotton]+  out:+  - [1, string]+  required:+  - [1, small motor]++- in:+  - [256, string]+  out:+  - [1, net]
+ data/scenarios/00-ORDER.txt view
@@ -0,0 +1,7 @@+classic.yaml+creative.yaml+Tutorials+Challenges+Fun+Speedruns+Testing
+ data/scenarios/Challenges/00-ORDER.txt view
@@ -0,0 +1,5 @@+chess_horse.yaml+teleport.yaml+2048.yaml+hanoi.yaml+Mazes
+ data/scenarios/Challenges/2048.yaml view
@@ -0,0 +1,195 @@+version: 1+name: "2048"+author: Brent Yorgey+description: Make 2048!+objectives:+  - goal:+    - OK, OK, it's not really the same as the classic "2048" game.+      However, your goal is still to make 2048!  You start with a `1`+      which regrows immediately when+      it is harvested, so if you plant it, you can get as many as you want.  Your+      job is to combine `1`s in order to make a `2048`+      entity.+    - "Hint: the `format` command can turn numbers into strings!"+    condition: |+      try {+        as base {has "2048"}+      } { return false }+solution: |+  def makeN : int -> cmd unit = \n.+    if (n == 1)+      {harvest; return ()}+      {makeN (n/2); makeN (n/2); make (format n)}+  end;+  place "1";+  makeN 2048+entities:+  - name: "1"+    display:+      attr: gold+      char: "#"+    description:+    - This is a one.  Maybe you can combine it with other ones+      somehow.+    properties: [growable, portable, infinite]+  - name: "2"+    display:+      attr: gold+      char: "#"+    description:+    - This is a two.  Maybe you can combine it with other twos+      somehow.+    properties: [portable]+  - name: "4"+    display:+      attr: gold+      char: "#"+    description:+    - This is a four.  You get the idea.+    properties: [portable]+  - name: "8"+    display:+      attr: gold+      char: "#"+    description:+    - An eight.+    properties: [portable]+  - name: "16"+    display:+      attr: gold+      char: "#"+    description:+    - A 16.+    properties: [portable]+  - name: "32"+    display:+      attr: gold+      char: "#"+    description:+    - A 32.+    properties: [portable]+  - name: "64"+    display:+      attr: gold+      char: "#"+    description:+    - A 64.+    properties: [portable]+  - name: "128"+    display:+      attr: gold+      char: "#"+    description:+    - A 128.+    properties: [portable]+  - name: "256"+    display:+      attr: gold+      char: "#"+    description:+    - A 256.+    properties: [portable]+  - name: "512"+    display:+      attr: gold+      char: "#"+    description:+    - A 512.+    properties: [portable]+  - name: "1024"+    display:+      attr: gold+      char: "#"+    description:+    - A 1024.+    properties: [portable]+  - name: "2048"+    display:+      attr: gold+      char: "#"+    description:+    - A 2048.+    properties: [portable]+recipes:+  - in:+    - [2, "1"]+    out:+    - [1, "2"]+  - in:+    - [2, "2"]+    out:+    - [1, "4"]+  - in:+    - [2, "4"]+    out:+    - [1, "8"]+  - in:+    - [2, "8"]+    out:+    - [1, "16"]+  - in:+    - [2, "16"]+    out:+    - [1, "32"]+  - in:+    - [2, "32"]+    out:+    - [1, "64"]+  - in:+    - [2, "64"]+    out:+    - [1, "128"]+  - in:+    - [2, "128"]+    out:+    - [1, "256"]+  - in:+    - [2, "256"]+    out:+    - [1, "512"]+  - in:+    - [2, "512"]+    out:+    - [1, "1024"]+  - in:+    - [2, "1024"]+    out:+    - [1, "2048"]+robots:+  - name: base+    dir: [1,0]+    display:+      attr: robot+      char: "Ω"+    devices:+      - logger+      - harvester+      - dictionary+      - clock+      - workbench+      - solar panel+      - comparator+      - calculator+      - string+      - life support system+      - branch predictor+      - strange loop+      - lambda+    inventory:+      - [1, "1"]+known: [water, wavy water, flower, tree]+world:+  default: [stone]+  palette:+    "Ω": [grass, null, base]+    "┌": [stone, upper left corner]+    "┐": [stone, upper right corner]+    "└": [stone, lower left corner]+    "┘": [stone, lower right corner]+    "─": [stone, horizontal wall]+    "│": [stone, vertical wall]+  upperleft: [-1, 3]+  map: |+    ┌─┐+    │Ω│+    └─┘
+ data/scenarios/Challenges/Mazes/00-ORDER.txt view
@@ -0,0 +1,4 @@+easy_cave_maze.yaml+easy_spiral_maze.yaml+invisible_maze.yaml+loopy_maze.yaml
+ data/scenarios/Challenges/Mazes/easy_cave_maze.yaml view
@@ -0,0 +1,94 @@+version: 1+name: Cave shaped maze+author: Ondřej Šebek+description: A maze shaped like a cave. It only goes down or forward.+objectives:+- goal:+  - You are at the top of a cave that gradually descends until reaching a dead end.+  - At its bottom is a great treasure.+  - Luckily, the cave does not branch out, so it is easy to find the path to the treasure.+  - Send a robot to the the item marked as '!'. You win once the robot grabs it.+  condition: |+    j <- robotNamed "judge";+    as j {has "goal"}+solution: |+  def until = \p. \c. b <- p; if b {} {c; until p c} end;+  def fwd = until blocked move end;+  build {+    require "branch predictor"; // #540+    turn east;+    until (ishere "goal") (fwd; turn right; fwd; turn left);+    grab+  }+robots:+  - name: base+    dir: [0,1]+    display:+      char: 'Ω'+      attr: robot+    devices:+      - dictionary+      - 3D printer+      - logger+      - grabber+    inventory:+      - [50, solar panel]+      - [50, treads]+      - [50, compass]+      - [50, scanner]+      - [50, lambda]+      - [50, branch predictor]+      - [50, strange loop]+      - [50, logger]+      - [50, grabber]+      - [0, goal]+  - name: judge+    dir: [0,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      until (d <- scan down; return (d == inl ()));+      create "goal"+known: [water]+entities:+  - name: wall+    display:+      char: █+      attr: rock+    description:+    - An impassable stone wall.+    properties: [unwalkable, known]+  - name: goal+    display:+      char: '!'+      attr: device+    description:+    - The place you're trying to reach!  You win by executing `grab` on this item.+    properties: [known, portable]+world:+  default: [ice]+  palette:+    'Ω': [stone, null, base]+    ' ': [stone, null]+    '~': [stone, water]+    '█': [stone, wall]+    '!': [stone, goal, judge]+  upperleft: [0,0]+  map: |+    ██████████████████████████████+    █Ω  ████████ █████████████████+    ███   ██████████████████████ █+    █████ ███████████ ██████████ █+    █████    ███████~███ ███ █████+    ████████ ███████████ ██ ██████+    ███ ████      ██████~█~█ █████+    ██~██████████  █████~~███ █ ██+    ████████ █████  █████████~████+    ███ ███████████   ███████~~███+    ███  █ ███ ██████ ██████~~████+    █ ██ ███   ██████ ████████████+    ██ █   █ ██ █████    █████████+    ██~~~~~~~██~~~██████        !█+    ██████████████████████████████
+ data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml view
@@ -0,0 +1,97 @@+version: 1+name: Spiral shaped maze+author: Ondřej Šebek+description: A maze shaped like a spiral, with a twist!+objectives:+- goal:+  - You find yourself in the middle of a large maze.+  - It's straightforward to get out, but the path is long and dull.+  - You need to send a robot to the goal square, labelled with an exclamation mark;+    you win by `grab`bing the `goal`.+  - Beware! The winding corridors are wider then they look!+  condition: |+    j <- robotNamed "judge";+    as j {has "goal"}+solution: |+  def until = \p. \c. b <- p; if b {} {c; until p c} end;+  def fwd = until blocked move end;+  build {+    require "branch predictor"; // #540+    turn west;+    until (ishere "goal") (fwd; turn right);+    grab+  }+robots:+  - name: base+    dir: [0,1]+    display:+      char: 'Ω'+      attr: robot+    devices:+      - dictionary+      - 3D printer+      - logger+      - grabber+    inventory:+      - [50, solar panel]+      - [50, treads]+      - [50, compass]+      - [50, scanner]+      - [50, lambda]+      - [50, branch predictor]+      - [50, strange loop]+      - [50, logger]+      - [50, grabber]+      - [0, goal]+  - name: judge+    dir: [0,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      until (d <- scan down; return (d == inl ()));+      create "goal"+entities:+  - name: wall+    display:+      char: █+      attr: rock+    description:+    - An impassable stone wall.+    properties: [unwalkable, known]+  - name: goal+    display:+      char: '!'+      attr: device+    description:+    - The place you're trying to reach!  You win by executing `grab` on this item.+    properties: [known, portable]+world:+  default: [ice]+  palette:+    'Ω': [stone, null, base]+    ' ': [stone, null]+    '█': [stone, wall]+    '!': [stone, goal, judge]+  upperleft: [0,0]+  map: |+    ████████████████████████████████████+    ██                                ██+    ██  ████████████████████████████  ██+    ██  ██                        ██  ██+    ██  ██  ████████████████████  ██  ██+    ██  ██  ██                ██  ██  ██+    ██  ██  ██  ████████████  ██  ██  ██+    ██  ██  ██  ██        ██  ██  ██  ██+    ██  ██  ██  ██  ████  ██  ██  ██  ██+    ██  ██  ██  ██   Ω██  ██  ██  ██  ██+    ██  ██  ██  ████████  ██  ██  ██  ██+    ██  ██  ██            ██  ██  ██  ██+    ██  ██  ████████████████  ██  ██  ██+    ██  ██                    ██  ██  ██+    ██  ████████████████████████  ██  ██+    ██                            ██  ██+    ████████████████████████████████  ██+    █!                                ██+    ████████████████████████████████████
+ data/scenarios/Challenges/Mazes/invisible_maze.yaml view
@@ -0,0 +1,99 @@+version: 1+name: Invisible maze+author: Brent Yorgey+description: There is a maze, but it can't be seen, only sensed... can you+  program a robot to navigate it successfully?+objectives:+- goal:+  - There is a maze, but it can't be seen, only sensed... can you+    program a robot to navigate it successfully?  You need to get a robot+    to the goal square, labelled with an exclamation mark; you win by `grab`bing+    the `goal`.+  - In this challenge, it is guaranteed that the maze is a tree, that is,+    there are no loops within the maze.+  condition: |+    try {+      teleport self (27, -17);+      b <- ishere "goal";+      return (not b)+    } { return false }+solution: |+  def tL = turn left end;+  def tR = turn right end;+  def ifC = \test. \then. \else. b <- test; if b then else end;+  def forever = \c. c ; forever c end;+  def rightBlocked = tR; b <- blocked; tL; return b end;+  def mazeStep = ifC rightBlocked {ifC blocked {tL} {move}} {tR; move} end;+  build {+    require "treads"; require "branch predictor"; require "lambda";+    require "strange loop"; require "scanner"; require "grabber";   // #540++    forever (mazeStep; ifC (ishere "goal") {grab; return ()} {})+  }+robots:+  - name: base+    dir: [0,1]+    display:+      char: 'Ω'+      attr: robot+    devices:+      - dictionary+      - 3D printer+      - logger+      - grabber+    inventory:+      - [50, solar panel]+      - [50, treads]+      - [50, compass]+      - [50, scanner]+      - [50, lambda]+      - [50, branch predictor]+      - [50, strange loop]+      - [50, logger]+      - [50, grabber]+      - [0, boulder]+      - [0, goal]+entities:+  - name: wall+    display:+      invisible: true+    description:+    - An invisible wall.+    properties: [unwalkable, known]+  - name: goal+    display:+      char: '!'+      attr: device+    description:+    - The place you're trying to reach!  You win by executing `grab` on this item.+    properties: [known, portable]+world:+  default: [grass]+  palette:+    'Ω': [grass, null, base]+    '.': [grass, null]+    'x': [grass, wall]+    '@': [grass, boulder]+    '!': [grass, goal]+  upperleft: [-1,1]+  map: |+    @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@+    @Ω........x...x..............@+    @xx.xxxxx.x.x.xxx....xxxxxxx.@+    @.x.x...x.x.x...xxxx.......x.@+    @.....x.x.x.x.x....xxxxxxxxx.@+    @xxxxxxxx.x.x.xxxx...........@+    @.......x...x....xxxxxxxxxxxx@+    @.xxxxx.xxxxxxxx.x...........@+    @.x.x.x..x.....x.x.xxxxxxxxx.@+    @.x.x.xx.x.xxxxx.x.x.....x...@+    @.x.x.xx.x.x...x.x.x.x.x.x.xx@+    @......x...x.x...x.x.x.x.x...@+    @xxxxxxx.xxx.xxxxx.x.x.x.xxx.@+    @....................x.x.x.x.@+    @xxxxxxxxxxxxxxxxxxxxx.x.x.x.@+    @..x...x...x...x.....x.x.x.x.@+    @x...x...x...x...x.x.x.x.x.x.@+    @xxxxxxxxxxxxxxxxx.x.x.x.x.x.@+    @..................x...x...x!@+    @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+ data/scenarios/Challenges/Mazes/loopy_maze.yaml view
@@ -0,0 +1,89 @@+version: 1+name: Invisible, loopy maze+author: Brent Yorgey+description: There is a maze, but it can't be seen, only sensed... can you+  program a robot to navigate it successfully?+objectives:+- goal:+  - There is a maze, but it can't be seen, only sensed... can you+    program a robot to navigate it successfully?  You need to get a robot+    to the goal square, labelled with an exclamation mark; you win by `grab`bing+    the `goal`.+  - In this challenge, you are NOT guaranteed that the maze is a tree, that is,+    the maze may contain loops.+  condition: |+    try {+      teleport self (27, -17);+      b <- ishere "goal";+      return (not b)+    } { return false }+solution: |+  run "data/scenarios/Challenges/Mazes/loopy_maze_sol.sw"+robots:+  - name: base+    dir: [0,1]+    display:+      char: 'Ω'+      attr: robot+    devices:+      - dictionary+      - 3D printer+      - logger+      - grabber+    inventory:+      - [50, solar panel]+      - [50, treads]+      - [50, compass]+      - [50, scanner]+      - [50, lambda]+      - [50, branch predictor]+      - [50, strange loop]+      - [50, logger]+      - [50, grabber]+      - [1000, rock]+      - [0, boulder]+      - [0, goal]+entities:+  - name: wall+    display:+      invisible: true+    description:+    - An invisible wall.+    properties: [unwalkable, known]+  - name: goal+    display:+      char: '!'+      attr: device+    description:+    - The place you're trying to reach!  You win by executing `grab` on this item.+    properties: [known, portable]+world:+  default: [grass]+  palette:+    'Ω': [grass, null, base]+    '.': [grass, null]+    'x': [grass, wall]+    '@': [grass, boulder]+    '!': [grass, goal]+  upperleft: [-1,1]+  map: |+    @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@+    @.........x...x..............@+    @xx.xxxxx.x.x.xxx....xxxxxxx.@+    @.x.x...x.x.x...xxxx.......x.@+    @.....x.x.x.x.x....xxxxxxxxx.@+    @xx.xxxxx.x.x.xxxx...........@+    @.......x...x....xxxxxxx.xxxx@+    @.xxxxx.xxx.xxxx.x...........@+    @.x.x.x..x...Ω...x.xxx.xxxxx.@+    @.x.x.xx.x.x.xxx.x.x.....x...@+    @.x.x.xx.x.x...x...x.x.x.x.xx@+    @......x...x.x...x.x.x.x.x...@+    @xxxxxxx.xxx.xxxxx.x.x.x.xxx.@+    @....................x.x.x.x.@+    @xxxxxxxxxx.xxxxxxxxxx.x.x.x.@+    @..x...x.......x.....x.x.....@+    @x.......x...x...x.x.x.x.x.x.@+    @xxxxxxxxxx.xxxxxx.x.x.x.x.x.@+    @..................x...x...x!@+    @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+ data/scenarios/Challenges/Mazes/loopy_maze_sol.sw view
@@ -0,0 +1,22 @@+def tL = turn left end;+def tR = turn right end;+def tB = turn back end;+def ifM = \p.\t.\e. b <- p; if b t e end;+def DFS =+  ifM (ishere "goal") {grab; return ()} {};+  ifM (ishere "rock") {} {+    place "rock";+    tL; b <- blocked; if b {} {move; DFS};+    tR; b <- blocked; if b {} {move; DFS};+    tR; b <- blocked; if b {} {move; DFS};+    tL+  };+  tB; move; tB+end;+build {+  require "treads"; require "scanner"; require "lambda";+  require "strange loop"; require "branch predictor";+  require "grabber";  // #540++  require 500 "rock"; DFS+}
+ data/scenarios/Challenges/chess_horse.yaml view
@@ -0,0 +1,58 @@+version: 1+name: Chess Knight+author: Ondřej Šebek+description: In this quirky challenge, you move as the chess knight piece. Can you capture the enemy king?+objectives:+  - goal:+      - Robots can use the 'move' command to move.+        But they only 'turn' in cardinal directions. +      - You are special. You are a knight. +      - Go forth and capture the King!+    condition: |+      try {+        bloc <- as base {whereami};+        king <- robotNamed "king";+        kloc <- as king {whereami};+        return (bloc == kloc)+      } { return false }+solution: |+  move; move; move; turn right; move; turn left; move;+robots:+  - name: horse+    loc: [0,0]+    dir: [2,-1]+    devices:+      - treads+      - logger+    inventory: []+    display:+      char: '♘'+  - name: king+    loc: [7,-6]+    dir: [0,0]+    display:+      char: '♚'+known: [water]+world:+  default: [ice, water]+  palette:+    '.': [grass]+    '#': [ice]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌────────┐+    │.#.#.#.#│+    │#.#.#.#.│+    │.#.#.#.#│+    │#.#.#.#.│+    │.#.#.#.#│+    │#.#.#.#.│+    │.#.#.#.#│+    │#.#.#.#.│+    └────────┘
+ data/scenarios/Challenges/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-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-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-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/hanoi.yaml view
@@ -0,0 +1,192 @@+version: 1+name: Towers of Hanoi+author: Ondřej Šebek and Brent Yorgey+description: The classic Towers of Hanoi puzzle with three disks.+objectives:+  - goal:+      - Move all the numbers (traditionally, "disks") from the+        left column to the right column.+      - You may only pick up one disk at a time, and you may never+        place a larger disk on top of a smaller one.+    condition: |+      teleport self (2,-1);+      x <- ishere "one";+      teleport self (2,-2);+      y <- ishere "blocked two";+      teleport self (2,-3);+      z <- ishere "blocked three";+      return (x && y && z)+solution: |+  run "data/scenarios/Challenges/hanoi-solution.sw"+robots:+  - name: base+    dir: [0,-1]+    devices:+      - net+      - treads+      - logger+      - grabber+      - dictionary+      - branch predictor+      - comparator+      - strange loop+      - compass+      - clock+      - scanner+      - ADT calculator+  - name: invariant+    dir: [0,0]+    system: true+    display:+      invisible: true+    devices:+    - logger+    inventory:+    - [1, one]+    - [1, two]+    - [1, three]+    - [1, blocked one]+    - [1, blocked two]+    - [1, blocked three]+    program: |+      // 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+      // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+      // if+      //  0. I stand on unlocked X+      //  1. place noth of me is NOT empty+      // then+      //  - lock X+      run "data/scenarios/Challenges/hanoi-invariant.sw"+  - name: increasing+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory:+    - [1, OK]+    devices:+    - logger+    program: |+      // if+      //  0. all (but max 3) disks in my column are sorted+      // then+      //  - place "OK"+      // else+      //  - try to grab "OK"+      run "data/scenarios/Challenges/hanoi-increasing.sw"+  - name: count+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory:+    - [1, two]+    - [0, three]+    devices:+    - logger+    program: |+      // 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 "data/scenarios/Challenges/hanoi-count.sw"+entities:+  - name: bottom tee+    display:+      char: '┴'+      attr: entity+    description:+    - A bottom tee wall.+    properties: [unwalkable]+  - name: three+    display:+      char: '3'+      attr: gold+    description:+    - A disk of radius 3.+    properties: [portable]+  - name: two+    display:+      char: '2'+      attr: gold+    description:+    - A disk of radius 2.+    properties: [portable]+  - name: one+    display:+      char: '1'+      attr: gold+    description:+    - A disk of radius 1.+    properties: [portable]+  - name: blocked one+    display:+      char: '1'+      attr: entity+    description:+    - A disk of radius 1.+    properties: [unwalkable]+  - name: blocked two+    display:+      char: '2'+      attr: entity+    description:+    - A disk of radius 2.+    properties: [unwalkable]+  - name: blocked three+    display:+      char: '3'+      attr: entity+    description:+    - A disk of radius 3.+    properties: [unwalkable]+  - name: OK+    display:+      char: 'O'+      attr: gold+    description:+      - This entity signals that the column is sorted.+known:+  - bottom tee+  - OK+  - one+  - two+  - three+  - blocked one+  - blocked two+  - blocked three+world:+  default: [grass, null]+  palette:+    ' ': [grass]+    '_': [stone]+    'v': [stone, null, base]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    '┴': [stone, bottom tee]+    '1': [stone, one, invariant]+    '2': [stone, blocked two, invariant]+    '3': [stone, blocked three, invariant]+    '.': [stone, null, invariant]+    '^': [grass, null, increasing]+    'X': [grass, three, count]++  upperleft: [-3, 1]+  map: |+    ┌─────┐+    │__v__│+    │1│.│.│+    │2│.│.│+    │3│.│.│+    └─┴─┴─┘+     ^ ^ ^ +       X
+ data/scenarios/Challenges/teleport.yaml view
@@ -0,0 +1,86 @@+version: 1+name: Portal room+author: Ondřej Šebek+description: An impossible challenge - can you magically jump across the water?+objectives:+  - goal:+      - Get to the other room and grab the lambda.+      - Oh wait.+      - The tunnel is flooded.+      - Just give up then. It is impossible to get there.+    condition: |+      try {+        as base {has "lambda"}+      } { return false }+solution: |+  def w2 = turn back; turn back end;+  def w10 = w2; w2; w2; w2; w2 end;+  turn back; move;move;move; w10; move;move;move; grab+robots:+  - name: base+    loc: [3,0]+    dir: [1,0]+    devices:+      - treads+      - logger+      - grabber+      - dictionary+    inventory:+      - [0, lambda]+  - name: portkey1+    system: true+    display:+      invisible: true+    loc: [0,0]+    dir: [0,0]+    program: |+      def forever = \prog. wait 10; prog; forever prog; end;+      destRob <- robotNamed "portkey2";+      destPos <- as destRob {whereami};+      myPos <- whereami;+      forever (+        basePos <- as base {whereami};+        if (myPos == basePos) {teleport base destPos} {};+      );+  - name: portkey2+    system: true+    display:+      invisible: true+    loc: [16,0]+    dir: [0,0]+    program: |+      def forever = \prog. wait 10; prog; forever prog; end;+      wait 5;+      destRob <- robotNamed "portkey1";+      destPos <- as destRob {whereami};+      myPos <- whereami;+      forever (+        basePos <- as base {whereami};+        if (myPos == basePos) {teleport base destPos} {};+      );+known: [water, wavy water, flower, tree]+world:+  default: [ice, water]+  palette:+    ' ': [ice, water]+    '~': [ice, wavy water]+    '*': [grass, flower]+    'T': [grass, tree]+    '.': [grass]+    '_': [stone]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    'λ': [grass, lambda]+  upperleft: [-1, 3]+  map: |+    ~~   ~         ~    ~+    ~┌─────┐~  ┌─────┐~  +    ┌┘.....└───┘T...*└┐ ~+    │_....._   _..λ.._│  +    └┐.....┌───┐*...T┌┘ ~+    ~└─────┘ ~~└─────┘~  +    ~~~   ~        ~    ~
+ data/scenarios/Fun/00-ORDER.txt view
@@ -0,0 +1,1 @@+GoL.yaml
+ data/scenarios/Fun/GoL.yaml view
@@ -0,0 +1,82 @@+version: 1+name: Conway's Game of Life+author: Brent Yorgey+description: A basic implementation of the rules of the Game of Life.+robots:+  - name: base+    display:+      attr: robot+      char: 'Ω'+    loc: [0,0]+    dir: [1,0]+    devices:+      - treads+      - compass+      - grabber+      - clock+      - logger+    inventory:+      - [1000, rock]+  - name: cell+    system: true+    dir: [0,1]+    display:+      invisible: true+    inventory:+      - [1, rock]+    program: |+      def forever = \c. c; forever c; end;+      def cnt = \x.+        if (x == inl ()) {0} {1}+      end;+      def count3 =+        h <- scan down;+        f <- scan forward;+        b <- scan back;+        return (cnt h + cnt f + cnt b)+      end;+      def mod : int -> int -> int = \a. \b. a - (a/b)*b end;+      def waitUntil = \p.+        b <- p;+        if b {wait 1} {waitUntil p}+      end;+      forever (+        h <- scan down;+        alive <- return (h != inl ());+        n1 <- count3;+        turn left; move; turn right; n2 <- count3;+        turn right; move; move; turn left; n3 <- count3;+        turn left; move; turn right;+        total <- return (n1 + n2 + n3 - if alive {1} {0});+        if (alive && (total < 2 || total > 3))+          { grab; return () }+          { if (not alive && total == 3)+            { place "rock" }+            {}+          };+        // synchronize+        waitUntil (t <- time; return (mod t 0x20 == 0))+      )+world:+  default: [ice]+  palette:+    'o': [ice, rock, cell]+    '.': [ice, null, cell]+  upperleft: [1,-1]+  map: |+    ..............................+    ..............................+    ......o.......................+    .......o......................+    .....ooo......................+    ..............................+    ..............................+    ..............................+    ..............................+    ..............................+    ..............................+    ..............................+    ...............oooooooooo.....+    ..............................+    ..............................+    ..............................
+ data/scenarios/Speedruns/00-ORDER.txt view
@@ -0,0 +1,3 @@+curry.yaml+forester.yaml+mithril.yaml
+ data/scenarios/Speedruns/curry.yaml view
@@ -0,0 +1,35 @@+version: 1+name: Curry+author: Brent Yorgey+description: Race to make a bowl of curry as fast as possible.+  See the Swarm wiki for more information on Swarm speedrunning.+objectives:+  - condition: as base {has "curry"}+robots:+  - name: base+    loc: [0,0]+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - 3D printer+      - dictionary+      - grabber+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [5, 3D printer]+      - [100, treads]+      - [70, grabber]+      - [100, solar panel]+      - [50, scanner]+      - [5, toolkit]+world:+  seed: null+  offset: true
+ data/scenarios/Speedruns/forester.yaml view
@@ -0,0 +1,35 @@+version: 1+name: Forester+author: Brent Yorgey+description: Race to harvest 1024 trees as quickly as possible.+  See the Swarm wiki for more information on Swarm speedrunning.+objectives:+  - condition: as base {n <- count "tree"; return (n >= 1024)}+robots:+  - name: base+    loc: [0,0]+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - 3D printer+      - dictionary+      - grabber+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [5, 3D printer]+      - [100, treads]+      - [70, grabber]+      - [100, solar panel]+      - [50, scanner]+      - [5, toolkit]+world:+  seed: null+  offset: true
+ data/scenarios/Speedruns/mithril.yaml view
@@ -0,0 +1,35 @@+version: 1+name: Mithril+author: Brent Yorgey+description: Race to mine some mithril.+  See the Swarm wiki for more information on Swarm speedrunning.+objectives:+  - condition: as base {has "mithril"}+robots:+  - name: base+    loc: [0,0]+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - 3D printer+      - dictionary+      - grabber+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [5, 3D printer]+      - [100, treads]+      - [70, grabber]+      - [100, solar panel]+      - [50, scanner]+      - [5, toolkit]+world:+  seed: null+  offset: true
+ data/scenarios/Testing/00-ORDER.txt view
@@ -0,0 +1,16 @@+373-drill.yaml+394-build-drill.yaml+428-drowning-destroy.yaml+475-wait-one.yaml+490-harvest.yaml+504-teleport-self.yaml+508-capability-subset.yaml+201-require+479-atomic-race.yaml+479-atomic.yaml+555-teleport-location.yaml+562-lodestone.yaml+378-objectives.yaml+684-swap.yaml+699-movement-fail+710-multi-robot.yaml
+ data/scenarios/Testing/201-require/00-ORDER.txt view
@@ -0,0 +1,7 @@+201-require-device.yaml+201-require-device-creative.yaml+201-require-device-creative1.yaml+201-require-entities.yaml+201-require-entities-def.yaml+533-reprogram-simple.yaml+533-reprogram.yaml
+ data/scenarios/Testing/201-require/201-require-device-creative.yaml view
@@ -0,0 +1,42 @@+version: 1+name: Require device in creative mode+description: |+  Require a device using the 'require' command in creative mode.+  https://github.com/swarm-game/swarm/issues/201+objectives:+  - condition: |+      try {+        r <- robotNumbered 1;+        p <- as r {whereami};+        boatInstalled <- as r {installed "boat"};+        b1 <- as r {count "boat"};+        b0 <- as base {count "boat"};+        return (p == (2,0) && b0 == 0 && boatInstalled && b1 == 0);+      } { return false }+creative: true+solution: |+  build {require "boat"; move; move}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - 3D printer+      - logger+known: [water]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '~': [dirt, water]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │.~.│+    └───┘
+ data/scenarios/Testing/201-require/201-require-device-creative1.yaml view
@@ -0,0 +1,53 @@+version: 1+name: Require existing device in creative mode+description: |+  Require a device the base has using the 'require' command in creative mode.+  https://github.com/swarm-game/swarm/issues/201+objectives:+  - condition: |+      try {+        r <- robotNumbered 1;+        p <- as r {whereami};+        boatInstalled <- as r {installed "boat"};+        b1 <- as r {count "boat"};+        b0 <- as base {count "boat"};+        return (p == (2,0) && b0 == 1 && boatInstalled && b1 == 0);+      } { return false }+creative: true+solution: |+  build {require "boat"; move; move}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - 3D printer+    inventory:+      - [1, boat]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '~': [dirt, knownwater]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │.~.│+    └───┘+entities:+  - name: knownwater+    display:+      attr: water+      char: ' '+    description:+    - An infinite ocean of water.+    properties: [known, portable, growable, liquid]+    growth: [0,0]+    yields: water
+ data/scenarios/Testing/201-require/201-require-device.yaml view
@@ -0,0 +1,45 @@+version: 1+name: Require device+description: |+  Require a device using the 'require' command.+  https://github.com/swarm-game/swarm/issues/201+objectives:+  - condition: |+      try {+        r <- robotNumbered 1;+        p <- as r {whereami};+        boatInstalled <- as r {installed "boat"};+        b1 <- as r {count "boat"};+        b0 <- as base {count "boat"};+        return (p == (2,0) && b0 == 0 && boatInstalled && b1 == 0);+      } { return false }+solution: |+  build {require "boat"; move; require "boat"; move}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - 3D printer+      - logger+    inventory:+      - [1, boat]+      - [1, solar panel]+      - [1, treads]+known: [water]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '~': [dirt, water]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │.~.│+    └───┘
+ data/scenarios/Testing/201-require/201-require-entities-def.yaml view
@@ -0,0 +1,46 @@+version: 1+name: Require entities with definition+description: |+  Require some entities using the 'require' command, and a definition.+  https://github.com/swarm-game/swarm/issues/201+objectives:+  - condition: |+      try {+        r <- robotNumbered 1;+        p <- as r {whereami};+        r1 <- as r {count "rock"};+        r0 <- as base {count "rock"};+        return (p == (4,0) && r0 == 5 && r1 == 1);+      } { return false }+solution: |+  def mp = move; place "rock" end;+  build { log "hi"; require 5 "rock"; mp; mp; mp; mp }+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - 3D printer+      - logger+      - dictionary+    inventory:+      - [10, rock]+      - [1, solar panel]+      - [1, treads]+      - [1, grabber]+      - [1, logger]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌─────┐+    │.....│+    └─────┘
+ data/scenarios/Testing/201-require/201-require-entities.yaml view
@@ -0,0 +1,44 @@+version: 1+name: Require entities+description: |+  Require some entities using the 'require' command.+  https://github.com/swarm-game/swarm/issues/201+objectives:+  - condition: |+      try {+        r <- robotNumbered 1;+        r1 <- as r {count "rock"};+        r0 <- as base {count "rock"};+        return (r0 == 5 && r1 == 3);+      } { return false }+solution: |+  build { require 5 "rock"; move; place "rock"; move; place "rock" }+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - 3D printer+      - logger+      - dictionary+    inventory:+      - [10, rock]+      - [1, solar panel]+      - [1, treads]+      - [1, grabber]+      - [1, logger]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │...│+    └───┘
+ data/scenarios/Testing/201-require/533-reprogram-simple.yaml view
@@ -0,0 +1,63 @@+version: 1+name: Install devices while reprogramming+description: |+  While executing 'reprogram', we should install any required devices which+  the target robot doesn't have.+  https://github.com/swarm-game/swarm/pulls/533+objectives:+  - condition: |+      try {+        base_boats <- as base {count "boat"};+        base_solar <- as base {count "solar panel"};+        base_treads <- as base {count "treads"};+        base_drills <- as base {count "metal drill"};++        fred <- robotNamed "fred";+        p <- as fred {whereami};+        boatInstalled <- as fred {installed "boat"};+        drillInstalled <- as fred {installed "metal drill"};+        solarInstalled <- as fred {installed "solar panel"};+        treadsInstalled <- as fred {installed "treads"};++        return (p == (2,0)+                && boatInstalled && drillInstalled && solarInstalled && treadsInstalled+                && base_boats == 1 && base_solar == 1+                && base_treads == 1 && base_drills == 1+               );+      } { return false }+solution: |+  fred <- build {require "boat"; setname "fred"};+  wait 5;+  reprogram fred {require "boat"; require "metal drill"; move; move}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - 3D printer+      - logger+      - flash memory+      - clock+    inventory:+      - [2, boat]+      - [2, solar panel]+      - [2, treads]+      - [2, metal drill]+      - [50, rock]+known: [water]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '~': [dirt, water]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │.~.│+    └───┘
+ data/scenarios/Testing/201-require/533-reprogram.yaml view
@@ -0,0 +1,63 @@+version: 1+name: Install devices + entities while reprogramming+description: |+  While executing 'reprogram', we should install any required devices and+  give required entities which the target robot doesn't have.+  https://github.com/swarm-game/swarm/pulls/533+objectives:+  - condition: |+      try {+        base_boats <- as base {count "boat"};+        base_solar <- as base {count "solar panel"};+        base_treads <- as base {count "treads"};+        base_drills <- as base {count "metal drill"};+        base_rocks <- as base {count "rock"};++        fred <- robotNamed "fred";+        p <- as fred {whereami};+        boatInstalled <- as fred {installed "boat"};+        drillInstalled <- as fred {installed "metal drill"};+        fred_rocks <- as fred {count "rock"};++        return (p == (2,0) && boatInstalled && drillInstalled+                && base_boats == 1 && base_solar == 1+                && base_treads == 1 && base_drills == 1+                && base_rocks == 42 && fred_rocks == 8+               );+      } { return false }+solution: |+  fred <- build {require "boat"; require 5 "rock"; setname "fred"};+  wait 5;+  reprogram fred {require "boat"; require "metal drill"; move; require 3 "rock"; move; require 5 "rock"}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - 3D printer+      - logger+      - flash memory+      - clock+    inventory:+      - [2, boat]+      - [2, solar panel]+      - [2, treads]+      - [2, metal drill]+      - [50, rock]+known: [water]+world:+  default: [blank, null]+  palette:+    '.': [grass]+    '~': [dirt, water]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │.~.│+    └───┘
+ data/scenarios/Testing/373-drill.yaml view
@@ -0,0 +1,126 @@+version: 1+name: Drill test+description: A developer playground for drilling.+objectives:+  - goal:+      - Send robots to mine rock, iron and copper.+    condition: |+      try {+        i <- as base {has "iron ore"};+        c <- as base {has "copper ore"};+        s <- as base {has "rock"};+        return (i && c && s)+      } { return false }+solution: |+  build {+    move; drill forward; turn back; move; turn left;+    move; move; drill left;+    move; drill forward;+    turn back; move; move; move;+    give base "iron ore"; give base "copper ore"; give base "rock"+  }+robots:+  - name: base+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - grabber+      - toolkit+      - 3D printer+    inventory:+      - [2, metal drill]+      - [1, drill]+      - [3, logger]+      - [3, compass]+      - [5, solar panel]+      - [5, treads]+      - [5, grabber]+known: [water, wavy water]+world:+  default: [ice, water]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    ' ': [ice, water]+    '~': [ice, wavy water]+    'L': [grass, Linux]+    'T': [grass, tree]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    'A': [stone, mountain]+    'C': [stone, copper vein]+    '@': [stone, boulder]+    'I': [stone, iron vein]+  upperleft: [-1, 1]+  map: |+    ┌─────┐                                                                ~~+    │IAAT~                                                                ~L~+    │..@AA│                                                                ~~+    │Ω...C│                                                                 ~+    └─────┘                                                                 ~+entities:+  - name: copper vein+    display:+      attr: copper'+      char: 'A'+    description:+    - A place in the mountains where raw copper ore can be mined.+      As it is hidden inside a mountain, a tunnel needs to be+      first drilled through, so that the vein becomes accessible.+    properties: [unwalkable]++  - name: iron vein+    display:+      attr: iron'+      char: 'A'+    description:+    - A place in the mountains where raw iron ore can be mined.+      As it is hidden inside a mountain, a tunnel needs to be+      first drilled through, so that the vein becomes accessible.+    properties: [unwalkable]++recipes:+  ## TOY DRILL+  - in:+    - [1, copper vein]+    out:+    - [1, copper mine]+    - [1, copper ore]+    required:+    - [1, drill]+    time: 42++  - in:+    - [1, iron vein]+    out:+    - [1, iron mine]+    - [1, iron ore]+    required:+    - [1, drill]+    time: 64++  ## METAL DRILL+  - in:+    - [1, copper vein]+    out:+    - [1, copper mine]+    - [1, copper ore]+    required:+    - [1, metal drill]+    time: 6++  - in:+    - [1, iron vein]+    out:+    - [1, iron mine]+    - [1, iron ore]+    required:+    - [1, metal drill]+    time: 7
+ data/scenarios/Testing/378-objectives.yaml view
@@ -0,0 +1,61 @@+version: 1+name: Complete two objectives in succession.+description: |+  First, get some trees; then, use them to build a harvester.+objectives:+  - goal:+      - Your first goal is to get three trees.+    condition: |+      try {+        n <- as base {count "tree"};+        return (n >= 3)+      } { return false }+  - goal:+      - Nice job.  Now, build a harvester.+    condition: |+      try { as base {has "harvester"} } {return false}+solution: |+  build {turn right; move; move; grab; move; grab; move; grab; turn back; move; move; move; move};+  wait 16;+  salvage;+  make "log"; make "log"; make "log";+  make "board"; make "board"; make "board";+  make "box";+  make "wooden gear"; make "wooden gear";+  make "harvester"+robots:+  - name: base+    display:+      char: 'Ω'+      attr: robot+    dir: [0,1]+    devices:+      - 3D printer+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [10, treads]+      - [10, grabber]+      - [10, solar panel]+      - [0, harvester]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    'T': [grass, tree]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌────────┐+    │Ω.TTTTTT│+    └────────┘
+ data/scenarios/Testing/394-build-drill.yaml view
@@ -0,0 +1,52 @@+version: 1+name: Test build with drill+description: |+  Inner build does not correctly require Drill.+  https://github.com/swarm-game/swarm/issues/394+creative: True+objectives:+  - condition: |+      try {+        as base {l <- has "detonator"; return (not l)}+      } { return false }+# When testing, add `s <- build {...}; n <- as s {whoami}; log n` +solution: |+  def forever = \c. c ; forever c end;+  def unblock = try {drill forward} {} end;+  def push = unblock; move end;+  log "Hi, I am base";+  r <- build {+    wait 2;+    log "Hi, I am builder";+    forever (build {log "Hi, I am pusher"; turn forward; forever push}; log "- robot built")+  };+  wait 10;+  place "detonator";+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - treads+      - logger+      - 3D printer+      - dictionary+      - grabber+    inventory:+      - [1, detonator] # used to mark win+world:+  default: [blank]+  palette:+    '.': [grass]+    'M': [stone, mountain]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │..M│+    └───┘
+ data/scenarios/Testing/428-drowning-destroy.yaml view
@@ -0,0 +1,53 @@+version: 1+name: Drowning results in destruction+description: |+  Destroying robots doesn't work.+  https://github.com/swarm-game/swarm/issues/428+objectives:+  - condition: |+      def isAlive = \n. try {+        _ <- robotNamed n;+        log ("Is alive: " ++ n);+        return true+      } { return false } end;+      try {+        baseAlive <- isAlive "base";+        botAlive <- isAlive "bot";+        return (baseAlive && not botAlive);+      } { return false; }++solution: |+  log "start";+  wait 5;+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - treads+      - logger+    program: "move"+  - name: bot+    loc: [0,-1]+    dir: [1,0]+    devices:+      - treads+    program: "move"+known: [water]+world:+  default: [blank]+  palette:+    '.': [grass]+    ' ': [ice, water]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌──┐+    │. │+    │. │+    └──┘
+ data/scenarios/Testing/475-wait-one.yaml view
@@ -0,0 +1,51 @@+version: 1+name: Wait for one tick+description: |+  Robots waiting for one tick should not be put into inactive robot queue.+  https://github.com/swarm-game/swarm/issues/475+# The game state validation is performed in integration test,+# here we just set a robot to wait for one tick, during which+# the base wins.+objectives:+  - condition: |+      try {+        teleport self (0,0);+        ishere "lambda"+      } { return false }+solution: |+  log "I will win next tick!"; place "lambda";+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - grabber+    inventory:+      - [1, lambda]+  - name: sleeper+    loc: [0,-1]+    dir: [1,0]+    devices:+      - logger+      - clock+    program: |+      log "I shall sleep"; wait 1; log "I have awoken"+world:+  default: [blank]+  palette:+    '.': [grass]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    'λ': [grass, lambda]+  upperleft: [-1, 1]+  map: |+    ┌─────┐+    │..λ..│+    │....λ│+    │...λ.│+    └─────┘
+ data/scenarios/Testing/479-atomic-race.yaml view
@@ -0,0 +1,85 @@+# This scenario is specially engineered to almost guarantee a crash+# due to a race condition in short order.+#+#   - The steps per tick is set to 1, so robots are interrupted after+#     every single step, making bugs due to bad interleaving much more+#     probable.+#   - A `weed` entity is used which grows very quickly+#   - `harvest` is used, which causes more weeds to grow in the same spot+#   - A crash happens when the planter robot tests for the presence of a weed+#     and doesn't find one, but then is interrupted and a new weed grows;+#     then the planter robot crashes when it tries to place a weed.+#   - The harvesting robot waits a random number of ticks between 1-4 each+#     time, to give the planting robot time to run into the race condition.+#+# This may work slightly less well once we implement #502, but I think it should+# still work.++version: 1+name: Grab/harvest/place (with race)+description: |+  Make sure we can cause a robot to crash due to a race condition, in order to+  know that atomic blocks are doing their job.+  https://github.com/swarm-game/swarm/issues/479+stepsPerTick: 1+creative: true+objectives:+  - condition: |+      try {+        p <- robotNamed "planter";+        as p {has "Win"}+      } { return false }+solution: |+  def forever = \c. force c ; forever c end+  def tryharvest =+    b <- ishere "weed";+    if b {harvest; n <- random 4; wait n} {}+  end;+  forever {tryharvest}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - harvester+    inventory:+      - [1, lambda]+  - name: planter+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - grabber+    inventory:+      - [25, weed]+    program: |+      def forever = \c. force c ; forever c end+      def tryplant =+        b <- ishere "weed";+        if b {} {place "weed"}+      end;+      forever {try {tryplant} {create "Win"}}+entities:+  - name: weed+    display:+      attr: plant+      char: 'W'+    description:+    - A fast-growing weed.+    properties: [known, portable, growable]+    growth: [1,2]+  - name: Win+    display:+      attr: device+      char: 'W'+    description:+      - You win!+    properties: [known, portable]+world:+  default: [blank]+  palette:+    '.': [grass]+  upperleft: [0,0]+  map: |+    .
+ data/scenarios/Testing/479-atomic.yaml view
@@ -0,0 +1,67 @@+# See also 479-atomic-race.++version: 1+name: Atomic grab/harvest/place+description: |+  'atomic' blocks should be able to prevent crashes due to race conditions+  https://github.com/swarm-game/swarm/issues/479+stepsPerTick: 1+creative: true+objectives:+  - condition: |+      try {+        p <- robotNamed "planter";+        as p {n <- count "weed"; return (n == 0)}+      } { return false }+solution: |+  def forever = \c. force c ; forever c end+  def tryharvest =+    atomic (+      b <- ishere "weed";+      if b {harvest; return ()} {}+    );+    n <- random 4; wait n+  end;+  forever {tryharvest}+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - harvester+    inventory:+      - [1, lambda]+  - name: planter+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - grabber+    inventory:+      - [25, weed]+    program: |+      def forever = \c. force c ; forever c end+      def tryplant =+        atomic (+          b <- ishere "weed";+          if b {} {place "weed"}+        )+      end;+      forever {tryplant}+entities:+  - name: weed+    display:+      attr: plant+      char: 'W'+    description:+    - A fast-growing weed.+    properties: [known, portable, growable]+    growth: [1,2]+world:+  default: [blank]+  palette:+    '.': [grass]+  upperleft: [0,0]+  map: |+    .
+ data/scenarios/Testing/490-harvest.yaml view
@@ -0,0 +1,45 @@+version: 1+name: Test harvest command+description: |+  Test the difference between the grab and harvest commands,+  and test that grab doesn't drain water.+  https://github.com/swarm-game/swarm/issues/490+objectives:+  - condition: |+      try {+        turn east; move;+        t1 <- ishere "tree";+        move;+        t2 <- ishere "tree";+        t3 <- as base {n <- count "water"; return (n == 4)};+        return (t1 && not t2 && t3)+      } { return false }+solution: |+  move; harvest; move; grab; turn right; move; grab; grab; harvest; grab+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - treads+      - harvester+      - grabber+      - boat+world:+  default: [blank]+  palette:+    '.': [grass]+    'T': [stone, tree]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    '~': [stone, water]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │.TT│+    │~~~│+    └───┘
+ data/scenarios/Testing/504-teleport-self.yaml view
@@ -0,0 +1,39 @@+version: 1+name: Teleport self in win condition check+description: |+  `teleport self` did not work in the win condition check.+  https://github.com/swarm-game/swarm/issues/504+objectives:+  - condition: |+      try {+        create "tree"; place "tree";+        teleport self (5,0);+        ishere "tree"+      } { return false }+solution: |+  place "tree"+robots:+  - name: base+    loc: [5,0]+    dir: [1,0]+    devices:+      - treads+      - logger+      - grabber+    inventory:+    - [1, tree]+world:+  default: [blank]+  palette:+    '.': [grass]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌──────┐+    │......│+    └──────┘
+ data/scenarios/Testing/508-capability-subset.yaml view
@@ -0,0 +1,71 @@+version: 1+name: Install one device+description: |+  Install least amount of devices that provide needed capabilities+  https://github.com/swarm-game/swarm/issues/508+objectives:+  - condition: |+      try {+        r <- robotNumbered 1;+        p <- as r {whereami};+        g <- as base {count "GPS"};+        t <- as base {count "Tardis"};+        return (p == (5,0) && g == 1 && t == 0);+      } { return false }+solution: |+  log "Hi, I can build teleporting robots!";+  try {+    build {log "Hi, I can teleport!"; teleport self (5,0); p <- whereami; log $ "I am at " ++ format p}+  } {+    fail "Fatal error: BASE: I could not build my robot! What happened?!"+  }+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - net+      - 3D printer+    inventory:+      - [1, mirror]+      - [1, string]+      - [1, GPS]+      - [1, Tardis]+      - [1, logger]+      - [1, solar panel]+      - [1, ADT calculator]+known: [water]+world:+  default: [ice, water]+  palette:+    '.': [grass]+    ' ': [ice, water]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌─┐  ┌─┐+    │.│  │.│+    └─┘  └─┘+entities:+  - name: GPS+    display:+      attr: water+      char: 'G'+    description:+    - A satellite navigation device.+    properties: [known, portable]+    capabilities: [senseloc]+  - name: Tardis+    display:+      attr: water+      char: '█'+    description:+    - Bigger on the inside.+    properties: [known, portable]+    capabilities: [senseloc, teleport]
+ data/scenarios/Testing/555-teleport-location.yaml view
@@ -0,0 +1,27 @@+version: 1+name: Teleport updates robotsByLocation+description: |+  Teleporting another robot should correctly update the robotsByLocation map.+  https://github.com/swarm-game/swarm/issues/555+creative: True+objectives:+  - condition: |+      try {+        as base {has "rock"}+      } { return false }+solution: |+  fred <- robotNamed "fred";+  myLoc <- whereami;+  teleport fred myLoc;+  salvage+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+  - name: fred+    loc: [1,0]+    dir: [0,0]+    inventory:+      - [1, rock]+world:+  default: [grass, null]
+ data/scenarios/Testing/562-lodestone.sw view
@@ -0,0 +1,45 @@+// 562-lodestone solution++def ifC = \p.\t.\e.+  b <- p;+  if b t e+end;++def until = \p.\t.+  ifC p t {until p t}+end;++def repeat = \c.+  c;+  repeat c;+end++def m2 =+  move;+  move+end;++// ---------------------------------------------------+// ┌─────┐+// │o.AT~ +// │..AAA│+// │B.0.A│+// └─────┘+// ---------------------------------------------------++// get one lodestone+build {log "Hey!"; turn north; m2; l <- grab; turn back; m2; place l};+until (ishere "lodestone") {grab};++// get two bit (0)+// TODO: require should not be necessary+build {+  log "Hi!";+  require "branch predictor";+  repeat (+    turn east; m2; x <- until (ishere "bit (0)") {harvest}; turn back; m2; place x+)};+until (ishere "bit (0)") {grab};+until (ishere "bit (0)") {grab};++make "drill bit"
+ data/scenarios/Testing/562-lodestone.yaml view
@@ -0,0 +1,105 @@+version: 1+name: Test lodestone+description: Pick or drill lodestone and use it to flip bits.+goal:+    - To create a drill bit, you will need to flip the available bit.+win: |+  try {+    as base {has "drill bit"};+  } { return false }+solution: |+  run "562-lodestone.sw"+robots:+  - name: base+    dir: [1,0]+    display:+      char: Ω+      attr: robot+    devices:+      - dictionary+      - logger+      - grabber+      - scanner+      - toolkit+      - workbench+      - 3D printer+      - branch predictor+    inventory:+      - [10, drill]+      - [10, logger]+      - [10, compass]+      - [10, treads]+      - [10, harvester]+      - [10, solar panel]+      - [10, scanner]+      - [10, strange loop]+      - [10, branch predictor]+      - [10, toolkit]+      - [0, drill bit]+      - [0, bit (0)]+      - [0, bit (1)]+known: [water, wavy water]+world:+  default: [ice, water]+  palette:+    '.': [grass]+    ' ': [ice, water]+    '~': [ice, wavy water]+    'L': [grass, Linux]+    'T': [grass, tree]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    'A': [stone, magnetic vein]+    'o': [stone, lodestone]+    '0': [grass, bit (0)]+    'B': [grass, null, base]+  upperleft: [-1, 1]+  map: |+    ┌─────┐                                                                ~~+    │o.AT~                                                                ~L~+    │..AAA│                                                                ~~+    │B.0.A│                                                                 ~+    └─────┘                                                                 ~+entities:+  - name: magnetic vein+    display:+      attr: iron'+      char: 'A'+    description:+    - A place in the mountains where raw iron ore can be mined.+      As it is hidden inside a mountain, a tunnel needs to be+      first drilled through, so that the vein becomes accessible.+    properties: [unwalkable]++  - name: magnetic mine+    display:+      attr: iron'+      char: 'Å'+    description:+    - A place in the mountains where raw iron ore can be mined.+    properties: [unwalkable]++recipes:+  ## TOY DRILL+  - in:+    - [1, magnetic vein]+    out:+    - [1, magnetic mine]+    - [1, lodestone]+    required:+    - [1, drill]+    time: 42++  - in:+    - [1, magnetic mine]+    out:+    - [1, magnetic mine]+    - [1, iron ore]+    - [1, lodestone]+    required:+    - [1, drill]+    time: 42
+ data/scenarios/Testing/684-swap.yaml view
@@ -0,0 +1,61 @@+version: 1+name: Swap in one tick+description: |+  Swapping an entity should be done in one tick.+  https://github.com/swarm-game/swarm/issues/684+objectives:+  - condition: |+      try {+        as base {+          l <- has "lambda";+          b <- has "bitcoin";+          return $ l && b+        }+      } {+        return false+      }+solution: |+  swap "bitcoin"; swap "gold coin";+robots:+  - name: base+    loc: [0,0]+    dir: [1,0]+    devices:+      - logger+      - scanner+      - grabber+      - fast grabber+    inventory:+      - [1, gold coin]+      - [1, bitcoin]+  - name: watcher+    loc: [0,0]+    dir: [1,0]+    system: true+    devices:+      - logger+    program: |+      def repeat = \c. c; repeat c end;+      repeat (+        d <- scan down;+        case d (\_.+          say "Fatal error: swap does not work atomically!"+        ) (\_.+          return ()+        )+      )+world:+  default: [blank]+  palette:+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+    'λ': [grass, lambda]+  upperleft: [-1, 1]+  map: |+    ┌─┐+    │λ│+    └─┘
+ data/scenarios/Testing/699-movement-fail/00-ORDER.txt view
@@ -0,0 +1,3 @@+699-move-blocked.yaml+699-move-liquid.yaml+699-teleport-blocked.yaml
+ data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml view
@@ -0,0 +1,50 @@+version: 1+name: Move to blocked+description: |+  Robot moving to blocked location results in its destruction.+  https://github.com/swarm-game/swarm/issues/699+objectives:+  - condition: |+      def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; return $ l == loc} {return false} end;+      def isDead = \name. try {robotNamed name; return false} {return true} end;+      a1 <- isAliveOn "one" (0,-1);+      a2 <- isAliveOn "two" (1,-2);+      b <- isAliveOn "base" (0,0);+      return (a1 && a2 && b)+solution: |+  move; say "Fatal error: base was able to move into a boulder and not fail!"+robots:+  - name: base+    dir: [1,0]+    devices: ["treads", "logger"]+  - name: one+    dir: [1,0]+    devices: ["treads", "logger"]+    program: |+      move; say "Fatal error: one was able to move into a boulder and not fail!"+  - name: two+    dir: [1,0]+    system: true+    devices: ["logger"]+    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]+    '1': [grass, null, one]+    '2': [grass, null, two]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌──┐+    │B@│+    │1@│+    │2@│+    └──┘
+ data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml view
@@ -0,0 +1,58 @@+version: 1+name: Move to liquid+description: |+  Robot moving to water location results in its drowning.+  https://github.com/swarm-game/swarm/issues/699+objectives:+  - condition: |+      def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; return $ l == loc} {return false} end;+      def isDead = \name. try {robotNamed name; return false} {return true} end;+      d1 <- isDead "one";+      a2 <- isAliveOn "two" (1,-2);+      a3 <- isAliveOn "three" (1,-3);+      b <- isAliveOn "base" (0,0);+      return (d1 && a2 && a3 && b)+solution: |+  move; say "Fatal error: base was able to move into water and not fail!"+robots:+  - name: base+    dir: [1,0]+    devices: ["treads", "logger"]+  - name: one+    dir: [1,0]+    devices: ["treads", "logger"]+    program: |+      move; say "Fatal error: one was able to move into water and not fail or drown!"+  - name: two+    dir: [1,0]+    devices: ["treads", "logger", "boat", "net"]+    program: |+      try {move} {say "Fatal error: two was unable to move into water even though it has a boat!"}+  - name: three+    dir: [1,0]+    system: true+    devices: ["logger"]+    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]+    '1': [grass, null, one]+    '2': [grass, null, two]+    '3': [grass, null, three]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌──┐+    │B~│+    │1~│+    │2~│+    │3~│+    └──┘
+ data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml view
@@ -0,0 +1,54 @@+version: 1+name: Teleport to blocked+description: |+  Teleporting self or another robot to blocked location results in destruction of that robot.+  https://github.com/swarm-game/swarm/issues/699+creative: true+objectives:+  - condition: |+      def isAliveOn = \name.\loc. try {r <- robotNamed name; l <- as r {whereami}; return $ l == loc} {return false} end;+      def isDead = \name. try {robotNamed name; return false} {return true} end;+      d1 <- isDead "one";+      d2 <- isDead "two";+      a3 <- isAliveOn "three" (3,0);+      a4 <- isAliveOn "four" (3,0);+      b <- isAliveOn "base" (5,0);+      return (d1 && d2 && a3 && a4 && b)+solution: |+  o <- robotNamed "one"; reprogram o {t <- robotNamed "two"; teleport t (3,0); teleport self (3,0)};+  try {teleport self (3,0)} {teleport self (5,0)}+robots:+  - name: base+    dir: [0,0]+  - name: one+    dir: [1,0]+  - name: two+    dir: [-1,0]+  - name: three+    dir: [0,1]+    system: true+    program: |+      t <- robotNamed "four"; teleport t (3,0); teleport self (3,0)+  - name: four+    dir: [0,-1]+    system: true+world:+  default: [blank]+  palette:+    '@': [stone, boulder]+    'B': [grass, null, base]+    '1': [grass, null, one]+    '2': [grass, null, two]+    '3': [grass, null, three]+    '4': [grass, null, four]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌──────┐+    │B12@34│+    └──────┘
+ data/scenarios/Testing/710-multi-robot.yaml view
@@ -0,0 +1,250 @@+version: 1+name: Multiple robots in palette+description: |+  Using multiple robots in palette to open new rooms.+  See the lowright/upright robots in the second room.+  https://github.com/swarm-game/swarm/issues/710+objectives:+  - goal:+      - Move to the end of the room.+    condition: |+      r <- robotNamed "check1";+      as r {has "Win"}+  - goal:+      - Move to the end of the second room.+    condition: |+      r <- robotNamed "check2";+      as r {has "Win"}+  - goal:+      - Move to the end of the third room.+    condition: |+      r <- robotNamed "check3";+      as r {has "Win"}+solution: |+  move;move;move; move;move;move; move;move;move;+world:+  default: [blank]+  palette:+    '.': [blank]+    # FIRST ROOM+    '┌': [blank, upper left corner]+    '└': [blank, lower left corner]+    '─': [blank, horizontal wall]+    '│': [blank, vertical wall]+    '┐': [blank, upper right corner, upright0]+    '┘': [blank, lower right corner, lowright0]+    # SECOND ROOM+    '1': [blank, vertical wall, gate1]+    '-': [blank, "1", horizon]+    'u': [blank, "1", upright, upright1]+    'l': [blank, "1", lowright, lowright1]+    '2': [blank, "1", vertice, gate2]+    # THIRD ROOM+    '~': [blank, "2", horizon]+    '/': [blank, "2", vertice]+    'U': [blank, "2", upright]+    'L': [blank, "2", lowright]+  upperleft: [-1, 1]+  map: |+    ┌────┐--u~~U+    │....1..2../+    └────┘--l~~L++robots:+  - name: base+    dir: [1,0]+    loc: [0,0]+    devices:+      - treads+      - logger+  - name: check1+    dir: [0,0]+    loc: [3,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l)+        } { return false }+      );+      create "Win"+  - name: check2+    dir: [0,0]+    loc: [6,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l)+        } { return false }+      );+      create "Win"+  - name: check3+    dir: [0,0]+    loc: [9,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l)+        } { return false }+      );+      create "Win"+  - name: horizon+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,horizontal wall]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);+      c1 <- robotNamed ("check" ++ n);+      until (as c1 {has "Win"});+      swap "horizontal wall"+  - name: vertice+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,vertical wall]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);+      c1 <- robotNamed ("check" ++ n);+      until (as c1 {has "Win"});+      swap "vertical wall"+  - name: upright+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,upper right corner]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);+      c1 <- robotNamed ("check" ++ n);+      until (as c1 {has "Win"});+      swap "upper right corner"+  - name: lowright+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,lower right corner]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);+      c1 <- robotNamed ("check" ++ n);+      until (as c1 {has "Win"});+      swap "lower right corner"+  - name: upleft+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,upper left corner]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);+      c1 <- robotNamed ("check" ++ n);+      until (as c1 {has "Win"});+      swap "upper left corner"+  - name: upright0+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,down and horizontal wall]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check1";+      until (as c1 {has "Win"});+      swap "down and horizontal wall"+  - name: lowright0+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,up and horizontal wall]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check1";+      until (as c1 {has "Win"});+      swap "up and horizontal wall"+  - name: upright1+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,down and horizontal wall]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check2";+      until (as c1 {has "Win"});+      swap "down and horizontal wall"+  - name: lowright1+    dir: [0,0]+    system: true+    display:+      invisible: true+    inventory: [[1,up and horizontal wall]]+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check2";+      until (as c1 {has "Win"});+      swap "up and horizontal wall"+  - name: gate1+    dir: [0,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check1";+      until (as c1 {has "Win"});+      grab+  - name: gate2+    dir: [0,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check2";+      until (as c1 {has "Win"});+      grab+entities:+  - name: Win+    display:+      char: W+      attr: gold+    description:+      - This entity signals that the objective has been met.+  - name: "1"+    display:+      char: W+      invisible: true+    description:+      - This entity is used to mean that the robot should check the 1st objective.+  - name: "2"+    display:+      char: W+      invisible: true+    description:+      - This entity is used to mean that the robot should check the 2nd objective.
+ data/scenarios/Tutorials/00-ORDER.txt view
@@ -0,0 +1,19 @@+backstory.yaml+move.yaml+craft.yaml+grab.yaml+place.yaml+types.yaml+type-errors.yaml+bind.yaml+install.yaml+build.yaml+crash.yaml+scan.yaml+def.yaml+lambda.yaml+require.yaml+requireinv.yaml+conditionals.yaml+world101.yaml+farming.yaml
+ data/scenarios/Tutorials/backstory.yaml view
@@ -0,0 +1,87 @@+version: 1+name: Backstory+description: |+  Introduction to the backstory of Swarm.+objectives:+  - goal:+      - In a shockingly original turn of events, you have crash landed+        on an alien planet!  It's not clear how you'll ever get home,+        but since you're here, you might as well explore a bit. Your+        sensors indicate that the atmosphere is highly toxic, so+        you'll have to stay inside your robotic base, with its+        built-in life support system. However, you are stocked with+        all the materials you need to build robots to explore+        for you!+      - To start, you only have some very basic+        devices which can give your robots abilities like moving, turning,+        grabbing things, and interpreting very simple imperative+        programs. As you use your robots to gather resources, you will+        be able to construct better devices, which in turn allow you to+        construct robots with upgraded abilities and programming+        language features, which in turn allow you to program more+        sophisticated robots which in turn will... you get the+        idea.+      - To prepare you, this simulator will walk you through a series of hands-on+        exercises that introduce you to the way robots work and the programming+        language you will use to control them.+      - |+        When you're ready for your first challenge, close this dialog with Esc or Ctrl-G,+        and type at the prompt:+      - |+        say "Ready!"+    condition: |+      try {+        l <- robotNamed "listener";+        as l {has "READY"}+      } { return false }+solution: |+  say "Ready!"+entities:+  - name: READY+    display:+      attr: device+      char: 'R'+    description:+      - |+        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.+    properties: [known, portable]+robots:+  - name: base+    system: true+    display:+      char: 'Ω'+      attr: robot+    dir: [1,0]+    loc: [0,0]+    inventory:+      - [1, READY]+  - name: listener+    system: true+    display:+      invisible: true+    loc: [0,0]+    dir: [0,0]+    inventory:+      - [0, READY]+    devices:+      - logger+    program: |+      def forever = \c. force c; forever c end;+      forever {+        try {+          m <- listen;+          if (m == "Ready!" || m == "ready!" || m == "ready") {+            create "READY";+            log "The player is ready!"+          } {+            say $ "Wrong message: " ++ format m+          }+        } {log "Something bad happened!"}+      }+seed: 0+world:+  offset: true
+ data/scenarios/Tutorials/bind.yaml view
@@ -0,0 +1,81 @@+version: 1+name: Bind notation+description: |+  Learn about command return types and how to bind the results.+objectives:+  - goal:+      - |+        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,+        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`.+      - |+        Other commands do return a nontrivial value after executing.+        For example, `grab` has type+        `cmd text`, and returns the name of the+        grabbed entity as a text value. Try it:+      - |+        move; grab+      - |+        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.+        This could be 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.+      - Once you are done experimenting, do `place "Win"` to finish this challenge.+        (Note, you might need to `grab` the entity you are standing on+        or move to an empty cell first, since each cell can only+        contain at most one entity.)+    condition: |+      try {+        w <- as base {has "Win"};+        return (not w);+      } { return false }+solution: |+  place "Win"+entities:+  - name: Win+    display:+      attr: device+      char: 'W'+    description:+      - Do `place "Win"` once you are done with this challenge.+      - You might need to `grab` the entity you are standing on+        or move to an empty cell first.+    properties: [known, portable]+robots:+  - name: base+    dir: [1,0]+    devices:+      - treads+      - grabber+      - logger+      - compass+      - dictionary+    inventory:+      - [1, Win]+      - [0, tree]+world:+  default: [blank]+  palette:+    '>': [grass, null, base]+    'T': [grass, tree]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │>TT│+    └───┘
+ data/scenarios/Tutorials/build.yaml view
@@ -0,0 +1,84 @@+version: 1+name: Build+description: |+  Learn how to build robots to carry out simple tasks.+#+# Has to be easy, so that you do not have to debug it too much yet.+#+objectives:+  - goal:+      - Now that you know basic commands, it is time to+        build robots to do the work for you.+        You will start in a base ('Ω') that does not move (at least not yet).+      - 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+        of commands for the robot to execute (separated by semicolons).+      - Build a robot to harvest the flower and place it next+        to the water.+      - |+        TIP: You can use the name of the flower directly ("pickerelweed"),+        or you can use bind notation: `f <- harvest; ... ; place f;`.+      - |+        TIP: Newly built robots always start out facing north.+    condition: |+      try {+        teleport self (0,-1);+        turn east;+        a <- ishere "pickerelweed";+        move;+        b <- ishere "pickerelweed";+        move;+        c <- ishere "pickerelweed";+        return (a || b || c);+      } { return false }+entities:+  - name: pickerelweed+    display:+      attr: flower+      char: '*'+    description:+      - A small plant that grows near the water.+    properties: [known, portable, growable]+    # It would make sense for the plant to NOT grow away from water.+    # But if the player sent a robot that grabbed it and then did not+    # place it, another robot would need to salvage that robot.+solution: |+  build {turn right; move; move; t <- harvest; turn right; move; place t}+robots:+  - name: base+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+    inventory:+      - [10, logger]+      - [10, compass]+      - [10, solar panel]+      - [10, harvester]+      - [10, treads]+known: [water]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '~': [ice, water]+    '*': [grass, pickerelweed]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │Ω.*│+    │...│+    │~~~│+    └───┘
+ data/scenarios/Tutorials/conditionals.yaml view
@@ -0,0 +1,120 @@+version: 1+name: Conditionals+description: |+  Learn how to write conditional expressions.+objectives:+  - goal:+      - |+        The 4x4 gray square contains 4 `very small rock`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.+      - |+        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`+        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.)+      - |+        As you might expect, `if` can be used to write+        conditional expressions.  However, `if` is not special syntax;+        it is simply a built-in function of type+      - |+        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,+        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`+        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`.+      - |+        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: 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}`.+        In this case `{grab; return ()}` has the right type.+    condition: |+      try {+        n <- as base {count "very small rock"};+        return (n == 4)+      } { return false}+solution: |+  def tL = turn left end;+  def tB = turn back end;+  def x4 = \c. c;c;c;c end;+  def VSR = "very small rock" end;+  def ifC = \c.\t.\e. b <- c; if b t e end;+  def pick = move; ifC (ishere VSR) {grab; return ()} {} end;+  def pickrow = x4 pick; turn back; x4 move end;+  build {+    require "treads"; require "branch predictor"; require "grabber";+    require "lambda"; require "scanner";  // #540++    turn south; x4 (move; tL; pickrow; tL); tB; x4 move; x4 (give base VSR)+  }+robots:+  - name: base+    heavy: true+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+      - dictionary+    inventory:+      - [8, compass]+      - [8, solar panel]+      - [8, logger]+      - [8, treads]+      - [8, grabber]+      - [8, scanner]+      - [8, lambda]+      - [8, branch predictor]+      - [8, 3D printer]+      - [0, very small rock]+entities:+  - name: very small rock+    display:+      invisible: true+    description:+      - A small rock.  It is so small, it is practically invisible.+    properties: [portable]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '_': [stone]+    'o': [stone, very small rock]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌─────┐+    │Ω....│+    │.o___│+    │._o__│+    │.___o│+    │.__o_│+    └─────┘
+ data/scenarios/Tutorials/craft.yaml view
@@ -0,0 +1,49 @@+version: 1+name: Crafting+description: |+  Learn how to make new things using recipes.+#+# The players should read the recipes and acquaint themselves with the UI.+# This also motivates the next tutorial about obtaining entities.+#+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+        available recipes.+      - Your goal is to make a "branch predictor", so you will have to make+        some "branch"es first.+    condition: |+      try {+        as base {has "branch predictor"}+      } { return false }+solution: |+  make "branch"; make "branch predictor"+robots:+  - name: base+    display:+      attr: robot+      char: 'Ω'+    dir: [1,0]+    devices:+      - workbench+      - logger+    inventory:+      - [10, tree]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌─┐+    │Ω│+    └─┘
+ data/scenarios/Tutorials/crash-secret.sw view
@@ -0,0 +1,65 @@+// A for cycle from start to end (excluded) that carries a state.+def foreachF = \s.\e.\com.\state.+  if (s >= e) {+    return state+  } {+    n <- com state s;+    foreachF (s+1) e com n+  }+end;++// An infinite while cycle that carries a state.+def iterate = \state.\com.+  n <- com state;+  iterate n com;+end;++// At the beginning all robots can be given Win.+def allOK: robot -> bool = \rob.+  true+end;++// Try to give a robot a Win, filtering out those that were already given a Win.+// The robot will also receive instructions, so it **must have a logger!**+def tryGive: text -> (robot -> bool) -> int -> cmd (robot -> bool) = \msg.\f.\i.+  r <- try {+    robotNumbered i;+  } {+    log $ "could not find robot " ++ format i;+    return self+  };+  if (r != self && f r) {+    log $ "found the robot " ++ format i;+    l <- whereami;+    rl <- as r {whereami}; wait 1;  // WHY is this 'wait 1' required???+    if (l != rl) {+      log $ "the robot" ++ format i ++ "is not in my cell";+      return f;+    } {+      try {+        reprogram r { log msg; };+        log $ "successfully reprogrammed robot " ++ format i;+        give r "Win";+        log $ "successfully gave Win to robot " ++ format i;+      } {+        log $ "the robot " ++ format i ++ "is missing a logger!"+      };+      return (\rob. (rob != r && f rob));+    }+  } {+    log $ "skipping the robot " ++ format i;+    return f+  }+end;++// -------------------------------------------------------------------------+// RUN+// -------------------------------------------------------------------------++log "Hi, I am secret";+iterate allOK (foreachF 1 16 $ tryGive+  $ "Send a robot to `salvage` me and come back to `give base \"Win\"`.\n"+  ++ "When the rescue robot stands where I am and executes `salvage`,\n"+  ++ "all my inventory and logs will go to it, namely the \"Win\".\n"+  ++ "Once you have brought the \"Win\" to your base, you will win!"+)
+ data/scenarios/Tutorials/crash-solution.sw view
@@ -0,0 +1,8 @@+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
@@ -0,0 +1,92 @@+version: 1+name: Debug+description: |+  Learn how to view built robots and debug them.+objectives:+  - goal:+      - Before you send your robots far away 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 (1) make sure it has a `logger`,+        so we can see what command failed,+        and (2) use the bind syntax `r <- build {COMMANDS}` so you can refer to+        the newly built robot later.  All together, it might look something like+        this:+      - |+        r <- build {log "Hi!"; turn east; move; move; move; log "3"; move; log "OK"}+      - (`build` will make sure the robot has a `logger` since its program includes+        calls to the `log` command.)+      - After the robot crashes, execute `view r` to see how far it got.+        Further instructions should appear in the crashed robot's log.+    condition: |+      try {+        as base {has "Win"}+      } { return false }+entities:+  - name: Win+    display:+      attr: device+      char: 'W'+    description:+      - If you have this, you win!+    properties: [known, portable]+solution: |+  run "data/scenarios/Tutorials/crash-solution.sw"+robots:+  - name: base+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+      - clock+    inventory:+      - [10, logger]+      - [10, compass]+      - [10, scanner]+      - [10, toolkit]+      - [10, solar panel]+      - [10, treads]+      - [10, grabber]+  - name: secret+    dir: [0, 0]+    devices:+      - logger+      - flash memory+      - dictionary+      - 3D printer+    inventory:+      - [100000, Win]+    display:+      invisible: true+    system: true+    program: |+      run "data/scenarios/Tutorials/crash-secret.sw"+known: [water, tree, mountain]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '!': [grass, null, secret]+    '.': [grass]+    '~': [ice, water]+    'T': [grass, tree]+    'A': [stone, mountain]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 3]+  map: |+    ┌─────┐+    │AAAT~│+    │..A.~│+    │Ω..!A│+    └─────┘
+ data/scenarios/Tutorials/def.yaml view
@@ -0,0 +1,93 @@+version: 1+name: Define+description: |+  Learn how to define new commands.+objectives:+  - goal:+      - Your goal is to build a robot to fetch the flower growing in the+        upper right and bring it back to you; you win the challenge when the base+        has a flower 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+        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.+        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+        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+        `def m4 = move; move; move; move end`, and Swarm would infer+        the type of `m4`.+      - |+        TIP: writing function definitions at the prompt is annoying.+        You can also put definitions in a `.sw` 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+        syntax and error highlighting.+    condition: |+      try {+        as base {has "flower"}+      } { return false }+solution: |+  def m2 = move; move end;+  def m4 = m2; m2 end;+  def m8 = m4; m4 end;+  def m16 = m8; m8 end;+  def tL = turn left end;+  def tR = turn right end;+  def tB = turn back end;+  def S = m16; tL; m2; tL; m16; tR; m2; tR; m16 end;+  build {+    require "treads";  // #540+    turn right; S; f <- harvest; tB; S; give base f+  }+robots:+  - name: base+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+      - dictionary+    inventory:+      - [10, logger]+      - [10, compass]+      - [10, scanner]+      - [10, treads]+      - [10, solar panel]+      - [10, harvester]+      - [10, grabber]+      - [0, flower]+known: [boulder]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '*': [grass, flower]+    '@': [grass, boulder]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 5]+  map: |+    ┌─────────────────┐+    │................*│+    │.@@@@@@@@@@@@@@@@│+    │.................│+    │@@@@@@@@@@@@@@@@.│+    │Ω................│+    └─────────────────┘
+ data/scenarios/Tutorials/farming.sw view
@@ -0,0 +1,52 @@+// Solution to 'farming.yaml' tutorial challenge++// Part 1: farm 256 lambdas+def tR = turn right end;+def tL = turn left end;+def tB = turn back end;+def forever = \c. c ; forever c end;+def ifC : cmd bool -> {cmd a} -> {cmd a} -> cmd a = \test. \then. \else.+  b <- test; if b then else+end;+def while : cmd bool -> {cmd a} -> cmd unit = \test. \body.+  ifC test {force body ; while test body} {}+end;+def giveall : robot -> text -> cmd unit = \r. \thing.+  while (has thing) {give r thing}+end;+def x4 = \c. c; c; c; c end;+def m4 = x4 move end;+def x12 = \c. x4 (c;c;c) end;+def m12 = x12 move end;+def next_row = tB; m12; tL; move; tL end;+def plant_field : text -> cmd unit = \thing.+  log "planting";+  x4 (+    x12 (move; place thing; harvest);+    next_row+  )+end;+def harvest_field : text -> cmd unit = \thing.+  x4 (+    x12 (move; ifC (ishere thing) {harvest; return ()} {});+    next_row+  );+  tL; m4; tR+end;+def harvest_lambdas =+  forever (+    tB; move; tR; harvest_field "lambda"; tR; move; giveall base "lambda"+  )+end;+build {+  require "treads"; require "harvester"; require "logger";+  require "lambda"; require "branch predictor";             // #540+  require 1 "lambda";+  tB; move; tR; plant_field "lambda";+};+build {+  require "treads"; require "harvester"; require "logger"; require "scanner";+  require "grabber";+  require "lambda"; require "branch predictor"; require "strange loop";  // #540+  harvest_lambdas+}
+ data/scenarios/Tutorials/farming.yaml view
@@ -0,0 +1,85 @@+version: 1+name: Farming+description: |+  Learn how to build a farm to grow and harvest items.+objectives:+  - goal:+      - Lambdas 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+        allow robots to evaluate conditional expressions, and some+        `strange loops` 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+        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+        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."+    condition: |+      try {+        as base {+          n <- count "lambda";+          return (n >= 256)+        }+      } { return false }+  - goal:+      - Congratulations!  You have completed the most difficult simulated exercise and+        are ready to begin exploring the new planet in earnest.  Of course there+        is much more remaining to explore in the world, and many additional programming+        language features to unlock.+      - |+        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`.+      - Afterwards, you will return to the menu where you can select+        "Classic game" for the complete game experience.  Or, play a+        "Creative game" if you just want to play around with+        programming robots, without any constraints or need to collect+        resources.  You could also choose to redo some tutorial scenarios, or+        explore the other challenge scenarios listed in the menu.+      - Now go forth and build your swarm!+    condition: |+      try {as base {has "curry"}} {return false}+solution: |+  run "data/scenarios/Tutorials/farming.sw";+  run "data/scenarios/Tutorials/make_curry.sw";+robots:+  - name: base+    display:+      char: 'Ω'+      attr: robot+    loc: [0,0]+    dir: [0,1]+    devices:+      - 3D printer+      - dictionary+      - grabber+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [5, 3D printer]+      - [100, treads]+      - [70, grabber]+      - [100, solar panel]+      - [50, scanner]+      - [5, toolkit]+      - [10, strange loop]+      - [10, branch predictor]+      - [10, lambda]+      - [10, tree]+      - [10, harvester]+      - [10, logger]+seed: 0+world:+  offset: true
+ data/scenarios/Tutorials/grab.yaml view
@@ -0,0 +1,52 @@+version: 1+name: Grab+description: |+  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.+        Now you will learn how to obtain the ingredients you need.+      - There are some trees ahead of your robot; `move` to each one and `grab` it.+      - You can learn more by reading about the grabber device in your inventory.+      - |+        TIP: You can use the arrow key Up ('↑') to reuse your previous commands.+    condition: |+      try {+        t <- as base {count "tree"};+        return (t >= 6);+      } { return false }+solution:+  move;+  move; grab;+  move; grab;+  move; grab;+  move; grab;+  move; grab;+  move; grab;+robots:+  - name: base+    dir: [1,0]+    devices:+      - treads+      - grabber+      - logger+      - compass+    inventory:+      - [0, tree]+world:+  default: [blank]+  palette:+    '>': [grass, null, base]+    '.': [grass]+    'T': [grass, tree]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌────────┐+    │>.TTTTTT│+    └────────┘
+ data/scenarios/Tutorials/install.yaml view
@@ -0,0 +1,60 @@+version: 1+name: Install+description: |+  Learn how to install devices and gain new capabilities.+objectives:+  - goal:+      - You know how to `grab` things lying around, so you are ready to get+        an upgrade!+        By installing devices, you learn new capabilities which allow you to+        perform more complex commands.+      - Before you start building new robots in the later tutorials, you need+        to gain the "build" capability.+        Try typing `build {}` - you should get an error telling you that you+        need to install a "3D printer".+      - |+        Fortunately, there is a 3D printer lying nearby.  Go `grab` it, then+        install it on yourself with `install base "3D printer"`.+      - |+        You win by building your first robot:+      - |+        build {log "Hello World!"}+    condition: |+      try {+        _ <- robotNumbered 1;+        return true;+      } { return false }+solution: |+  turn south; move; grab; install base "3D printer"; build {log "Hello World!"};+robots:+  - name: base+    dir: [1,0]+    devices:+      - logger+      - treads+      - compass+      - grabber+    inventory:+      - [10, solar panel]+      - [10, logger]+known: [3D printer, water]+world:+  default: [blank]+  palette:+    '>': [grass, null, base]+    '.': [grass]+    '~': [ice, water]+    '3': [grass, 3D printer]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │>..│+    │3..│+    │~~~│+    └───┘
+ data/scenarios/Tutorials/lambda.yaml view
@@ -0,0 +1,96 @@+version: 1+name: Lambda+description: |+  Learn how to define functions.+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).+      - |+        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:+      - |+        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.+    condition: |+      try {+        teleport self (32,-16);+        b <- ishere "flower";+        return (not b)+      } { return false }+solution: |+  def x4 = \c. c; c; c; c end;+  def m2 = move; move end;+  def m4 = x4 move end;+  def tR = turn right end;+  def tL = turn left end;+  def s = m4; tL; m2; tL; m4; tR; m2; tR end;+  build {+    require "treads"; require "lambda";  // #540+    turn right;+    x4 (x4 s; m4; m2; tR; x4 (x4 move); tL; m2);+    grab+  }+robots:+  - name: base+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+      - dictionary+    inventory:+      - [10, logger]+      - [10, compass]+      - [10, treads]+      - [10, solar panel]+      - [10, grabber]+      - [10, lambda]+      - [0, boulder]+      - [0, flower]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '*': [grass, flower]+    '@': [grass, boulder]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1,1]+  map: |+    ┌─────────────────────────────────┐+    │.......@.......@.......@.......@@│+    │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│+    │.....@.@.....@.@.....@.@.....@.@@│+    │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│+    │Ω....@.......@.......@.......@..*│+    └─────────────────────────────────┘++
+ data/scenarios/Tutorials/make_curry.sw view
@@ -0,0 +1,10 @@++// Part 2 of 'farming' tutorial: make curry+make "log"; make "log"; make "board"; make "board"; make "boat";+build {+  require "boat";+  turn right; move; move; move; grab; turn back; move; move; move;+  give base "water";+};+wait 16;+make "curry"
+ data/scenarios/Tutorials/move.yaml view
@@ -0,0 +1,409 @@+version: 1+name: Moving+description: |+  Learn how to move and chain commands.+objectives:+  - goal:+      - Robots can use the `move` command to move forward one unit+        in the direction they are currently facing.+      - To complete this challenge, move your robot two spaces to the right,+        to the coordinates (2,0) marked with the purple flower.+      - Note that you can chain commands with semicolon, `;`.+      - You can open this popup window at any time to remind yourself of the goal+        using Ctrl-G.+    condition: |+      r <- robotNamed "check1";+      loc <- as r {has "Win"};+  - goal:+      - Good! Now you need to learn how to effectively repeat actions.+      - |+        Previously you could move twice by chaining the move command:+      - |+        move; move+      - To reuse that command without having to retype it press the upward+        arrow on your keyboard. This will allow you to select previous commands.+      - Ahead of you is a six steps long corridor. Move to its end, i.e. the+        coordinates (8,0) marked with the second purple flower.+      - You can open this popup window at any time to remind yourself of the goal+        using Ctrl-G.+    condition: |+      r <- robotNamed "check2";+      loc <- as r {has "Win"};+  - goal:+      - Well done! In addition to `move`, you can use the `turn` command+        to turn your robot, for example, `turn right` or `turn east`.+      - Switch to the inventory view (by clicking on it, or typing `Alt+E`)+        and select the treads device to read about the details.+        You can come back to the REPL prompt by clicking on it or typing `Alt+R`.+      - 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:+      - |+        `move;move;move;move`+      - You can open this popup window at any time to remind yourself of the goal+        using Ctrl-G.+    condition: |+      r <- robotNamed "check3";+      loc <- as r {has "Win"};+  - 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.+      - Remember you can press the upward arrow on your keyboard to select previous commands.+      - You can open this popup window at any time to remind yourself of the goal+        using Ctrl-G.+    condition: |+      r <- robotNamed "check4";+      loc <- as r {has "Win"};+solution: |+  // 0+  move;move;+  // 1+  move;move;+  move;move;move;move;+  // 2+  turn left;+  move;move;move;move; // go 6 north+  // 3+  turn left;+  move;move;move;move; // go 8 west+  move;move;move;move;+  turn right;+  move;move;move;move; // go 4 north+  turn right;+  move;move;move;move; // go 8 east+  move;move;move;move;+known:+  - flower+world:+  default: [blank]+  palette:+    '.': [blank]+    '*': [blank, flower]+    'X': [blank, null, 1P flower]+    'Y': [blank, null, 2P flower]+    'Z': [blank, null, 3P flower]+    # FIRST ROOM+    '┌': [blank, upper left corner]+    '┐': [blank, upper right corner, 1S down and horizontal wall]+    '└': [blank, lower left corner]+    '┘': [blank, lower right corner, 1S up and horizontal wall]+    '─': [blank, horizontal wall]+    '│': [blank, vertical wall]+    # SECOND ROOM+    '1': [blank, vertical wall, 1G]+    '-': [blank, null, 1P horizontal wall]+    '|': [blank, null, 1P vertical wall]+    'c': [blank, null, 1P upper right corner, 2S left and vertical wall]+    'b': [blank, null, 1P lower right corner]+    'd': [blank, null, 1P horizontal wall, 2S up and horizontal wall]+    # THIRD ROOM+    '2': [blank, null, 1P horizontal wall, 2G]+    '~': [blank, null, 2P horizontal wall]+    '/': [blank, null, 2P vertical wall]+    'R': [blank, null, 2P upper right corner]+    'L': [blank, null, 2P upper left corner, 3S down and horizontal wall]+    'K': [blank, null, 2P vertical wall, 3S left and vertical wall]+    # FOURTH ROOM+    '3': [blank, null, 2P vertical wall, 3G]+    '_': [blank, null, 3P horizontal wall]+    '\': [blank, null, 3P vertical wall]+    'A': [blank, null, 3P lower left corner]+    'B': [blank, null, 3P lower right corner]+    'C': [blank, null, 3P upper right corner]+    'D': [blank, null, 3P upper left corner]+  upperleft: [-1, 9]+  map: |+    D_________C+    \........Z\+    \..D______B+    \..\.......+    \..A___L~~R+    \......3YY/+    A______K../+    ......./../+    ┌───┐--d22c+    │..*1....X|+    └───┘-----b++# Font inspiration and a nicely visible separator:+#+# ███████ ██     ██  █████  ██████  ███    ███ +# ██      ██     ██ ██   ██ ██   ██ ████  ████ +# ███████ ██  █  ██ ███████ ██████  ██ ████ ██ +#      ██ ██ ███ ██ ██   ██ ██   ██ ██  ██  ██ +# ███████  ███ ███  ██   ██ ██   ██ ██      ██ ++robots:+  - name: base+    dir: [1,0]+    loc: [0,0]+    devices:+      - treads+      - logger+      - compass+  #################+  ## OBJECTIVES  ##+  #################+  - name: check1+    loc: [2,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l)+        } { return false }+      );+      create "Win"+  - name: check2+    loc: [8,0]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l)+        } { return false }+      );+      create "Win"+  - name: check3+    loc: [8,4]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l || loc == (fst l - 1, snd l))+        } { return false }+      );+      create "Win"+  - name: check4+    loc: [8,8]+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      l <- whereami;+      until (+        try {+          loc <- as base {whereami};+          return (loc == l)+        } { return false }+      );+      create "Win"+  #################+  ## HORIZONTAL  ##+  #################+  - name: 1P horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #################+  ## VERTICAL    ##+  #################+  - name: 1P vertical wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P vertical wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P vertical wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #################+  ## CORNERS     ##+  #################+  # the order is:+  # upleft   upright+  #     D+----+C+  #      |    |+  #      |    |+  #     A+----+B+  # lowleft  lowright+  #########+  ##  A  ##+  #########+  - name: 1P lower left corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P lower left corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P lower left corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #########+  ##  B  ##+  #########+  - name: 1P lower right corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P lower right corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P lower right corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #########+  ##  C  ##+  #########+  - name: 1P upper right corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P upper right corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P upper right corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #########+  ##  D  ##+  #########+  - name: 1P upper left corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P upper left corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P upper left corner+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #################+  ## SEPARATORS  ##+  #################+  # 1+  - name: 1S down and horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 1S up and horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  # 2+  - name: 2S left and vertical wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2S up and horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  # 3+  - name: 3S left and vertical wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3S down and horizontal wall+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #################+  ## GATES       ##+  #################+  - name: 1G+    system: true+    display:+      invisible: true+    program: |+      def until = \c. b <- c; if b {} {until c} end;+      c1 <- robotNamed "check1";+      until (as c1 {has "Win"});+      grab+  - name: 2G+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3G+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  #################+  ## GARDENERS   ##+  #################+  - name: 1P flower+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 2P flower+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+  - name: 3P flower+    system: true+    display:+      invisible: true+    program: run "data/scenarios/Tutorials/move_system.sw"+entities:+  - name: Win+    display:+      char: W+      attr: gold+    description:+      - This entity signals that the objective has been met.
+ data/scenarios/Tutorials/move_system.sw view
@@ -0,0 +1,28 @@+def until = \c. b <- c; if b {} {until c} end;++// name format: NA Entity+// N - one digit room number+// A one letter action+nameCheck <- atomic (+    name <- whoami;+    check <- robotNamed ("check" ++ fst (split 1 name));+    return (name, check)+);+let a = fst $ split 1 $ snd $ split 1 $ fst nameCheck in+let e = snd $ split 3 $ fst nameCheck in++until (as (snd nameCheck) {has "Win"});++if (a == "S") {+    if (e != "") { create e } {};+    swap e;+    return ()+} { if (a == "G") {+    grab;+    return ()+} { if (a == "P") {+    if (e != "") { create e } {};+    place e+} {+    say $ "Finished waiting for check but I don't know what to do: '" ++ a ++ "'"+}}}
+ data/scenarios/Tutorials/place.yaml view
@@ -0,0 +1,89 @@+version: 1+name: Place+description: |+  Learn how to interact with the world by harvesting entities and placing them.+#+# Placing the tree is motivated by speeding up tree collection as their growth+# is really slow. It can be cheesed by speeding up the game, but there is no need+# to tell the players. :)+#+objectives:+  - goal:+      - Previously you learned how to plunder a plentiful forest for wood.+        Now you will learn how to plant trees to obtain as much wood as you need.+      - There is a fast-growing tree (called "spruce") ahead of you.  You could `grab`+        it as before, but you now have a new device called a `harvester`.+        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+        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.+    condition: |+      try {+        t <- as base {count "spruce"};+        return (t >= 6);+      } { return false }+entities:+  # faster tree (the normal one grows 500-600 ticks)+  - name: spruce+    display:+      attr: plant+      char: 'T'+    description:+    - |+      A tall, living entity made of a tough cellular material called "wood".+      They regrow after being harvested and are an important raw ingredient used+      in making many different devices.+    - |+      This one seems to grow a little faster.+    properties: [portable, growable]+    growth: [100, 120]+solution: |+  def t = move; place "spruce"; harvest; end;+  def h = harvest; move end;+  // wait without needing a clock: literally spin our wheels+  def w4 = turn left; turn left; turn left; turn left end;+  def w16 = w4; w4; w4; w4 end;+  def w64 = w16; w16; w16; w16 end;+  def w256 = w64; w64; w64; w64 end;+  move;+  move; harvest; t; t; t; t; t;+  w256;+  turn back; h; h; h; h; h; h;+robots:+  - name: base+    dir: [1,0]+    devices:+      - treads+      - grabber+      - harvester+      - logger+      - compass+      - dictionary+    inventory:+      - [0, spruce]+world:+  default: [blank]+  palette:+    '>': [grass, null, base]+    '.': [grass]+    'T': [grass, spruce]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌────────┐+    │>.T.....│+    └────────┘
+ data/scenarios/Tutorials/require.yaml view
@@ -0,0 +1,82 @@+version: 1+name: Require devices+description: |+  Learn how to require additional devices that would otherwise not be installed.+objectives:+  - goal:+      - The `build` command automatically installs devices that it knows+        will be required.  For example, if you `build {move}`, some `treads`+        will automatically be installed on the new robot since it needs+        them to `move`.+      - However, sometimes you need a device but `build` can't tell that+        you need it. In this case, you can use the special `require`+        command to require a particular device.  For example, if you+        `build {require "3D printer"; move}`, a 3D printer will be+        installed on the new robot even though it does not execute any+        commands that use a 3D printer.+      - 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+        installed!"+    condition: |+      try {+        as base {has "periwinkle"}+      } { return false }+entities:+  - name: periwinkle+    display:+      attr: flower+      char: '*'+    description:+    - A flower.+    properties: [known, infinite, portable]+solution: |+  def m5 = move; move; move; move; move end;+  build {+    require "treads";  // #540++    require "boat"; turn right;+    m5; f <- grab; turn back; m5; give base f+  }+robots:+  - name: base+    heavy: true+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+      - dictionary+    inventory:+      - [10, solar panel]+      - [10, logger]+      - [10, treads]+      - [10, boat]+      - [10, grabber]+      - [10, scanner]+known: [water]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '~': [ice, water]+    '*': [grass, periwinkle]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 3]+  map: |+    ┌──────┐+    │..~~..│+    │..~~..│+    │Ω.~~.*│+    │..~~..│+    │..~~..│+    └──────┘
+ data/scenarios/Tutorials/requireinv.yaml view
@@ -0,0 +1,86 @@+version: 1+name: Require inventory+description: |+  Learn how to require inventory when building robots.+objectives:+  - goal:+      - In the previous tutorial challenge, you learned how to use+        `require` to require specific devices to be installed.+        Sometimes, instead of requiring installed devices, you require+        supplies in your inventory.  In this case, you can write+        `require <int> <name>` 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.+      - Your goal in this challenge is to cover the entire 4x4 gray area+        with rocks!+      - |+        Remember that you can define commands to simplify your task, for example:+      - |+        `def PR = move; place "rock" end`+    condition: |+      def repeat = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end;+      def ifC = \test. \then. \else. b <- test; if b then else end;+      try {+        teleport self (0,0); turn south;+        repeat 4 (+          move; turn east;+          repeat 4 (+            move;+            ifC (ishere "rock") {} {create "tree"};+          );+          turn back; move; move; move; move; turn left+        );+        ifC (has "tree") {return false} {return true}+      } { return false }+solution: |+  def m4 = move; move; move; move end;+  def mp = move; place "rock" end;+  def mp4 = mp; mp; mp; mp end;+  def rr = move; turn right; mp4; turn back; m4; turn right end;+  build {+    require "treads"; require "grabber"; // #540+    require 16 "rock";+    turn right;+    rr; rr; rr; rr+  };+robots:+  - name: base+    heavy: true+    dir: [0,1]+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+      - dictionary+    inventory:+      - [16, compass]+      - [16, solar panel]+      - [16, logger]+      - [16, treads]+      - [16, grabber]+      - [16, scanner]+      - [100, rock]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '_': [stone]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌─────┐+    │Ω....│+    │.____│+    │.____│+    │.____│+    │.____│+    └─────┘
+ data/scenarios/Tutorials/scan.yaml view
@@ -0,0 +1,67 @@+version: 1+name: Scan+description: |+  Learn how to send robots to safely scan your surroundings.+objectives:+  - goal:+      - When you land on an alien planet, all the entities in the+        world will be unfamiliar to you, but you can learn what they are using+        the `scan` command, enabled by a `scanner` 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.+    condition: |+      try {+        bm <- as base {knows "mountain"};+        bt <- as base {knows "tree"};+        bw <- as base {knows "wavy water"};+        return (bm || bt || bw)+      } { return false }+solution: |+  build {+    turn east; move; move; move;+    turn left; move;+    scan left; scan forward; scan east;+    turn back; move;+    turn west; move; move; move;+    upload base;+  }+robots:+  - name: base+    dir: [1,0]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - logger+      - 3D printer+    inventory:+      - [10, logger]+      - [10, compass]+      - [10, scanner]+      - [10, treads]+      - [10, solar panel]+world:+  default: [blank]+  palette:+    'Ω': [grass, null, base]+    '.': [grass]+    '~': [ice, wavy water]+    'T': [grass, tree]+    'A': [stone, mountain]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 3]+  map: |+    ┌─────┐+    │AAAT~│+    │..A.~│+    │Ω...A│+    └─────┘
+ data/scenarios/Tutorials/type-errors.yaml view
@@ -0,0 +1,67 @@+version: 1+name: Type errors+description: |+  Learn how to discover type errors.+objectives:+  - 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.+        A box will pop up with a type (or parser) error.+      - "Some other type errors for you to try:"+      - |+        `turn move`+      - |+        `place tree` (without double quotes around "tree")+      - |+        `move move`+      - The last expression might give the most confusing error.+        Obviously we are just missing a `;` separating the two `move`+        commands.  However, without the semicolon, it looks like+        `move` is a function being applied to an argument, but of course+        `move` is not a function.+      - Once you are done experimenting, execute `place "Win"` to finish this challenge and+        move on to the next.+    condition: |+      try {+        w <- as base {has "Win"};+        return (not w);+      } { return false }+entities:+  - name: Win+    display:+      attr: device+      char: 'W'+    description:+      - Do `place "Win"` once you are done with this challenge.+    properties: [known, portable]+solution: |+  place "Win"+robots:+  - name: base+    dir: [1,0]+    devices:+      - treads+      - compass+      - logger+      - grabber+    inventory:+      - [1, Win]+world:+  default: [blank]+  palette:+    '>': [grass, null, base]+    '.': [grass]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │>..│+    │...│+    └───┘
+ data/scenarios/Tutorials/types.yaml view
@@ -0,0 +1,77 @@+version: 1+name: Types+description: |+  Learn about the Swarm type system.+objectives:+  - goal:+      - The Swarm programming language has a strong static type system.  That is,+        every expression in the language has a type, and all the types must match up+        properly before a program can be executed.+      - To see the type of an expression, enter the expression at the+        REPL prompt without hitting Return.  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`,+        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+      - |+        move; move+      - |+        grab+      - |+        make+      - |+        3+      - |+        "tree"+      - Once you are done experimenting, execute `place "Win"` to finish this challenge and+        move on to the next.+    condition: |+      try {+        w <- as base {has "Win"};+        return (not w);+      } { return false }+entities:+  - name: Win+    display:+      attr: device+      char: 'W'+    description:+      - Do `place "Win"` once you are done with this challenge.+    properties: [known, portable]+solution: |+  place "Win"++robots:+  - name: base+    dir: [1,0]+    devices:+      - treads+      - compass+      - logger+      - grabber+    inventory:+      - [1, Win]+world:+  default: [blank]+  palette:+    '>': [grass, null, base]+    '.': [grass]+    '┌': [stone, upper left corner]+    '┐': [stone, upper right corner]+    '└': [stone, lower left corner]+    '┘': [stone, lower right corner]+    '─': [stone, horizontal wall]+    '│': [stone, vertical wall]+  upperleft: [-1, 1]+  map: |+    ┌───┐+    │>..│+    │...│+    └───┘
+ data/scenarios/Tutorials/world101.yaml view
@@ -0,0 +1,79 @@+version: 1+name: First steps+description: |+  Learn some of the first steps you might take on the new planet.+objectives:+  - goal:+      - You're ready to graduate to something a bit more complex! This+        multi-step tutorial will walk you through a few of the first+        steps you might take in exploring the new planet, using many+        of the commands and techniques you have learned in the+        previous tutorial challenges.+      - You can see that your base starts out with some key devices+        installed and some basic supplies for building robots.  To+        build more advanced devices and produce more robots,+        you'll need to explore, gather resources, and set up some+        automated production pipelines.+      - At this point you may want to create an external `.sw` 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.+    condition: |+      try {+        n <- as base {count "tree"};+        return (n >= 3)+      } { return false }+  - goal:+      - Nice work!  Now, use the trees to make a harvester device.+        This will require several intermediate products; try making+        various things, and take a look at your available recipes (F3)+        and at the recipes listed for items in your inventory.  Of course,+        you may end up needing some additional trees.+    condition: |+      try { as base {has "harvester"} } {return false}+  - goal:+      - 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+        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+        define and use parameterized commands.  Scan some things and use+        the process of elimination to find one.  Since lambdas regrow,+        once you find one, try getting it with `harvest`.+      - "TIP: remember that you can click on cells in the world to see their+        coordinates."+    condition: |+      try { as base {has "lambda"} } {return false}+robots:+  - name: base+    display:+      char: 'Ω'+      attr: robot+    loc: [0,0]+    dir: [0,1]+    devices:+      - 3D printer+      - dictionary+      - grabber+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [5, 3D printer]+      - [100, treads]+      - [70, grabber]+      - [100, solar panel]+      - [50, scanner]+      - [5, toolkit]+seed: 0+world:+  offset: true
+ data/scenarios/classic.yaml view
@@ -0,0 +1,32 @@+version: 1+name: Classic game+description: The classic open-world, resource-gathering version of the game.  You start with a few basic supplies and have to program robots to explore and collect resources.+robots:+  - name: base+    loc: [0,0]+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+    devices:+      - 3D printer+      - dictionary+      - grabber+      - life support system+      - logger+      - toolkit+      - solar panel+      - workbench+      - clock+    inventory:+      - [5, 3D printer]+      - [100, treads]+      - [70, grabber]+      - [100, solar panel]+      - [50, scanner]+      - [50, clock]+      - [5, toolkit]+world:+  seed: null+  offset: true
+ data/scenarios/creative.yaml view
@@ -0,0 +1,16 @@+version: 1+name: Creative game+description: No constraints!  Do whatever you want, create any items you+  want out of thin air, build robots to your heart's content.+creative: true+robots:+  - name: base+    loc: [0,0]+    dir: [0,1]+    heavy: true+    display:+      char: Ω+      attr: robot+world:+  seed: null+  offset: true
+ editors/emacs/swarm-mode.el view
@@ -0,0 +1,134 @@+;;; swarm-mode.el --- Swarm Lang mode -*- lexical-binding: t -*-+;;+;; Author: swarm contributors+;; URL: https://github.com/swarm-game/swarm+;; Version: 0.1+;; Package-Requires: ((emacs-lsp))+;;+;; This file is not part of GNU Emacs.+;;+;;; Code:++(require 'lsp-mode)++(defvar swarm-mode-syntax-table nil "Syntax table for `swarm-mode'.")++(setq swarm-mode-syntax-table+      (let ( (synTable (make-syntax-table)))++        ;; C++ style comments ("// ..." and "/* ... */")+        (modify-syntax-entry ?\/ ". 124" synTable)+        (modify-syntax-entry ?* ". 23b" synTable)+        (modify-syntax-entry ?\n "> " synTable)++        synTable))++(setq swarm-font-lock-keywords+      (let* (+             ;; Generate the current keywords with:+             ;; cabal run swarm:swarm -- generate editors --emacs+             (x-keywords '("def" "end" "let" "in" "require"))+             (x-builtins '(+               "self"+               "parent"+               "base"+               "if"+               "inl"+               "inr"+               "case"+               "fst"+               "snd"+               "force"+               "undefined"+               "fail"+               "not"+               "format"+               "chars"+               "split"+             ))+             (x-commands '(+               "noop"+               "wait"+               "selfdestruct"+               "move"+               "turn"+               "grab"+               "harvest"+               "place"+               "give"+               "install"+               "make"+               "has"+               "installed"+               "count"+               "drill"+               "build"+               "salvage"+               "reprogram"+               "say"+               "listen"+               "log"+               "view"+               "appear"+               "create"+               "time"+               "whereami"+               "blocked"+               "scan"+               "upload"+               "ishere"+               "whoami"+               "setname"+               "random"+               "run"+               "return"+               "try"+               "swap"+               "atomic"+               "teleport"+               "as"+               "robotnamed"+               "robotnumbered"+               "knows"+               "left"+               "right"+               "back"+               "forward"+               "north"+               "south"+               "east"+               "west"+               "down"+             ))+             (x-types '("int" "text" "dir" "bool" "cmd"))++             (x-keywords-regexp (regexp-opt x-keywords 'words))+             (x-builtins-regexp (regexp-opt x-builtins 'words))+             (x-commands-regexp (regexp-opt x-commands 'words))+             (x-types-regexp (regexp-opt x-types 'words)))++        `(+          (,x-keywords-regexp . 'font-lock-keyword-face)+          (,x-builtins-regexp . 'font-lock-builtin-face)+          (,x-types-regexp . 'font-lock-type-face)+          (,x-commands-regexp . 'font-lock-constant-face)+          ("[a-z_][a-z0-9_]*" . 'font-lock-function-name-face)+          )))++(define-derived-mode swarm-mode prog-mode "Swarm Lang Mode"+  (setq font-lock-defaults '((swarm-font-lock-keywords) nil t nil))+  (set-syntax-table swarm-mode-syntax-table))++(add-to-list 'auto-mode-alist '("\\.sw\\'" . swarm-mode))++(with-eval-after-load 'lsp-mode+  (add-to-list 'lsp-language-id-configuration+    '(swarm-mode . "swarm"))++  (lsp-register-client+    (make-lsp-client :new-connection (lsp-stdio-connection (list "swarm" "lsp"))+                     :activation-fn (lsp-activate-on "swarm")+                     :server-id 'swarm-check)))++(provide 'swarm-mode)+;;; swarm-mode.el ends here
+ editors/vscode/syntaxes/swarm.tmLanguage.json view
@@ -0,0 +1,113 @@+{+	"$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json",+	"name": "swarm",+	"patterns": [+		{"include": "#keywords"},+		{"include": "#comments"},+		{"include": "#strings"},+		{"include": "#variables"},+		{"include": "#constants"}+	],+	"repository": {+		"keywords": {+			"patterns": [+				{+				"name": "keyword.control.dictionary.def",+				"begin": "def\\s+(\\w+)\\s*(:((\\s*(cmd|dir|string|int|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=",+				"end": "end",+				"beginCaptures": {+					"1": {"name": "variable.other"},+					"3": {"name": "storage.type"},+					"5": {"name": "storage.modifier"}+				},+				"patterns": [+					{"include": "#keywords"},+					{"include": "#comments"},+					{"include": "#strings"},+					{"include": "#variables"},+					{"include": "#constants"}+				]+				},+				{+				"name": "keyword.control.dictionary.let",+				"begin": "\\s*let\\s+(\\w+)\\s*(:((\\s*(cmd|dir|string|int|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=",+				"end": "\\s*in",+				"beginCaptures": {+					"1": {"name": "variable.other"},+					"3": {"name": "storage.type"},+					"5": {"name": "storage.modifier"}+				},+				"patterns": [+					{"include": "#keywords"},+					{"include": "#comments"},+					{"include": "#strings"},+					{"include": "#variables"},+					{"include": "#constants"}+				]+				},+				{+				"name": "keyword.control.require",+				"match": "require"+				},+				{+				"name": "keyword.operator",+				"match": "-|==|!=|<|>|<=|>=|\\|\\||&&|\\+|-|\\*|/(?![/|*])|\\^|\\+\\+|\\$"+				},+				{+				"name": "keyword.operator.lambda",+				"match": "\\\\(\\w+)\\.",+				"captures": { "1": {"name": "variable.other"} }+				},+				{+				"name": "keyword.other",+				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|noop|wait|selfdestruct|move|turn|grab|harvest|place|give|install|make|has|installed|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|whereami|blocked|scan|upload|ishere|whoami|setname|random|run|return|try|swap|atomic|teleport|as|robotnamed|robotnumbered|knows)\\b"+				}+			]+			},+		"comments": {+			"patterns": [+				{+				"name": "comment.line.double-slash",+				"begin": "//",+				"end": "\n"+				},+				{+				"name":"comment.block",+				"begin": "\/[*]",+				"end": "[*](\/)"+				}+			]+		},+		"strings":{+			"patterns": [+				{+				"name":"string.quoted.double",+				"begin": "\"",+				"end": "\""+				}+			]+		},+		"variables":{+			"patterns": [+				{+				"name": "variable.language.dir",+				"match": "\\b(?i)(left|right|back|forward|north|south|east|west|down)\\b"+				},+				{+				"name": "variable.other"	,+				"match": "\\b(?i)([a-z]\\w*)\\b"+				}+			]+		},+		"constants": {+			"patterns": [+				{+				"name": "constant.numeric",+				"match": "([0-9]+|0b[01]+|0o[0-8]+|0x\\x+)"+				}+			]+		}++	},+	"scopeName": "source.swarm"+}
+ example/BFS-clear.sw view
@@ -0,0 +1,66 @@+// Quickly harvesting an entire forest in parallel using breadth-first+// search, with robots spawning more robots.  Fun, though not very practical+// in classic mode.++def repeat : int -> cmd unit -> cmd unit = \n.\c.+  if (n == 0)+    {}+    {c ; repeat (n-1) c}+end;+def while : cmd bool -> cmd unit -> cmd unit = \test.\c.+  b <- test;+  if b {c ; while test c} {}+end;+def getX : cmd int =+  pos <- whereami;+  return (fst pos);+end;+def getY : cmd int =+  pos <- whereami;+  return (snd pos);+end;+def gotoX : int -> cmd unit = \tgt.+  cur <- getX;+  if (cur == tgt)+    {}+    {if (cur < tgt)+       {turn east}+       {turn west};+     try {move} {turn south; move};+     gotoX tgt+    }+end;+def gotoY : int -> cmd unit = \tgt.+  cur <- getY;+  if (cur == tgt)+    {}+    {if (cur < tgt)+       {turn north}+       {turn south};+     try {move} {turn east; move};+     gotoY tgt+    }+end;+def goto : int -> int -> cmd unit = \x. \y. gotoX x; gotoY y; gotoX x; gotoY y end;+def spawnfwd : {cmd unit} -> cmd unit = \c.+   try {+     move;+     b <- isHere "tree";+     if b+       { build c; return () }+       {};+     turn back;+     move+   } { turn back }+end;+def clear : cmd unit =+  grab;+  repeat 4 (+    spawnfwd {clear};+    turn left+  );+  goto 0 0;+  give base "tree";+  selfdestruct;+end;+def start : cmd robot = build {turn west; repeat 7 move; clear} end
+ example/cat.sw view
@@ -0,0 +1,24 @@+// A "cat" that wanders around randomly.  Shows off use of the+// 'random' command.++let forever : cmd unit -> cmd unit = \c. c ; forever c in+let repeat : int -> cmd unit -> cmd unit =+  \n. \c. if (n == 0) {} {c ; repeat (n-1) c} in+let randdir : cmd dir =+  d <- random 4;+  return (+    if (d == 0) {north}+    {if (d == 1) {east}+    {if (d == 2) {south} {west}}})+  in++forever (+  n <- random 20;+  wait (10 + n);+  d <- randdir;+  turn d;+  dist <- random 10;+  repeat dist move;+  r <- random 5;+  if (r == 0) { say "meow" } {}+)
+ example/dfs.sw view
@@ -0,0 +1,13 @@+def ifC : forall a. cmd bool -> {cmd a} -> {cmd a} -> cmd a =+  \test. \thn. \els. b <- test; if b thn els end++// Recursive DFS to harvest a contiguous forest+def dfs : cmd unit =+  ifC (ishere "tree") {+    grab;+    turn west;+    ifC blocked {} {move; dfs; turn east; move};+    turn north;+    ifC blocked {} {move; dfs; turn south; move};+  } {}+end
+ example/fact.sw view
@@ -0,0 +1,13 @@+// Defining simple recursive functions.++def repeat : int -> cmd unit -> cmd unit = \n.\c.+  if (n == 0) {} {c ; repeat (n-1) c}+end++def fact : int -> int = \n:int.+  if (n == 0)+    {1}+    {n * fact (n-1)}+end++def gofar = repeat (fact 4) move end
+ example/list.sw view
@@ -0,0 +1,314 @@+/*******************************************************************/+/*                       LIST ENCODING IN INT                      */+/*                                                                 */+/* This file defines functions that allow storing arbitrary list   */+/* of values in one integer. It is possible because an integer can */+/* have unlimited length and can be split into chunks of smaller   */+/* integers. See Haskell docs for Integer (used by swarm for int). */+/*                                                                 */+/* For examples of usage see the unit tests in testLIST function.  */+/*                                                                 */+/*******************************************************************/++// Definitions:+// - MAIN: nil (Haskell []), cons (Haskell (:)), head, tail+// - BONUS: headTail, index, for, for_each, for_each_i+// - ARITH: len, mod, shiftL, shiftR, shiftLH, shiftRH+// - HELPERS: consP, getLenPart, setLenPart, to1numA, getLenA+// - TESTS: assert, testLIST, testLIST_BIG, testLIST_ALL++/*******************************************************************/+/*                              TYPE                               */+/*******************************************************************/++// Type of list of ints - the inner ints can themselves be lists,+// so *any* type can be encoded inside.+//+// It is the callers responsibility to make sure a program using this+// "type" is type safe. Notably 2 == [0] != [] == 0 but [] !! x == 0.+// +// TODO: once #153 is resolved, add types to definitions+//+// type listI = int++/*******************************************************************/+/*                             LAYOUT                              */+/*******************************************************************/++// The length of a number is kept in the header and split into 7bit+// chunks each prefixed by 1bit that marks if the byte is last in+// the header (0=YES).++/* EXAMPLE - [short_x,long_y] - concretly e.g. [42, 2^(2^7)] ++0   < len short_x < 2^7+2^7 < len long_y  < 2^14 ++cons short_x   $          cons long_y          $ nil+vvvvvvvvvvvv       vvvvvvvvvvvvvvvvvvvvvvvvv     vvv+  0|len x|x    |   1|len y%2^7|0|len y/2^7|y   |  0+^^^^^^^^^^^^       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+  head                         tail            +*/++/*******************************************************************/+/*                         ARITH PRIMITIVES                        */+/*******************************************************************/++// bitlength of a number (shifting by one)+def naive_len : int -> int = \i.+  if (i == 0) {0} {1 + naive_len (i/2)}+end++// modulus function (%)+def mod : int -> int -> int = \i.\m.+  i - m * (i / m)+end++// f X Y = Y * 2^(-X)+def shiftL : int -> int -> int = \s.\i.+  i / 2^s+end++// f X Y = Y * 2^(X)+def shiftR : int -> int -> int = \s.\i.+  i * 2^s+end++// shift by (8bit) bytes+def shiftLH : int -> int -> int = \s. shiftL (s*8) end+def shiftRH : int -> int -> int = \s. shiftR (s*8) end++// bitlength of a number (shifting by 64)+def len : int -> int = \i.+  let next = i / 2^64 in+  if (next == 0) {naive_len i} {64 + len next}+end++/*******************************************************************/+/*                       helper functions                          */+/*******************************************************************/++def getLenPart : int -> int = \i. mod (i/2) (2^7) end+def setLenPart : int -> int = \i. 2 * (mod i (2^7)) end++// Split length into 7-bit parts and prefix all but last with 1+def to1numA : int -> int * int = \i.+  let nextPart = shiftL 7 i in+  if (nextPart == 0)+    { ((2 * i), 1) } /* last part */+    { let p = to1numA nextPart in+      ( 1 /* header isEnd bit */ + setLenPart i + shiftRH 1 (fst p)+      , 1 + snd p+      )+    }+end++// Get bitlength of the first number in the list+// and also the list starting at the number itself+//+// getLenA : listI -> int * int+def getLenA = \xs.+  let isEnd = 0 == mod xs 2 in+  let l = getLenPart xs in+  let nextPart = shiftLH 1 xs in+  if isEnd+    { (l, nextPart) }+    { let p = getLenA nextPart in+      (l + shiftR 7 (fst p), snd p)+    }+end++/*******************************************************************/+/*                         LIST FUNCTIONS                          */+/*******************************************************************/++// headTail : listI -> {int} * {listI} +def headTail = \xs.+  let sign = mod xs 2 in+  let ns = xs / 2 in+  let p = getLenA ns in+  ( { let x = mod (snd p) $ 2 ^ fst p in+      if (sign == 0) {x} {-x}+    }+  , { shiftL (fst p) (snd p) }+  )+end++// head : listI -> int+def head : int -> int = \xs.+  force $ fst $ headTail xs+end++// tail : listI -> listI +def tail = \xs.+  force $ snd $ headTail xs+end++// nil : listI+def nil = 0 end++// Add non-negative number to beggining of list (cons adds the sign)+// consP : nat -> listI -> int+def consP = \x.\xs.+  if (x == 0)+    { 2 /* header says one bit length */ + shiftR (8+1) xs}+    { let l = len x in+      let pl = to1numA l in+      (fst pl + shiftRH (snd pl) (x + shiftR l xs))+    }+end++// Add integer to the beggining of the list+// consP : int -> listI -> listI+def cons = \x.\xs.+  if (x >= 0)+    {     2 * consP   x  xs }+    { 1 + 2 * consP (-x) xs }+end+++/*******************************************************************/+/*                       MORE LIST FUNCTIONS                       */+/*******************************************************************/++// index : int -> listI -> int+def index = \i.\xs.+  if (i <= 0)+    {head xs}+    {index (i-1) (tail xs)}+end++def for : int -> int -> (int -> cmd a) -> cmd unit = \s.\e.\act.+  if (s == e) {}+  {act s; for (s+1) e act}+end++// for_each_i : int -> listI int -> (int * int -> cmd a) -> cmd unit+def for_each_i = \i.\xs.\act.+  if (xs == nil) {}+  { let ht = headTail xs+    in act i (force $ fst ht); for_each_i (i+1) (force $ snd ht) act+  }+end++// for_each : listI int -> (int -> cmd a) -> cmd unit+def for_each = \xs.\act.+  for_each_i 0 xs (\i. act)+end++/*******************************************************************/+/*                           UNIT TESTS                            */+/*******************************************************************/++// TODO: show values when #248 is implemented+def assert = \b.\m.+  if b {} {log "FAIL:"; fail m}+end++def testLIST =+  log "STARTING TESTS OF LIST:";++  log "check [0]";+  let l0 = cons 0 nil in+  assert (l0 == 4)                   "[0] ~ 4";+  assert (head l0 == 0)              "head [0] == 0";+  assert (tail l0 == nil)            "tail [0] == []";++  log "check [1]";+  let l1 = cons 1 nil in+  assert (l1 == 516)                 "[1] ~ 516";+  assert (head l1 == 1)              "head [1] == 1";+  assert (tail l1 == nil)            "tail [1] == []";++  log "check [-1]";+  let ln1 = cons (-1) nil in+  assert (ln1 == 517)                "[-1] ~ 517";+  assert (head ln1 == -1)            "head [-1] == -1";+  assert (tail ln1 == nil)           "tail [-1] == []";+  +  log "check [42]";+  let l42 = cons 42 nil in+  assert (l42 == 21528)              "[42] ~ 21528";+  assert (head l42 == 42)            "head [42] == 42";+  assert (tail l42 == nil)           "tail [42] == []";+  +  log "check [499672]";+  let l499672 = cons 499672 nil in+  assert (l499672 == 255832140)      "[499672] ~ 255832140";+  assert (head l499672 == 499672)    "head [499672] == 499672";+  assert (tail l499672 == nil)       "tail [499672] == []";+  +  log "check [1,0]";+  let l1_0 = cons 1 l0 in+  assert (l1_0 == 4612)              "[1,0] ~ 4612";+  assert (head l1_0 == 1)            "head [1,0] == 1";+  assert (tail l1_0 == l0)           "tail [1,0] == [0]";++  log "check [11,1,0]";+  let l11_1_0 = cons 11 l1_0 in+  assert (head l11_1_0 == 11)        "head [11,1,0] == 11";+  assert (tail l11_1_0 == l1_0)      "tail [11,1,0] == [1,0]";++  log "check [0..9]";+  let l0__9 = cons 0 $ cons 1 $ cons 2 $ cons 3 $ cons 4 $ cons 5 $ cons 6 $ cons 7 $ cons 8 $ cons 9 nil in+  assert (head l0__9 == 0)           "head [0..9] == 0";++  log "check indices";+  assert (index 0 l0__9 == 0)        "[0..9] !! 0 == 0";+  assert (index 9 l0__9 == 9)        "[0..9] !! 9 == 9";++  // TODO: log the number of iteration once #248 is implemented++  log "check for";+  for 0 9 (\i.+    assert (index i l0__9 == i)      "[0..9] - every index I has value I"+  );++  log "check for_each";+  for_each l0__9 (\x.+    assert (x < 10)                  "[0..9] - every value X < 10"+  );++  log "check for_each_i";+  for_each_i 0 l0__9 (\i.\x.+    assert (i == x)                  "[0..9] - I == X for every value X at index I"+  );++  log "OK - ALL TEST PASSED\a"+end++// This tests uses VERY LONG lists of size up to 2097332 bits.+// TIP: increase the game speed (ticks/s) when you run this test.+def testLIST_BIG =+  log "STARTING TESTS OF BIG LISTS:";++  log "check [2^(2^7)] aka [big]";+  let big = 2^2^7 in+  assert (len big == 129)            "len (2^2^7) == 2^7+1";+  assert (to1numA 129 == (515,2))    "to1numA: 129 == 1000_0001 --> 515 == [0000 001 0] [0000 001 1]";+  assert (getLenA 515 == (129,nil))  "getLenA: 515 --> 129";+  let ibig = 2 * (shiftR 16 big + 515) in+  let lbig = cons big nil in+  assert (lbig == ibig)              "[big] ~ 2 * ((big * 2^(2*8)) + 515)";+  assert (head lbig == big)          "head [big] == big";+  assert (tail lbig == nil)          "tail [big] == []";++  log "check [2^(2^21)] aka [bigger]";+  let bigger = 2^(2^21) in+  let lbigger = cons bigger nil in+  assert (head lbigger == bigger)    "head [bigger] == bigger";+  assert (tail lbigger == nil)       "tail [bigger] == []";++  log "check [2^(2^21),2^(2^7)] aka [bigger,big]";+  let lbiggest = cons bigger lbig in+  assert (head lbiggest == bigger)  "head [bigger,big] == bigger";+  assert (tail lbiggest == lbig)    "tail [bigger,big] == [big]";+  +  log "OK - ALL TEST PASSED";+end++def testLIST_ALL =+  testLIST;+  testLIST_BIG;+end
+ example/wander.sw view
@@ -0,0 +1,12 @@+def forever : {cmd unit} -> cmd unit =+  \c. force c ; forever c+end++// Wander randomly forever.+def wander : cmd unit =+  forever {+    b <- random 2;+    turn (if (b == 0) {left} {right});+    move+  }+end
+ src/Swarm/App.hs view
@@ -0,0 +1,130 @@+{-# 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.+module Swarm.App where++import Brick+import Brick.BChan+import Control.Concurrent (forkIO, threadDelay)+import Control.Lens ((%~), (&), (?~), (^.))+import Control.Monad.Except+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.Robot (LogSource (ErrorTrace, Said))+import Swarm.TUI.Attr+import Swarm.TUI.Controller+import Swarm.TUI.Model+import Swarm.TUI.View+import Swarm.Version (getNewerReleaseVersion)+import Swarm.Web+import System.IO (stderr)++type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState ()++-- | The definition of the app used by the @brick@ library.+app :: EventHandler -> App AppState AppEvent Name+app eventHandler =+  App+    { appDraw = drawUI+    , appChooseCursor = chooseCursor+    , appHandleEvent = eventHandler+    , appStartEvent = enablePasteMode+    , appAttrMap = const swarmAttrMap+    }++-- | The main @IO@ computation which initializes the state, sets up+--   some communication channels, and runs the UI.+appMain :: AppOpts -> IO ()+appMain opts = do+  res <- runExceptT $ initAppState opts+  case res of+    Left errMsg -> T.hPutStrLn stderr errMsg+    Right s -> do+      -- Send Frame events as at a reasonable rate for 30 fps. The+      -- game is responsible for figuring out how many steps to take+      -- each frame to achieve the desired speed, regardless of the+      -- frame rate.  Note that if the game cannot keep up with 30+      -- fps, it's not a problem: the channel will fill up and this+      -- thread will block.  So the force of the threadDelay is just+      -- to set a *maximum* possible frame rate.+      --+      -- 5 is the size of the bounded channel; when it gets that big,+      -- any writes to it will block.  Probably 1 would work fine,+      -- though it seems like it could be good to have a bit of buffer+      -- just so the app never has to wait for the thread to wake up+      -- and do another write.++      chan <- newBChan 5+      _ <- forkIO $+        forever $ do+          threadDelay 33_333 -- cap maximum framerate at 30 FPS+          writeBChan chan Frame++      _ <- forkIO $ do+        upRel <- getNewerReleaseVersion+        writeBChan chan (UpstreamVersion upRel)++      -- Start the web service with a reference to the game state+      gsRef <- newIORef (s ^. gameState)+      eport <- Swarm.Web.startWebThread (userWebPort opts) gsRef++      let logP p = logEvent Said ("Web API", -2) ("started on :" <> T.pack (show p))+      let logE e = logEvent ErrorTrace ("Web API", -2) (T.pack e)+      let s' =+            s & runtimeState+              %~ case eport of+                Right p -> (webPort ?~ p) . (eventLog %~ logP p)+                Left e -> eventLog %~ logE e++      -- Update the reference for every event+      let eventHandler e = do+            curSt <- get+            liftIO $ writeIORef gsRef (curSt ^. gameState)+            handleEvent e++      -- Run the app.+      let buildVty = V.mkVty V.defaultConfig+      initialVty <- buildVty+      V.setMode (V.outputIface initialVty) V.Mouse True+      void $ customMain initialVty buildVty (Just chan) (app eventHandler) s'++-- | A demo program to run the web service directly, without the terminal application.+-- This is useful to live update the code using `ghcid -W --test "Swarm.App.demoWeb"`+demoWeb :: IO ()+demoWeb = do+  let demoPort = 8080+  res <-+    runExceptT $+      initAppState $+        AppOpts+          { userSeed = Nothing+          , userScenario = demoScenario+          , toRun = Nothing+          , cheatMode = False+          , userWebPort = Nothing+          }+  case res of+    Left errMsg -> T.putStrLn errMsg+    Right s -> do+      gsRef <- newIORef (s ^. gameState)+      webMain Nothing demoPort gsRef+ where+  demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml"++-- | If available for the terminal emulator, enable bracketed paste mode.+enablePasteMode :: EventM n s ()+enablePasteMode = do+  vty <- getVtyHandle+  let output = V.outputIface vty+  when (V.supportsMode output V.BracketedPaste) $+    liftIO $+      V.setMode output V.BracketedPaste True
+ src/Swarm/DocGen.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE OverloadedStrings #-}++module Swarm.DocGen (+  generateDocs,+  GenerateDocs (..),+  EditorType (..),+  SheetType (..),++  -- ** Formatted keyword lists+  keywordsCommands,+  keywordsDirections,+  operatorNames,+  builtinFunctionList,+  editorList,++  -- ** Wiki pages+  commandsPage,+) where++import Control.Lens (view, (^.))+import Control.Monad (zipWithM, zipWithM_, (<=<))+import Control.Monad.Except (ExceptT, runExceptT)+import Data.Bifunctor (Bifunctor (bimap))+import Data.Containers.ListUtils (nubOrd)+import Data.Foldable (toList)+import Data.List (transpose)+import Data.Map.Lazy (Map)+import Data.Map.Lazy qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text, unpack)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Tuple (swap)+import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, loadEntities)+import Swarm.Game.Entity qualified as E+import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements)+import Swarm.Game.Robot (installedDevices, instantiateRobot, robotInventory)+import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)+import Swarm.Game.WorldGen (testWorld2Entites)+import Swarm.Language.Capability (capabilityName, constCaps)+import Swarm.Language.Pretty (prettyText)+import Swarm.Language.Syntax (Const (..))+import Swarm.Language.Syntax qualified as Syntax+import Swarm.Language.Typecheck (inferConst)+import Swarm.Util (isRightOr)+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+  CheatSheet :: 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)++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 [minBound .. maxBound]+  CheatSheet s -> case s of+    Nothing -> error "Not implemented"+    Just st -> case st of+      Commands -> T.putStrLn commandsPage+      _ -> error "Not implemented"++-- ----------------------------------------------------------------------------+-- 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 "|"+ where+  quote = T.cons '"' . flip T.snoc '"'++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++-- ---------+-- COMMANDS+-- ---------++commandHeader :: [Text]+commandHeader = ["Syntax", "Type", "Capability", "Description"]++commandToList :: Const -> [Text]+commandToList c =+  map+    escapeTable+    [ addLink (T.pack $ "#" <> show c) . codeQuote $ constSyntax c+    , codeQuote . prettyText $ inferConst c+    , maybe "" capabilityName $ constCaps c+    , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c+    ]+ where+  addLink l t = T.concat ["[", t, "](", l, ")"]++constTable :: [Const] -> Text+constTable cs = T.unlines $ header <> map (listToRow mw) commandRows+ 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: " <>) . capabilityName) $ 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)++-- ----------------------------------------------------------------------------+-- 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 entites+  let enames' = toList . Map.keysSet . entitiesByName $ emap+      enames = filter (`Set.notMember` ignoredEntites) 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, entites 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 entites+  (_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 entites 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 entites 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 entites 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 entites in sets depending on how soon it is possible to obtain them.+--+-- So:+--  * Level 0 - starting entites (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 entites+-- required for recipe is subset of the entites 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 entites.+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 installedDevices . 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 entites that are just used for tutorials and challenges.+ignoredEntites :: Set Text+ignoredEntites =+  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/CESK.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# 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+-- <https://matt.might.net/articles/cesk-machines/ CESK machine> (if+-- you want to read up on them, you may want to start by reading about+-- <https://matt.might.net/articles/cek-machines/ CEK machines>+-- first).  Execution happens simply by iterating a step function,+-- sending one state of the CESK machine to the next. In addition to+-- being relatively efficient, this means we can easily run a bunch of+-- robots synchronously, in parallel, without resorting to any threads+-- (by stepping their machines in a round-robin fashion); pause and+-- single-step the game; save and resume, and so on.+--+-- Essentially, a CESK machine state has four components:+--+-- - The __C__ontrol is the thing we are currently focused on:+--   either a 'Term' to evaluate, or a 'Value' that we have+--   just finished evaluating.+-- - The __E__nvironment ('Env') is a mapping from variables that might+--   occur free in the Control to their values.+-- - The __S__tore ('Store') is a mapping from abstract integer+--   /locations/ to values.  We use it to store delayed (lazy) values,+--   so they will be computed at most once.+-- - The __K__ontinuation ('Cont') is a stack of 'Frame's,+--   representing the evaluation context, /i.e./ what we are supposed+--   to do after we finish with the currently focused thing.  When we+--   reduce the currently focused term to a value, the top frame on+--   the stack tells us how to proceed.+--+-- You can think of a CESK machine as a defunctionalization of a+-- recursive big-step interpreter, where we explicitly keep track of+-- the call stack and the environments that would be in effect at+-- various places in the recursion.  One could probably even derive+-- this mechanically, by writing a recursive big-step interpreter,+-- then converting it to CPS, then defunctionalizing the+-- continuations.+--+-- The slightly confusing thing about CESK machines is how we+-- have to pass around environments everywhere.  Basically,+-- anywhere there can be unevaluated terms containing free+-- variables (in values, in continuation stack frames, ...), we+-- have to store the proper environment alongside so that when+-- we eventually get around to evaluating it, we will be able to+-- pull out the environment to use.+module Swarm.Game.CESK (+  -- * Frames and continuations+  Frame (..),+  Cont,++  -- ** Wrappers for creating delayed change of state++  --    See 'FImmediate'.+  WorldUpdate (..),+  RobotUpdate (..),++  -- * Store+  Store,+  Loc,+  emptyStore,+  Cell (..),+  allocate,+  lookupCell,+  setCell,++  -- * CESK machine states+  CESK (..),++  -- ** Construction+  initMachine,+  initMachine',+  cancel,+  resetBlackholes,++  -- ** Extracting information+  finalValue,++  -- ** Pretty-printing+  prettyFrame,+  prettyCont,+  prettyCESK,+) where++import Control.Lens.Combinators (pattern Empty)+import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson qualified+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.List (intercalate)+import GHC.Generics (Generic)+import Swarm.Game.Entity (Entity, Inventory)+import Swarm.Game.Exception+import Swarm.Game.Value as V+import Swarm.Game.World (World)+import Swarm.Language.Context+import Swarm.Language.Pipeline+import Swarm.Language.Pretty+import Swarm.Language.Requirement (ReqCtx)+import Swarm.Language.Syntax+import Swarm.Language.Types+import Witch (from)++------------------------------------------------------------+-- Frames and continuations+------------------------------------------------------------++-- | A frame is a single component of a continuation stack, explaining+--   what to do next after we finish evaluating the currently focused+--   term.+data Frame+  = -- | We were evaluating the first component of a pair; next, we+    --   should evaluate the second component which was saved in this+    --   frame (and push a 'FFst' frame on the stack to save the first component).+    FSnd Term Env+  | -- | We were evaluating the second component of a pair; when done,+    --   we should combine it with the value of the first component saved+    --   in this frame to construct a fully evaluated pair.+    FFst Value+  | -- | @FArg t e@ says that we were evaluating the left-hand side of+    -- an application, so the next thing we should do is evaluate the+    -- term @t@ (the right-hand side, /i.e./ argument of the+    -- application) in environment @e@.  We will also push an 'FApp'+    -- frame on the stack.+    FArg Term Env+  | -- | @FApp v@ says that we were evaluating the right-hand side of+    -- an application; once we are done, we should pass the resulting+    -- value as an argument to @v@.+    FApp Value+  | -- | @FLet x t2 e@ says that we were evaluating a term @t1@ in an+    -- expression of the form @let x = t1 in t2@, that is, we were+    -- evaluating the definition of @x@; the next thing we should do+    -- is evaluate @t2@ in the environment @e@ extended with a binding+    -- for @x@.+    FLet Var Term Env+  | -- | We are executing inside a 'Try' block.  If an exception is+    --   raised, we will execute the stored term (the "catch" block).+    FTry Value+  | -- | We were executing a command; next we should take any+    --   environment it returned and union it with this one to produce+    --   the result of a bind expression.+    FUnionEnv Env+  | -- | We were executing a command that might have definitions; next+    --   we should take the resulting 'Env' and add it to the robot's+    --   'Swarm.Game.Robot.robotEnv', along with adding this accompanying 'Ctx' and+    --   'ReqCtx' to the robot's 'Swarm.Game.Robot.robotCtx'.+    FLoadEnv TCtx ReqCtx+  | -- | We were executing a definition; next we should take the resulting value+    --   and return a context binding the variable to the value.+    FDef Var+  | -- | An @FExec@ frame means the focused value is a command, which+    -- we should now execute.+    FExec+  | -- | We are in the process of executing the first component of a+    --   bind; once done, we should also execute the second component+    --   in the given environment (extended by binding the variable,+    --   if there is one, to the output of the first command).+    FBind (Maybe Var) Term Env+  | -- | Apply specific updates to the world and current robot.+    FImmediate WorldUpdate RobotUpdate+  | -- | Update the memory cell at a certain location with the computed value.+    FUpdate Loc+  | -- | Signal that we are done with an atomic computation.+    FFinishAtomic+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | A continuation is just a stack of frames.+type Cont = [Frame]++------------------------------------------------------------+-- Store+------------------------------------------------------------++type Loc = Int++-- | 'Store' represents a store, indexing integer locations to 'Cell's.+data Store = Store {next :: Loc, mu :: IntMap Cell} deriving (Show, Eq, Generic, FromJSON, ToJSON)++-- | A memory cell can be in one of three states.+data Cell+  = -- | A cell starts out life as an unevaluated term together with+    --   its environment.+    E Term Env+  | -- | When the cell is 'Force'd, it is set to a 'Blackhole' while+    --   being evaluated.  If it is ever referenced again while still+    --   a 'Blackhole', that means it depends on itself in a way that+    --   would trigger an infinite loop, and we can signal an error.+    --   (Of course, we+    --   <http://www.lel.ed.ac.uk/~gpullum/loopsnoop.html cannot+    --   detect /all/ infinite loops this way>.)+    --+    --   A 'Blackhole' saves the original 'Term' and 'Env' that are+    --   being evaluated; if Ctrl-C is used to cancel a computation+    --   while we are in the middle of evaluating a cell, the+    --   'Blackhole' can be reset to 'E'.+    Blackhole Term Env+  | -- | Once evaluation is complete, we cache the final 'Value' in+    --   the 'Cell', so that subsequent lookups can just use it+    --   without recomputing anything.+    V Value+  deriving (Show, Eq, Generic, FromJSON, ToJSON)++emptyStore :: Store+emptyStore = Store 0 IM.empty++-- | Allocate a new memory cell containing an unevaluated expression+--   with the current environment.  Return the index of the allocated+--   cell.+allocate :: Env -> Term -> Store -> (Loc, Store)+allocate e t (Store n m) = (n, Store (n + 1) (IM.insert n (E t e) m))++-- | Look up the cell at a given index.+lookupCell :: Loc -> Store -> Maybe Cell+lookupCell n = IM.lookup n . mu++-- | Set the cell at a given index.+setCell :: Loc -> Cell -> Store -> Store+setCell n c (Store nxt m) = Store nxt (IM.insert n c m)++------------------------------------------------------------+-- CESK machine+------------------------------------------------------------++-- | The overall state of a CESK machine, which can actually be one of+--   three kinds of states. The CESK machine is named after the first+--   kind of state, and it would probably be possible to inline a+--   bunch of things and get rid of the second state, but I find it+--   much more natural and elegant this way.  Most tutorial+--   presentations of CEK/CESK machines only have one kind of state, but+--   then again, most tutorial presentations only deal with the bare+--   lambda calculus, so one can tell whether a term is a value just+--   by seeing whether it is syntactically a lambda.  I learned this+--   approach from Harper's Practical Foundations of Programming+--   Languages.+data CESK+  = -- | When we are on our way "in/down" into a term, we have a+    --   currently focused term to evaluate in the environment, a store,+    --   and a continuation.  In this mode we generally pattern-match on the+    --   'Term' to decide what to do next.+    In Term Env Store Cont+  | -- | Once we finish evaluating a term, we end up with a 'Value'+    --   and we switch into "out" mode, bringing the value back up+    --   out of the depths to the context that was expecting it.  In+    --   this mode we generally pattern-match on the 'Cont' to decide+    --   what to do next.+    --+    --   Note that there is no 'Env', because we don't have anything+    --   with variables to evaluate at the moment, and we maintain the+    --   invariant that any unevaluated terms buried inside a 'Value'+    --   or 'Cont' must carry along their environment with them.+    Out Value Store Cont+  | -- | An exception has been raised.  Keep unwinding the+    --   continuation stack (until finding an enclosing 'Try' in the+    --   case of a command failure or a user-generated exception, or+    --   until the stack is empty in the case of a fatal exception).+    Up Exn Store Cont+  | -- | The machine is waiting for the game to reach a certain time+    --   to resume its execution.+    Waiting Integer CESK+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | Is the CESK machine in a final (finished) state?  If so, extract+--   the final value and store.+finalValue :: CESK -> Maybe (Value, Store)+{-# INLINE finalValue #-}+finalValue (Out v s []) = Just (v, s)+finalValue _ = Nothing++-- | Initialize a machine state with a starting term along with its+--   type; the term will be executed or just evaluated depending on+--   whether it has a command type or not.+initMachine :: ProcessedTerm -> Env -> Store -> CESK+initMachine t e s = initMachine' t e s []++-- | Like 'initMachine', but also take an explicit starting continuation.+initMachine' :: ProcessedTerm -> Env -> Store -> Cont -> CESK+initMachine' (ProcessedTerm t (Module (Forall _ (TyCmd _)) ctx) _ reqCtx) e s k =+  case ctx of+    Empty -> In t e s (FExec : k)+    _ -> In t e s (FExec : FLoadEnv ctx reqCtx : k)+initMachine' (ProcessedTerm t _ _ _) e s k = In t e s k++-- | Cancel the currently running computation.+cancel :: CESK -> CESK+cancel cesk = Out VUnit s' []+ where+  s' = resetBlackholes $ getStore cesk+  getStore (In _ _ s _) = s+  getStore (Out _ s _) = s+  getStore (Up _ s _) = s+  getStore (Waiting _ c) = getStore c++-- | Reset any 'Blackhole's in the 'Store'.  We need to use this any+--   time a running computation is interrupted, either by an exception+--   or by a Ctrl+C.+resetBlackholes :: Store -> Store+resetBlackholes (Store n m) = Store n (IM.map resetBlackhole m)+ where+  resetBlackhole (Blackhole t e) = E t e+  resetBlackhole c = c++------------------------------------------------------------+-- Very crude pretty-printing of CESK states.  Should really make a+-- nicer version of this code...+------------------------------------------------------------++-- | Very poor pretty-printing of CESK machine states, really just for+--   debugging. At some point we should make a nicer version.+prettyCESK :: CESK -> String+prettyCESK (In c _ _ k) =+  unlines+    [ "▶ " ++ prettyString c+    , "  " ++ prettyCont k+    ]+prettyCESK (Out v _ k) =+  unlines+    [ "◀ " ++ from (prettyValue v)+    , "  " ++ prettyCont k+    ]+prettyCESK (Up e _ k) =+  unlines+    [ "! " ++ from (formatExn mempty e)+    , "  " ++ prettyCont k+    ]+prettyCESK (Waiting t cek) =+  "🕑" <> show t <> " " <> show cek++-- | Poor pretty-printing of continuations.+prettyCont :: Cont -> String+prettyCont = ("[" ++) . (++ "]") . intercalate " | " . map prettyFrame++-- | Poor pretty-printing of frames.+prettyFrame :: Frame -> String+prettyFrame (FSnd t _) = "(_, " ++ prettyString t ++ ")"+prettyFrame (FFst v) = "(" ++ from (prettyValue v) ++ ", _)"+prettyFrame (FArg t _) = "_ " ++ prettyString t+prettyFrame (FApp v) = prettyString (valueToTerm v) ++ " _"+prettyFrame (FLet x t _) = "let " ++ from x ++ " = _ in " ++ prettyString t+prettyFrame (FTry t) = "try _ (" ++ prettyString (valueToTerm t) ++ ")"+prettyFrame FUnionEnv {} = "_ ∪ <Env>"+prettyFrame FLoadEnv {} = "loadEnv"+prettyFrame (FDef x) = "def " ++ from x ++ " = _"+prettyFrame FExec = "exec _"+prettyFrame (FBind Nothing t _) = "_ ; " ++ prettyString t+prettyFrame (FBind (Just x) t _) = from x ++ " <- _ ; " ++ prettyString t+prettyFrame FImmediate {} = "(_ : cmd a)"+prettyFrame (FUpdate loc) = "store@" ++ show loc ++ "(_)"+prettyFrame FFinishAtomic = "finishAtomic"++--------------------------------------------------------------+-- Wrappers for functions in FImmediate+--+-- NOTE: we can not use GameState and Robot directly, as it+-- would create a cyclic dependency. The alternative is+-- making CESK, Cont and Frame polymorphic which just muddies+-- the picture too much for one little game feature.+--+-- BEWARE: the types do not follow normal laws for Show and Eq+--------------------------------------------------------------++newtype WorldUpdate = WorldUpdate+  { worldUpdate :: World Int Entity -> Either Exn (World Int Entity)+  }++newtype RobotUpdate = RobotUpdate+  { robotUpdateInventory :: Inventory -> Inventory+  }++instance Show WorldUpdate where show _ = "WorldUpdate {???}"++instance Show RobotUpdate where show _ = "RobotUpdate {???}"++instance Eq WorldUpdate where _ == _ = True++instance Eq RobotUpdate where _ == _ = True++-- TODO: remove these instances once Update fields are concret+instance FromJSON WorldUpdate where parseJSON _ = pure $ WorldUpdate $ \w -> Right w+instance ToJSON WorldUpdate where toJSON _ = Data.Aeson.Null+instance FromJSON RobotUpdate where parseJSON _ = pure $ RobotUpdate id+instance ToJSON RobotUpdate where toJSON _ = Data.Aeson.Null
+ src/Swarm/Game/Display.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- 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,+  Display,++  -- ** Fields+  defaultChar,+  orientationMap,+  curOrientation,+  displayAttr,+  displayPriority,+  invisible,++  -- ** Rendering+  displayChar,+  renderDisplay,+  hidden,++  -- ** Construction+  defaultTerrainDisplay,+  defaultEntityDisplay,+  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.Yaml+import GHC.Generics (Generic)+import Swarm.Language.Syntax (Direction (..))+import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix)+import Swarm.Util (maxOn, (?))++-- | 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++-- | A record explaining how to display an entity in the TUI.+data Display = Display+  { _defaultChar :: Char+  , _orientationMap :: Map Direction Char+  , _curOrientation :: Maybe Direction+  , _displayAttr :: AttrName+  , _displayPriority :: Priority+  , _invisible :: Bool+  }+  deriving (Eq, Ord, Show, Generic, Hashable)++instance Semigroup Display where+  d1 <> d2+    | _invisible d1 = d2+    | _invisible d2 = d1+    | otherwise = maxOn _displayPriority d1 d2++makeLensesWith (lensRules & generateSignatures .~ False) ''Display++-- | The default character to use for display.+defaultChar :: Lens' Display Char++-- | For robots or other entities that have an orientation, this map+--   optionally associates different display characters with+--   different orientations.  If an orientation is not in the map,+--   the 'defaultChar' will be used.+orientationMap :: Lens' Display (Map Direction Char)++-- | The display caches the current orientation of the entity, so we+--   know which character to use from the orientation map.+curOrientation :: Lens' Display (Maybe Direction)++-- | The attribute to use for display.+displayAttr :: Lens' Display AttrName++-- | This entity's display priority. Higher priorities are drawn+--   on top of lower.+displayPriority :: Lens' Display Priority++-- | Whether the entity is currently invisible.+invisible :: Lens' Display Bool++instance FromJSON Display where+  parseJSON = withObject "Display" $ \v ->+    Display+      <$> v .:? "char" .!= ' '+      <*> v .:? "orientationMap" .!= M.empty+      <*> v .:? "curOrientation"+      <*> (fmap (worldPrefix <>) <$> v .:? "attr") .!= entityAttr+      <*> v .:? "priority" .!= 1+      <*> v .:? "invisible" .!= False++instance ToJSON Display where+  toJSON d =+    object $+      [ "char" .= (d ^. defaultChar)+      , "attr" .= (d ^. displayAttr)+      , "priority" .= (d ^. displayPriority)+      ]+        ++ ["orientationMap" .= (d ^. orientationMap) | not (M.null (d ^. orientationMap))]+        ++ ["invisible" .= (d ^. invisible) | d ^. invisible]++-- | Look up the character that should be used for a display.+displayChar :: Display -> Char+displayChar disp = case disp ^. curOrientation of+  Nothing -> disp ^. defaultChar+  Just dir -> M.lookup dir (disp ^. orientationMap) ? (disp ^. defaultChar)++-- | 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+hidden = (defaultChar .~ '?') . (curOrientation .~ Nothing)++-- | The default way to display some terrain using the given character+--   and attribute, with priority 0.+defaultTerrainDisplay :: Char -> AttrName -> Display+defaultTerrainDisplay c attr =+  defaultEntityDisplay c+    & displayPriority .~ 0+    & displayAttr .~ attr++-- | Construct a default display for an entity that uses only a single+--   display character, the default entity attribute, and priority 1.+defaultEntityDisplay :: Char -> Display+defaultEntityDisplay c =+  Display+    { _defaultChar = c+    , _orientationMap = M.empty+    , _curOrientation = Nothing+    , _displayAttr = entityAttr+    , _displayPriority = 1+    , _invisible = False+    }++-- | Construct a default robot display for a given orientation, with+--   display characters @"X^>v<"@, the default robot attribute, and+--   priority 10.+--+--   Note that the 'defaultChar' is used for direction 'DDown'+--   and is overriden for the special base robot.+defaultRobotDisplay :: Display+defaultRobotDisplay =+  Display+    { _defaultChar = 'X'+    , _orientationMap =+        M.fromList+          [ (DEast, '>')+          , (DWest, '<')+          , (DSouth, 'v')+          , (DNorth, '^')+          ]+    , _curOrientation = Nothing+    , _displayAttr = robotAttr+    , _displayPriority = 10+    , _invisible = False+    }++instance Monoid Display where+  mempty = defaultEntityDisplay ' ' & invisible .~ True
+ src/Swarm/Game/Entity.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE OverloadedStrings #-}+{-# 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+-- entity has a way to be displayed, some metadata such as a name and+-- description, some properties, and possibly an inventory of other+-- entities.+--+-- This module also defines the 'Inventory' type, since the two types+-- are mutually recursive (an inventory contains entities, which can+-- have inventories).+module Swarm.Game.Entity (+  -- * Properties+  EntityProperty (..),+  GrowthTime (..),+  defaultGrowthTime,++  -- * Entities+  Entity,+  mkEntity,++  -- ** Lenses+  -- $lenses+  entityDisplay,+  entityName,+  entityPlural,+  entityNameFor,+  entityDescription,+  entityOrientation,+  entityGrowth,+  entityYields,+  entityProperties,+  hasProperty,+  entityCapabilities,+  entityInventory,+  entityHash,++  -- ** Entity map+  EntityMap (..),+  buildEntityMap,+  loadEntities,+  lookupEntityName,+  deviceForCap,++  -- * Inventories+  Inventory,+  Count,++  -- ** Construction+  empty,+  singleton,+  fromList,+  fromElems,++  -- ** Lookup+  lookup,+  lookupByName,+  countByName,+  contains,+  contains0plus,+  elems,+  isSubsetOf,+  isEmpty,+  inventoryCapabilities,++  -- ** Modification+  insert,+  insertCount,+  delete,+  deleteCount,+  deleteAll,+  union,+  difference,+) where++import Control.Arrow ((&&&))+import Control.Lens (Getter, Lens', lens, to, view, (^.), _2)+import Control.Monad.IO.Class+import Data.Bifunctor (bimap, first)+import Data.Char (toLower)+import Data.Function (on)+import Data.Hashable+import Data.Int (Int64)+import Data.IntMap (IntMap)+import Data.IntMap qualified as IM+import Data.IntSet (IntSet)+import Data.IntSet qualified as IS+import Data.List (foldl')+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isJust, listToMaybe)+import Data.Set (Set)+import Data.Set.Lens (setOf)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Yaml+import GHC.Generics (Generic)+import Linear (V2)+import Swarm.Game.Display+import Swarm.Language.Capability+import Swarm.Util (dataNotFound, getDataFileNameSafe, plural, reflow, (?))+import Swarm.Util.Yaml+import Text.Read (readMaybe)+import Witch+import Prelude hiding (lookup)++------------------------------------------------------------+-- Properties+------------------------------------------------------------++-- | Various properties that an entity can have, which affect how+--   robots can interact with it.+data EntityProperty+  = -- | Robots can't move onto a cell containing this entity.+    Unwalkable+  | -- | Robots can pick this up (via 'Swarm.Language.Syntax.Grab' or 'Swarm.Language.Syntax.Harvest').+    Portable+  | -- | Regrows from a seed after it is harvested.+    Growable+  | -- | Regenerates infinitely when grabbed or harvested.+    Infinite+  | -- | Robots drown if they walk on this without a boat.+    Liquid+  | -- | Robots automatically know what this is without having to scan it.+    Known+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable)++instance ToJSON EntityProperty where+  toJSON = String . from . map toLower . show++instance FromJSON EntityProperty where+  parseJSON = withText "EntityProperty" tryRead+   where+    tryRead :: Text -> Parser EntityProperty+    tryRead t = case readMaybe . from . T.toTitle $ t of+      Just c -> return c+      Nothing -> fail $ "Unknown entity property " ++ from t++-- | How long an entity takes to regrow.  This represents the minimum+--   and maximum amount of time taken by one growth stage (there are+--   two stages).  The actual time for each stage will be chosen+--   uniformly at random between these two values.+newtype GrowthTime = GrowthTime (Integer, Integer)+  deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON)++defaultGrowthTime :: GrowthTime+defaultGrowthTime = GrowthTime (100, 200)++------------------------------------------------------------+-- Entity+------------------------------------------------------------++-- | A record to hold information about an entity.+--+--   The constructor for 'Entity' is intentionally not exported.  To+--   construct one manually, use the 'mkEntity' function.+--+--   There are two main constraints on the way entities are stored:+--+--   1. We want to be able to easily modify an entity in one+--      particular cell of the world (for example, painting one+--      tree red).+--   2. In an inventory, we want to store identical entities only+--      once, along with a count.+--+--   We could get (2) nicely by storing only names of entities, and+--   having a global lookup table from names to entity records.+--   However, storing names instead of actual entity records in the+--   world makes (1) more complex: every time we modify an entity we+--   would have to generate a fresh name for the modified entity and+--   add it to the global entity table.  This approach is also+--   annoying because it means we can't just uses lenses to drill down+--   into the properties of an entity in the world or in an inventory,+--   but have to do an intermediate lookup in the global (mutable!)+--   entity table.+--+--   On the other hand, if we just store entity records everywhere,+--   checking them for equality becomes expensive.  Having an+--   inventory be a map with entities themselves as keys sounds awful.+--+--   The solution we adopt here is that every @Entity@ record carries+--   along a hash value of all the other fields.  We just assume that+--   these hashes are unique (a collision is of course possible but+--   extremely unlikely).  Entities can be efficiently compared just+--   by looking at their hashes; they can be stored in a map using+--   hash values as keys; and we provide lenses which automatically+--   recompute the hash value when modifying a field of an entity+--   record.  Note also that world storage is still efficient, too:+--   thanks to referential transparency, in practice most of the+--   entities stored in the world that are the same will literally+--   just be stored as pointers to the same shared record.+data Entity = Entity+  { -- | A hash value computed from the other fields+    _entityHash :: Int+  , -- | The way this entity should be displayed on the world map.+    _entityDisplay :: Display+  , -- | The name of the entity, used /e.g./ in an inventory display.+    _entityName :: Text+  , -- | The plural of the entity name, in case it is irregular.  If+    --   this field is @Nothing@, default pluralization heuristics+    --   will be used (see 'plural').+    _entityPlural :: Maybe Text+  , -- | A longer-form description. Each 'Text' value is one+    --   paragraph.+    _entityDescription :: [Text]+  , -- | The entity's orientation (if it has one).  For example, when+    --   a robot moves, it moves in the direction of its orientation.+    _entityOrientation :: Maybe (V2 Int64)+  , -- | If this entity grows, how long does it take?+    _entityGrowth :: Maybe GrowthTime+  , -- | The name of a different entity obtained when this entity is+    -- grabbed.+    _entityYields :: Maybe Text+  , -- | Properties of the entity.+    _entityProperties :: [EntityProperty]+  , -- | Capabilities provided by this entity.+    _entityCapabilities :: [Capability]+  , -- | Inventory of other entities held by this entity.+    _entityInventory :: Inventory+  }+  -- Note that an entity does not have a location, because the+  -- location of an entity is implicit in the way it is stored (by+  -- location).++  deriving (Show, Generic)++-- | The @Hashable@ instance for @Entity@ ignores the cached hash+--   value and simply combines the other fields.+instance Hashable Entity where+  hashWithSalt s (Entity _ disp nm pl descr orient grow yld props caps inv) =+    s `hashWithSalt` disp+      `hashWithSalt` nm+      `hashWithSalt` pl+      `hashWithSalt` descr+      `hashWithSalt` orient+      `hashWithSalt` grow+      `hashWithSalt` yld+      `hashWithSalt` props+      `hashWithSalt` caps+      `hashWithSalt` inv++-- | Entities are compared by hash for efficiency.+instance Eq Entity where+  (==) = (==) `on` _entityHash++-- | Entities are compared by hash for efficiency.+instance Ord Entity where+  compare = compare `on` _entityHash++-- | Recompute an entity's hash value.+rehashEntity :: Entity -> Entity+rehashEntity e = e {_entityHash = hash e}++-- | Create an entity with no orientation, an empty inventory,+--   providing no capabilities (automatically filling in the hash+--   value).+mkEntity ::+  -- | Display+  Display ->+  -- | Entity name+  Text ->+  -- | Entity description+  [Text] ->+  -- | Properties+  [EntityProperty] ->+  -- | Capabilities+  [Capability] ->+  Entity+mkEntity disp nm descr props caps =+  rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing props caps empty++------------------------------------------------------------+-- Entity map+------------------------------------------------------------++-- | An 'EntityMap' is a data structure containing all the loaded+--   entities, allowing them to be looked up either by name or by what+--   capabilities they provide (if any).+data EntityMap = EntityMap+  { entitiesByName :: Map Text Entity+  , entitiesByCap :: Map Capability [Entity]+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++instance Semigroup EntityMap where+  EntityMap n1 c1 <> EntityMap n2 c2 = EntityMap (n1 <> n2) (c1 <> c2)++instance Monoid EntityMap where+  mempty = EntityMap M.empty M.empty+  mappend = (<>)++-- | Find an entity with the given name.+lookupEntityName :: Text -> EntityMap -> Maybe Entity+lookupEntityName nm = M.lookup nm . entitiesByName++-- | Find all entities which are devices that provide the given+--   capability.+deviceForCap :: Capability -> EntityMap -> [Entity]+deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap++-- | Build an 'EntityMap' from a list of entities.  The idea is that+--   this will be called once at startup, when loading the entities+--   from a file; see 'loadEntities'.+buildEntityMap :: [Entity] -> EntityMap+buildEntityMap es =+  EntityMap+    { entitiesByName = M.fromList . map (view entityName &&& id) $ es+    , entitiesByCap = M.fromListWith (<>) . concatMap (\e -> map (,[e]) (e ^. entityCapabilities)) $ es+    }++------------------------------------------------------------+-- Serialization+------------------------------------------------------------++instance FromJSON Entity where+  parseJSON = withObject "Entity" $ \v ->+    rehashEntity+      <$> ( Entity 0+              <$> v .: "display"+              <*> v .: "name"+              <*> v .:? "plural"+              <*> (map reflow <$> (v .: "description"))+              <*> v .:? "orientation"+              <*> v .:? "growth"+              <*> v .:? "yields"+              <*> v .:? "properties" .!= []+              <*> v .:? "capabilities" .!= []+              <*> pure empty+          )++-- | If we have access to an 'EntityMap', we can parse the name of an+--   'Entity' as a string and look it up in the map.+instance FromJSONE EntityMap Entity where+  parseJSONE = withTextE "entity name" $ \name ->+    E $ \em -> case lookupEntityName name em of+      Nothing -> fail $ "Unknown entity: " ++ from @Text name+      Just e -> return e++instance ToJSON Entity where+  toJSON e =+    object $+      [ "display" .= (e ^. entityDisplay)+      , "name" .= (e ^. entityName)+      , "description" .= (e ^. entityDescription)+      ]+        ++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)]+        ++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)]+        ++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)]+        ++ ["yields" .= (e ^. entityYields) | isJust (e ^. entityYields)]+        ++ ["properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties]+        ++ ["capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities]++-- | Load entities from a data file called @entities.yaml@, producing+--   either an 'EntityMap' or a 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++------------------------------------------------------------+-- Entity lenses+------------------------------------------------------------++-- $lenses+-- Our own custom lenses which properly recompute the cached hash+-- value each time something gets updated.  See+-- https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/+-- for the approach used here.++-- | Make a lens for Entity that recomputes the hash after setting.+hashedLens :: (Entity -> a) -> (Entity -> a -> Entity) -> Lens' Entity a+hashedLens get set = lens get (\e a -> rehashEntity $ set e a)++-- | Get the hash of an entity.  Note that this is a getter, not a+--   lens; the "Swarm.Game.Entity" module carefully maintains some+--   internal invariants ensuring that hashes work properly, and by+--   golly, no one else is going to mess that up.+entityHash :: Getter Entity Int+entityHash = to _entityHash++-- | The 'Display' explaining how to draw this entity in the world display.+entityDisplay :: Lens' Entity Display+entityDisplay = hashedLens _entityDisplay (\e x -> e {_entityDisplay = x})++-- | The name of the entity.+entityName :: Lens' Entity Text+entityName = hashedLens _entityName (\e x -> e {_entityName = x})++-- | The irregular plural version of the entity's name, if there is+--   one.+entityPlural :: Lens' Entity (Maybe Text)+entityPlural = hashedLens _entityPlural (\e x -> e {_entityPlural = x})++-- | Get a version of the entity's name appropriate to the+--   number---the singular name for 1, and a plural name for any other+--   number.  The plural name is obtained either by looking it up if+--   irregular, or by applying standard heuristics otherwise.+entityNameFor :: Int -> Getter Entity Text+entityNameFor 1 = entityName+entityNameFor _ = to $ \e ->+  case e ^. entityPlural of+    Just pl -> pl+    Nothing -> plural (e ^. entityName)++-- | A longer, free-form description of the entity.  Each 'Text' value+--   represents a paragraph.+entityDescription :: Lens' Entity [Text]+entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x})++-- | The direction this entity is facing (if it has one).+entityOrientation :: Lens' Entity (Maybe (V2 Int64))+entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x})++-- | How long this entity takes to grow, if it regrows.+entityGrowth :: Lens' Entity (Maybe GrowthTime)+entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x})++-- | The name of a different entity yielded when this entity is+--   grabbed, if any.+entityYields :: Lens' Entity (Maybe Text)+entityYields = hashedLens _entityYields (\e x -> e {_entityYields = x})++-- | The properties enjoyed by this entity.+entityProperties :: Lens' Entity [EntityProperty]+entityProperties = hashedLens _entityProperties (\e x -> e {_entityProperties = x})++-- | Test whether an entity has a certain property.+hasProperty :: Entity -> EntityProperty -> Bool+hasProperty e p = p `elem` (e ^. entityProperties)++-- | The capabilities this entity provides when installed.+entityCapabilities :: Lens' Entity [Capability]+entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x})++-- | The inventory of other entities carried by this entity.+entityInventory :: Lens' Entity Inventory+entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x})++------------------------------------------------------------+-- Inventory+------------------------------------------------------------++-- | A convenient synonym to remind us when an 'Int' is supposed to+--   represent /how many/ of something we have.+type Count = Int++-- | An inventory is really just a bag/multiset of entities.  That is,+--   it contains some entities, along with the number of times each+--   occurs.  Entities can be looked up directly, or by name.+data Inventory = Inventory+  { -- Main map+    counts :: IntMap (Count, Entity)+  , -- Mirrors the main map; just caching the ability to look up by+    -- name.+    byName :: Map Text IntSet+  , -- Cached hash of the inventory, using a homomorphic hashing scheme+    -- (see https://github.com/swarm-game/swarm/issues/229).+    --+    -- Invariant: equal to Sum_{(k,e) \in counts} (k+1) * (e ^. entityHash).+    -- The k+1 is so the hash distinguishes between having a 0 count of something+    -- and not having it as a key in the map at all.+    inventoryHash :: Int+  }+  deriving (Show, Generic, FromJSON, ToJSON)++instance Hashable Inventory where+  -- Just return cached hash value.+  hash = inventoryHash+  hashWithSalt s = hashWithSalt s . inventoryHash++-- | Inventories are compared by hash for efficiency.+instance Eq Inventory where+  (==) = (==) `on` hash++-- | Look up an entity in an inventory, returning the number of copies+--   contained.+lookup :: Entity -> Inventory -> Count+lookup e (Inventory cs _ _) = maybe 0 fst $ IM.lookup (e ^. entityHash) cs++-- | Look up an entity by name in an inventory, returning a list of+--   matching entities.  Note, if this returns some entities, it does+--   *not* mean we necessarily have any in our inventory!  It just+--   means we *know about* them.  If you want to know whether you have+--   any, use 'lookup' and see whether the resulting 'Count' is+--   positive, or just use 'countByName' in the first place.+lookupByName :: Text -> Inventory -> [Entity]+lookupByName name (Inventory cs byN _) =+  maybe [] (map (snd . (cs IM.!)) . IS.elems) (M.lookup (T.toLower name) byN)++-- | Look up an entity by name and see how many there are in the+--   inventory.  If there are multiple entities with the same name, it+--   just picks the first one returned from 'lookupByName'.+countByName :: Text -> Inventory -> Count+countByName name inv =+  maybe 0 (`lookup` inv) (listToMaybe (lookupByName name inv))++-- | The empty inventory.+empty :: Inventory+empty = Inventory IM.empty M.empty 0++-- | Create an inventory containing one entity.+singleton :: Entity -> Inventory+singleton = flip insert empty++-- | Insert an entity into an inventory.  If the inventory already+--   contains this entity, then only its count will be incremented.+insert :: Entity -> Inventory -> Inventory+insert = insertCount 1++-- | Create an inventory from a list of entities.+fromList :: [Entity] -> Inventory+fromList = foldl' (flip insert) empty++-- | Create an inventory from a list of entities and their counts.+fromElems :: [(Count, Entity)] -> Inventory+fromElems = foldl' (flip (uncurry insertCount)) empty++-- | Insert a certain number of copies of an entity into an inventory.+--   If the inventory already contains this entity, then only its+--   count will be incremented.+insertCount :: Count -> Entity -> Inventory -> Inventory+insertCount k e (Inventory cs byN h) =+  Inventory+    (IM.insertWith (\(m, _) (n, _) -> (m + n, e)) (e ^. entityHash) (k, e) cs)+    (M.insertWith IS.union (T.toLower $ e ^. entityName) (IS.singleton (e ^. entityHash)) byN)+    (h + (k + extra) * (e ^. entityHash)) -- homomorphic hashing+ where+  -- Include the hash of an entity once just for "knowing about" it;+  -- then include the hash once per actual copy of the entity.  In+  -- other words, having k copies of e in the inventory contributes+  -- (k+1)*(e ^. entityHash) to the inventory hash.  The reason for+  -- doing this is so that the inventory hash changes even when we+  -- insert 0 copies of something, since having 0 copies of something+  -- is different than not having it as a key at all; having 0 copies+  -- signals that we at least "know about" the entity.+  extra = if (e ^. entityHash) `IM.member` cs then 0 else 1++-- | Check whether an inventory contains at least one of a given entity.+contains :: Inventory -> Entity -> Bool+contains inv e = lookup e inv > 0++-- | Check whether an inventory has an entry for entity (used by robots).+contains0plus :: Entity -> Inventory -> Bool+contains0plus e = isJust . IM.lookup (e ^. entityHash) . counts++-- | Check if the first inventory is a subset of the second.+--   Note that entities with a count of 0 are ignored.+isSubsetOf :: Inventory -> Inventory -> Bool+isSubsetOf inv1 inv2 = all (\(n, e) -> lookup e inv2 >= n) (elems inv1)++-- | Check whether an inventory is empty, meaning that it contains 0+--   total entities (although it may still /know about/ some entities, that+--   is, have them as keys with a count of 0).+isEmpty :: Inventory -> Bool+isEmpty = all ((== 0) . fst) . elems++-- | Compute the set of capabilities provided by the devices in an inventory.+inventoryCapabilities :: Inventory -> Set Capability+inventoryCapabilities = setOf (to elems . traverse . _2 . entityCapabilities . traverse)++-- | Delete a single copy of a certain entity from an inventory.+delete :: Entity -> Inventory -> Inventory+delete = deleteCount 1++-- | Delete a specified number of copies of an entity from an inventory.+deleteCount :: Count -> Entity -> Inventory -> Inventory+deleteCount k e (Inventory cs byN h) = Inventory cs' byN h'+ where+  m = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0+  cs' = IM.adjust removeCount (e ^. entityHash) cs+  h' = h - min k m * (e ^. entityHash)++  removeCount :: (Count, a) -> (Count, a)+  removeCount (n, a) = (max 0 (n - k), a)++-- | Delete all copies of a certain entity from an inventory.+deleteAll :: Entity -> Inventory -> Inventory+deleteAll e (Inventory cs byN h) =+  Inventory+    (IM.adjust (first (const 0)) (e ^. entityHash) cs)+    byN+    (h - n * (e ^. entityHash))+ where+  n = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0++-- | Get the entities in an inventory and their associated counts.+elems :: Inventory -> [(Count, Entity)]+elems (Inventory cs _ _) = IM.elems cs++-- | Union two inventories.+union :: Inventory -> Inventory -> Inventory+union (Inventory cs1 byN1 h1) (Inventory cs2 byN2 h2) =+  Inventory+    (IM.unionWith (\(c1, e) (c2, _) -> (c1 + c2, e)) cs1 cs2)+    (M.unionWith IS.union byN1 byN2)+    (h1 + h2 - common)+ where+  -- Need to subtract off the sum of the hashes in common, because+  -- of the way each entity with count k contributes (k+1) times its+  -- hash.  So if the two inventories share an entity e, just adding their+  -- hashes would mean e now contributes (k+2) times its hash.+  common = IS.foldl' (+) 0 $ IM.keysSet cs1 `IS.intersection` IM.keysSet cs2++-- | Subtract the second inventory from the first.+difference :: Inventory -> Inventory -> Inventory+difference inv1 = foldl' (flip (uncurry deleteCount)) inv1 . elems
+ src/Swarm/Game/Exception.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# 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.+module Swarm.Game.Exception (+  Exn (..),+  IncapableFix (..),+  formatExn,++  -- * Helper functions+  formatIncapable,+  formatIncapableFix,+) where++import Control.Lens ((^.))+import Data.Aeson (FromJSON, ToJSON)+import Data.Map qualified as M+import Data.Set qualified as S+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Swarm.Game.Entity (EntityMap, deviceForCap, entityName)+import Swarm.Language.Capability (Capability (CGod), capabilityName)+import Swarm.Language.Pretty (prettyText)+import Swarm.Language.Requirement (Requirements (..))+import Swarm.Language.Syntax (Const, Term)+import Swarm.Util+import Witch (from)++-- ------------------------------------------------------------------+-- SETUP FOR DOCTEST++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Control.Lens+-- >>> import Data.Text (unpack)+-- >>> import Swarm.Language.Syntax+-- >>> import Swarm.Language.Capability+-- >>> import Swarm.Game.Entity+-- >>> import Swarm.Game.Display+-- >>> import qualified Swarm.Language.Requirement as R++-- ------------------------------------------------------------------++-- | Suggested way to fix incapable error.+data IncapableFix+  = -- | Install the missing device on yourself/target+    FixByInstall+  | -- | Add the missing device to your inventory+    FixByObtain+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | The type of exceptions that can be thrown by robot programs.+data Exn+  = -- | Something went very wrong.  This is a bug in Swarm and cannot+    --   be caught by a @try@ block (but at least it will not crash+    --   the entire UI).+    Fatal Text+  | -- | An infinite loop was detected via a blackhole.  This cannot+    --   be caught by a @try@ block.+    InfiniteLoop+  | -- | A robot tried to do something for which it does not have some+    --   of the required capabilities.  This cannot be caught by a+    --   @try@ block.+    Incapable IncapableFix Requirements Term+  | -- | A command failed in some "normal" way (/e.g./ a 'Move'+    --   command could not move, or a 'Grab' command found nothing to+    --   grab, /etc./).+    CmdFailed Const Text+  | -- | The user program explicitly called 'Undefined' or 'Fail'.+    User Text+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | Pretty-print an exception for displaying to the player.+formatExn :: EntityMap -> Exn -> Text+formatExn em = \case+  Fatal t ->+    T.unlines+      [ "Fatal error: " <> t+      , "Please report this as a bug at"+      , "<https://github.com/swarm-game/swarm/issues/new>."+      ]+  InfiniteLoop -> "Infinite loop detected!"+  (CmdFailed c t) -> T.concat [prettyText c, ": ", t]+  (User t) -> "Player exception: " <> t+  (Incapable f caps tm) -> formatIncapable em f caps tm++-- ------------------------------------------------------------------+-- INCAPABLE HELPERS+-- ------------------------------------------------------------------++formatIncapableFix :: IncapableFix -> Text+formatIncapableFix = \case+  FixByInstall -> "install"+  FixByObtain -> "obtain"++-- | 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]+-- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByInstall cs t+--+-- >>> incapableError (R.singletonCap CGod) (TConst As)+-- Thou shalt not utter such blasphemy:+--   'as'+--   If God in troth thou wantest to play, try thou a Creative game.+--+-- >>> incapableError (R.singletonCap CAppear) (TConst Appear)+-- You do not have the devices required for:+--   'appear'+--   Please install:+--   - the one ring or magic wand+--+-- >>> incapableError (R.singletonCap CRandom) (TConst Random)+-- Missing the random capability for:+--   'random'+--   but no device yet provides it. See+--   https://github.com/swarm-game/swarm/issues/26+--+-- >>> incapableError (R.singletonInv 3 "tree") (TConst Noop)+-- You are missing required inventory for:+--   'noop'+--   Please obtain:+--   - tree (3)+formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text+formatIncapable em f (Requirements caps _ inv) tm+  | CGod `S.member` caps =+    unlinesExText+      [ "Thou shalt not utter such blasphemy:"+      , squote $ prettyText tm+      , "If God in troth thou wantest to play, try thou a Creative game."+      ]+  | not (null capsNone) =+    unlinesExText+      [ "Missing the " <> capMsg <> " for:"+      , squote $ prettyText tm+      , "but no device yet provides it. See"+      , "https://github.com/swarm-game/swarm/issues/26"+      ]+  | not (S.null caps) =+    unlinesExText+      ( "You do not have the devices required for:" :+        squote (prettyText tm) :+        "Please " <> formatIncapableFix f <> ":" :+        (("- " <>) . formatDevices <$> filter (not . null) deviceSets)+      )+  | otherwise =+    unlinesExText+      ( "You are missing required inventory for:" :+        squote (prettyText tm) :+        "Please obtain:" :+        (("- " <>) . formatEntity <$> M.assocs inv)+      )+ where+  capList = S.toList caps+  deviceSets = map (`deviceForCap` em) capList+  devicePerCap = zip capList deviceSets+  -- capabilities not provided by any device+  capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap+  capMsg = case capsNone of+    [ca] -> ca <> " capability"+    cas -> "capabilities " <> T.intercalate ", " cas+  formatDevices = T.intercalate " or " . map (^. entityName)+  formatEntity (e, 1) = e+  formatEntity (e, n) = e <> " (" <> from (show n) <> ")"++-- | Exceptions that span multiple lines should be indented.+unlinesExText :: [Text] -> Text+unlinesExText ts = T.unlines . (head ts :) . map ("  " <>) $ tail ts
+ src/Swarm/Game/Recipe.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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+-- some input entities into some output entities.+module Swarm.Game.Recipe (+  -- * Ingredient lists and recipes+  IngredientList,+  Recipe (..),+  recipeInputs,+  recipeOutputs,+  recipeRequirements,+  recipeTime,+  recipeWeight,++  -- * Loading recipes+  loadRecipes,+  outRecipeMap,+  inRecipeMap,+  reqRecipeMap,++  -- * Looking up recipes+  MissingIngredient (..),+  MissingType (..),+  knowsIngredientsFor,+  recipesFor,+  make,+  make',+) where++import Control.Lens hiding (from, (.=))+import Data.Bifunctor (second)+import Data.Either.Validation+import Data.IntMap (IntMap)+import Data.IntMap qualified as IM+import Data.List (foldl')+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Yaml+import GHC.Generics (Generic)+import 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.Util.Yaml++-- | An ingredient list is a list of entities with multiplicity.  It+--   is polymorphic in the entity type so that we can use either+--   entity names when serializing, or actual entity objects while the+--   game is running.+type IngredientList e = [(Count, e)]++-- | A recipe is just a list of input entities and a list of output+--   entities (both with multiplicity).  The idea is that it+--   represents some kind of process where the inputs are+--   transformed into the outputs.+data Recipe e = Recipe+  { _recipeInputs :: IngredientList e+  , _recipeOutputs :: IngredientList e+  , _recipeRequirements :: IngredientList e+  , _recipeTime :: Integer+  , _recipeWeight :: Integer+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)++deriving instance ToJSON (Recipe Entity)+deriving instance FromJSON (Recipe Entity)++makeLensesWith (lensRules & generateSignatures .~ False) ''Recipe++-- | The inputs to a recipe.+recipeInputs :: Lens' (Recipe e) (IngredientList e)++-- | The outputs from a recipe.+recipeOutputs :: Lens' (Recipe e) (IngredientList e)++-- | The time required to finish a recipe.+recipeTime :: Lens' (Recipe e) Integer++-- | Other entities which the recipe requires you to have, but which+--   are not consumed by the recipe (e.g. a furnace).+recipeRequirements :: Lens' (Recipe e) (IngredientList e)++-- | How this recipe is weighted against other recipes.  Any time+--   there are multiple valid recipes that fit certain criteria, one+--   of the recipes will be randomly chosen with probability+--   proportional to its weight.+recipeWeight :: Lens' (Recipe e) Integer++------------------------------------------------------------+-- Serializing+------------------------------------------------------------++instance ToJSON (Recipe Text) where+  toJSON (Recipe ins outs reqs time weight) =+    object $+      [ "in" .= ins+      , "out" .= outs+      ]+        ++ ["required" .= reqs | not (null reqs)]+        ++ ["time" .= time | time /= 1]+        ++ ["weight" .= weight | weight /= 1]++instance FromJSON (Recipe Text) where+  parseJSON = withObject "Recipe" $ \v ->+    Recipe+      <$> v .: "in"+      <*> v .: "out"+      <*> v .:? "required" .!= []+      <*> v .:? "time" .!= 1+      <*> v .:? "weight" .!= 1++-- | Given an 'EntityMap', turn a list of recipes containing /names/+--   of entities into a list of recipes containing actual 'Entity'+--   records; or.+resolveRecipes :: EntityMap -> [Recipe Text] -> Validation [Text] [Recipe Entity]+resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lookupEntityName t em))++instance FromJSONE EntityMap (Recipe Entity) where+  parseJSONE v = do+    rt <- liftE $ parseJSON @(Recipe Text) v+    em <- getE+    let erEnt :: Validation [Text] (Recipe Entity)+        erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt+    case validationToEither erEnt of+      Right rEnt -> return rEnt+      Left err -> fail . from @Text . T.unlines $ err++-- | Given an already loaded 'EntityMap', try to load a list of+--   recipes from the data file @recipes.yaml@.+loadRecipes :: (Has (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 ", ")++------------------------------------------------------------++-- | Build a map of recipes either by inputs or outputs.+buildRecipeMap ::+  Getter (Recipe Entity) (IngredientList Entity) ->+  [Recipe Entity] ->+  IntMap [Recipe Entity]+buildRecipeMap select recipeList =+  IM.fromListWith (++) (map (second (: [])) (concatMap mk recipeList))+ where+  mk r = [(e ^. entityHash, r) | (_, e) <- r ^. select]++-- | Build a map of recipes indexed by output ingredients.+outRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]+outRecipeMap = buildRecipeMap recipeOutputs++-- | Build a map of recipes indexed by input ingredients.+inRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]+inRecipeMap = buildRecipeMap recipeInputs++-- | Build a map of recipes indexed by requirements.+reqRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]+reqRecipeMap = buildRecipeMap recipeRequirements++-- | Get a list of all the recipes for the given entity.  Look up an+--   entity in either an 'inRecipeMap' or 'outRecipeMap' depending on+--   whether you want to know recipes that consume or produce the+--   given entity, respectively.+recipesFor :: IntMap [Recipe Entity] -> Entity -> [Recipe Entity]+recipesFor rm e = fromMaybe [] $ IM.lookup (e ^. entityHash) rm++data MissingIngredient = MissingIngredient MissingType Count Entity+  deriving (Show, Eq)++data MissingType = MissingInput | MissingCatalyst+  deriving (Show, Eq)++-- | Figure out which ingredients (if any) are lacking from an+--   inventory to be able to carry out the recipe.+--   Requirements are not consumed and so can use installed.+missingIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> [MissingIngredient]+missingIngredientsFor (inv, ins) (Recipe inps _ reqs _ _) =+  mkMissing MissingInput (findLacking inv inps)+    <> mkMissing MissingCatalyst (findLacking ins (findLacking inv reqs))+ where+  mkMissing k = map (uncurry (MissingIngredient k))+  findLacking inven = filter ((> 0) . fst) . map (countNeeded inven)+  countNeeded inven (need, entity) = (need - E.lookup entity inven, entity)++-- | Figure out if a recipe is available, but it can be lacking items.+knowsIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> Bool+knowsIngredientsFor (inv, ins) recipe =+  knowsAll inv (recipe ^. recipeInputs) && knowsAll ins (recipe ^. recipeRequirements)+ where+  knowsAll xs = all (E.contains xs . snd)++-- | Try to make a recipe, deleting the recipe's inputs from the+--   inventory. Return either a description of which items are+--   lacking, if the inventory does not contain sufficient inputs,+--   or an inventory without inputs and function adding outputs if+--   it was successful.+make ::+  -- robots inventory and installed devices+  (Inventory, Inventory) ->+  -- considered recipe+  Recipe Entity ->+  -- failure (with count of missing) or success with a new inventory,+  -- a function to add results and the recipe repeated+  Either+    [MissingIngredient]+    (Inventory, Inventory -> Inventory, Recipe Entity)+make invs r = finish <$> make' invs r+ where+  finish (invTaken, out) = (invTaken, addOuts out, r)+  addOuts out inv' = foldl' (flip $ uncurry insertCount) inv' out++-- | Try to make a recipe, but do not insert it yet.+make' :: (Inventory, Inventory) -> Recipe Entity -> Either [MissingIngredient] (Inventory, IngredientList Entity)+make' invs@(inv, _) r =+  case missingIngredientsFor invs r of+    [] ->+      let removed = foldl' (flip (uncurry deleteCount)) inv (r ^. recipeInputs)+       in Right (removed, r ^. recipeOutputs)+    missing -> Left missing
+ src/Swarm/Game/Robot.hs view
@@ -0,0 +1,530 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# 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.+module Swarm.Game.Robot (+  -- * Robots data++  -- * Robot log entries+  LogSource (..),+  LogEntry (..),+  leText,+  leSaid,+  leRobotName,+  leTime,+  leLocation,+  leRobotID,++  -- * Robots+  RobotPhase (..),+  RID,+  RobotR,+  Robot,+  TRobot,++  -- * Robot context+  RobotContext,+  defTypes,+  defReqs,+  defVals,+  defStore,++  -- ** Lenses+  robotEntity,+  robotName,+  trobotName,+  robotCreatedAt,+  robotDisplay,+  robotLocation,+  unsafeSetRobotLocation,+  trobotLocation,+  robotOrientation,+  robotInventory,+  installedDevices,+  robotLog,+  robotLogUpdated,+  inventoryHash,+  robotCapabilities,+  robotContext,+  robotID,+  robotParentID,+  robotHeavy,+  machine,+  systemRobot,+  selfDestruct,+  tickSteps,+  runningAtomic,++  -- ** Creation & instantiation+  mkRobot,+  instantiateRobot,++  -- ** Query+  robotKnows,+  isActive,+  waitingUntil,+  getResult,++  -- ** Constants+  hearingDistance,+) where++import Control.Lens hiding (contains)+import Data.Aeson (FromJSON, ToJSON)+import Data.Hashable (hashWithSalt)+import Data.Int (Int64)+import Data.Maybe (fromMaybe, isNothing)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Set (Set)+import Data.Text (Text)+import Data.Yaml ((.!=), (.:), (.:?))+import GHC.Generics (Generic)+import Linear+import Swarm.Game.CESK+import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay)+import Swarm.Game.Entity hiding (empty)+import Swarm.Game.Value as V+import Swarm.Language.Capability (Capability)+import Swarm.Language.Context qualified as Ctx+import Swarm.Language.Requirement (ReqCtx)+import Swarm.Language.Syntax (toDirection)+import Swarm.Language.Types (TCtx)+import Swarm.Util ()+import Swarm.Util.Yaml+import System.Clock (TimeSpec)++-- | A record that stores the information+--   for all defintions stored in a 'Robot'+data RobotContext = RobotContext+  { -- | Map definition names to their types.+    _defTypes :: TCtx+  , -- | Map defintion names to the capabilities+    --   required to evaluate/execute them.+    _defReqs :: ReqCtx+  , -- | Map defintion names to their values. Note that since+    --   definitions are delayed, the values will just consist of+    --   'VRef's pointing into the store.+    _defVals :: Env+  , -- | A store containing memory cells allocated to hold+    --   definitions.+    _defStore :: Store+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++makeLenses ''RobotContext++data LogSource = Said | Logged | ErrorTrace+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)++-- | An entry in a robot's log.+data LogEntry = LogEntry+  { -- | The time at which the entry was created.+    --   Note that this is the first field we sort on.+    _leTime :: Integer+  , -- | Whether this log records a said message.+    _leSaid :: LogSource+  , -- | The name of the robot that generated the entry.+    _leRobotName :: Text+  , -- | The ID of the robot that generated the entry.+    _leRobotID :: Int+  , -- | Location of the robot at log entry creation.+    _leLocation :: V2 Int64+  , -- | The text of the log entry.+    _leText :: Text+  }+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)++makeLenses ''LogEntry++-- | A unique identifier for a robot.+type RID = Int++-- | The phase of a robot description record.+data RobotPhase+  = -- | The robot record has just been read in from a scenario+    --   description; it represents a /template/ that may later be+    --   instantiated as one or more concrete robots.+    TemplateRobot+  | -- | The robot record represents a concrete robot in the world.+    ConcreteRobot++-- | With a robot template, we may or may not have a location.  With a+--   concrete robot we must have a location.+type family RobotLocation (phase :: RobotPhase) :: * where+  RobotLocation 'TemplateRobot = Maybe (V2 Int64)+  RobotLocation 'ConcreteRobot = V2 Int64++-- | Robot templates have no ID; concrete robots definitely do.+type family RobotID (phase :: RobotPhase) :: * where+  RobotID 'TemplateRobot = ()+  RobotID 'ConcreteRobot = RID++-- | A value of type 'RobotR' is a record representing the state of a+--   single robot.  The @f@ parameter is for tracking whether or not+--   the robot has been assigned a unique ID.+data RobotR (phase :: RobotPhase) = RobotR+  { _robotEntity :: Entity+  , _installedDevices :: Inventory+  , -- | A cached view of the capabilities this robot has.+    --   Automatically generated from '_installedDevices'.+    _robotCapabilities :: Set Capability+  , _robotLog :: Seq LogEntry+  , _robotLogUpdated :: Bool+  , _robotLocation :: RobotLocation phase+  , _robotContext :: RobotContext+  , _robotID :: RobotID phase+  , _robotParentID :: Maybe RID+  , _robotHeavy :: Bool+  , _machine :: CESK+  , _systemRobot :: Bool+  , _selfDestruct :: Bool+  , _tickSteps :: Int+  , _runningAtomic :: Bool+  , _robotCreatedAt :: TimeSpec+  }+  deriving (Generic)++deriving instance (Show (RobotLocation phase), Show (RobotID phase)) => Show (RobotR phase)+deriving instance (Eq (RobotLocation phase), Eq (RobotID phase)) => Eq (RobotR phase)++deriving instance (ToJSON (RobotLocation phase), ToJSON (RobotID phase)) => ToJSON (RobotR phase)++-- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/+-- for the approach used here with lenses.++let exclude = ['_robotCapabilities, '_installedDevices, '_robotLog]+ in makeLensesWith+      ( lensRules+          & generateSignatures .~ False+          & lensField . mapped . mapped %~ \fn n ->+            if n `elem` exclude then [] else fn n+      )+      ''RobotR++-- | A template robot, i.e. a template robot record without a unique ID number,+--   and possibly without a location.+type TRobot = RobotR 'TemplateRobot++-- | A concrete robot, with a unique ID number and a specific location.+type Robot = RobotR 'ConcreteRobot++-- In theory we could make all these lenses over (RobotR phase), but+-- that leads to lots of type ambiguity problems later.  In practice+-- we only need lenses for Robots.++-- | Robots are not entities, but they have almost all the+--   characteristics of one (or perhaps we could think of robots as+--   very special sorts of entities), so for convenience each robot+--   carries an 'Entity' record to store all the information it has in+--   common with any 'Entity'.+--+--   Note there are various lenses provided for convenience that+--   directly reference fields inside this record; for example, one+--   can use 'robotName' instead of writing @'robotEntity'+--   . 'entityName'@.+robotEntity :: Lens' (RobotR phase) Entity++-- | The creation date of the robot.+robotCreatedAt :: Lens' Robot TimeSpec++-- robotName and trobotName could be generalized to robotName' ::+-- Lens' (RobotR phase) Text.  However, type inference does not work+-- very well with the polymorphic version, so we export both+-- monomorphic versions instead.++-- | The name of a robot.+robotName :: Lens' Robot Text+robotName = robotEntity . entityName++-- | The name of a robot template.+trobotName :: Lens' TRobot Text+trobotName = robotEntity . entityName++-- | The 'Display' of a robot.  This is a special lens that+--   automatically sets the 'curOrientation' to the orientation of the+--   robot every time you do a @get@ operation.  Technically this does+--   not satisfy the lens laws---in particular, the get/put law does+--   not hold.  But we should think of the 'curOrientation' as being+--   simply a cache of the displayed entity's direction.+robotDisplay :: Lens' Robot Display+robotDisplay = lens getDisplay setDisplay+ where+  getDisplay r =+    (r ^. robotEntity . entityDisplay)+      & curOrientation .~ ((r ^. robotOrientation) >>= toDirection)+  setDisplay r d = r & robotEntity . entityDisplay .~ d++-- | The robot's current location, represented as (x,y).  This is only+--   a getter, since when changing a robot's location we must remember+--   to update the 'robotsByLocation' map as well.  You can use the+--   'updateRobotLocation' function for this purpose.+robotLocation :: Getter Robot (V2 Int64)++-- | 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 :: V2 Int64 -> 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 (V2 Int64))+trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l})++-- | Which way the robot is currently facing.+robotOrientation :: Lens' Robot (Maybe (V2 Int64))+robotOrientation = robotEntity . entityOrientation++-- | The robot's inventory.+robotInventory :: Lens' Robot Inventory+robotInventory = robotEntity . entityInventory++-- | The robot's context+robotContext :: Lens' Robot RobotContext++-- | The (unique) ID number of the robot.  This is only a Getter since+--   the robot ID is immutable.+robotID :: Getter Robot RID++-- | Instantiate a robot template to make it into a concrete robot, by+--    providing a robot ID. Concrete robots also require a location;+--    if the robot template didn't have a location already, just set+--    the location to (0,0) by default.  If you want a different location,+--    set it via 'trobotLocation' before calling 'instantiateRobot'.+instantiateRobot :: RID -> TRobot -> Robot+instantiateRobot i r =+  r+    { _robotID = i+    , _robotLocation = fromMaybe (V2 0 0) (_robotLocation r)+    }++-- | The ID number of the robot's parent, that is, the robot that+--   built (or most recently reprogrammed) this robot, if there is+--   one.+robotParentID :: Lens' Robot (Maybe RID)++-- | Is this robot extra heavy (thus requiring tank treads to move)?+robotHeavy :: Lens' Robot Bool++-- | A separate inventory for "installed devices", which provide the+--   robot with certain capabilities.+--+--   Note that every time the inventory of installed devices is+--   modified, this lens recomputes a cached set of the capabilities+--   the installed devices provide, to speed up subsequent lookups to+--   see whether the robot has a certain capability (see 'robotCapabilities')+installedDevices :: Lens' Robot Inventory+installedDevices = lens _installedDevices setInstalled+ where+  setInstalled r inst =+    r+      { _installedDevices = inst+      , _robotCapabilities = inventoryCapabilities inst+      }++-- | The robot's own private message log, most recent message last.+--   Messages can be added both by explicit use of the 'Log' command,+--   and by uncaught exceptions.  Stored as a "Data.Sequence" so that+--   we can efficiently add to the end and also process from beginning+--   to end.  Note that updating via this lens will also set the+--   'robotLogUpdated'.+robotLog :: Lens' Robot (Seq LogEntry)+robotLog = lens _robotLog setLog+ where+  setLog r newLog =+    r+      { _robotLog = newLog+      , -- Flag the log as updated if (1) if already was, or (2) the new+        -- log is a different length than the old.  (This would not+        -- catch updates that merely modify an entry, but we don't want+        -- to have to compare the entire logs, and we only ever append+        -- to logs anyway.)+        _robotLogUpdated =+          _robotLogUpdated r || Seq.length (_robotLog r) /= Seq.length newLog+      }++-- | Has the 'robotLog' been updated since the last time it was+--   viewed?+robotLogUpdated :: Lens' Robot Bool++-- | A hash of a robot's entity record and installed devices, to+--   facilitate quickly deciding whether we need to redraw the robot+--   info panel.+inventoryHash :: Getter Robot Int+inventoryHash = to (\r -> 17 `hashWithSalt` (r ^. (robotEntity . entityHash)) `hashWithSalt` (r ^. installedDevices))++-- | Does a robot know of an entity's existence?+robotKnows :: Robot -> Entity -> Bool+robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. installedDevices)++-- | Get the set of capabilities this robot possesses.  This is only a+--   getter, not a lens, because it is automatically generated from+--   the 'installedDevices'.  The only way to change a robot's+--   capabilities is to modify its 'installedDevices'.+robotCapabilities :: Getter Robot (Set Capability)+robotCapabilities = to _robotCapabilities++-- | The robot's current CEK machine state.+machine :: Lens' Robot CESK++-- | Is this robot a "system robot"?  System robots are generated by+--   the system (as opposed to created by the user) and are not+--   subject to the usual capability restrictions.+systemRobot :: Lens' Robot Bool++-- | Does this robot wish to self destruct?+selfDestruct :: Lens' Robot Bool++-- | The need for 'tickSteps' is a bit technical, and I hope I can+--   eventually find a different, better way to accomplish it.+--   Ideally, we would want each robot to execute a single+--   /command/ at every game tick, so that /e.g./ two robots+--   executing @move;move;move@ and @repeat 3 move@ (given a+--   suitable definition of @repeat@) will move in lockstep.+--   However, the second robot actually has to do more computation+--   than the first (it has to look up the definition of @repeat@,+--   reduce its application to the number 3, etc.), so its CESK+--   machine will take more steps.  It won't do to simply let each+--   robot run until executing a command---because robot programs+--   can involve arbitrary recursion, it is very easy to write a+--   program that evaluates forever without ever executing a+--   command, which in this scenario would completely freeze the+--   UI. (It also wouldn't help to ensure all programs are+--   terminating---it would still be possible to effectively do+--   the same thing by making a program that takes a very, very+--   long time to terminate.)  So instead, we allocate each robot+--   a certain maximum number of computation steps per tick+--   (defined in 'Swarm.Game.Step.evalStepsPerTick'), and it+--   suspends computation when it either executes a command or+--   reaches the maximum number of steps, whichever comes first.+--+--   It seems like this really isn't something the robot should be+--   keeping track of itself, but that seemed the most technically+--   convenient way to do it at the time.  The robot needs some+--   way to signal when it has executed a command, which it+--   currently does by setting tickSteps to zero.  However, that+--   has the disadvantage that when tickSteps becomes zero, we+--   can't tell whether that happened because the robot ran out of+--   steps, or because it executed a command and set it to zero+--   manually.+--+--   Perhaps instead, each robot should keep a counter saying how+--   many commands it has executed.  The loop stepping the robot+--   can tell when the counter increments.+tickSteps :: Lens' Robot Int++-- | Is the robot currently running an atomic block?+runningAtomic :: Lens' Robot Bool++-- | A general function for creating robots.+mkRobot ::+  -- | ID number of the robot.+  RobotID phase ->+  -- | ID number of the robot's parent, if it has one.+  Maybe Int ->+  -- | Name of the robot.+  Text ->+  -- | Description of the robot.+  [Text] ->+  -- | Initial location.+  RobotLocation phase ->+  -- | Initial heading/direction.+  V2 Int64 ->+  -- | Robot display.+  Display ->+  -- | Initial CESK machine.+  CESK ->+  -- | Installed devices.+  [Entity] ->+  -- | Initial inventory.+  [(Count, Entity)] ->+  -- | Should this be a system robot?+  Bool ->+  -- | Is this robot heavy?+  Bool ->+  -- | Creation date+  TimeSpec ->+  RobotR phase+mkRobot rid pid name descr loc dir disp m devs inv sys heavy ts =+  RobotR+    { _robotEntity =+        mkEntity disp name descr [] []+          & entityOrientation ?~ dir+          & entityInventory .~ fromElems inv+    , _installedDevices = inst+    , _robotCapabilities = inventoryCapabilities inst+    , _robotLog = Seq.empty+    , _robotLogUpdated = False+    , _robotLocation = loc+    , _robotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore+    , _robotID = rid+    , _robotParentID = pid+    , _robotHeavy = heavy+    , _robotCreatedAt = ts+    , _machine = m+    , _systemRobot = sys+    , _selfDestruct = False+    , _tickSteps = 0+    , _runningAtomic = False+    }+ where+  inst = fromList devs++-- | We can parse a robot from a YAML file if we have access to an+--   'EntityMap' in which we can look up the names of entities.+instance FromJSONE EntityMap TRobot where+  parseJSONE = withObjectE "robot" $ \v ->+    -- Note we can't generate a unique ID here since we don't have+    -- access to a 'State GameState' effect; a unique ID will be+    -- filled in later when adding the robot to the world.+    mkRobot () Nothing+      <$> liftE (v .: "name")+      <*> liftE (v .:? "description" .!= [])+      <*> liftE (v .:? "loc")+      <*> liftE (v .:? "dir" .!= zero)+      <*> liftE (v .:? "display" .!= defaultRobotDisplay)+      <*> liftE (mkMachine <$> (v .:? "program"))+      <*> v ..:? "devices" ..!= []+      <*> v ..:? "inventory" ..!= []+      <*> liftE (v .:? "system" .!= False)+      <*> liftE (v .:? "heavy" .!= False)+      <*> pure 0+   where+    mkMachine Nothing = Out VUnit emptyStore []+    mkMachine (Just pt) = initMachine pt mempty emptyStore++-- | Is the robot actively in the middle of a computation?+isActive :: Robot -> Bool+{-# INLINE isActive #-}+isActive = isNothing . getResult++-- | The time until which the robot is waiting, if any.+waitingUntil :: Robot -> Maybe Integer+waitingUntil robot =+  case _machine robot of+    Waiting time _ -> Just time+    _ -> Nothing++-- | Get the result of the robot's computation if it is finished.+getResult :: Robot -> Maybe (Value, Store)+{-# INLINE getResult #-}+getResult = finalValue . view machine++hearingDistance :: Num i => i+hearingDistance = 32
+ src/Swarm/Game/Scenario.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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+-- conditions, which can be used both for building interactive+-- tutorials and for standalone puzzles and scenarios.+module Swarm.Game.Scenario (+  -- * Objectives+  Objective,+  objectiveGoal,+  objectiveCondition,++  -- * WorldDescription+  Cell (..),+  WorldDescription (..),++  -- * Scenario+  Scenario,++  -- ** Fields+  scenarioVersion,+  scenarioName,+  scenarioAuthor,+  scenarioDescription,+  scenarioCreative,+  scenarioSeed,+  scenarioEntities,+  scenarioRecipes,+  scenarioKnown,+  scenarioWorld,+  scenarioRobots,+  scenarioObjectives,+  scenarioSolution,+  scenarioStepsPerTick,++  -- * Loading from disk+  loadScenario,+  loadScenarioFile,+  getScenarioPath,+) where++import Control.Algebra (Has)+import Control.Arrow ((&&&))+import Control.Carrier.Lift (Lift, sendIO)+import Control.Carrier.Throw.Either (Throw, throwError)+import Control.Lens hiding (from, (<.>))+import Control.Monad (filterM, when)+import Control.Monad.Extra (mapMaybeM)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap (KeyMap)+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe (catMaybes, isNothing, listToMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Data.Yaml as Y+import GHC.Generics (Generic)+import GHC.Int (Int64)+import Linear.V2+import Swarm.Game.Entity+import Swarm.Game.Recipe+import Swarm.Game.Robot (TRobot, trobotName)+import Swarm.Game.Terrain+import Swarm.Language.Pipeline (ProcessedTerm)+import Swarm.Util (getDataFileNameSafe, reflow)+import Swarm.Util.Yaml+import System.Directory (doesFileExist)+import System.FilePath ((<.>), (</>))+import Witch (from, into)++------------------------------------------------------------+-- Scenario objectives+------------------------------------------------------------++-- | An objective is a condition to be achieved by a player in a+--   scenario.+data Objective = Objective+  { _objectiveGoal :: [Text]+  , _objectiveCondition :: ProcessedTerm+  }+  deriving (Eq, Show, Generic, ToJSON)++makeLensesWith (lensRules & generateSignatures .~ False) ''Objective++-- | 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]++-- | A winning condition for the objective, expressed as a+--   program of type @cmd bool@.  By default, this program will be+--   run to completion every tick (the usual limits on the number+--   of CESK steps per tick do not apply).+objectiveCondition :: Lens' Objective ProcessedTerm++instance FromJSON Objective where+  parseJSON = withObject "objective" $ \v ->+    Objective+      <$> (fmap . map) reflow (v .:? "goal" .!= [])+      <*> (v .: "condition")++------------------------------------------------------------+-- Robot map+------------------------------------------------------------++-- | A map from names to robots, used to look up robots in scenario+--   descriptions.+type RobotMap = Map Text TRobot++-- | Create a 'RobotMap' from a list of robot templates.+buildRobotMap :: [TRobot] -> RobotMap+buildRobotMap = M.fromList . map (view trobotName &&& id)++------------------------------------------------------------+-- Lookup utilities+------------------------------------------------------------++-- | 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 thing lkup name = do+  m <- getE+  case lkup name m of+    Nothing -> fail $ "Unknown " <> thing <> " name: " ++ show name+    Just a -> return a++-- | Look up an entity by name in an 'EntityMap', throwing a parse+--   error if it is not found.+getEntity :: Text -> ParserE EntityMap Entity+getEntity = getThing "entity" lookupEntityName++-- | Look up a robot by name in a 'RobotMap', throwing a parse error+--   if it is not found.+getRobot :: Text -> ParserE RobotMap TRobot+getRobot = getThing "robot" M.lookup++------------------------------------------------------------+-- World cells+------------------------------------------------------------++-- | A single cell in a world map, which contains a terrain value,+--   and optionally an entity and robot.+data Cell = Cell+  { cellTerrain :: TerrainType+  , cellEntity :: Maybe Entity+  , cellRobots :: [TRobot]+  }+  deriving (Eq, Show)++-- | 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++------------------------------------------------------------+-- World description+------------------------------------------------------------++-- | A world palette maps characters to 'Cell' values.+newtype WorldPalette = WorldPalette+  {unPalette :: KeyMap Cell}+  deriving (Eq, Show)++instance FromJSONE (EntityMap, RobotMap) WorldPalette where+  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE++-- | A description of a world parsed from a YAML file.+data WorldDescription = WorldDescription+  { defaultTerrain :: Maybe Cell+  , offsetOrigin :: Bool+  , palette :: WorldPalette+  , ul :: V2 Int64+  , area :: [[Cell]]+  }+  deriving (Eq, Show)++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" .!= V2 0 0)+      <*> 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 -> Text -> m [[Cell]]+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++------------------------------------------------------------+-- Scenario+------------------------------------------------------------++-- | A 'Scenario' contains all the information to describe a+--   scenario.+data Scenario = Scenario+  { _scenarioVersion :: Int+  , _scenarioName :: Text+  , _scenarioAuthor :: Maybe Text+  , _scenarioDescription :: Text+  , _scenarioCreative :: Bool+  , _scenarioSeed :: Maybe Int+  , _scenarioEntities :: EntityMap+  , _scenarioRecipes :: [Recipe Entity]+  , _scenarioKnown :: [Text]+  , _scenarioWorld :: WorldDescription+  , _scenarioRobots :: [TRobot]+  , _scenarioObjectives :: [Objective]+  , _scenarioSolution :: Maybe ProcessedTerm+  , _scenarioStepsPerTick :: Maybe Int+  }+  deriving (Eq, Show)++makeLensesWith (lensRules & generateSignatures .~ False) ''Scenario++instance FromJSONE EntityMap Scenario where+  parseJSONE = withObjectE "scenario" $ \v -> do+    -- parse custom entities+    em <- liftE (buildEntityMap <$> (v .:? "entities" .!= []))+    -- extend ambient EntityMap with custom entities+    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++      -- parse robots and build RobotMap+      rs <- v ..: "robots"+      let rsMap = buildRobotMap rs++      Scenario+        <$> liftE (v .: "version")+        <*> liftE (v .: "name")+        <*> liftE (v .:? "author")+        <*> liftE (v .:? "description" .!= "")+        <*> liftE (v .:? "creative" .!= False)+        <*> liftE (v .:? "seed")+        <*> pure em+        <*> v ..:? "recipes" ..!= []+        <*> pure known+        <*> localE (,rsMap) (v ..: "world")+        <*> pure rs+        <*> liftE (v .:? "objectives" .!= [])+        <*> liftE (v .:? "solution")+        <*> liftE (v .:? "stepsPerTick")++--------------------------------------------------+-- Lenses++-- | The version number of the scenario schema.  Currently, this+--   should always be 1, but it is ignored.  In the future, this may+--   be used to convert older formats to newer ones, or simply to+--   print a nice error message when we can't read an older format.+scenarioVersion :: Lens' Scenario Int++-- | The name of the scenario.+scenarioName :: Lens' Scenario Text++-- | The author of the scenario.+scenarioAuthor :: Lens' Scenario (Maybe Text)++-- | A high-level description of the scenario, shown /e.g./ in the+--   menu.+scenarioDescription :: Lens' Scenario Text++-- | Whether the scenario should start in creative mode.+scenarioCreative :: Lens' Scenario Bool++-- | The seed used for the random number generator.  If @Nothing@, use+--   a random seed / prompt the user for the seed.+scenarioSeed :: Lens' Scenario (Maybe Int)++-- | Any custom entities used for this scenario.+scenarioEntities :: Lens' Scenario EntityMap++-- | Any custom recipes used in this scenario.+scenarioRecipes :: Lens' Scenario [Recipe Entity]++-- | List of entities that should be considered "known", so robots do+--   not have to scan them.+scenarioKnown :: Lens' Scenario [Text]++-- | The starting world for the scenario.+scenarioWorld :: Lens' Scenario WorldDescription++-- | The starting robots for the scenario.  Note this should+--   include the base.+scenarioRobots :: Lens' Scenario [TRobot]++-- | A sequence of objectives for the scenario (if any).+scenarioObjectives :: Lens' Scenario [Objective]++-- | An optional solution of the scenario, expressed as a+--   program of type @cmd a@. This is useful for automated+--   testing of the win condition.+scenarioSolution :: Lens' Scenario (Maybe ProcessedTerm)++-- | Optionally, specify the maximum number of steps each robot may+--   take during a single tick.+scenarioStepsPerTick :: Lens' Scenario (Maybe Int)+------------------------------------------------------------+-- Loading scenarios+------------------------------------------------------------++getScenarioPath :: FilePath -> IO (Maybe FilePath)+getScenarioPath scenario = do+  libScenario <- getDataFileNameSafe $ "scenarios" </> scenario+  libScenarioExt <- getDataFileNameSafe $ "scenarios" </> scenario <.> "yaml"++  let candidates = catMaybes [Just scenario, libScenarioExt, libScenario]+  listToMaybe <$> 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 ->+  EntityMap ->+  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++-- | Load a scenario from a file.+loadScenarioFile ::+  (Has (Lift IO) sig m, Has (Throw Text) sig m) =>+  EntityMap ->+  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
+ src/Swarm/Game/ScenarioInfo.hs view
@@ -0,0 +1,340 @@+{-# 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+-- well as loading recursive scenario collections.+module Swarm.Game.ScenarioInfo (+  -- * Scenario info+  ScenarioStatus (..),+  _NotStarted,+  _InProgress,+  _Complete,+  ScenarioInfo (..),+  scenarioPath,+  scenarioStatus,+  scenarioBestTime,+  scenarioBestTicks,+  updateScenarioInfoOnQuit,++  -- * Scenario collection+  ScenarioCollection (..),+  scenarioCollectionToList,+  scenarioItemByPath,+  normalizeScenarioPath,+  ScenarioItem (..),+  scenarioItemName,+  _SISingle,++  -- * Loading and saving scenarios+  loadScenarios,+  loadScenarioInfo,+  saveScenarioInfo,++  -- * Re-exports+  module Swarm.Game.Scenario,+) where++import Control.Algebra (Has)+import Control.Carrier.Lift (Lift, sendIO)+import Control.Carrier.Throw.Either (Throw, runThrow, throwError)+import Control.Lens hiding (from, (<.>))+import Control.Monad (unless, when)+import Data.Aeson (+  Options (..),+  defaultOptions,+  genericParseJSON,+  genericToEncoding,+  genericToJSON,+ )+import Data.Char (isSpace, toLower)+import Data.Function (on)+import Data.List (intercalate, stripPrefix, (\\))+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.Yaml as Y+import GHC.Generics (Generic)+import Swarm.Game.Entity+import Swarm.Game.Scenario+import Swarm.Util (dataNotFound, getDataDirSafe, getSwarmSavePath)+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+      { -- | Time when the scenario was started including time zone.+        _scenarioStarted :: ZonedTime+      , -- | Time elapsed until quitting the scenario.+        _scenarioElapsed :: NominalDiffTime+      , -- | Ticks elapsed until quitting the scenario.+        _scenarioElapsedTicks :: Integer+      }+  | Complete+      { -- | Time when the scenario was started including time zone.+        _scenarioStarted :: ZonedTime+      , -- | Time elapsed until quitting the scenario.+        _scenarioElapsed :: NominalDiffTime+      , -- | Ticks elapsed until quitting the scenario.+        _scenarioElapsedTicks :: Integer+      }+  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++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+-- ----------------------------------------------------------------------------++-- | A scenario item is either a specific scenario, or a collection of+--   scenarios (*e.g.* the scenarios contained in a subdirectory).+data ScenarioItem = SISingle Scenario ScenarioInfo | SICollection Text ScenarioCollection+  deriving (Eq, Show)++-- | Retrieve the name of a scenario item.+scenarioItemName :: ScenarioItem -> Text+scenarioItemName (SISingle s _ss) = s ^. scenarioName+scenarioItemName (SICollection name _) = name++-- | A scenario collection is a tree of scenarios, keyed by name,+--   together with an optional order.  Invariant: every item in the+--   scOrder exists as a key in the scMap.+data ScenarioCollection = SC+  { scOrder :: Maybe [FilePath]+  , scMap :: Map FilePath ScenarioItem+  }+  deriving (Eq, 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 [] _ col = pure col+  ixp [s] f (SC n m) = SC n <$> ix s f m+  ixp (d : xs) f (SC n m) = SC n <$> ix d inner m+   where+    inner si = case si of+      SISingle {} -> pure si+      SICollection n' col -> SICollection n' <$> ixp xs f col++-- | Canonicalize a scenario path, making it usable as a unique key.+normalizeScenarioPath :: ScenarioCollection -> FilePath -> IO FilePath+normalizeScenarioPath col p =+  let path = p -<.> "yaml"+   in if isJust $ col ^? scenarioItemByPath path+        then return path+        else do+          canonPath <- canonicalizePath path+          Just ddir <- getDataDirSafe "." -- no way we got this far without data directory+          d <- canonicalizePath ddir+          let n =+                stripPrefix (d </> "scenarios") canonPath+                  & maybe canonPath (dropWhile (== pathSeparator))+          return n++-- | Convert a scenario collection to a list of scenario items.+scenarioCollectionToList :: ScenarioCollection -> [ScenarioItem]+scenarioCollectionToList (SC Nothing m) = M.elems m+scenarioCollectionToList (SC (Just order) m) = (m M.!) <$> order++-- | 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++-- | The name of the special file which indicates the order of+--   scenarios in a folder.+orderFileName :: FilePath+orderFileName = "00-ORDER.txt"++-- | 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) =>+  EntityMap ->+  FilePath ->+  m ScenarioCollection+loadScenarioDir em 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"+      return Nothing+    True -> Just . filter (not . null) . lines <$> sendIO (readFile orderFile)+  fs <- sendIO $ keepYamlOrDirectory <$> listDirectory dir++  case morder of+    Just order -> do+      let missing = fs \\ order+          dangling = order \\ fs++      unless (null missing) $+        sendIO . putStr . unlines $+          ( "Warning: while processing " <> (dirName </> orderFileName) <> ": files not listed in "+              <> orderFileName+              <> " will be ignored"+          ) :+          map ("  - " <>) missing++      unless (null dangling) $+        sendIO . putStr . unlines $+          ( "Warning: while processing " <> (dirName </> orderFileName)+              <> ": nonexistent files will be ignored"+          ) :+          map ("  - " <>) dangling+    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+ where+  keepYamlOrDirectory = filter (\f -> takeExtensions f `elem` ["", ".yaml"])++-- | How to transform scenario path to save path.+scenarioPathToSavePath :: FilePath -> FilePath -> FilePath+scenarioPathToSavePath path swarmData = swarmData </> Data.List.intercalate "_" (splitDirectories path)++-- | Load saved info about played scenario from XDG data directory.+loadScenarioInfo ::+  (Has (Lift IO) sig m, Has (Throw Text) sig m) =>+  FilePath ->+  m ScenarioInfo+loadScenarioInfo p = do+  path <- sendIO $ normalizeScenarioPath (SC Nothing mempty) p+  infoPath <- sendIO $ scenarioPathToSavePath path <$> getSwarmSavePath False+  hasInfo <- sendIO $ doesFileExist infoPath+  if not hasInfo+    then do+      return $ ScenarioInfo path NotStarted NotStarted NotStarted+    else+      sendIO (decodeFileEither infoPath)+        >>= either (throwError . pack . prettyPrintParseException) return++-- | Save info about played scenario to XDG data directory.+saveScenarioInfo ::+  FilePath ->+  ScenarioInfo ->+  IO ()+saveScenarioInfo path si = do+  infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True+  encodeFile infoPath si++-- | Load a scenario item (either a scenario, or a subdirectory+--   containing a collection of scenarios) from a particular path.+loadScenarioItem ::+  (Has (Lift IO) sig m, Has (Throw Text) sig m) =>+  EntityMap ->+  FilePath ->+  m ScenarioItem+loadScenarioItem em path = do+  isDir <- sendIO $ doesDirectoryExist path+  let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path+  case isDir of+    True -> SICollection collectionName <$> loadScenarioDir em path+    False -> do+      s <- loadScenarioFile em path+      si <- loadScenarioInfo path+      return $ SISingle s si++------------------------------------------------------------+-- Some lenses + prisms+------------------------------------------------------------++makePrisms ''ScenarioItem+makePrisms ''ScenarioStatus
+ src/Swarm/Game/State.hs view
@@ -0,0 +1,856 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# 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+-- utility functions.+module Swarm.Game.State (+  -- * Game state record and related types+  ViewCenterRule (..),+  REPLStatus (..),+  WinCondition (..),+  _NoWinCondition,+  _WinConditions,+  _Won,+  RunStatus (..),+  Seed,+  GameState,++  -- ** GameState fields+  creativeMode,+  winCondition,+  winSolution,+  runStatus,+  paused,+  robotMap,+  robotsByLocation,+  robotsAtLocation,+  robotsInArea,+  activeRobots,+  waitingRobots,+  availableRecipes,+  availableCommands,+  messageNotifications,+  allDiscoveredEntities,+  gensym,+  seed,+  randGen,+  adjList,+  nameList,+  entityMap,+  recipesOut,+  recipesIn,+  recipesReq,+  scenarios,+  currentScenarioPath,+  knownEntities,+  world,+  viewCenterRule,+  viewCenter,+  needsRedraw,+  replStatus,+  replWorking,+  messageQueue,+  lastSeenMessageTime,+  focusedRobotID,+  ticks,+  robotStepsPerTick,++  -- ** Notifications+  Notifications (..),+  notificationsCount,+  notificationsContent,++  -- ** GameState initialization+  initGameState,+  scenarioToGameState,+  initGameStateForScenario,+  classicGame0,++  -- * Utilities+  applyViewCenterRule,+  recalcViewCenter,+  modifyViewCenter,+  viewingRegion,+  focusedRobot,+  clearFocusedRobotLogUpdated,+  addRobot,+  addTRobot,+  emitMessage,+  sleepUntil,+  sleepForever,+  wakeUpRobotsDoneSleeping,+  deleteRobot,+  activateRobot,+  toggleRunStatus,+  messageIsRecent,+  messageIsFromNearby,+) where++import Control.Algebra (Has)+import Control.Applicative ((<|>))+import Control.Arrow (Arrow ((&&&)))+import Control.Effect.Lens+import Control.Effect.State (State)+import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))+import Control.Monad.Except+import Data.Aeson (FromJSON, ToJSON)+import Data.Array (Array, listArray)+import Data.Bifunctor (first)+import Data.Foldable (toList)+import Data.Int (Int64)+import Data.IntMap (IntMap)+import Data.IntMap qualified as IM+import Data.IntSet (IntSet)+import Data.IntSet qualified as IS+import Data.IntSet.Lens (setOf)+import Data.List (partition)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Sequence (Seq ((:<|)))+import Data.Sequence qualified as Seq+import Data.Set qualified as S+import Data.Text (Text)+import Data.Text qualified as T (lines)+import Data.Text.IO qualified as T (readFile)+import Data.Time (getZonedTime)+import GHC.Generics (Generic)+import Linear+import Swarm.Game.CESK (emptyStore, initMachine)+import Swarm.Game.Entity+import Swarm.Game.Recipe (+  Recipe,+  inRecipeMap,+  loadRecipes,+  outRecipeMap,+  reqRecipeMap,+ )+import Swarm.Game.Robot+import Swarm.Game.ScenarioInfo+import Swarm.Game.Terrain (TerrainType (..))+import Swarm.Game.Value (Value)+import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray)+import Swarm.Game.World qualified as W+import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray)+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.Types+import Swarm.Util (getDataFileNameSafe, getElemsInArea, isRightOr, manhattan, uniq, (<+=), (<<.=), (?))+import System.Clock qualified as Clock+import System.Random (StdGen, mkStdGen, randomRIO)+import Witch (into)++------------------------------------------------------------+-- Subsidiary data types+------------------------------------------------------------++-- | The 'ViewCenterRule' specifies how to determine the center of the+--   world viewport.+data ViewCenterRule+  = -- | The view should be centered on an absolute position.+    VCLocation (V2 Int64)+  | -- | The view should be centered on a certain robot.+    VCRobot RID+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)++makePrisms ''ViewCenterRule++-- | A data type to represent the current status of the REPL.+data REPLStatus+  = -- | The REPL is not doing anything actively at the moment.+    REPLDone+  | -- | A command entered at the REPL is currently being run.  The+    --   'Polytype' represents the type of the expression that was+    --   entered.  The @Maybe Value@ starts out as @Nothing@ and gets+    --   filled in with a result once the command completes.+    REPLWorking Polytype (Maybe Value)+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++data WinCondition+  = -- | There is no winning condition.+    NoWinCondition+  | -- | There are one or more objectives remaining that the player+    --   has not yet accomplished.+    WinConditions (NonEmpty Objective)+  | -- | The player has won. The boolean indicates whether they have+    --   already been congratulated.+    Won Bool+  deriving (Show, Generic, FromJSON, ToJSON)++makePrisms ''WinCondition++-- | A data type to keep track of the pause mode.+data RunStatus+  = -- | The game is running.+    Running+  | -- | The user paused the game, and it should stay pause after visiting the help.+    ManualPause+  | -- | The game got paused while visiting the help,+    --   and it should unpause after returning back to the game.+    AutoPause+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | Switch (auto or manually) paused game to running and running to manually paused.+--+--   Note that this function is not safe to use in the app directly, because the UI+--   also tracks time between ticks - use 'Swarm.TUI.Controller.safeTogglePause' instead.+toggleRunStatus :: RunStatus -> RunStatus+toggleRunStatus s = if s == Running then ManualPause else Running++-- | A data type to keep track of discovered recipes and commands+data Notifications a = Notifications+  { _notificationsCount :: Int+  , _notificationsContent :: [a]+  }+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++instance Semigroup (Notifications a) where+  Notifications count1 xs1 <> Notifications count2 xs2 = Notifications (count1 + count2) (xs1 <> xs2)++instance Monoid (Notifications a) where+  mempty = Notifications 0 []++makeLenses ''Notifications++------------------------------------------------------------+-- The main GameState record type+------------------------------------------------------------++-- | By default, robots may make a maximum of 100 CESK machine steps+--   during one game tick.+defaultRobotStepsPerTick :: Int+defaultRobotStepsPerTick = 100++-- | 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+  , _winCondition :: WinCondition+  , _winSolution :: Maybe ProcessedTerm+  , _runStatus :: RunStatus+  , _robotMap :: IntMap Robot+  , -- A set of robots to consider for the next game tick. It is guaranteed to+    -- be a subset of the keys of robotMap. It may contain waiting or idle+    -- robots. But robots that are present in robotMap and not in activeRobots+    -- are guaranteed to be either waiting or idle.+    _activeRobots :: IntSet+  , -- A set of probably waiting robots, indexed by probable wake-up time. It+    -- may contain robots that are in fact active or idle, as well as robots+    -- that do not exist anymore. Its only guarantee is that once a robot name+    -- with its wake up time is inserted in it, it will remain there until the+    -- wake-up time is reached, at which point it is removed via+    -- wakeUpRobotsDoneSleeping.+    -- Waiting robots for a given time are a list because it is cheaper to+    -- append to a list than to a Set.+    _waitingRobots :: Map Integer [RID]+  , _robotsByLocation :: Map (V2 Int64) IntSet+  , _allDiscoveredEntities :: Inventory+  , _availableRecipes :: Notifications (Recipe Entity)+  , _availableCommands :: Notifications Const+  , _gensym :: Int+  , _seed :: Seed+  , _randGen :: StdGen+  , _adjList :: Array Int Text+  , _nameList :: Array Int Text+  , _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+  , _viewCenterRule :: ViewCenterRule+  , _viewCenter :: V2 Int64+  , _needsRedraw :: Bool+  , _replStatus :: REPLStatus+  , _messageQueue :: Seq LogEntry+  , _lastSeenMessageTime :: Integer+  , _focusedRobotID :: RID+  , _ticks :: Integer+  , _robotStepsPerTick :: Int+  }++------------------------------------------------------------+-- Lenses+------------------------------------------------------------++-- We want to access active and waiting robots via lenses inside+-- this module but to expose it as a Getter to protect invariants.+makeLensesFor+  [ ("_activeRobots", "internalActiveRobots")+  , ("_waitingRobots", "internalWaitingRobots")+  ]+  ''GameState++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++-- | Is the user in creative mode (i.e. able to do anything without restriction)?+creativeMode :: Lens' GameState Bool++-- | How to determine whether the player has won.+winCondition :: Lens' GameState WinCondition++-- | How to win (if possible). This is useful for automated testing+--   and to show help to cheaters (or testers).+winSolution :: Lens' GameState (Maybe ProcessedTerm)++-- | The current 'RunStatus'.+runStatus :: Lens' GameState RunStatus++-- | Whether the game is currently paused.+paused :: Getter GameState Bool+paused = to (\s -> s ^. runStatus /= Running)++-- | All the robots that currently exist in the game, indexed by name.+robotMap :: Lens' GameState (IntMap Robot)++-- | The names of all robots that currently exist in the game, indexed by+--   location (which we need both for /e.g./ the 'Salvage' command as+--   well as for actually drawing the world).  Unfortunately there is+--   no good way to automatically keep this up to date, since we don't+--   just want to completely rebuild it every time the 'robotMap'+--   changes.  Instead, we just make sure to update it every time the+--   location of a robot changes, or a robot is created or destroyed.+--   Fortunately, there are relatively few ways for these things to+--   happen.+robotsByLocation :: Lens' GameState (Map (V2 Int64) IntSet)++-- | Get a list of all the robots at a particular location.+robotsAtLocation :: V2 Int64 -> GameState -> [Robot]+robotsAtLocation loc gs =+  mapMaybe (`IM.lookup` (gs ^. robotMap))+    . maybe [] IS.toList+    . M.lookup loc+    . view robotsByLocation+    $ gs++-- | Get robots in manhattan distastance from location.+robotsInArea :: V2 Int64 -> Int64 -> GameState -> [Robot]+robotsInArea o d gs = map (rm IM.!) rids+ where+  rm = gs ^. robotMap+  rl = gs ^. robotsByLocation+  rids = concatMap IS.elems $ getElemsInArea o d rl++-- | The list of entities that have been discovered.+allDiscoveredEntities :: Lens' GameState Inventory++-- | The list of available recipes.+availableRecipes :: Lens' GameState (Notifications (Recipe Entity))++-- | The list of available commands.+availableCommands :: Lens' GameState (Notifications Const)++-- | The names of the robots that are currently not sleeping.+activeRobots :: Getter GameState IntSet+activeRobots = internalActiveRobots++-- | The names of the robots that are currently sleeping, indexed by wake up+--   time. Note that this may not include all sleeping robots, particularly+--   those that are only taking a short nap (e.g. wait 1).+waitingRobots :: Getter GameState (Map Integer [RID])+waitingRobots = internalWaitingRobots++-- | A counter used to generate globally unique IDs.+gensym :: Lens' GameState Int++-- | The initial seed that was used for the random number generator,+--   and world generation.+seed :: Lens' GameState Seed++-- | Pseudorandom generator initialized at start.+randGen :: Lens' GameState StdGen++-- | Read-only list of words, for use in building random robot names.+adjList :: Getter GameState (Array Int Text)+adjList = to _adjList++-- | Read-only list of words, for use in building random robot names.+nameList :: Getter GameState (Array Int Text)+nameList = to _nameList++-- | The catalog of all entities that the game knows about.+entityMap :: Lens' GameState EntityMap++-- | All recipes the game knows about, indexed by outputs.+recipesOut :: Lens' GameState (IntMap [Recipe Entity])++-- | All recipes the game knows about, indexed by inputs.+recipesIn :: Lens' GameState (IntMap [Recipe Entity])++-- | 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,+--   robots know what they are without having to scan them.+knownEntities :: Lens' GameState [Text]++-- | The current state of the world (terrain and entities only; robots+--   are stored in the 'robotMap').  Int is used instead of+--   TerrainType because we need to be able to store terrain values in+--   unboxed tile arrays.+world :: Lens' GameState (W.World Int Entity)++-- | 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 (V2 Int64)+viewCenter = to _viewCenter++-- | Whether the world view needs to be redrawn.+needsRedraw :: Lens' GameState Bool++-- | The current status of the REPL.+replStatus :: Lens' GameState REPLStatus++-- | 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++-- | The current robot in focus.+--+-- It is only a 'Getter' because this value should be updated only when+-- the 'viewCenterRule' is specified to be a robot.+--+-- Technically it's the last robot ID specified by 'viewCenterRule',+-- but that robot may not be alive anymore - to be safe use 'focusedRobot'.+focusedRobotID :: Getter GameState RID+focusedRobotID = to _focusedRobotID++-- | The number of ticks elapsed since the game started.+ticks :: Lens' GameState Integer++-- | The maximum number of CESK machine steps a robot may take during+--   a single tick.+robotStepsPerTick :: Lens' GameState Int++------------------------------------------------------------+-- Utilities+------------------------------------------------------------++-- | The current rule for determining the center of the world view.+--   It updates also, viewCenter and focusedRobotName to keep+--   everything synchronize.+viewCenterRule :: Lens' GameState ViewCenterRule+viewCenterRule = lens getter setter+ where+  getter :: GameState -> ViewCenterRule+  getter = _viewCenterRule++  -- The setter takes care of updating viewCenter and focusedRobotName+  -- So non of this fields get out of sync.+  setter :: GameState -> ViewCenterRule -> GameState+  setter g rule =+    case rule of+      VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2}+      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}++-- | Whether the repl is currently working.+replWorking :: Getter GameState Bool+replWorking = to (\s -> matchesWorking $ s ^. replStatus)+ where+  matchesWorking REPLDone = False+  matchesWorking (REPLWorking _ _) = True++-- | Get the notification list of messages from the point of view of focused robot.+messageNotifications :: Getter GameState (Notifications LogEntry)+messageNotifications = to getNotif+ where+  getNotif gs = Notifications {_notificationsCount = length new, _notificationsContent = allUniq}+   where+    allUniq = uniq $ toList allMessages+    new = takeWhile (\l -> l ^. leTime > gs ^. lastSeenMessageTime) $ reverse allUniq+    -- creative players and system robots just see all messages (and focused robots logs)+    unchecked = gs ^. creativeMode || fromMaybe False (focusedRobot gs ^? _Just . systemRobot)+    messages = (if unchecked then id else focusedOrLatestClose) (gs ^. messageQueue)+    allMessages = Seq.sort $ focusedLogs <> messages+    focusedLogs = maybe Empty (view robotLog) (focusedRobot gs)+    -- classic players only get to see messages that they said and a one message that they just heard+    -- other they have to get from log+    latestMsg = messageIsRecent gs+    closeMsg = messageIsFromNearby (gs ^. viewCenter)+    focusedOrLatestClose mq =+      (Seq.take 1 . Seq.reverse . Seq.filter closeMsg $ Seq.takeWhileR latestMsg mq)+        <> Seq.filter ((== gs ^. focusedRobotID) . view leRobotID) mq++messageIsRecent :: GameState -> LogEntry -> Bool+messageIsRecent gs e = e ^. leTime >= gs ^. ticks - 1++messageIsFromNearby :: V2 Int64 -> LogEntry -> Bool+messageIsFromNearby l e = manhattan l (e ^. leLocation) <= hearingDistance++-- | Given a current mapping from robot names to robots, apply a+--   'ViewCenterRule' to derive the location it refers to.  The result+--   is @Maybe@ because the rule may refer to a robot which does not+--   exist.+applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (V2 Int64)+applyViewCenterRule (VCLocation l) _ = Just l+applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation++-- | Recalculate the veiw center (and cache the result in the+--   'viewCenter' field) based on the current 'viewCenterRule'.  If+--   the 'viewCenterRule' specifies a robot which does not exist,+--   simply leave the current 'viewCenter' as it is. Set 'needsRedraw'+--   if the view center changes.+recalcViewCenter :: GameState -> GameState+recalcViewCenter g =+  g+    { _viewCenter = newViewCenter+    }+    & (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id)+ where+  oldViewCenter = g ^. viewCenter+  newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap))++-- | Modify the 'viewCenter' by applying an arbitrary function to the+--   current value.  Note that this also modifies the 'viewCenterRule'+--   to match.  After calling this function the 'viewCenterRule' will+--   specify a particular location, not a robot.+modifyViewCenter :: (V2 Int64 -> V2 Int64) -> GameState -> GameState+modifyViewCenter update g =+  g+    & case g ^. viewCenterRule of+      VCLocation l -> viewCenterRule .~ VCLocation (update l)+      VCRobot _ -> viewCenterRule .~ VCLocation (update (g ^. viewCenter))++-- | Given a width and height, compute the region, centered on the+--   'viewCenter', that should currently be in view.+viewingRegion :: GameState -> (Int64, Int64) -> (W.Coords, W.Coords)+viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax))+ where+  V2 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)++-- | Find out which robot has been last specified by the+--   'viewCenterRule', if any.+focusedRobot :: GameState -> Maybe Robot+focusedRobot g = g ^. robotMap . at (g ^. focusedRobotID)++-- | Clear the 'robotLogUpdated' flag of the focused robot.+clearFocusedRobotLogUpdated :: Has (State GameState) sig m => m ()+clearFocusedRobotLogUpdated = do+  n <- use focusedRobotID+  robotMap . ix n . robotLogUpdated .= False++-- | Add a concrete instance of a robot template to the game state:+--   first, generate a unique ID number for it.  Then, add it to the+--   main robot map, the active robot set, and to to the index of+--   robots by location. Return the updated robot.+addTRobot :: Has (State GameState) sig m => TRobot -> m Robot+addTRobot r = do+  rid <- gensym <+= 1+  let r' = instantiateRobot rid r+  addRobot r'+  return r'++-- | Add a robot to the game state, adding it to the main robot map,+--   the active robot set, and to to the index of robots by+--   location.+addRobot :: Has (State GameState) sig m => Robot -> m ()+addRobot r = do+  let rid = r ^. robotID++  robotMap %= IM.insert rid r+  robotsByLocation+    %= M.insertWith IS.union (r ^. robotLocation) (IS.singleton rid)+  internalActiveRobots %= IS.insert rid++maxMessageQueueSize :: Int+maxMessageQueueSize = 1000++-- | Add a message to the message queue.+emitMessage :: Has (State GameState) sig m => LogEntry -> m ()+emitMessage msg = messageQueue %= (|> msg) . dropLastIfLong+ where+  tooLong s = Seq.length s >= maxMessageQueueSize+  dropLastIfLong whole@(_oldest :<| newer) = if tooLong whole then newer else whole+  dropLastIfLong emptyQueue = emptyQueue++-- | Takes a robot out of the activeRobots set and puts it in the waitingRobots+--   queue.+sleepUntil :: Has (State GameState) sig m => RID -> Integer -> m ()+sleepUntil rid time = do+  internalActiveRobots %= IS.delete rid+  internalWaitingRobots . at time . non [] %= (rid :)++-- | Takes a robot out of the activeRobots set.+sleepForever :: Has (State GameState) sig m => RID -> m ()+sleepForever rid = internalActiveRobots %= IS.delete rid++-- | Adds a robot to the activeRobots set.+activateRobot :: Has (State GameState) sig m => RID -> m ()+activateRobot rid = internalActiveRobots %= IS.insert rid++-- | Removes robots whose wake up time matches the current game ticks count+--   from the waitingRobots queue and put them back in the activeRobots set+--   if they still exist in the keys of robotMap.+wakeUpRobotsDoneSleeping :: Has (State GameState) sig m => m ()+wakeUpRobotsDoneSleeping = do+  time <- use ticks+  mrids <- internalWaitingRobots . at time <<.= Nothing+  case mrids of+    Nothing -> return ()+    Just rids -> do+      robots <- use robotMap+      let aliveRids = filter (`IM.member` robots) rids+      internalActiveRobots %= IS.union (IS.fromList aliveRids)++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++------------------------------------------------------------+-- Initialization+------------------------------------------------------------++-- | Create an initial game state record, first loading entities and+--   recipies 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"++  let markEx what a = catchError a (\e -> fail $ "Failed to " <> what <> ": " <> show e)++  (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)++  return $+    GameState+      { _creativeMode = False+      , _winCondition = NoWinCondition+      , _winSolution = Nothing+      , _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 = V2 0 0+      , _needsRedraw = False+      , _replStatus = REPLDone+      , _messageQueue = Empty+      , _lastSeenMessageTime = -1+      , _focusedRobotID = 0+      , _ticks = 0+      , _robotStepsPerTick = defaultRobotStepsPerTick+      }++-- | Set a given scenario as the currently loaded scenario in the game state.+scenarioToGameState :: Scenario -> Maybe Seed -> Maybe String -> GameState -> IO GameState+scenarioToGameState scenario userSeed toRun g = do+  -- Decide on a seed.  In order of preference, we will use:+  --   1. seed value provided by the user+  --   2. seed value specified in the scenario description+  --   3. randomly chosen seed value+  theSeed <- case userSeed <|> scenario ^. scenarioSeed of+    Just s -> return s+    Nothing -> randomRIO (0, maxBound :: Int)++  now <- Clock.getTime Clock.Monotonic+  let robotList' = (robotCreatedAt .~ now) <$> robotList++  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 = V2 0 0+      , _needsRedraw = False+      , -- When starting base with the run flag, REPL status must be set to working,+        -- otherwise the store of definition cells is not saved (see #333)+        _replStatus = case toRun of+          Nothing -> REPLDone+          Just _ -> REPLWorking (Forall [] (TyCmd TyUnit)) Nothing+      , _messageQueue = Empty+      , _focusedRobotID = baseID+      , _ticks = 0+      , _robotStepsPerTick = (scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick+      }+ where+  em = g ^. entityMap <> 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+  robotList =+    zipWith instantiateRobot [baseID ..] (locatedRobots ++ genRobots)+      -- If the  --run flag was used, use it to replace the CESK machine of the+      -- robot whose id is 0, i.e. the first robot listed in the scenario.+      & ix baseID . machine+        %~ case toRun of+          Nothing -> id+          Just (into @Text -> f) -> const (initMachine [tmQ| run($str:f) |] Ctx.empty emptyStore)+      -- If we are in creative mode, give base all the things+      & ix baseID . robotInventory+        %~ case scenario ^. scenarioCreative of+          False -> id+          True -> union (fromElems (map (0,) things))+      & ix baseID . installedDevices+        %~ case scenario ^. scenarioCreative of+          False -> id+          True -> const (fromList devices)++  -- Initial list of available commands = all commands enabled by+  -- devices in inventory or installed; and commands that require no+  -- capability.+  allCapabilities r =+    inventoryCapabilities (r ^. installedDevices)+      <> inventoryCapabilities (r ^. robotInventory)+  initialCaps = mconcat $ map allCapabilities robotList+  initialCommands =+    filter+      (maybe True (`S.member` initialCaps) . constCaps)+      allConst++  (genRobots, wf) = buildWorld em (scenario ^. scenarioWorld)+  theWorld = W.newWorld . wf+  theWinCondition = maybe NoWinCondition WinConditions (NE.nonEmpty (scenario ^. scenarioObjectives))+  initGensym = length robotList - 1+  addRecipesWith f gRs = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) (g ^. gRs)++-- | Take a world description, parsed from a scenario file, and turn+--   it into a list of located robots and a world function.+buildWorld :: EntityMap -> WorldDescription -> ([TRobot], Seed -> WorldFun Int Entity)+buildWorld em WorldDescription {..} = (robots, first fromEnum . wf)+ where+  rs = fromIntegral $ length area+  cs = fromIntegral $ length (head area)+  Coords (ulr, ulc) = locToCoords ul++  worldGrid :: [[(TerrainType, Maybe Entity)]]+  worldGrid = (map . map) (cellTerrain &&& cellEntity) area++  worldArray :: Array (Int64, Int64) (TerrainType, Maybe 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))++  -- Get all the robots described in cells and set their locations appropriately+  robots :: [TRobot]+  robots =+    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))+             in map robotWithLoc robotList+        )++-- | Create an initial game state for a specific scenario.+initGameStateForScenario :: String -> Maybe Seed -> Maybe String -> ExceptT Text IO GameState+initGameStateForScenario sceneName userSeed toRun = do+  g <- initGameState+  (scene, path) <- loadScenario sceneName (g ^. entityMap)+  gs <- liftIO $ scenarioToGameState scene userSeed 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.+classicGame0 :: ExceptT Text IO GameState+classicGame0 = initGameStateForScenario "classic" (Just 0) Nothing
+ src/Swarm/Game/Step.hs view
@@ -0,0 +1,2017 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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.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, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))+import Control.Monad (forM, forM_, guard, msum, unless, when)+import Data.Array (bounds, (!))+import Data.Bifunctor (second)+import Data.Bool (bool)+import Data.Containers.ListUtils (nubOrd)+import Data.Either (partitionEithers, rights)+import Data.Foldable (asum, traverse_)+import Data.Functor (void)+import Data.Int (Int64)+import Data.IntMap qualified as IM+import Data.IntSet qualified as IS+import Data.List (find)+import Data.List qualified as L+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.List.NonEmpty qualified as NE+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isNothing, listToMaybe)+import Data.Sequence qualified as Seq+import Data.Set (Set)+import Data.Set qualified as S+import Data.Text (Text)+import Data.Text qualified as T+import Data.Tuple (swap)+import Linear (V2 (..), 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 (objectiveCondition)+import Swarm.Game.State+import Swarm.Game.Value+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.Requirement qualified as R+import Swarm.Language.Syntax+import Swarm.Util+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 ty Nothing -> case getResult r of+          Just (v, s) -> do+            replStatus .= REPLWorking ty (Just v)+            robotMap . ix 0 . 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 (obj :| objs) -> do+      g <- get @GameState++      -- Execute the win condition check *hypothetically*: i.e. in a+      -- fresh CESK machine, using a copy of the current game state.+      v <- runThrow @Exn . evalState @GameState g $ evalPT (obj ^. objectiveCondition)+      case v of+        -- Log exceptions in the message queue so we can check for them in tests+        Left exn -> do+          em <- use entityMap+          time <- use ticks+          let h = hypotheticalRobot (Out VUnit emptyStore []) 0+              hid = view robotID h+              hn = view robotName h+              farAway = V2 maxBound maxBound+          let m = LogEntry time ErrorTrace hn hid farAway $ formatExn em exn+          emitMessage m+        Right (VBool True) -> winCondition .= maybe (Won False) WinConditions (NE.nonEmpty objs)+        _ -> return ()+    _ -> return ()++  -- Advance the game time by one.+  ticks += 1++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) => V2 Int64 -> 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) => V2 Int64 -> (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 FixByInstall (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 FixByInstall (R.singletonCap cap) term++-- | Create an exception about a command failing.+cmdExn :: Const -> [Text] -> Exn+cmdExn c parts = CmdFailed c (T.unwords parts)++-- | 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))+  return $ r' & machine .~ cesk'++-- | 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+  -- (sendIO $ appendFile "out.txt" (prettyCESK cesk)) >>++  ------------------------------------------------------------+  -- 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 wf rf : k) -> do+    wc <- worldUpdate wf <$> use world+    case wc of+      Left exn -> return $ Up exn s k+      Right wo -> do+        robotInventory %= robotUpdateInventory rf+        world .= wo+        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++  -- 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 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+  -- 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.+  Up exn s [] -> do+    let s' = resetBlackholes s+    h <- hasCapability CLog+    em <- use entityMap+    if h+      then do+        void $ traceLog ErrorTrace (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+            , from (prettyCESK 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) -> V2 Int64 -> TimeSpec -> m ()+addSeedBot e (minT, maxT) loc ts =+  void $+    addTRobot $+      mkRobot+        ()+        Nothing+        "seed"+        ["A growing seed."]+        (Just loc)+        (V2 0 0)+        ( 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+      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 = V2 (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+    Install -> case vs of+      [VRobot otherID, VText itemName] -> do+        -- Make sure the other robot exists and is close+        _other <- getRobotWithinTouch otherID++        item <- ensureItem itemName "install"++        myID <- use robotID+        focusedID <- use focusedRobotID+        case otherID == myID of+          -- We have to special case installing something on ourselves+          -- for the same reason as Give.+          True -> do+            -- Don't do anything if the robot already has the device.+            already <- use (installedDevices . to (`E.contains` item))+            unless already $ do+              installedDevices %= insert item+              robotInventory %= delete item++              -- Flag the UI for a redraw if we are currently showing our inventory+              when (focusedID == myID) flagRedraw+          False -> do+            let otherDevices = robotMap . at otherID . _Just . installedDevices+            already <- use $ pre (otherDevices . to (`E.contains` item))+            unless (already == Just True) $ do+              robotMap . at otherID . _Just . installedDevices %= 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+    Make -> case vs of+      [VText name] -> do+        inv <- use robotInventory+        ins <- use installedDevices+        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 installed"+            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 (WorldUpdate Right) (RobotUpdate changeInv)+      _ -> badConst+    Has -> case vs of+      [VText name] -> do+        inv <- use robotInventory+        return $ Out (VBool ((> 0) $ countByName name inv)) s k+      _ -> badConst+    Installed -> case vs of+      [VText name] -> do+        inv <- use installedDevices+        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+      V2 x y <- use robotLocation+      return $ Out (VPair (VInt (fromIntegral x)) (VInt (fromIntegral y))) 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 installedDevices++        let toyDrill = lookupByName "drill" ins+            metalDrill = lookupByName "metal drill" ins+            insDrill = listToMaybe $ metalDrill <> toyDrill++        drill <- insDrill `isJustOr` Fatal "Drill is required but not installed?!"++        let directionText = case d of+              DDown -> "under"+              DForward -> "ahead of"+              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+            changeInv =+              flip (L.foldl' (flip $ uncurry insertCount)) out+                . flip (L.foldl' (flip $ insertCount 0)) (map snd down)+            changeWorld = changeWorld' nextE nextLoc down++        -- take recipe inputs from inventory and add outputs after recipeTime+        robotInventory .= invTaken+        finishCookingRecipe recipe (WorldUpdate changeWorld) (RobotUpdate changeInv)+      _ -> 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 installedDevices+        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 robot 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.Empty+              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+      creative <- use creativeMode+      system <- use systemRobot+      mq <- use messageQueue+      let recentAndClose e = system || creative || messageIsRecent gs e && messageIsFromNearby loc e+          limitLast = \case+            _s Seq.:|> l -> Just $ l ^. leText+            _ -> Nothing+          mm = limitLast $ Seq.takeWhileR recentAndClose 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 robot 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+    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+    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 robot 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.+        (toInstall, toGive) <-+          checkRequirements+            (r ^. robotInventory)+            (childRobot ^. robotInventory)+            (childRobot ^. installedDevices)+            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 $ toInstall) 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++        (toInstall, 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.+        newRobot <-+          addTRobot $+            mkRobot+              ()+              (Just pid)+              displayName+              ["A robot built by the robot named " <> r ^. robotName <> "."]+              (Just (r ^. robotLocation))+              ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir)+                  ? east+              )+              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 $ toInstall) 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 installed devices into its inventory, in preparation+            -- for transferring it.+            let salvageInventory = E.union (target ^. robotInventory) (target ^. installedDevices)+            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 installedDevices+            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+        mf <- sendIO $ mapM readFileMay [into fileName, into $ fileName <> ".sw"]++        f <- msum mf `isJustOrFail` ["File not found:", fileName]++        mt <-+          processTerm (into @Text f) `isRightOr` \err ->+            cmdExn Run ["Error in", fileName, "\n", err]++        return $ case mt of+          Nothing -> Out VUnit s k+          Just t -> 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+    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:"+      , from (prettyCESK (Out (VCApp c (reverse vs)) s k))+      ]++  finishCookingRecipe :: HasRobotStepState sig m => Recipe e -> WorldUpdate -> 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 wf rf : k)++  lookInDirection :: HasRobotStepState sig m => Direction -> m (V2 Int64, 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+  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 installedDevices+    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 installed 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+  -- installed, 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, and fail with+    -- an exception if not+    devs <- forM devNames $ \devName ->+      E.lookupEntityName devName em `isJustOrFail` ["Unknown device required: " <> devName]++    -- Check that all required inventory entity names exist, and fail+    -- with an exception if not+    reqElems <- forM (M.assocs reqInvNames) $ \(eName, n) ->+      (n,)+        <$> ( E.lookupEntityName eName em+                `isJustOrFail` ["Unknown entity required: " <> eName]+            )+    let reqInv = E.fromElems reqElems++    let -- List of possible devices per requirement.  Devices for+        -- required capabilities come first, then singleton devices+        -- that are required directly.  This order is important since+        -- later we zip required capabilities with this list to figure+        -- out which capabilities are missing.+        capDevices = map (`deviceForCap` em) caps ++ map (: []) devs++        -- A device is OK if it is available in the inventory of the+        -- parent robot, or already installed in the child robot.+        deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d++        -- take a pair of device sets providing capabilities that is+        -- split into (AVAIL,MISSING) and if there are some available+        -- ignore missing because we only need them for error message+        ignoreOK ([], miss) = ([], miss)+        ignoreOK (ds, _miss) = (ds, [])++        (deviceSets, missingDeviceSets) =+          Lens.over both (nubOrd . map S.fromList) . unzip $+            map (ignoreOK . L.partition deviceOK) capDevices++        formatDevices = T.intercalate " or " . map (^. entityName) . S.toList+        -- capabilities not provided by any device in inventory+        missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets++        alreadyInstalled = S.fromList . map snd . E.elems $ childDevices++        -- Figure out what is missing from the required inventory+        missingChildInv = reqInv `E.difference` childInventory++    if creative+      then -- In creative mode, just return ALL the devices+        return (S.unions (map S.fromList capDevices) `S.difference` alreadyInstalled, missingChildInv)+      else do+        -- check if robot has all devices to execute new command+        all null missingDeviceSets+          `holdsOrFail` ( singularSubjectVerb subject "do" :+                          "not have required devices, please" :+                          formatIncapableFix fixI <> ":" :+                          (("\n  - " <>) . formatDevices <$> filter (not . null) missingDeviceSets)+                        )+        -- check that there are in fact devices to provide every required capability+        not (any null deviceSets) `holdsOr` Incapable fixI (R.Requirements missingCaps S.empty M.empty) cmd++        let minimalInstallSet = smallHittingSet (filter (S.null . S.intersection alreadyInstalled) deviceSets)++            -- Check that we have enough in our inventory to cover the+            -- required installs PLUS what's missing from the child+            -- inventory.++            -- What do we need?+            neededParentInv =+              missingChildInv+                `E.union` (fromList . S.toList $ minimalInstallSet)++            -- 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 (minimalInstallSet, missingChildInv)++  -- replace some entity in the world with another entity+  changeWorld' ::+    Entity ->+    V2 Int64 ->+    IngredientList Entity ->+    W.World Int Entity ->+    Either Exn (W.World Int Entity)+  changeWorld' eThen loc down w =+    let eNow = W.lookupEntity (W.locToCoords loc) w+     in if Just eThen /= eNow+          then Left $ cmdExn c ["The", eThen ^. entityName, "is not there."]+          else+            w `updateLoc` loc <$> case down of+              [] -> Right Nothing+              [de] -> Right $ Just $ snd de+              _ -> Left $ Fatal "Bad recipe:\n more than one unmovable entity produced."++  destroyIfNotBase :: HasRobotStepState sig m => m ()+  destroyIfNotBase = do+    rid <- use robotID+    (rid /= 0) `holdsOrFail` ["You consider destroying your base, but decide not to do it after all."]+    selfDestruct .= True++  -- Make sure nothing is in the way. Note that system robots implicitly ignore and base throws on failure.+  checkMoveAhead :: HasRobotStepState sig m => V2 Int64 -> 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+              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+              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++  -- update some tile in the world setting it to entity or making it empty+  updateLoc w loc res = W.update (W.locToCoords loc) (const res) w++  holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m ()+  holdsOrFail a ts = a `holdsOr` cmdExn c ts++  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"++-- | 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 installed, 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 toInstall toGive = do+  -- Install and give devices to child+  robotMap . ix childID . installedDevices %= E.union toInstall+  robotMap . ix childID . robotInventory %= E.union toGive++  -- Delete all items from parent in classic mode+  creative <- use creativeMode+  unless creative $+    robotInventory %= (`E.difference` (toInstall `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) =>+  V2 Int64 ->+  V2 Int64 ->+  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++-- | Values with different types were compared; this should not be+--   possible since the type system should catch it.+incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a+incompatCmp v1 v2 =+  throwError $+    Fatal $+      T.unwords ["Incompatible comparison of ", prettyValue v1, "and", prettyValue v2]++-- | Values were compared of a type which cannot be compared+--   (e.g. functions, etc.).+incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a+incomparable v1 v2 =+  throwError $+    CmdFailed Lt $+      T.unwords ["Comparison is undefined for ", prettyValue v1, "and", prettyValue v2]++------------------------------------------------------------+-- Arithmetic+------------------------------------------------------------++-- | Evaluate the application of an arithmetic operator, returning+--   an exception in the case of a failing operation, or in case we+--   incorrectly use it on a bad 'Const' in the library.+evalArith :: Has (Throw Exn) sig m => Const -> Integer -> Integer -> m Integer+evalArith = \case+  Add -> ok (+)+  Sub -> ok (-)+  Mul -> ok (*)+  Div -> safeDiv+  Exp -> safeExp+  c -> \_ _ -> throwError $ Fatal $ T.append "evalArith called on bad constant " (from (show c))+ where+  ok f x y = return $ f x y++-- | Perform an integer division, but return @Nothing@ for division by+--   zero.+safeDiv :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer+safeDiv _ 0 = throwError $ CmdFailed Div "Division by zero"+safeDiv a b = return $ a `div` b++-- | Perform exponentiation, but return @Nothing@ if the power is negative.+safeExp :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer+safeExp a b+  | b < 0 = throwError $ CmdFailed Exp "Negative exponent"+  | otherwise = return $ a ^ b++------------------------------------------------------------+-- Updating discovered entities, recipes, and commands+------------------------------------------------------------++-- | Update the global list of discovered entities, and check for new recipes.+updateDiscoveredEntities :: (HasRobotStepState sig m) => Entity -> m ()+updateDiscoveredEntities e = do+  allDiscovered <- use allDiscoveredEntities+  if E.contains0plus e allDiscovered+    then pure ()+    else do+      let newAllDiscovered = E.insertCount 1 e allDiscovered+      updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e+      updateAvailableCommands e+      allDiscoveredEntities .= newAllDiscovered++-- | Update the availableRecipes list.+-- This implementation is not efficient:+-- * Every time we discover a new entity, we iterate through the entire list of recipes to see which ones we can make.+--   Trying to do something more clever seems like it would definitely be a case of premature optimization.+--   One doesn't discover new entities all that often.+-- * For each usable recipe, we do a linear search through the list of known recipes to see if we already know it.+--   This is a little more troubling, since it's quadratic in the number of recipes.+--   But it probably doesn't really make that much difference until we get up to thousands of recipes.+updateAvailableRecipes :: Has (State GameState) sig m => (Inventory, Inventory) -> Entity -> m ()+updateAvailableRecipes invs e = do+  allInRecipes <- use recipesIn+  let entityRecipes = recipesFor allInRecipes e+      usableRecipes = filter (knowsIngredientsFor invs) entityRecipes+  knownRecipes <- use (availableRecipes . notificationsContent)+  let newRecipes = filter (`notElem` knownRecipes) usableRecipes+      newCount = length newRecipes+  availableRecipes %= mappend (Notifications newCount newRecipes)+  updateAvailableCommands e++updateAvailableCommands :: Has (State GameState) sig m => Entity -> m ()+updateAvailableCommands e = do+  let newCaps = S.fromList (e ^. entityCapabilities)+      keepConsts = \case+        Just cap -> cap `S.member` newCaps+        Nothing -> False+      entityConsts = filter (keepConsts . constCaps) allConst+  knownCommands <- use (availableCommands . notificationsContent)+  let newCommands = filter (`notElem` knownCommands) entityConsts+      newCount = length newCommands+  availableCommands %= mappend (Notifications newCount newCommands)
+ src/Swarm/Game/Terrain.hs view
@@ -0,0 +1,49 @@+-- |+-- 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 (..),+  terrainMap,+) where++import Data.Aeson (FromJSON (..), withText)+import Data.Map (Map)+import Data.Map qualified as M+import Data.Text qualified as T+import Swarm.Game.Display+import Swarm.TUI.Attr+import Text.Read (readMaybe)+import Witch (into)++-- | The different possible types of terrain. Unlike entities and+--   robots, these are hard-coded into the game.+data TerrainType+  = StoneT+  | DirtT+  | GrassT+  | IceT+  | BlankT+  deriving (Eq, Ord, Show, Read, Bounded, Enum)++instance FromJSON TerrainType where+  parseJSON = withText "text" $ \t ->+    case readMaybe (into @String (T.toTitle t) ++ "T") of+      Just ter -> return ter+      Nothing -> fail $ "Unknown terrain type: " ++ into @String t++-- | 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)+    ]
+ src/Swarm/Game/Value.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}++-- |+-- Module      :  Swarm.Game.Value+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Values and environments used for interpreting the Swarm language.+module Swarm.Game.Value (+  -- * Values+  Value (..),+  prettyValue,+  valueToTerm,++  -- * Environments+  Env,+) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Bool (bool)+import Data.List (foldl')+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.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.+data Value where+  -- | The unit value.+  VUnit :: Value+  -- | An integer.+  VInt :: Integer -> Value+  -- | Literal text.+  VText :: Text -> Value+  -- | A direction.+  VDir :: Direction -> Value+  -- | A boolean.+  VBool :: Bool -> Value+  -- | A reference to a robot.+  VRobot :: Int -> Value+  -- | An injection into a sum type.  False = left, True = right.+  VInj :: Bool -> Value -> Value+  -- | A pair.+  VPair :: Value -> Value -> Value+  -- | A /closure/, representing a lambda term along with an+  --   environment containing bindings for any free variables in the+  --   body of the lambda.+  VClo :: Var -> Term -> Env -> Value+  -- | An application of a constant to some value arguments,+  --   potentially waiting for more arguments.  If a constant+  --   application is fully saturated (as defined by its 'arity'),+  --   whether it is a value or not depends on whether or not it+  --   represents a command (as defined by 'isCmd').  If a command+  --   (e.g. 'Build'), it is a value, and awaits an 'Swarm.Game.CESK.FExec' frame+  --   which will cause it to execute.  Otherwise (e.g. 'If'), it is+  --   not a value, and will immediately reduce.+  VCApp :: Const -> [Value] -> Value+  -- | A definition, which does not take effect until executed.+  --   The @Bool@ indicates whether the definition is recursive.+  VDef :: Bool -> Var -> Term -> Env -> Value+  -- | The result of a command, consisting of the result of the+  --   command as well as an environment of bindings from 'TDef'+  --   commands.+  VResult :: Value -> Env -> Value+  -- | An unevaluated bind expression, waiting to be executed, of the+  --   form /i.e./ @c1 ; c2@ or @x <- c1; c2@.  We also store an 'Env'+  --   in which to interpret the commands.+  VBind :: Maybe Var -> Term -> Term -> Env -> Value+  -- | A (non-recursive) delayed term, along with its environment. If+  --   a term would otherwise be evaluated but we don't want it to be+  --   (/e.g./ as in the case of arguments to an 'if', or a recursive+  --   binding), we can stick a 'TDelay' on it, which turns it into a+  --   value.  Delayed terms won't be evaluated until 'Force' is+  --   applied to them.+  VDelay :: Term -> Env -> Value+  -- | A reference to a memory cell in the store.+  VRef :: Int -> Value+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | Pretty-print a value.+prettyValue :: Value -> Text+prettyValue = prettyText . valueToTerm++-- | Inject a value back into a term.+valueToTerm :: Value -> Term+valueToTerm VUnit = TUnit+valueToTerm (VInt n) = TInt n+valueToTerm (VText s) = TText s+valueToTerm (VDir d) = TDir d+valueToTerm (VBool b) = TBool b+valueToTerm (VRobot r) = TRobot r+valueToTerm (VInj s v) = TApp (TConst (bool Inl Inr s)) (valueToTerm v)+valueToTerm (VPair v1 v2) = TPair (valueToTerm v1) (valueToTerm v2)+valueToTerm (VClo x t e) =+  M.foldrWithKey+    (\y v -> TLet False y Nothing (valueToTerm v))+    (TLam x Nothing t)+    (M.restrictKeys (unCtx e) (S.delete x (setOf fv t)))+valueToTerm (VCApp c vs) = foldl' TApp (TConst c) (reverse (map valueToTerm vs))+valueToTerm (VDef r x t _) = TDef r x Nothing t+valueToTerm (VResult v _) = valueToTerm v+valueToTerm (VBind mx c1 c2 _) = TBind mx c1 c2+valueToTerm (VDelay t _) = TDelay SimpleDelay t+valueToTerm (VRef n) = TRef n++-- | An environment is a mapping from variable names to values.+type Env = Ctx Value
+ src/Swarm/Game/World.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# 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+-- things in it (besides robots). A world has a base, immutable+-- /terrain/ layer, where each cell contains a terrain type, and a+-- mutable /entity/ layer, with at most one entity per cell.+--+-- A world is technically finite but practically infinite (worlds are+-- indexed by 64-bit signed integers, so they correspond to a+-- \( 2^{64} \times 2^{64} \) torus).+module Swarm.Game.World (+  -- * World coordinates+  Coords (..),+  locToCoords,+  coordsToLoc,++  -- * Worlds+  WorldFun (..),+  worldFunFromArray,+  World,++  -- ** Tile management+  loadCell,+  loadRegion,++  -- ** World functions+  newWorld,+  emptyWorld,+  lookupTerrain,+  lookupEntity,+  update,++  -- ** Monadic variants+  lookupTerrainM,+  lookupEntityM,+  updateM,+) where++import Control.Algebra (Has)+import Control.Arrow ((&&&))+import Control.Effect.State (State, get, modify)+import Control.Lens+import Data.Array qualified as A+import Data.Array.IArray+import Data.Array.Unboxed qualified as U+import Data.Bits+import Data.Foldable (foldl')+import Data.Int (Int64)+import Data.Map.Strict qualified as M+import GHC.Generics (Generic)+import Linear+import Swarm.Util+import Prelude hiding (lookup)++------------------------------------------------------------+-- World coordinates+------------------------------------------------------------++-- | World coordinates use (row,column) format, with the row+--   increasing as we move down the screen.  This format plays nicely+--   with drawing the screen.+newtype Coords = Coords {unCoords :: (Int64, Int64)}+  deriving (Eq, Ord, Show, Ix, Generic)++instance Rewrapped Coords t+instance Wrapped Coords++-- | Convert an (x,y) location to a 'Coords' value.+locToCoords :: V2 Int64 -> Coords+locToCoords (V2 x y) = Coords (- y, x)++-- | Convert 'Coords' to an (x,y) location.+coordsToLoc :: Coords -> V2 Int64+coordsToLoc (Coords (r, c)) = V2 c (- r)++------------------------------------------------------------+-- 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)}++instance Bifunctor WorldFun where+  bimap g h (WF z) = WF (bimap g (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 (Int64, Int64) (t, Maybe e) -> (t, Maybe e) -> WorldFun t e+worldFunFromArray arr def = WF $ \(Coords (r, c)) ->+  if inRange bnds (r, c)+    then arr ! (r, c)+    else def+ where+  bnds = bounds arr++------------------------------------------------------------+-- Tiles and coordinates+------------------------------------------------------------++-- | The number of bits we need in each coordinate to represent all+--   the locations in a tile.  In other words, each tile has a size of+--   @2^tileBits x 2^tileBits@.+--+--   Currently, 'tileBits' is set to 6, giving us 64x64 tiles, with+--   4096 cells in each tile. That seems intuitively like a good size,+--   but I don't have a good sense for the tradeoffs here, and I don't+--   know how much the choice of tile size matters.+tileBits :: Int+tileBits = 6++-- | The number consisting of 'tileBits' many 1 bits.  We can use this+--   to mask out the tile offset of a coordinate.+tileMask :: Int64+tileMask = (1 `shiftL` tileBits) - 1++-- | If we think of the world as a grid of /tiles/, we can assign each+--   tile some coordinates in the same way we would if each tile was a+--   single cell.  These are the tile coordinates.+newtype TileCoords = TileCoords {unTileCoords :: Coords}+  deriving (Eq, Ord, Show, Ix, Generic)++instance Rewrapped TileCoords t+instance Wrapped TileCoords++-- | Convert from a cell's coordinates to the coordinates of its tile,+--   simply by shifting out 'tileBits' many bits.+tileCoords :: Coords -> TileCoords+tileCoords = TileCoords . over (_Wrapped . both) (`shiftR` tileBits)++-- | Find the coordinates of the upper-left corner of a tile.+tileOrigin :: TileCoords -> Coords+tileOrigin = over (_Wrapped . both) (`shiftL` tileBits) . unTileCoords++-- | A 'TileOffset' represents an offset from the upper-left corner of+--   some tile to a cell in its interior.+newtype TileOffset = TileOffset Coords+  deriving (Eq, Ord, Show, Ix, Generic)++-- | The offsets of the upper-left and lower-right corners of a tile:+--   (0,0) to ('tileMask', 'tileMask').+tileBounds :: (TileOffset, TileOffset)+tileBounds = (TileOffset (Coords (0, 0)), TileOffset (Coords (tileMask, tileMask)))++-- | Compute the offset of a given coordinate within its tile.+tileOffset :: Coords -> TileOffset+tileOffset = TileOffset . over (_Wrapped . both) (.&. tileMask)++-- | Add a tile offset to the coordinates of the tile's upper left+--   corner.  NOTE that for efficiency, this function only works when+--   the first argument is in fact the coordinates of a tile's+--   upper-left corner (/i.e./ it is an output of 'tileOrigin').  In+--   that case the coordinates will end with all 0 bits, and we can+--   add the tile offset just by doing a coordinatewise 'xor'.+plusOffset :: Coords -> TileOffset -> Coords+plusOffset (Coords (x1, y1)) (TileOffset (Coords (x2, y2))) = Coords (x1 `xor` x2, y1 `xor` y2)++instance Rewrapped TileOffset t+instance Wrapped TileOffset++-- | A terrain tile is an unboxed array of terrain values.+type TerrainTile t = U.UArray TileOffset t++-- | An entity tile is an array of possible entity values.  Note it+--   cannot be an unboxed array since entities are complex records+--   which have to be boxed.+type EntityTile e = A.Array TileOffset (Maybe e)++-- | A 'World' consists of a 'WorldFun' that specifies the initial+--   world, a cache of loaded square tiles to make lookups faster, and+--   a map storing locations whose entities have changed from their+--   initial values.+--+--   Right now the 'World' simply holds on to all the tiles it has+--   ever loaded.  Ideally it would use some kind of LRU caching+--   scheme to keep memory usage bounded, but it would be a bit+--   tricky, and in any case it's probably not going to matter much+--   for a while.  Once tile loads can trigger robots to spawn, it+--   would also make for some difficult decisions in terms of how to+--   handle respawning.+data World t e = World+  { _worldFun :: WorldFun t e+  , _tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e)+  , _changed :: M.Map Coords (Maybe e)+  }++-- | Create a new 'World' from a 'WorldFun'.+newWorld :: WorldFun t e -> World t e+newWorld f = World f M.empty M.empty++-- | Create a new empty 'World' consisting of nothing but the given+--   terrain.+emptyWorld :: t -> World t e+emptyWorld t = newWorld (WF $ const (t, Nothing))++-- | Look up the terrain value at certain coordinates: try looking it+--   up in the tile cache first, and fall back to running the 'WorldFun'+--   otherwise.+--+--   This function does /not/ ensure that the tile containing the+--   given coordinates is loaded.  For that, see 'lookupTerrainM'.+lookupTerrain :: IArray U.UArray t => Coords -> World t e -> t+lookupTerrain i (World f t _) =+  ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t)+    ? fst (runWF f i)++-- | A stateful variant of 'lookupTerrain', which first loads the tile+--   containing the given coordinates if it is not already loaded,+--   then looks up the terrain value.+lookupTerrainM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m t+lookupTerrainM c = do+  modify @(World t e) $ loadCell c+  lookupTerrain c <$> get @(World t e)++-- | Look up the entity at certain coordinates: first, see if it is in+--   the map of locations with changed entities; then try looking it+--   up in the tile cache first; and finally fall back to running the+--   'WorldFun'.+--+--   This function does /not/ ensure that the tile containing the+--   given coordinates is loaded.  For that, see 'lookupEntityM'.+lookupEntity :: Coords -> World t e -> Maybe e+lookupEntity i (World f t m) =+  M.lookup i m+    ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)+    ? snd (runWF f i)++-- | A stateful variant of 'lookupTerrain', which first loads the tile+--   containing the given coordinates if it is not already loaded,+--   then looks up the terrain value.+lookupEntityM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m (Maybe e)+lookupEntityM c = do+  modify @(World t e) $ loadCell c+  lookupEntity c <$> get @(World t e)++-- | Update the entity (or absence thereof) at a certain location,+--   returning an updated 'World'.  See also 'updateM'.+update :: Coords -> (Maybe e -> Maybe e) -> World t e -> World t e+update i g w@(World f t m) =+  World f t (M.insert i (g (lookupEntity i w)) m)++-- | 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++-- | Load the tile containing a specific cell.+loadCell :: IArray U.UArray t => Coords -> World t e -> World t e+loadCell c = loadRegion (c, c)++-- | Load all the tiles which overlap the given rectangular region+--   (specified as an upper-left and lower-right corner).+loadRegion :: forall t e. IArray U.UArray t => (Coords, Coords) -> World t e -> World t e+loadRegion reg (World f t m) = World f t' m+ where+  tiles = range (over both tileCoords reg)+  t' = foldl' (\hm (i, tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles)++  maybeInsert k v tm+    | k `M.member` tm = tm+    | otherwise = M.insert k v tm++  loadTile :: TileCoords -> (TerrainTile t, EntityTile e)+  loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities)+   where+    tileCorner = tileOrigin tc+    (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds)
+ src/Swarm/Game/WorldGen.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- 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.Enumeration+import Data.Hash.Murmur+import Data.Int (Int64)+import Data.List (find)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Set qualified as S+import Data.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++-- | 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 . into . 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 (Int64, Int64) (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 Int64+  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
@@ -0,0 +1,251 @@+-- |+-- 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+-- constructs or commands require certain capabilities, and in turn+-- capabilities are provided by various devices.  A robot must have an+-- appropriate device installed in order to make use of each language+-- construct or command.+module Swarm.Language.Capability (+  Capability (..),+  capabilityName,+  constCaps,+) where++import Data.Aeson (FromJSONKey, ToJSONKey)+import Data.Char (toLower)+import Data.Data (Data)+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Yaml+import GHC.Generics (Generic)+import Swarm.Language.Syntax+import Text.Read (readMaybe)+import Witch (from)+import Prelude hiding (lookup)++-- | Various capabilities which robots can have.+data Capability+  = -- | Be powered, i.e. execute anything at all+    CPower+  | -- | Execute the 'Move' command+    CMove+  | -- | Execute the 'Move' command for a heavy robot+    CMoveheavy+  | -- | Execute the 'Turn' command+    --+    -- NOTE: using cardinal directions is separate 'COrient' capability+    CTurn+  | -- | Execute the 'Selfdestruct' command+    CSelfdestruct+  | -- | Execute the 'Grab' command+    CGrab+  | -- | Execute the 'Harvest' command+    CHarvest+  | -- | Execute the 'Place' command+    CPlace+  | -- | Execute the 'Give' command+    CGive+  | -- | Execute the 'Install' command+    CInstall+  | -- | Execute the 'Make' command+    CMake+  | -- | Execute the 'Count' command+    CCount+  | -- | Execute the 'Build' command+    CBuild+  | -- | Execute the 'Salvage' command+    CSalvage+  | -- | Execute the 'Drill' command+    CDrill+  | -- | Execute the 'Whereami' command+    CSenseloc+  | -- | Execute the 'Blocked' command+    CSensefront+  | -- | Execute the 'Ishere' command+    CSensehere+  | -- | Execute the 'Scan' command+    CScan+  | -- | Execute the 'Random' command+    CRandom+  | -- | Execute the 'Appear' command+    CAppear+  | -- | Execute the 'Create' command+    CCreate+  | -- | Execute the 'Listen' command and passively log messages if also has 'CLog'+    CListen+  | -- | Execute the 'Log' command+    CLog+  | -- | Manipulate text values+    CText+  | -- | Don't drown in liquid+    CFloat+  | -- | Evaluate conditional expressions+    CCond+  | -- | Negate boolean value+    CNegation+  | -- | Evaluate comparison operations+    CCompare+  | -- | Use cardinal direction constants.+    COrient+  | -- | Evaluate arithmetic operations+    CArith+  | -- | Store and look up definitions in an environment+    CEnv+  | -- | Interpret lambda abstractions+    CLambda+  | -- | Enable recursive definitions+    CRecursion+  | -- | Execute the 'Reprogram' command+    CReprogram+  | -- | Capability to introspect and see its own name+    CWhoami+  | -- | Capability to set its own name+    CSetname+  | -- | Capability to move unrestricted to any place+    CTeleport+  | -- | Capability to run commands atomically+    CAtomic+  | -- | Capability to execute swap (grab and place atomically at the same time).+    CSwap+  | -- | Capabiltiy to do time-related things, like `wait` and get the+    --   current time.+    CTime+  | -- | Capability to execute `try`.+    CTry+  | -- | Capability for working with sum types.+    CSum+  | -- | Capability for working with product types.+    CProd+  | -- | God-like capabilities.  For e.g. commands intended only for+    --   checking challenge mode win conditions, and not for use by+    --   players.+    CGod+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data, FromJSONKey, ToJSONKey)++capabilityName :: Capability -> Text+capabilityName = from @String . map toLower . drop 1 . show++instance ToJSON Capability where+  toJSON = String . capabilityName++instance FromJSON Capability where+  parseJSON = withText "Capability" tryRead+   where+    tryRead :: Text -> Parser Capability+    tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of+      Just c -> return c+      Nothing -> fail $ "Unknown capability " ++ from t++-- | Capabilities needed to evaluate or execute a constant.+constCaps :: Const -> Maybe Capability+constCaps = \case+  -- ----------------------------------------------------------------+  -- Some built-in constants that don't require any special capability.+  Noop -> Nothing+  AppF -> Nothing+  Force -> Nothing+  Return -> Nothing+  Parent -> Nothing+  Base -> Nothing+  Setname -> Nothing+  Undefined -> Nothing+  Fail -> Nothing+  Has -> Nothing+  Installed -> Nothing+  -- speaking is natural to robots (unlike listening)+  Say -> Nothing+  -- TODO: #495+  --   the require command will be inlined once the Issue is fixed+  --   so the capabilities of the run commands will be checked instead+  Run -> Nothing+  -- ----------------------------------------------------------------+  -- Some straightforward ones.+  Listen -> Just CListen+  Log -> Just CLog+  Selfdestruct -> Just CSelfdestruct+  Move -> Just CMove+  Turn -> Just CTurn+  Grab -> Just CGrab+  Harvest -> Just CHarvest+  Place -> Just CPlace+  Give -> Just CGive+  Install -> Just CInstall+  Make -> Just CMake+  Count -> Just CCount+  If -> Just CCond+  Blocked -> Just CSensefront+  Scan -> Just CScan+  Ishere -> Just CSensehere+  Upload -> Just CScan+  Build -> Just CBuild+  Salvage -> Just CSalvage+  Reprogram -> Just CReprogram+  Drill -> Just CDrill+  Neg -> Just CArith+  Add -> Just CArith+  Sub -> Just CArith+  Mul -> Just CArith+  Div -> Just CArith+  Exp -> Just CArith+  Whoami -> Just CWhoami+  Self -> Just CWhoami+  Swap -> Just CSwap+  Atomic -> Just CAtomic+  Time -> Just CTime+  Wait -> Just CTime+  -- ----------------------------------------------------------------+  -- Text operations+  Format -> Just CText+  Concat -> Just CText+  Split -> Just CText+  Chars -> Just CText+  -- ----------------------------------------------------------------+  -- Some God-like abilities.+  As -> Just CGod+  RobotNamed -> Just CGod+  RobotNumbered -> Just CGod+  Create -> Just CGod+  -- ----------------------------------------------------------------+  -- arithmetic+  Eq -> Just CCompare+  Neq -> Just CCompare+  Lt -> Just CCompare+  Gt -> Just CCompare+  Leq -> Just CCompare+  Geq -> Just CCompare+  -- ----------------------------------------------------------------+  -- boolean logic+  And -> Just CCond+  Or -> Just CCond+  Not -> Just CNegation+  -- ----------------------------------------------------------------+  -- exceptions+  Try -> Just CTry+  -- ----------------------------------------------------------------+  -- type-level arithmetic+  Inl -> Just CSum+  Inr -> Just CSum+  Case -> Just CSum+  Fst -> Just CProd+  Snd -> Just CProd+  -- XXX pair syntax should require CProd too++  -- ----------------------------------------------------------------+  -- Some additional straightforward ones, which however currently+  -- cannot be used in classic mode since there is no craftable item+  -- which conveys their capability. TODO: #26+  Teleport -> Just CTeleport -- Some space-time machine like Tardis?+  Appear -> Just CAppear -- paint?+  Whereami -> Just CSenseloc -- GPS?+  Random -> Just CRandom -- randomness device (with bitcoins)?+  -- ----------------------------------------------------------------+  -- Some more constants which *ought* to have their own capability but+  -- currently don't. TODO: #26+  View -> Nothing -- XXX this should also require something.+  Knows -> Nothing
+ src/Swarm/Language/Context.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# 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+-- types, values, or capability sets) used throughout the codebase.+module Swarm.Language.Context where++import Control.Lens.Empty (AsEmpty (..))+import Control.Lens.Prism (prism)+import Control.Monad.Reader (MonadReader, local)+import Data.Aeson (FromJSON, ToJSON)+import Data.Data (Data)+import Data.Map (Map)+import Data.Map qualified as M+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude hiding (lookup)++-- | We use 'Text' values to represent variables.+type Var = Text++-- | A context is a mapping from variable names to things.+newtype Ctx t = Ctx {unCtx :: Map Var t}+  deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON)++-- | The semigroup operation for contexts is /right/-biased union.+instance Semigroup (Ctx t) where+  (<>) = union++instance Monoid (Ctx t) where+  mempty = empty+  mappend = (<>)++instance AsEmpty (Ctx t) where+  _Empty = prism (const empty) isEmpty+   where+    isEmpty (Ctx c)+      | M.null c = Right ()+      | otherwise = Left (Ctx c)++-- | The empty context.+empty :: Ctx t+empty = Ctx M.empty++-- | A singleton context.+singleton :: Var -> t -> Ctx t+singleton x t = Ctx (M.singleton x t)++-- | Look up a variable in a context.+lookup :: Var -> Ctx t -> Maybe t+lookup x (Ctx c) = M.lookup x c++-- | Delete a variable from a context.+delete :: Var -> Ctx t -> Ctx t+delete x (Ctx c) = Ctx (M.delete x c)++-- | Get the list of key-value associations from a context.+assocs :: Ctx t -> [(Var, t)]+assocs = M.assocs . unCtx++-- | Add a key-value binding to a context (overwriting the old one if+--   the key is already present).+addBinding :: Var -> t -> Ctx t -> Ctx t+addBinding x t (Ctx c) = Ctx (M.insert x t c)++-- | /Right/-biased union of contexts.+union :: Ctx t -> Ctx t -> Ctx t+union (Ctx c1) (Ctx c2) = Ctx (c2 `M.union` c1)++-- | Locally extend the context with an additional binding.+withBinding :: MonadReader (Ctx t) m => Var -> t -> m a -> m a+withBinding x ty = local (addBinding x ty)++-- | Locally extend the context with an additional context of+--   bindings.+withBindings :: MonadReader (Ctx t) m => Ctx t -> m a -> m a+withBindings ctx = local (`union` ctx)
+ src/Swarm/Language/Elaborate.hs view
@@ -0,0 +1,47 @@+-- |+-- Module      :  Swarm.Language.Elaborate+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Term elaboration which happens after type checking.+module Swarm.Language.Elaborate where++import Control.Lens (transform, (%~))+import Swarm.Language.Syntax++-- | Perform some elaboration / rewriting on a fully type-annotated+--   term, given its top-level type.  This currently performs such+--   operations as rewriting @if@ expressions and recursive let+--   expressions to use laziness appropriately.  In theory it could+--   also perform rewriting for overloaded constants depending on the+--   actual type they are used at, but currently that sort of thing+--   tends to make type inference fall over.+elaborate :: Term -> Term+elaborate =+  -- Wrap all *free* variables in 'Force'.  Free variables must be+  -- referring to a previous definition, which are all wrapped in+  -- 'TDelay'.+  (fvT %~ TApp (TConst Force))+    -- Now do additional rewriting on all subterms.+    . transform rewrite+ where+  -- For recursive let bindings, rewrite any occurrences of x to+  -- (force x).  When interpreting t1, we will put a binding (x |->+  -- delay t1) in the context.+  rewrite (TLet True x ty t1 t2) = TLet True x ty (wrapForce x t1) (wrapForce x t2)+  -- Rewrite any recursive occurrences of x inside t1 to (force x).+  -- When a TDef is encountered at runtime its body will immediately+  -- be wrapped in a VDelay. However, to make this work we also need+  -- to wrap all free variables in any term with 'force' --- since+  -- any such variables must in fact refer to things previously+  -- bound by 'def'.+  rewrite (TDef True x ty t1) = TDef True x ty (mapFree1 x (TApp (TConst Force)) t1)+  -- Rewrite @f $ x@ to @f x@.+  rewrite (TApp (TApp (TConst AppF) r) l) = TApp r l+  -- Leave any other subterms alone.+  rewrite t = t++wrapForce :: Var -> Term -> Term+wrapForce x = mapFree1 x (TApp (TConst Force))
+ src/Swarm/Language/LSP.hs view
@@ -0,0 +1,115 @@+{-# 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.+-- See the docs/EDITORS.md to learn how to use it.+module Swarm.Language.LSP where++import Control.Lens (to, (^.))+import Control.Monad (void)+import Control.Monad.IO.Class+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.IO qualified as Text+import Language.LSP.Diagnostics+import Language.LSP.Server+import Language.LSP.Types qualified as J+import Language.LSP.Types.Lens qualified as J+import Language.LSP.VFS+import Swarm.Language.Parse+import Swarm.Language.Pipeline+import System.IO (stderr)+import Witch++lspMain :: IO ()+lspMain =+  void $+    runServer $+      ServerDefinition+        { onConfigurationChange = const $ const $ Right ()+        , defaultConfig = ()+        , doInitialize = \env _req -> pure $ Right env+        , staticHandlers = handlers+        , interpretHandler = \env -> Iso (runLspT env) liftIO+        , options =+            defaultOptions+              { -- set sync options to get DidSave event+                textDocumentSync =+                  Just+                    ( J.TextDocumentSyncOptions+                        (Just True)+                        (Just syncKind)+                        (Just False)+                        (Just False)+                        (Just $ J.InR $ J.SaveOptions $ Just True)+                    )+              }+        }+ where+  -- Using SyncFull seems to handle the debounce for us.+  -- The alternative is to use SyncIncremental, but then then+  -- handler is called for each key-stroke.+  syncKind = J.TdSyncFull++debug :: MonadIO m => Text -> m ()+debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg++validateSwarmCode :: J.NormalizedUri -> J.TextDocumentVersion -> Text -> LspM () ()+validateSwarmCode doc version content = do+  -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")"+  flushDiagnosticsBySource 0 (Just "swarm-lsp")+  let err = case readTerm' content of+        Right Nothing -> Nothing+        Right (Just term) -> case processParsedTerm' mempty mempty term of+          Right _ -> Nothing+          Left e -> Just $ showTypeErrorPos content e+        Left e -> Just $ showErrorPos e+  -- debug $ "-> " <> from (show err)+  case err of+    Nothing -> pure ()+    Just e -> sendDiagnostic e+ where+  sendDiagnostic :: ((Int, Int), (Int, Int), Text) -> LspM () ()+  sendDiagnostic ((startLine, startCol), (endLine, endCol), msg) = do+    let diags =+          [ J.Diagnostic+              ( J.Range+                  (J.Position (fromIntegral startLine) (fromIntegral startCol))+                  (J.Position (fromIntegral endLine) (fromIntegral endCol))+              )+              (Just J.DsWarning) -- severity+              Nothing -- code+              (Just "swarm-lsp") -- source+              msg+              Nothing -- tags+              (Just (J.List []))+          ]+    publishDiagnostics 1 doc version (partitionBySource diags)++handlers :: Handlers (LspM ())+handlers =+  mconcat+    [ notificationHandler J.SInitialized $ \_not -> do+        debug "Initialized"+    , notificationHandler J.STextDocumentDidSave $ \msg -> do+        let doc = msg ^. J.params . J.textDocument . J.uri+            content = fromMaybe "?" $ msg ^. J.params . J.text+        validateSwarmCode (J.toNormalizedUri doc) Nothing content+    , notificationHandler J.STextDocumentDidOpen $ \msg -> do+        let doc = msg ^. J.params . J.textDocument . J.uri+            content = msg ^. J.params . J.textDocument . J.text+        validateSwarmCode (J.toNormalizedUri doc) Nothing content+    , notificationHandler J.STextDocumentDidChange $ \msg -> do+        let doc = msg ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri+        mdoc <- getVirtualFile doc+        case mdoc of+          Just vf@(VirtualFile _ version _rope) -> do+            validateSwarmCode doc (Just $ fromIntegral version) (virtualFileText vf)+          _ -> debug $ "No virtual file found for: " <> from (show msg)+    ]
+ src/Swarm/Language/Parse.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- 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+-- use this directly, unless there is a good reason to parse a term+-- without also type checking it; use+-- 'Swarm.Language.Pipeline.processTerm' instead, which parses,+-- typechecks, elaborates, and capability checks a term all at once.+module Swarm.Language.Parse (+  -- * Reserved words+  reservedWords,++  -- * Parsers+  Parser,+  parsePolytype,+  parseType,+  parseTerm,+  binOps,+  unOps,++  -- * Utility functions+  runParser,+  runParserTH,+  readTerm,+  readTerm',+  showShortError,+  showErrorPos,+  getLocRange,+) where++import Control.Monad.Combinators.Expr+import Control.Monad.Reader+import Data.Bifunctor+import Data.Foldable (asum)+import Data.List (nub)+import Data.List.NonEmpty qualified (head)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Set qualified as S+import Data.Set.Lens (setOf)+import Data.Text (Text, index, toLower)+import Data.Text qualified as T+import Data.Void+import Swarm.Language.Syntax+import Swarm.Language.Types+import Text.Megaparsec hiding (runParser)+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L+import Text.Megaparsec.Pos qualified as Pos+import Witch++-- Imports for doctests (cabal-docspec needs this)++-- $setup+-- >>> import qualified Data.Map.Strict as Map++-- | When parsing a term using a quasiquoter (i.e. something in the+--   Swarm source code that will be parsed at compile time), we want+--   to allow antiquoting, i.e. writing something like $x to refer to+--   an existing Haskell variable.  But when parsing a term entered by+--   the user at the REPL, we do not want to allow this syntax.+data Antiquoting = AllowAntiquoting | DisallowAntiquoting+  deriving (Eq, Ord, Show)++type Parser = ReaderT Antiquoting (Parsec Void Text)++type ParserError = ParseErrorBundle Text Void++--------------------------------------------------+-- Lexer++-- | List of reserved words that cannot be used as variable names.+reservedWords :: [Text]+reservedWords =+  map (syntax . constInfo) (filter isUserFunc allConst)+    ++ map (dirSyntax . dirInfo) allDirs+    ++ [ "unit"+       , "int"+       , "text"+       , "dir"+       , "bool"+       , "robot"+       , "cmd"+       , "delay"+       , "let"+       , "def"+       , "end"+       , "in"+       , "true"+       , "false"+       , "forall"+       , "require"+       ]++-- | Skip spaces and comments.+sc :: Parser ()+sc =+  L.space+    space1+    (L.skipLineComment "//")+    (L.skipBlockComment "/*" "*/")++-- | In general, we follow the convention that every token parser+--   assumes no leading whitespace and consumes all trailing+--   whitespace.  Concretely, we achieve this by wrapping every token+--   parser using 'lexeme'.+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++-- | A lexeme consisting of a literal string.+symbol :: Text -> Parser Text+symbol = L.symbol sc++-- | Parse a case-insensitive reserved word, making sure it is not a+--   prefix of a longer variable name, and allowing the parser to+--   backtrack if it fails.+reserved :: Text -> Parser ()+reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_')++-- | Parse an identifier, i.e. any non-reserved string containing+--   alphanumeric characters and underscores and not starting with a+--   number.+identifier :: Parser Text+identifier = (lexeme . try) (p >>= check) <?> "variable name"+ where+  p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'')+  check s+    | toLower t `elem` reservedWords =+      fail $ "reserved word '" ++ s ++ "' 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+textLiteral = into <$> lexeme (char '"' >> manyTill L.charLiteral (char '"'))++-- | Parse a positive integer literal token, in decimal, binary,+--   octal, or hexadecimal notation.  Note that negation is handled as+--   a separate operator.+integer :: Parser Integer+integer =+  label "integer literal" $+    lexeme $ do+      n <-+        string "0b" *> L.binary+          <|> string "0o" *> L.octal+          <|> string "0x" *> L.hexadecimal+          <|> L.decimal+      notFollowedBy alphaNumChar+      return n++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++--------------------------------------------------+-- Parser++-- | Parse a Swarm language polytype, which starts with an optional+--   quanitifation (@forall@ followed by one or more variables and a+--   period) followed by a type.  Note that anything accepted by+--   'parseType' is also accepted by 'parsePolytype'.+parsePolytype :: Parser Polytype+parsePolytype =+  join $+    quantify+      <$> (fromMaybe [] <$> optional (reserved "forall" *> some identifier <* symbol "."))+      <*> parseType+ where+  quantify :: [Var] -> Type -> Parser Polytype+  quantify xs ty+    -- Iplicitly quantify over free type variables if the user didn't write a forall+    | null xs = return $ Forall (S.toList free) ty+    -- Otherwise, require all variables to be explicitly quantified+    | S.null free = return $ Forall xs ty+    | otherwise =+      fail $+        unlines+          [ "  Type contains free variable(s): " ++ unwords (map from (S.toList free))+          , "  Try adding them to the 'forall'."+          ]+   where+    free = tyVars ty `S.difference` S.fromList xs++-- | Parse a Swarm language (mono)type.+parseType :: Parser Type+parseType = makeExprParser parseTypeAtom table+ where+  table =+    [ [InfixR ((:*:) <$ symbol "*")]+    , [InfixR ((:+:) <$ symbol "+")]+    , [InfixR ((:->:) <$ symbol "->")]+    ]++parseTypeAtom :: Parser Type+parseTypeAtom =+  TyUnit <$ reserved "unit"+    <|> TyVar <$> identifier+    <|> TyInt <$ reserved "int"+    <|> TyText <$ reserved "text"+    <|> TyDir <$ reserved "dir"+    <|> TyBool <$ reserved "bool"+    <|> TyRobot <$ reserved "robot"+    <|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)+    <|> TyDelay <$> braces parseType+    <|> parens parseType++parseDirection :: Parser Direction+parseDirection = asum (map alternative allDirs) <?> "direction constant"+ where+  alternative d = d <$ (reserved . dirSyntax . dirInfo) d++-- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@)+parseConst :: Parser Const+parseConst = asum (map alternative consts) <?> "built-in user function"+ where+  consts = filter isUserFunc allConst+  alternative c = c <$ reserved (syntax $ constInfo c)++-- | Add 'Location' to a parser+parseLocG :: Parser a -> Parser (Location, a)+parseLocG pa = do+  start <- getOffset+  a <- pa+  end <- getOffset+  pure (Location start end, a)++-- | Add 'Location' to a 'Term' parser+parseLoc :: Parser Term -> Parser Syntax+parseLoc pterm = uncurry Syntax <$> parseLocG pterm++parseTermAtom :: Parser Syntax+parseTermAtom =+  parseLoc+    ( TUnit <$ symbol "()"+        <|> TConst <$> parseConst+        <|> TVar <$> identifier+        <|> TDir <$> parseDirection+        <|> TInt <$> integer+        <|> TText <$> textLiteral+        <|> TBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false"))+        <|> reserved "require"+          *> ( ( TRequireDevice+                  <$> (textLiteral <?> "device name in double quotes")+               )+                <|> ( TRequire <$> (fromIntegral <$> integer)+                        <*> (textLiteral <?> "entity name in double quotes")+                    )+             )+        <|> SLam <$> (symbol "\\" *> identifier)+          <*> optional (symbol ":" *> parseType)+          <*> (symbol "." *> parseTerm)+        <|> sLet <$> (reserved "let" *> identifier)+          <*> optional (symbol ":" *> parsePolytype)+          <*> (symbol "=" *> parseTerm)+          <*> (reserved "in" *> parseTerm)+        <|> sDef <$> (reserved "def" *> identifier)+          <*> optional (symbol ":" *> parsePolytype)+          <*> (symbol "=" *> parseTerm <* reserved "end")+        <|> parens (mkTuple <$> (parseTerm `sepBy` symbol ","))+    )+    -- Potential syntax for explicitly requesting memoized delay.+    -- Perhaps we will not need this in the end; see the discussion at+    -- https://github.com/swarm-game/swarm/issues/150 .+    -- <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{{" *> symbol "}}"))+    -- <|> parseLoc (SDelay MemoizedDelay <$> dbraces parseTerm)++    <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{" *> symbol "}"))+    <|> parseLoc (SDelay SimpleDelay <$> braces parseTerm)+    <|> parseLoc (ask >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation)++mkTuple :: [Syntax] -> Term+mkTuple [] = TUnit+mkTuple [STerm x] = x+mkTuple (x : xs) = SPair x (STerm (mkTuple xs))++-- | Construct an 'SLet', automatically filling in the Boolean field+--   indicating whether it is recursive.+sLet :: Var -> Maybe Polytype -> Syntax -> Syntax -> Term+sLet x ty t1 = SLet (x `S.member` setOf fv (sTerm t1)) x ty t1++-- | Construct an 'SDef', automatically filling in the Boolean field+--   indicating whether it is recursive.+sDef :: Var -> Maybe Polytype -> Syntax -> Term+sDef x ty t = SDef (x `S.member` setOf fv (sTerm t)) x ty t++parseAntiquotation :: Parser Term+parseAntiquotation =+  TAntiText <$> (lexeme . try) (symbol "$str:" *> identifier)+    <|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> identifier)++-- | Parse a Swarm language term.+parseTerm :: Parser Syntax+parseTerm = sepEndBy1 parseStmt (symbol ";") >>= mkBindChain++mkBindChain :: [Stmt] -> Parser Syntax+mkBindChain stmts = case last stmts of+  Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Return) (TVar x))) stmts+  BareTerm t -> return $ foldr mkBind t (init stmts)+ where+  mkBind (BareTerm t1) t2 = loc t1 t2 $ SBind Nothing t1 t2+  mkBind (Binder x t1) t2 = loc t1 t2 $ SBind (Just x) t1 t2+  loc a b = Syntax $ sLoc a <> sLoc b++data Stmt+  = BareTerm Syntax+  | Binder Text Syntax+  deriving (Show)++parseStmt :: Parser Stmt+parseStmt =+  mkStmt <$> optional (try (identifier <* symbol "<-")) <*> parseExpr++mkStmt :: Maybe Text -> Syntax -> Stmt+mkStmt Nothing = BareTerm+mkStmt (Just x) = Binder x++-- | When semicolons are missing between definitions, for example:+--     def a = 1 end def b = 2 end def c = 3 end+--   The makeExprParser produces:+--     App (App (TDef a) (TDef b)) (TDef x)+--   This function fix that by converting the Apps into Binds, so that it results in:+--     Bind a (Bind b (Bind c))+fixDefMissingSemis :: Syntax -> Syntax+fixDefMissingSemis term =+  case nestedDefs term [] of+    [] -> term+    defs -> foldr1 mkBind defs+ where+  mkBind t1 t2 = Syntax (sLoc t1 <> sLoc t2) $ SBind Nothing t1 t2+  nestedDefs term' acc = case term' of+    def@(Syntax _ SDef {}) -> def : acc+    (Syntax _ (SApp nestedTerm def@(Syntax _ SDef {}))) -> nestedDefs nestedTerm (def : acc)+    -- Otherwise returns an empty list to keep the term unchanged+    _ -> []++parseExpr :: Parser Syntax+parseExpr = fixDefMissingSemis <$> makeExprParser parseTermAtom table+ where+  table = snd <$> Map.toDescList tableMap+  tableMap =+    Map.unionsWith+      (++)+      [ Map.singleton 9 [InfixL (exprLoc2 $ SApp <$ string "")]+      , binOps+      , unOps+      ]++  -- add location for ExprParser by combining all+  exprLoc2 :: Parser (Syntax -> Syntax -> Term) -> Parser (Syntax -> Syntax -> Syntax)+  exprLoc2 p = do+    (l, f) <- parseLocG p+    pure $ \s1 s2 -> Syntax (l <> sLoc s1 <> sLoc s2) $ f s1 s2++-- | Precedences and parsers of binary operators.+--+-- >>> Map.map length binOps+-- fromList [(0,1),(2,1),(3,1),(4,6),(6,3),(7,2),(8,1)]+binOps :: Map.Map Int [Operator Parser Syntax]+binOps = Map.unionsWith (++) $ mapMaybe binOpToTuple allConst+ where+  binOpToTuple c = do+    let ci = constInfo c+    ConstMBinOp assoc <- pure (constMeta ci)+    let assI = case assoc of+          L -> InfixL+          N -> InfixN+          R -> InfixR+    pure $+      Map.singleton+        (fixity ci)+        [assI (mkOp c <$ operatorString (syntax ci))]++-- | Precedences and parsers of unary operators (currently only 'Neg').+--+-- >>> Map.map length unOps+-- fromList [(7,1)]+unOps :: Map.Map Int [Operator Parser Syntax]+unOps = Map.unionsWith (++) $ mapMaybe unOpToTuple allConst+ where+  unOpToTuple c = do+    let ci = constInfo c+    ConstMUnOp assoc <- pure (constMeta ci)+    let assI = case assoc of+          P -> Prefix+          S -> Postfix+    pure $+      Map.singleton+        (fixity ci)+        [assI (exprLoc1 $ SApp (noLoc $ TConst c) <$ operatorString (syntax ci))]++  -- combine location for ExprParser+  exprLoc1 :: Parser (Syntax -> Term) -> Parser (Syntax -> Syntax)+  exprLoc1 p = do+    (l, f) <- parseLocG p+    pure $ \s -> Syntax (l <> sLoc s) $ f s++operatorString :: Text -> Parser Text+operatorString n = (lexeme . try) (string n <* notFollowedBy operatorSymbol)++operatorSymbol :: Parser Text+operatorSymbol = T.singleton <$> oneOf opChars+ where+  isOp = \case { ConstMFunc {} -> False; _ -> True } . constMeta+  opChars = nub . concatMap (from . syntax) . filter isOp $ map constInfo allConst++--------------------------------------------------+-- Utilities++-- | Run a parser on some input text, returning either the result or a+--   pretty-printed parse error message.+runParser :: Parser a -> Text -> Either Text a+runParser p t = first (from . errorBundlePretty) (parse (runReaderT p DisallowAntiquoting) "" t)++-- | A utility for running a parser in an arbitrary 'MonadFail' (which+--   is going to be the TemplateHaskell 'Q' monad --- see+--   "Swarm.Language.Parse.QQ"), with a specified source position.+runParserTH :: (Monad m, MonadFail m) => (String, Int, Int) -> Parser a -> String -> m a+runParserTH (file, line, col) p s =+  case snd (runParser' (runReaderT (fully p) AllowAntiquoting) initState) of+    Left err -> fail $ errorBundlePretty err+    Right e -> return e+ where+  -- This is annoying --- megaparsec does not export its function to+  -- construct an initial parser state, so we can't just use that+  -- and then change the one field we need to be different (the+  -- pstateSourcePos). We have to copy-paste the whole thing.+  initState :: State Text Void+  initState =+    State+      { stateInput = from s+      , stateOffset = 0+      , statePosState =+          PosState+            { pstateInput = from s+            , pstateOffset = 0+            , pstateSourcePos = SourcePos file (mkPos line) (mkPos col)+            , pstateTabWidth = defaultTabWidth+            , pstateLinePrefix = ""+            }+      , stateParseErrors = []+      }++-- | 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)++-- | 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) ""++-- | A utility for converting a ParserError into a one line message:+--   <line-nr>: <error-msg>+showShortError :: ParserError -> String+showShortError pe = show (line + 1) <> ": " <> from msg+ where+  ((line, _), _, msg) = showErrorPos pe++-- | A utility for converting a ParseError into a range and error message.+showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text)+showErrorPos (ParseErrorBundle errs sourcePS) = (minusOne start, minusOne end, from msg)+ where+  -- convert megaparsec source pos to starts at 0+  minusOne (x, y) = (x - 1, y - 1)++  -- get the first error position (ps) and line content (str)+  err = Data.List.NonEmpty.head errs+  offset = case err of+    TrivialError x _ _ -> x+    FancyError x _ -> x+  (str, ps) = reachOffset offset sourcePS+  msg = parseErrorTextPretty err++  -- extract the error starting position+  start@(line, col) = getLineCol ps++  -- compute the ending position based on the word at starting position+  wordlength = case break (== ' ') . drop col <$> str of+    Just (word, _) -> length word + 1+    _ -> 0+  end = (line, col + wordlength)++getLineCol :: PosState a -> (Int, Int)+getLineCol ps = (line, col)+ where+  line = unPos $ sourceLine $ pstateSourcePos ps+  col = unPos $ sourceColumn $ pstateSourcePos ps++-- | A utility for converting a Location into a range+getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int))+getLocRange code (locStart, locEnd) = (start, end)+ where+  start = getLocPos locStart+  end = getLocPos (dropWhiteSpace locEnd)++  -- remove trailing whitespace that got included by the lexer+  dropWhiteSpace offset+    | isWhiteSpace offset = dropWhiteSpace (offset - 1)+    | otherwise = offset+  isWhiteSpace offset =+    -- Megaparsec offset needs to be (-1) to start at 0+    Data.Text.index code (offset - 1) `elem` [' ', '\n', '\r', '\t']++  -- using megaparsec offset facility, compute the line/col+  getLocPos offset =+    let sourcePS =+          PosState+            { pstateInput = code+            , pstateOffset = 0+            , pstateSourcePos = Pos.initialPos ""+            , pstateTabWidth = Pos.defaultTabWidth+            , pstateLinePrefix = ""+            }+        (_, ps) = reachOffset offset sourcePS+     in getLineCol ps
+ src/Swarm/Language/Parse/QQ.hs view
@@ -0,0 +1,43 @@+-- |+-- Module      :  Swarm.Language.Parse.QQ+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- A quasiquoter for Swarm polytypes.+module Swarm.Language.Parse.QQ (tyQ) where++import Data.Generics+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Quote+import Swarm.Language.Parse+import Swarm.Util (liftText)++------------------------------------------------------------+-- Quasiquoters+------------------------------------------------------------++-- | A quasiquoter for Swarm polytypes, so we can conveniently write them+--   down using concrete syntax and have them parsed into abstract+--   syntax at compile time.  This is used, for example, in writing down+--   the concrete types of constants (see "Swarm.Language.Typecheck").+tyQ :: QuasiQuoter+tyQ =+  QuasiQuoter+    { quoteExp = quoteTypeExp+    , quotePat = error "quotePat  not implemented for polytypes"+    , quoteType = error "quoteType not implemented for polytypes"+    , quoteDec = error "quoteDec  not implemented for polytypes"+    }++quoteTypeExp :: String -> TH.ExpQ+quoteTypeExp s = do+  loc <- TH.location+  let pos =+        ( TH.loc_filename loc+        , fst (TH.loc_start loc)+        , snd (TH.loc_start loc)+        )+  parsed <- runParserTH pos parsePolytype s+  dataToExpQ (fmap liftText . cast) parsed
+ src/Swarm/Language/Pipeline.hs view
@@ -0,0 +1,109 @@+{-# 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+-- language processing pipeline: parsing, type checking, capability+-- checking, and elaboration.  If you want to simply turn some raw+-- text representing a Swarm program into something useful, this is+-- probably the module you want.+module Swarm.Language.Pipeline (+  ProcessedTerm (..),+  processTerm,+  processParsedTerm,+  processTerm',+  processParsedTerm',+  showTypeErrorPos,+) where++import Data.Bifunctor (first)+import Data.Data (Data)+import Data.Text (Text)+import Data.Yaml as Y+import GHC.Generics (Generic)+import Swarm.Language.Context+import Swarm.Language.Elaborate+import Swarm.Language.Parse+import Swarm.Language.Pretty+import Swarm.Language.Requirement+import Swarm.Language.Syntax+import Swarm.Language.Typecheck+import Swarm.Language.Types+import Witch++-- | A record containing the results of the language processing+--   pipeline.  Put a 'Term' in, and get one of these out.+data ProcessedTerm+  = ProcessedTerm+      Term+      -- ^ The elaborated term+      TModule+      -- ^ The type of the term (and of any embedded definitions)+      Requirements+      -- ^ Requirements of the term+      ReqCtx+      -- ^ Capability context for any definitions embedded in the term+  deriving (Data, Show, Eq, Generic)++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++instance ToJSON ProcessedTerm where+  toJSON (ProcessedTerm t _ _ _) = String $ prettyText t++-- | Given a 'Text' value representing a Swarm program,+--+--   1. Parse it (see "Swarm.Language.Parse")+--   2. Typecheck it (see "Swarm.Language.Typecheck")+--   3. Elaborate it (see "Swarm.Language.Elaborate")+--   4. Check what capabilities it requires (see "Swarm.Language.Capability")+--+--   Return either the end result (or @Nothing@ if the input was only+--   whitespace) or a pretty-printed error message.+processTerm :: Text -> Either Text (Maybe ProcessedTerm)+processTerm = processTerm' empty empty++-- | Like 'processTerm', but use a term that has already been parsed.+processParsedTerm :: Syntax -> Either TypeErr 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 getTypeErrLocation te of+    Just (Location 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 getTypeErrLocation te of+    Just (Location s e) -> getLocRange code (s, e)+    _anyOtherLoc -> ((1, 1), (65535, 65535)) -- unknown loc spans the whole document+  msg = prettyText te++-- | Like 'processTerm'', but use a term that has already been parsed.+processParsedTerm' :: TCtx -> ReqCtx -> Syntax -> Either TypeErr ProcessedTerm+processParsedTerm' ctx capCtx t = do+  ty <- inferTop ctx t+  let (caps, capCtx') = requirements capCtx (sTerm t)+  return $ ProcessedTerm (elaborate (sTerm t)) ty caps capCtx'
+ src/Swarm/Language/Pipeline/QQ.hs view
@@ -0,0 +1,60 @@+-- |+-- Module      :  Swarm.Language.Pipeline.QQ+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- A quasiquoter for Swarm terms.+module Swarm.Language.Pipeline.QQ (tmQ) where++import Data.Generics+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Quote+import Swarm.Language.Parse+import Swarm.Language.Pipeline+import Swarm.Language.Pretty (prettyText)+import Swarm.Language.Syntax+import Swarm.Util (liftText)+import Witch (from)++-- | A quasiquoter for Swarm language terms, so we can conveniently+--   write them down using concrete syntax and have them parsed into+--   abstract syntax at compile time.  The quasiquoter actually runs+--   the entire pipeline on them (parsing, typechecking, elaborating),+--   so a quasiquoted Swarm program with a parse error or a type error+--   will fail at Haskell compile time.  This is useful for creating+--   system robot programs (for example, see+--   'Swarm.Game.Step.seedProgram').+tmQ :: QuasiQuoter+tmQ =+  QuasiQuoter+    { quoteExp = quoteTermExp+    , quotePat = error "quotePat  not implemented for terms"+    , quoteType = error "quoteType not implemented for terms"+    , quoteDec = error "quoteDec  not implemented for terms"+    }++quoteTermExp :: String -> TH.ExpQ+quoteTermExp s = do+  loc <- TH.location+  let pos =+        ( TH.loc_filename loc+        , fst (TH.loc_start loc)+        , snd (TH.loc_start loc)+        )+  parsed <- runParserTH pos parseTerm s+  case processParsedTerm parsed of+    Left errMsg -> fail $ from $ prettyText errMsg+    Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm++antiTermExp :: Term -> Maybe TH.ExpQ+antiTermExp (TAntiText v) =+  Just $ TH.appE (TH.conE (TH.mkName "TText")) (TH.varE (TH.mkName (from v)))+antiTermExp (TAntiInt v) =+  Just $ TH.appE (TH.conE (TH.mkName "TInt")) (TH.varE (TH.mkName (from v)))+antiTermExp _ = Nothing++-- At the moment, only antiquotation of literal text and ints are+-- supported, because that's what we need for the seedProgram.  But+-- we can easily add more in the future.
+ src/Swarm/Language/Pretty.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UndecidableInstances #-}+{-# 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.+module Swarm.Language.Pretty where++import Control.Lens.Combinators (pattern Empty)+import Control.Unification+import Control.Unification.IntVar+import Data.Bool (bool)+import Data.Functor.Fixedpoint (Fix, unFix)+import Data.String (fromString)+import Data.Text (Text)+import Data.Text qualified as T+import Prettyprinter+import Prettyprinter.Render.String qualified as RS+import Prettyprinter.Render.Text qualified as RT+import Swarm.Language.Capability+import Swarm.Language.Context+import Swarm.Language.Syntax+import Swarm.Language.Typecheck+import Swarm.Language.Types+import Witch++-- | Type class for things that can be pretty-printed, given a+--   precedence level of their context.+class PrettyPrec a where+  prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired++-- | Pretty-print a thing, with a context precedence level of zero.+ppr :: PrettyPrec a => a -> Doc ann+ppr = prettyPrec 0++-- | Pretty-print something and render it as @Text@.+prettyText :: PrettyPrec a => a -> Text+prettyText = RT.renderStrict . layoutPretty defaultLayoutOptions . ppr++-- | Pretty-print something and render it as a @String@.+prettyString :: PrettyPrec a => a -> String+prettyString = RS.renderString . layoutPretty defaultLayoutOptions . ppr++-- | Optionally surround a document with parentheses depending on the+--   @Bool@ argument.+pparens :: Bool -> Doc ann -> Doc ann+pparens True = parens+pparens False = id++instance PrettyPrec BaseTy where+  prettyPrec _ BUnit = "unit"+  prettyPrec _ BInt = "int"+  prettyPrec _ BDir = "dir"+  prettyPrec _ BText = "text"+  prettyPrec _ BBool = "bool"+  prettyPrec _ BRobot = "robot"++instance PrettyPrec IntVar where+  prettyPrec _ = pretty . mkVarName "u"++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+  prettyPrec _ (TyBaseF b) = ppr b+  prettyPrec _ (TyVarF v) = pretty v+  prettyPrec p (TySumF ty1 ty2) =+    pparens (p > 1) $+      prettyPrec 2 ty1 <+> "+" <+> prettyPrec 1 ty2+  prettyPrec p (TyProdF ty1 ty2) =+    pparens (p > 2) $+      prettyPrec 3 ty1 <+> "*" <+> prettyPrec 2 ty2+  prettyPrec p (TyCmdF ty) = pparens (p > 9) $ "cmd" <+> prettyPrec 10 ty+  prettyPrec _ (TyDelayF ty) = braces $ ppr ty+  prettyPrec p (TyFunF ty1 ty2) =+    pparens (p > 0) $+      prettyPrec 1 ty1 <+> "->" <+> prettyPrec 0 ty2++instance PrettyPrec Polytype where+  prettyPrec _ (Forall [] t) = ppr t+  prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t++instance PrettyPrec UPolytype where+  prettyPrec _ (Forall [] t) = ppr t+  prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t++instance PrettyPrec t => PrettyPrec (Ctx t) where+  prettyPrec _ Empty = emptyDoc+  prettyPrec _ (assocs -> bs) = brackets (hsep (punctuate "," (map prettyBinding bs)))+   where+    prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty++instance PrettyPrec Direction where+  prettyPrec _ = pretty . dirSyntax . dirInfo++instance PrettyPrec Capability where+  prettyPrec _ c = pretty $ T.toLower (from (tail $ show c))++instance PrettyPrec Const where+  prettyPrec p c = pparens (p > fixity (constInfo c)) $ pretty . syntax . constInfo $ c++instance PrettyPrec Term where+  prettyPrec _ TUnit = "()"+  prettyPrec p (TConst c) = prettyPrec p c+  prettyPrec _ (TDir d) = ppr d+  prettyPrec _ (TInt n) = pretty n+  prettyPrec _ (TAntiInt v) = "$int:" <> pretty v+  prettyPrec _ (TText s) = fromString (show s)+  prettyPrec _ (TAntiText v) = "$str:" <> pretty v+  prettyPrec _ (TBool b) = bool "false" "true" b+  prettyPrec _ (TRobot r) = "<r" <> pretty r <> ">"+  prettyPrec _ (TRef r) = "@" <> pretty r+  prettyPrec p (TRequireDevice d) = pparens (p > 10) $ "require" <+> ppr (TText d)+  prettyPrec p (TRequire n e) = pparens (p > 10) $ "require" <+> pretty n <+> ppr (TText e)+  prettyPrec _ (TVar s) = pretty s+  prettyPrec _ (TDelay _ t) = braces $ ppr t+  prettyPrec _ t@TPair {} = prettyTuple t+  prettyPrec _ (TLam x mty body) =+    "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "." <+> ppr body+  -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3+  prettyPrec p (TApp t@(TApp (TConst c) l) r) =+    let ci = constInfo c+        pC = fixity ci+     in case constMeta ci of+          ConstMBinOp assoc ->+            pparens (p > pC) $+              hsep+                [ prettyPrec (pC + fromEnum (assoc == R)) l+                , ppr c+                , prettyPrec (pC + fromEnum (assoc == L)) r+                ]+          _ -> prettyPrecApp p t r+  prettyPrec p (TApp t1 t2) = case t1 of+    TConst c ->+      let ci = constInfo c+          pC = fixity ci+       in case constMeta ci of+            ConstMUnOp P -> pparens (p > pC) $ ppr t1 <> prettyPrec (succ pC) t2+            ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1+            _ -> prettyPrecApp p t1 t2+    _ -> prettyPrecApp p t1 t2+  prettyPrec _ (TLet _ x mty t1 t2) =+    hsep $+      ["let", pretty x]+        ++ maybe [] (\ty -> [":", ppr ty]) mty+        ++ ["=", ppr t1, "in", ppr t2]+  prettyPrec _ (TDef _ x mty t1) =+    hsep $+      ["def", pretty x]+        ++ maybe [] (\ty -> [":", ppr ty]) mty+        ++ ["=", ppr t1, "end"]+  prettyPrec p (TBind Nothing t1 t2) =+    pparens (p > 0) $+      prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2+  prettyPrec p (TBind (Just x) t1 t2) =+    pparens (p > 0) $+      pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2++prettyTuple :: Term -> Doc a+prettyTuple = pparens True . hsep . punctuate "," . map ppr . unnestTuple+ where+  unnestTuple (TPair t1 t2) = t1 : unnestTuple t2+  unnestTuple t = [t]++prettyPrecApp :: Int -> Term -> Term -> Doc a+prettyPrecApp p t1 t2 =+  pparens (p > 10) $+    prettyPrec 10 t1 <+> prettyPrec 11 t2++appliedTermPrec :: Term -> Int+appliedTermPrec (TApp f _) = case f of+  TConst c -> fixity $ constInfo c+  _ -> appliedTermPrec f+appliedTermPrec _ = 10++instance PrettyPrec TypeErr where+  prettyPrec _ (Mismatch _ ty1 ty2) =+    "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2+  prettyPrec _ (EscapedSkolem _ x) =+    "Skolem variable" <+> pretty x <+> "would escape its scope"+  prettyPrec _ (UnboundVar _ x) =+    "Unbound variable" <+> pretty x+  prettyPrec _ (Infinite x uty) =+    "Infinite type:" <+> ppr x <+> "=" <+> ppr uty+  prettyPrec _ (DefNotTopLevel _ t) =+    "Definitions may only be at the top level:" <+> ppr 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) =+    "Invalid atomic block:" <+> ppr reason <> ":" <+> ppr t++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"
+ src/Swarm/Language/Requirement.hs view
@@ -0,0 +1,243 @@+-- |+-- 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+-- build a robot running a certain program.+module Swarm.Language.Requirement (+  -- * Requirements++  -- ** The 'Requirement' type+  Requirement (..),++  -- ** The 'Requirements' type and utility functions+  Requirements (..),+  singleton,+  singletonCap,+  singletonDev,+  singletonInv,+  insert,+  ReqCtx,++  -- * Requirements analysis+  requirements,+) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Bifunctor (first)+import Data.Data (Data)+import Data.Hashable (Hashable)+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as S+import Data.Text (Text)+import GHC.Generics (Generic)+import Swarm.Language.Capability (Capability (..), constCaps)+import Swarm.Language.Context (Ctx)+import Swarm.Language.Context qualified as Ctx+import Swarm.Language.Syntax++-- | A /requirement/ is something a robot must have when it is+--   built. There are three types:+--   - A robot can require a certain 'Capability', which should be fulfilled+--     by installing an appropriate device.+--   - A robot can require a specific /device/, which should be installed.+--   - A robot can require some number of a specific entity in its inventory.+data Requirement+  = -- | Require a specific capability.  This must be fulfilled by+    --   installing an appropriate device.  Requiring the same+    --   capability multiple times is the same as requiring it once.+    ReqCap Capability+  | -- | Require a specific device to be installed.  Note that at this+    --   point it is only a name, and has not been resolved to an actual+    --   'Entity'.  That's because programs have to be type- and+    --   capability-checked independent of an 'EntityMap'.  The name+    --   will be looked up at runtime, when actually executing a 'Build'+    --   or 'Reprogram' command, and an appropriate exception thrown if+    --   a device with the given name does not exist.+    --+    --   Requiring the same device multiple times is the same as+    --   requiring it once.+    ReqDev Text+  | -- | Require a certain number of a specific entity to be available+    --   in the inventory.  The same comments apply re: resolving the+    --   entity name to an actual 'Entity'.+    --+    --   Inventory requirements are additive, that is, say, requiring 5+    --   of entity `e` and later requiring 7 is the same as requiring+    --   12.+    ReqInv Int Text+  deriving (Eq, Ord, Show, Read, Generic, Hashable, Data, FromJSON, ToJSON)++-- | It is tempting to define @Requirements = Set Requirement@, but+--   that would be wrong, since two identical 'ReqInv' should have+--   their counts added rather than simply being deduplicated.+--+--   Since we will eventually need to deal with the different types of+--   requirements separately, it makes sense to store them separately+--   anyway.+data Requirements = Requirements+  { capReqs :: Set Capability+  , devReqs :: Set Text+  , invReqs :: Map Text Int+  }+  deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)++instance Semigroup Requirements where+  Requirements c1 d1 i1 <> Requirements c2 d2 i2 =+    Requirements (c1 <> c2) (d1 <> d2) (M.unionWith (+) i1 i2)++instance Monoid Requirements where+  mempty = Requirements S.empty S.empty M.empty++-- | Create a 'Requirements' set with a single 'Requirement'.+singleton :: Requirement -> Requirements+singleton (ReqCap c) = Requirements (S.singleton c) S.empty M.empty+singleton (ReqDev d) = Requirements S.empty (S.singleton d) M.empty+singleton (ReqInv n e) = Requirements S.empty S.empty (M.singleton e n)++-- | For convenience, create a 'Requirements' set with a single+--   'Capability' requirement.+singletonCap :: Capability -> Requirements+singletonCap = singleton . ReqCap++-- | For convenience, create a 'Requirements' set with a single+--   device requirement.+singletonDev :: Text -> Requirements+singletonDev = singleton . ReqDev++-- | For convenience, create a 'Requirements' set with a single+--   inventory requirement.+singletonInv :: Int -> Text -> Requirements+singletonInv n e = singleton (ReqInv n e)++insert :: Requirement -> Requirements -> Requirements+insert = (<>) . singleton++-- | A requirement context records the requirements for the+--   definitions bound to variables.+type ReqCtx = Ctx Requirements++-- | Analyze a program to see what capabilities may be needed to+--   execute it. Also return a capability context mapping from any+--   variables declared via 'TDef' to the capabilities needed by+--   their definitions.+--+--   Note that this is necessarily a conservative analysis, especially+--   if the program contains conditional expressions.  Some+--   capabilities may end up not being actually needed if certain+--   commands end up not being executed.  However, the analysis should+--   be safe in the sense that a robot with the indicated capabilities+--   will always be able to run the given program.+requirements :: ReqCtx -> Term -> (Requirements, ReqCtx)+requirements ctx tm = first (insert (ReqCap CPower)) $ case tm of+  -- First, at the top level, we have to keep track of the+  -- requirements for variables bound with the 'TDef' command.++  -- To make a definition requires the env capability.  Note that the+  -- act of MAKING the definition does not require the capabilities of+  -- the body of the definition (including the possibility of the+  -- recursion capability, if the definition is recursive).  However,+  -- we also return a map which associates the defined name to the+  -- capabilities it requires.+  TDef r x _ t ->+    let bodyReqs = (if r then insert (ReqCap CRecursion) else id) (requirements' ctx t)+     in (singletonCap CEnv, Ctx.singleton x bodyReqs)+  TBind _ t1 t2 ->+    -- First, see what the requirements are to execute the+    -- first command.  It may also define some names, so we get a+    -- map of those names to their required capabilities.+    let (reqs1, ctx1) = requirements ctx t1++        -- Now see what capabilities are required for the second+        -- command; use an extended context since it may refer to+        -- things defined in the first command.+        ctx' = ctx `Ctx.union` ctx1+        (reqs2, ctx2) = requirements ctx' t2+     in -- Finally return the union of everything.+        (reqs1 <> reqs2, ctx' `Ctx.union` ctx2)+  -- Any other term can't bind variables with 'TDef', so we no longer+  -- need to worry about tracking a returned context.+  _ -> (requirements' ctx tm, Ctx.empty)++-- | Infer the requirements to execute/evaluate a term in a+--   given context, where the term is guaranteed not to contain any+--   'TDef'.+--+--   For function application and let-expressions, we assume that the+--   argument (respectively let-bound expression) is used at least+--   once in the body.  Doing otherwise would require a much more+--   fine-grained analysis where we differentiate between the+--   capabilities needed to *evaluate* versus *execute* any expression+--   (since e.g. an unused let-binding would still incur the+--   capabilities to *evaluate* it), which does not seem worth it at+--   all.+requirements' :: ReqCtx -> Term -> Requirements+requirements' = go+ where+  go ctx tm = case tm of+    -- Some primitive literals that don't require any special+    -- capability.+    TUnit -> mempty+    TDir d -> if isCardinal d then singletonCap COrient else mempty+    TInt _ -> mempty+    TAntiInt _ -> mempty+    TText _ -> mempty+    TAntiText _ -> mempty+    TBool _ -> mempty+    -- Look up the capabilities required by a function/command+    -- constants using 'constCaps'.+    TConst c -> maybe mempty singletonCap (constCaps c)+    -- Simply record device or inventory requirements.+    TRequireDevice d -> singletonDev d+    TRequire n e -> singletonInv n e+    -- Note that a variable might not show up in the context, and+    -- that's OK.  In particular, only variables bound by 'TDef' go+    -- in the context; variables bound by a lambda or let will not+    -- be there.+    TVar x -> fromMaybe mempty (Ctx.lookup x ctx)+    -- A lambda expression requires the 'CLambda' capability, and+    -- also all the capabilities of the body.  We assume that the+    -- lambda will eventually get applied, at which point it will+    -- indeed require the body's capabilities (this is unnecessarily+    -- conservative if the lambda is never applied, but such a+    -- program could easily be rewritten without the unused+    -- lambda). We also don't do anything with the argument: we+    -- assume that it is used at least once within the body, and the+    -- capabilities required by any argument will be picked up at+    -- the application site.  Again, this is overly conservative in+    -- the case that the argument is unused, but in that case the+    -- unused argument could be removed.+    --+    -- Note, however, that we do need to *delete* the argument from+    -- the context, in case the context already contains a definition+    -- with the same name: inside the lambda that definition will be+    -- shadowed, so we do not want the name to be associated to any+    -- capabilities.+    TLam x _ t -> insert (ReqCap CLambda) $ go (Ctx.delete x ctx) t+    -- An application simply requires the union of the capabilities+    -- from the left- and right-hand sides.  This assumes that the+    -- argument will be used at least once by the function.+    TApp t1 t2 -> go ctx t1 <> go ctx t2+    -- Similarly, for a let, we assume that the let-bound expression+    -- will be used at least once in the body. We delete the let-bound+    -- name from the context when recursing for the same reason as+    -- lambda.+    TLet r x _ t1 t2 ->+      (if r then insert (ReqCap CRecursion) else id) $+        insert (ReqCap CEnv) $ go (Ctx.delete x ctx) t1 <> go (Ctx.delete x ctx) t2+    -- We also delete the name in a TBind, if any, while recursing on+    -- the RHS.+    TBind mx t1 t2 -> go ctx t1 <> go (maybe id Ctx.delete mx ctx) t2+    -- Everything else is straightforward.+    TPair t1 t2 -> insert (ReqCap CProd) $ go ctx t1 <> go ctx t2+    TDelay _ t -> go ctx t+    -- This case should never happen if the term has been+    -- typechecked; Def commands are only allowed at the top level,+    -- so simply returning mempty is safe.+    TDef {} -> mempty
+ src/Swarm/Language/Syntax.hs view
@@ -0,0 +1,908 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- 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.+module Swarm.Language.Syntax (+  -- * Directions+  Direction (..),+  DirInfo (..),+  applyTurn,+  toDirection,+  fromDirection,+  allDirs,+  isCardinal,+  dirInfo,+  north,+  south,+  east,+  west,++  -- * Constants+  Const (..),+  allConst,+  ConstInfo (..),+  ConstDoc (..),+  ConstMeta (..),+  MBinAssoc (..),+  MUnAssoc (..),+  constInfo,+  arity,+  isCmd,+  isUserFunc,+  isOperator,+  isBuiltinFunction,+  isTangible,+  isLong,++  -- * Syntax+  Syntax (..),+  Location (..),+  noLoc,+  pattern STerm,+  pattern TPair,+  pattern TLam,+  pattern TApp,+  pattern (:$:),+  pattern TLet,+  pattern TDef,+  pattern TBind,+  pattern TDelay,++  -- * Terms+  Var,+  DelayType (..),+  Term (..),+  mkOp,+  mkOp',++  -- * Term traversal+  fvT,+  fv,+  mapFree1,+) where++import Control.Lens (Plated (..), Traversal', (%~))+import Data.Aeson.Types+import Data.Data (Data)+import Data.Data.Lens (uniplate)+import Data.Hashable (Hashable)+import Data.Int (Int64)+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Set qualified as S+import Data.String (IsString (fromString))+import Data.Text hiding (filter, map)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Linear+import Swarm.Language.Types+import Witch.From (from)++------------------------------------------------------------+-- Constants+------------------------------------------------------------++-- | The type of directions. Used /e.g./ to indicate which way a robot+--   will turn.+data Direction = DLeft | DRight | DBack | DForward | DNorth | DSouth | DEast | DWest | DDown+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON, Enum, Bounded)++instance ToJSONKey Direction where+  toJSONKey = genericToJSONKey defaultJSONKeyOptions++instance FromJSONKey Direction where+  fromJSONKey = genericFromJSONKey defaultJSONKeyOptions++data DirInfo = DirInfo+  { dirSyntax :: Text+  , -- absolute direction if it exists+    dirAbs :: Maybe (V2 Int64)+  , -- the turning for the direction+    dirApplyTurn :: V2 Int64 -> V2 Int64+  }++allDirs :: [Direction]+allDirs = [minBound .. maxBound]++-- | Information about all directions+dirInfo :: Direction -> DirInfo+dirInfo d = case d of+  DLeft -> relative (\(V2 x y) -> V2 (-y) x)+  DRight -> relative (\(V2 x y) -> V2 y (-x))+  DBack -> relative (\(V2 x y) -> V2 (-x) (-y))+  DDown -> relative (const down)+  DForward -> relative id+  DNorth -> cardinal north+  DSouth -> cardinal south+  DEast -> cardinal east+  DWest -> cardinal west+ where+  -- name is generate from Direction data constuctor+  -- e.g. DLeft becomes "left"+  directionSyntax = toLower . T.tail . from . show $ d+  cardinal v2 = DirInfo directionSyntax (Just v2) (const v2)+  relative = DirInfo directionSyntax Nothing++-- | Check if the direction is absolute (e.g. 'north' or 'south').+isCardinal :: Direction -> Bool+isCardinal = isJust . dirAbs . dirInfo++-- | The cardinal direction north = @V2 0 1@.+north :: V2 Int64+north = V2 0 1++-- | The cardinal direction south = @V2 0 (-1)@.+south :: V2 Int64+south = V2 0 (-1)++-- | The cardinal direction east = @V2 1 0@.+east :: V2 Int64+east = V2 1 0++-- | The cardinal direction west = @V2 (-1) 0@.+west :: V2 Int64+west = V2 (-1) 0++-- | The direction for viewing the current cell = @V2 0 0@.+down :: V2 Int64+down = V2 0 0++-- | The 'applyTurn' function gives the meaning of each 'Direction' by+--   turning relative to the given vector or by turning to an absolute+--   direction vector.+applyTurn :: Direction -> V2 Int64 -> V2 Int64+applyTurn = dirApplyTurn . dirInfo++-- | Mapping from heading to their corresponding cardinal directions+--   only directions with a 'dirAbs` value are mapped+cardinalDirs :: M.Map (V2 Int64) Direction+cardinalDirs =+  M.fromList+    . mapMaybe (\d -> (,d) <$> (dirAbs . dirInfo $ d))+    $ allDirs++-- | Possibly convert a vector into a 'Direction'---that is, if the+--   vector happens to be a unit vector in one of the cardinal+--   directions.+toDirection :: V2 Int64 -> Maybe Direction+toDirection v = M.lookup v cardinalDirs++-- | Convert a 'Direction' into a corresponding vector.  Note that+--   this only does something reasonable for 'DNorth', 'DSouth', 'DEast',+--   and 'DWest'---other 'Direction's return the zero vector.+fromDirection :: Direction -> V2 Int64+fromDirection = fromMaybe (V2 0 0) . dirAbs . dirInfo++-- | Constants, representing various built-in functions and commands.+--+--   IF YOU ADD A NEW CONSTANT, be sure to also update:+--   1. the 'constInfo' function (below)+--   2. the capability checker ("Swarm.Language.Capability")+--   3. the type checker ("Swarm.Language.Typecheck")+--   4. the runtime ("Swarm.Game.Step")+--   5. the emacs mode syntax highlighter (@contribs/swarm-mode.el@)+--+--   GHC will warn you about incomplete pattern matches for the first+--   four, so it's not really possible to forget.  Note you do not+--   need to update the parser or pretty-printer, since they are+--   auto-generated from 'constInfo'.+data Const+  = -- Trivial actions++    -- | Do nothing.  This is different than 'Wait'+    --   in that it does not take up a time step.+    Noop+  | -- | Wait for a number of time steps without doing anything.+    Wait+  | -- | Self-destruct.+    Selfdestruct+  | -- Basic actions++    -- | Move forward one step.+    Move+  | -- | Turn in some direction.+    Turn+  | -- | Grab an item from the current location.+    Grab+  | -- | Harvest an item from the current location.+    Harvest+  | -- | Try to place an item at the current location.+    Place+  | -- | Give an item to another robot at the current location.+    Give+  | -- | Install a device on a robot.+    Install+  | -- | Make an item.+    Make+  | -- | Sense whether we have a certain item.+    Has+  | -- | Sense whether we have a certain device installed.+    Installed+  | -- | Sense how many of a certain item we have.+    Count+  | -- | Drill through an entity.+    Drill+  | -- | Construct a new robot.+    Build+  | -- | Deconstruct an old robot.+    Salvage+  | -- | Reprogram a robot that has executed it's command+    --   with a new command+    Reprogram+  | -- | Emit a message.+    Say+  | -- | Listen for a message from other robots.+    Listen+  | -- | Emit a log message.+    Log+  | -- | View a certain robot.+    View+  | -- | Set what characters are used for display.+    Appear+  | -- | Create an entity out of thin air. Only+    --   available in creative mode.+    Create+  | -- Sensing / generation++    -- | Get current time+    Time+  | -- | Get the current x, y coordinates+    Whereami+  | -- | See if we can move forward or not.+    Blocked+  | -- | Scan a nearby cell+    Scan+  | -- | Upload knowledge to another robot+    Upload+  | -- | See if a specific entity is here. (This may be removed.)+    Ishere+  | -- | Get a reference to oneself+    Self+  | -- | Get the robot's parent+    Parent+  | -- | Get a reference to the base+    Base+  | -- | Get the robot's display name+    Whoami+  | -- | Set the robot's display name+    Setname+  | -- | Get a uniformly random integer.+    Random+  | -- Modules++    -- | Run a program loaded from a file.+    Run+  | -- Language built-ins++    -- | If-expressions.+    If+  | -- | Left injection.+    Inl+  | -- | Right injection.+    Inr+  | -- | Case analysis on a sum type.+    Case+  | -- | First projection.+    Fst+  | -- | Second projection.+    Snd+  | -- | Force a delayed evaluation.+    Force+  | -- | Return for the cmd monad.+    Return+  | -- | Try/catch block+    Try+  | -- | Undefined+    Undefined+  | -- | User error+    Fail+  | -- Arithmetic unary operators++    -- | Logical negation.+    Not+  | -- | Arithmetic negation.+    Neg+  | -- Comparison operators++    -- | Logical equality comparison+    Eq+  | -- | Logical unequality comparison+    Neq+  | -- | Logical lesser-then comparison+    Lt+  | -- | Logical greater-then comparison+    Gt+  | -- | Logical lesser-or-equal comparison+    Leq+  | -- | Logical greater-or-equal comparison+    Geq+  | -- Arithmetic binary operators++    -- | Logical or.+    Or+  | -- | Logical and.+    And+  | -- | Arithmetic addition operator+    Add+  | -- | Arithmetic subtraction operator+    Sub+  | -- | Arithmetic multiplication operator+    Mul+  | -- | Arithmetic division operator+    Div+  | -- | Arithmetic exponentiation operator+    Exp+  | -- String operators++    -- | Turn an arbitrary value into a string+    Format+  | -- | Concatenate string values+    Concat+  | -- | Count number of characters.+    Chars+  | -- | Split string into two parts.+    Split+  | -- Function composition with nice operators++    -- | Application operator - helps to avoid parentheses:+    --   @f $ g $ h x  =  f (g (h x))@+    AppF+  | -- Concurrency++    -- | Swap placed entity with one in inventory. Essentially atomic grab and place.+    Swap+  | -- | When executing @atomic c@, a robot will not be interrupted,+    --   that is, no other robots will execute any commands while+    --   the robot is executing @c@.+    Atomic+  | -- God-like commands that are omnipresent or omniscient.++    -- | Teleport a robot to the given position.+    Teleport+  | -- | Run a command as if you were another robot.+    As+  | -- | Find a robot by name.+    RobotNamed+  | -- | Find a robot by number.+    RobotNumbered+  | -- | Check if an entity is known.+    Knows+  deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, FromJSON, ToJSON)++allConst :: [Const]+allConst = [minBound .. maxBound]++data ConstInfo = ConstInfo+  { syntax :: Text+  , fixity :: Int+  , constMeta :: ConstMeta+  , constDoc :: ConstDoc+  , tangibility :: Tangibility+  }+  deriving (Eq, Ord, Show)++data ConstDoc = ConstDoc {briefDoc :: Text, longDoc :: Text}+  deriving (Eq, Ord, Show)++instance IsString ConstDoc where+  fromString = flip ConstDoc "" . T.pack++data ConstMeta+  = -- | Function with arity of which some are commands+    ConstMFunc Int Bool+  | -- | Unary operator with fixity and associativity.+    ConstMUnOp MUnAssoc+  | -- | Binary operator with fixity and associativity.+    ConstMBinOp MBinAssoc+  deriving (Eq, Ord, Show)++-- | The meta type representing associativity of binary operator.+data MBinAssoc+  = -- |  Left associative binary operator (see 'Control.Monad.Combinators.Expr.InfixL')+    L+  | -- |   Non-associative binary operator (see 'Control.Monad.Combinators.Expr.InfixN')+    N+  | -- | Right associative binary operator (see 'Control.Monad.Combinators.Expr.InfixR')+    R+  deriving (Eq, Ord, Show)++-- | The meta type representing associativity of unary operator.+data MUnAssoc+  = -- |  Prefix unary operator (see 'Control.Monad.Combinators.Expr.Prefix')+    P+  | -- |  Suffix unary operator (see 'Control.Monad.Combinators.Expr.Suffix')+    S+  deriving (Eq, Ord, Show)++-- | Whether a command is tangible or not.  Tangible commands have+--   some kind of effect on the external world; at most one tangible+--   command can be executed per tick.  Intangible commands are things+--   like sensing commands, or commands that solely modify a robot's+--   internal state; multiple intangible commands may be executed per+--   tick.  In addition, tangible commands can have a 'Length' (either+--   'Short' or 'Long') indicating whether they require only one, or+--   possibly more than one, tick to execute.  Long commands are+--   excluded from @atomic@ blocks to avoid freezing the game.+data Tangibility = Intangible | Tangible Length+  deriving (Eq, Ord, Show, Read)++-- | For convenience, @short = Tangible Short@.+short :: Tangibility+short = Tangible Short++-- | For convenience, @long = Tangible Long@.+long :: Tangibility+long = Tangible Long++-- | The length of a tangible command.  Short commands take exactly+--   one tick to execute.  Long commands may require multiple ticks.+data Length = Short | Long+  deriving (Eq, Ord, Show, Read, Bounded, Enum)++-- | The arity of a constant, /i.e./ how many arguments it expects.+--   The runtime system will collect arguments to a constant (see+--   'Swarm.Game.Value.VCApp') until it has enough, then dispatch+--   the constant's behavior.+arity :: Const -> Int+arity c = case constMeta $ constInfo c of+  ConstMUnOp {} -> 1+  ConstMBinOp {} -> 2+  ConstMFunc a _ -> a++-- | Whether a constant represents a /command/.  Constants which are+--   not commands are /functions/ which are interpreted as soon as+--   they are evaluated.  Commands, on the other hand, are not+--   interpreted until being /executed/, that is, when meeting an+--   'FExec' frame.  When evaluated, commands simply turn into a+--   'VCApp'.+isCmd :: Const -> Bool+isCmd c = case constMeta $ constInfo c of+  ConstMFunc _ cmd -> cmd+  _ -> False++-- | Function constants user can call with reserved words ('wait',...).+isUserFunc :: Const -> Bool+isUserFunc c = case constMeta $ constInfo c of+  ConstMFunc {} -> True+  _ -> False++-- | Whether the constant is an operator. Useful predicate for documentation.+isOperator :: Const -> Bool+isOperator c = case constMeta $ constInfo c of+  ConstMUnOp {} -> True+  ConstMBinOp {} -> True+  ConstMFunc {} -> False++-- | Whether the constant is a /function/ which is interpreted as soon+--   as it is evaluated, but *not* including operators.+--+-- Note: This is used for documentation purposes and complements 'isCmd'+-- and 'isOperator' in that exactly one will accept a given constant.+isBuiltinFunction :: Const -> Bool+isBuiltinFunction c = case constMeta $ constInfo c of+  ConstMFunc _ cmd -> not cmd+  _ -> False++-- | Whether the constant is a /tangible/ command, that has an+--   external effect on the world.  At most one tangible command may be+--   executed per tick.+isTangible :: Const -> Bool+isTangible c = case tangibility (constInfo c) of+  Tangible {} -> True+  _ -> False++-- | Whether the constant is a /long/ command, that is, a tangible+--   command which could require multiple ticks to execute.  Such+--   commands cannot be allowed in @atomic@ blocks.+isLong :: Const -> Bool+isLong c = case tangibility (constInfo c) of+  Tangible Long -> True+  _ -> False++-- | Information about constants used in parsing and pretty printing.+--+-- It would be more compact to represent the information by testing+-- whether the constants are in certain sets, but using pattern+-- matching gives us warning if we add more constants.+constInfo :: Const -> ConstInfo+constInfo c = case c of+  Wait -> command 0 long "Wait for a number of time steps."+  Noop ->+    command 0 Intangible . doc "Do nothing." $+      [ "This is different than `Wait` in that it does not take up a time step."+      , "It is useful for commands like if, which requires you to provide both branches."+      , "Usually it is automatically inserted where needed, so you do not have to worry about it."+      ]+  Selfdestruct ->+    command 0 short . doc "Self-destruct the robot." $+      [ "Useful to not clutter the world."+      , "This destroys the robot's inventory, so consider `salvage` as an alternative."+      ]+  Move -> command 0 short "Move forward one step."+  Turn -> command 1 short "Turn in some direction."+  Grab -> command 0 short "Grab an item from the current location."+  Harvest ->+    command 0 short . doc "Harvest an item from the current location." $+      [ "Leaves behind a growing seed if the harvested item is growable."+      , "Otherwise it works exactly like `grab`."+      ]+  Place ->+    command 1 short . doc "Place an item at the current location." $+      ["The current location has to be empty for this to work."]+  Give -> command 2 short "Give an item to another robot nearby."+  Install -> command 2 short "Install a device from inventory on a robot."+  Make -> command 1 long "Make an item using a recipe."+  Has -> command 1 Intangible "Sense whether the robot has a given item in its inventory."+  Installed -> command 1 Intangible "Sense whether the robot has a specific device installed."+  Count -> command 1 Intangible "Get the count of a given item in a robot's inventory."+  Reprogram ->+    command 2 long . doc "Reprogram another robot with a new command." $+      ["The other robot has to be nearby and idle."]+  Drill ->+    command 1 long . doc "Drill through an entity." $+      [ "Usually you want to `drill forward` when exploring to clear out obstacles."+      , "When you have found a source to drill, you can stand on it and `drill down`."+      , "See what recipes with drill you have available."+      ]+  Build ->+    command 1 long . doc "Construct a new robot." $+      [ "You can specify a command for the robot to execute."+      , "If the command requires devices they will be installed from your inventory."+      ]+  Salvage ->+    command 0 long . doc "Deconstruct an old robot." $+      ["Salvaging a robot will give you its inventory, installed devices and log."]+  Say ->+    command 1 short . doc "Emit a message." $+      [ "The message will be in the robots log (if it has one) and the global log."+      , "You can view the message that would be picked by `listen` from the global log "+          <> "in the messages panel, along with your own messages and logs."+      , "This means that to see messages from other robots you have to be able to listen for them, "+          <> "so once you have a listening device installed messages will be added to your log."+      , "In creative mode, there is of course no such limitation."+      ]+  Listen ->+    command 1 long . doc "Listen for a message from other robots." $+      [ "It will take the first message said by the closest robot."+      , "You do not need to actively listen for the message to be logged though, "+          <> "that is done automatically once you have a listening device installed."+      , "Note that you can see the messages either in your logger device or the message panel."+      ]+  Log -> command 1 Intangible "Log the string in the robot's logger."+  View -> command 1 short "View the given robot."+  Appear ->+    command 1 short . doc "Set how the robot is displayed." $+      [ "You can either specify one character or five (for each direction)."+      , "The default is \"X^>v<\"."+      ]+  Create ->+    command 1 short . doc "Create an item out of thin air." $+      ["Only available in creative mode."]+  Time -> command 0 Intangible "Get the current time."+  Whereami -> command 0 Intangible "Get the current x and y coordinates."+  Blocked -> command 0 Intangible "See if the robot can move forward."+  Scan ->+    command 0 Intangible . doc "Scan a nearby location for entities." $+      [ "Adds the entity (not robot) to your inventory with count 0 if there is any."+      , "If you can use sum types, you can also inspect the result directly."+      ]+  Upload -> command 1 short "Upload a robot's known entities and log to another robot."+  Ishere -> command 1 Intangible "See if a specific entity is in the current location."+  Self -> function 0 "Get a reference to the current robot."+  Parent -> function 0 "Get a reference to the robot's parent."+  Base -> function 0 "Get a reference to the base."+  Whoami -> command 0 Intangible "Get the robot's display name."+  Setname -> command 1 short "Set the robot's display name."+  Random ->+    command 1 Intangible . doc "Get a uniformly random integer." $+      ["The random integer will be chosen from the range 0 to n-1, exclusive of the argument."]+  Run -> command 1 long "Run a program loaded from a file."+  Return -> command 1 Intangible "Make the value a result in `cmd`."+  Try -> command 2 Intangible "Execute a command, catching errors."+  Undefined -> function 0 "A value of any type, that is evaluated as error."+  Fail -> function 1 "A value of any type, that is evaluated as error with message."+  If ->+    function 3 . doc "If-Then-Else function." $+      ["If the bool predicate is true then evaluate the first expression, otherwise the second."]+  Inl -> function 1 "Put the value into the left component of a sum type."+  Inr -> function 1 "Put the value into the right component of a sum type."+  Case -> function 3 "Evaluate one of the given functions on a value of sum type."+  Fst -> function 1 "Get the first value of a pair."+  Snd -> function 1 "Get the second value of a pair."+  Force -> function 1 "Force the evaluation of a delayed value."+  Not -> function 1 "Negate the boolean value."+  Neg -> unaryOp "-" 7 P "Negate the given integer value."+  Add -> binaryOp "+" 6 L "Add the given integer values."+  And -> binaryOp "&&" 3 R "Logical and (true if both values are true)."+  Or -> binaryOp "||" 2 R "Logical or (true if either value is true)."+  Sub -> binaryOp "-" 6 L "Subtract the given integer values."+  Mul -> binaryOp "*" 7 L "Multiply the given integer values."+  Div -> binaryOp "/" 7 L "Divide the left integer value by the right one, rounding down."+  Exp -> binaryOp "^" 8 R "Raise the left integer value to the power of the right one."+  Eq -> binaryOp "==" 4 N "Check that the left value is equal to the right one."+  Neq -> binaryOp "!=" 4 N "Check that the left value is not equal to the right one."+  Lt -> binaryOp "<" 4 N "Check that the left value is lesser than the right one."+  Gt -> binaryOp ">" 4 N "Check that the left value is greater than the right one."+  Leq -> binaryOp "<=" 4 N "Check that the left value is lesser or equal to the right one."+  Geq -> binaryOp ">=" 4 N "Check that the left value is greater or equal to the right one."+  Format -> function 1 "Turn an arbitrary value into a string."+  Concat -> binaryOp "++" 6 R "Concatenate the given strings."+  Chars -> function 1 "Counts the number of characters in the text."+  Split ->+    function 2 . doc "Split the text into two at given position." $+      [ "To be more specific, the following holds for all `text` values `s1` and `s2`:"+      , "`(s1,s2) == split (chars s1) (s1 ++ s2)`"+      , "So split can be used to undo concatenation if you know the length of the original string."+      ]+  AppF ->+    binaryOp "$" 0 R . doc "Apply the function on the left to the value on the right." $+      [ "This operator is useful to avoid nesting parentheses."+      , "For exaple:"+      , "`f $ g $ h x = f (g (h x))`"+      ]+  Swap ->+    command 1 short . doc "Swap placed entity with one in inventory." $+      [ "This essentially works like atomic grab and place."+      , "Use this to avoid race conditions where more robots grab, scan or place in one location."+      ]+  Atomic ->+    command 1 Intangible . doc "Execute a block of commands atomically." $+      [ "When executing `atomic c`, a robot will not be interrupted, that is, no other robots will execute any commands while the robot is executing @c@."+      ]+  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 a robot by name."+  RobotNumbered -> command 1 Intangible "Find a robot by number."+  Knows -> command 1 Intangible "Check if the robot knows about an entity."+ where+  doc b ls = ConstDoc b (T.unlines ls)+  unaryOp s p side d =+    ConstInfo+      { syntax = s+      , fixity = p+      , constMeta = ConstMUnOp side+      , constDoc = d+      , tangibility = Intangible+      }+  binaryOp s p side d =+    ConstInfo+      { syntax = s+      , fixity = p+      , constMeta = ConstMBinOp side+      , constDoc = d+      , tangibility = Intangible+      }+  command a f d =+    ConstInfo+      { syntax = lowShow c+      , fixity = 11+      , constMeta = ConstMFunc a True+      , constDoc = d+      , tangibility = f+      }+  function a d =+    ConstInfo+      { syntax = lowShow c+      , fixity = 11+      , constMeta = ConstMFunc a False+      , constDoc = d+      , tangibility = Intangible+      }++-- | Make infix operation, discarding any syntax related location+mkOp' :: Const -> Term -> Term -> Term+mkOp' c t1 = TApp (TApp (TConst c) t1)++-- | Make infix operation (e.g. @2 + 3@) a curried function+--   application (@((+) 2) 3@).+mkOp :: Const -> Syntax -> Syntax -> Syntax+mkOp c s1@(Syntax l1 _) s2@(Syntax l2 _) = Syntax newLoc newTerm+ where+  -- The new syntax span both terms+  newLoc = l1 <> l2+  -- We don't assign a source location for the operator since it is+  -- usually provided as-is and it is not likely to be useful.+  sop = noLoc (TConst c)+  newTerm = SApp (Syntax l1 $ SApp sop s1) s2++-- | The surface syntax for the language+data Syntax = Syntax {sLoc :: Location, sTerm :: Term}+  deriving (Eq, Show, Data, Generic, FromJSON, ToJSON)++data Location = NoLoc | Location Int Int+  deriving (Eq, Show, Data, Generic, FromJSON, ToJSON)++instance Semigroup Location where+  NoLoc <> l = l+  l <> NoLoc = l+  Location s1 e1 <> Location s2 e2 = Location (min s1 s2) (max e1 e2)++instance Monoid Location where+  mempty = NoLoc++noLoc :: Term -> Syntax+noLoc = Syntax mempty++-- | Match a term without its a syntax+pattern STerm :: Term -> Syntax+pattern STerm t <-+  Syntax _ t+  where+    STerm t = Syntax mempty t++-- | Match a TPair without syntax+pattern TPair :: Term -> Term -> Term+pattern TPair t1 t2 = SPair (STerm t1) (STerm t2)++-- | Match a TLam without syntax+pattern TLam :: Var -> Maybe Type -> Term -> Term+pattern TLam v ty t = SLam v ty (STerm t)++-- | Match a TApp without syntax+pattern TApp :: Term -> Term -> Term+pattern TApp t1 t2 = SApp (STerm t1) (STerm t2)++infixl 0 :$:++-- | Convenient infix pattern synonym for application.+pattern (:$:) :: Term -> Syntax -> Term+pattern (:$:) t1 s2 = SApp (STerm t1) s2++-- | Match a TLet without syntax+pattern TLet :: Bool -> Var -> Maybe Polytype -> Term -> Term -> Term+pattern TLet r v pt t1 t2 = SLet r v pt (STerm t1) (STerm t2)++-- | Match a TDef without syntax+pattern TDef :: Bool -> Var -> Maybe Polytype -> Term -> Term+pattern TDef r v pt t = SDef r v pt (STerm t)++-- | Match a TBind without syntax+pattern TBind :: Maybe Var -> Term -> Term -> Term+pattern TBind v t1 t2 = SBind v (STerm t1) (STerm t2)++-- | Match a TDelay without syntax+pattern TDelay :: DelayType -> Term -> Term+pattern TDelay m t = SDelay m (STerm t)++-- | 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 #-}++------------------------------------------------------------+-- Terms++-- | Different runtime behaviors for delayed expressions.+data DelayType+  = -- | A simple delay, implemented via a (non-memoized) @VDelay@+    --   holding the delayed expression.+    SimpleDelay+  | -- | A memoized delay, implemented by allocating a mutable cell+    --   with the delayed expression and returning a reference to it.+    --   When the @Maybe Var@ is @Just@, a recursive binding of the+    --   variable with a reference to the delayed expression will be+    --   provided while evaluating the delayed expression itself. Note+    --   that there is no surface syntax for binding a variable within+    --   a recursive delayed expression; the only way we can get+    --   @Just@ here is when we automatically generate a delayed+    --   expression while interpreting a recursive @let@ or @def@.+    MemoizedDelay (Maybe Var)+  deriving (Eq, Show, Data, Generic, FromJSON, ToJSON)++-- | Terms of the Swarm language.+data Term+  = -- | The unit value.+    TUnit+  | -- | A constant.+    TConst Const+  | -- | A direction literal.+    TDir Direction+  | -- | An integer literal.+    TInt Integer+  | -- | An antiquoted Haskell variable name of type Integer.+    TAntiInt Text+  | -- | A text literal.+    TText Text+  | -- | An antiquoted Haskell variable name of type Text.+    TAntiText Text+  | -- | A Boolean literal.+    TBool Bool+  | -- | A robot value.  These never show up in surface syntax, but are+    --   here so we can factor pretty-printing for Values through+    --   pretty-printing for Terms.+    TRobot Int+  | -- | A memory reference.  These likewise never show up in surface syntax,+    --   but are here to facilitate pretty-printing.+    TRef Int+  | -- | Require a specific device to be installed.+    TRequireDevice Text+  | -- | Require a certain number of an entity.+    TRequire Int Text+  | -- | A variable.+    TVar Var+  | -- | A pair.+    SPair Syntax Syntax+  | -- | A lambda expression, with or without a type annotation on the+    --   binder.+    SLam Var (Maybe Type) Syntax+  | -- | Function application.+    SApp Syntax Syntax+  | -- | A (recursive) let expression, with or without a type+    --   annotation on the variable. The @Bool@ indicates whether+    --   it is known to be recursive.+    SLet Bool Var (Maybe Polytype) Syntax Syntax+  | -- | A (recursive) definition command, which binds a variable to a+    --   value in subsequent commands. The @Bool@ indicates whether the+    --   definition is known to be recursive.+    SDef Bool Var (Maybe Polytype) Syntax+  | -- | A monadic bind for commands, of the form @c1 ; c2@ or @x <- c1; c2@.+    SBind (Maybe Var) Syntax Syntax+  | -- | Delay evaluation of a term, written @{...}@.  Swarm is an+    --   eager language, but in some cases (e.g. for @if@ statements+    --   and recursive bindings) we need to delay evaluation.  The+    --   counterpart to @{...}@ is @force@, where @force {t} = t@.+    --   Note that 'Force' is just a constant, whereas 'SDelay' has to+    --   be a special syntactic form so its argument can get special+    --   treatment during evaluation.+    SDelay DelayType Syntax+  deriving (Eq, Show, Data, Generic, FromJSON, ToJSON)++instance Plated Term where+  plate = uniplate++-- | Traversal over those subterms of a term which represent free+--   variables.+fvT :: Traversal' Term Term+fvT f = go S.empty+ where+  go bound t = case t of+    TUnit -> pure t+    TConst {} -> pure t+    TDir {} -> pure t+    TInt {} -> pure t+    TAntiInt {} -> pure t+    TText {} -> pure t+    TAntiText {} -> pure t+    TBool {} -> pure t+    TRobot {} -> pure t+    TRef {} -> pure t+    TRequireDevice {} -> pure t+    TRequire {} -> pure t+    TVar x+      | x `S.member` bound -> pure t+      | otherwise -> f (TVar x)+    SLam x ty (Syntax l1 t1) -> SLam x ty <$> (Syntax l1 <$> go (S.insert x bound) t1)+    SApp (Syntax l1 t1) (Syntax l2 t2) ->+      SApp <$> (Syntax l1 <$> go bound t1) <*> (Syntax l2 <$> go bound t2)+    SLet r x ty (Syntax l1 t1) (Syntax l2 t2) ->+      let bound' = S.insert x bound+       in SLet r x ty <$> (Syntax l1 <$> go bound' t1) <*> (Syntax l2 <$> go bound' t2)+    SPair (Syntax l1 t1) (Syntax l2 t2) ->+      SPair <$> (Syntax l1 <$> go bound t1) <*> (Syntax l2 <$> go bound t2)+    SDef r x ty (Syntax l1 t1) ->+      SDef r x ty <$> (Syntax l1 <$> go (S.insert x bound) t1)+    SBind mx (Syntax l1 t1) (Syntax l2 t2) ->+      SBind mx <$> (Syntax l1 <$> go bound t1) <*> (Syntax l2 <$> go (maybe id S.insert mx bound) t2)+    SDelay m (Syntax l1 t1) ->+      SDelay m <$> (Syntax l1 <$> go bound t1)++-- | Traversal over the free variables of a term.  Note that if you+--   want to get the set of all free variables, you can do so via+--   @'Data.Set.Lens.setOf' 'fv'@.+fv :: Traversal' Term Var+fv = fvT . (\f -> \case TVar x -> TVar <$> f x; t -> pure t)++-- | Apply a function to all free occurrences of a particular variable.+mapFree1 :: Var -> (Term -> Term) -> Term -> Term+mapFree1 x f = fvT %~ (\t -> if t == TVar x then f t else t)++lowShow :: Show a => a -> Text+lowShow a = toLower (from (show a))
+ src/Swarm/Language/Typecheck.hs view
@@ -0,0 +1,673 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- 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,+-- see+-- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ .+module Swarm.Language.Typecheck (+  -- * Type errors+  TypeErr (..),+  InvalidAtomicReason (..),+  getTypeErrLocation,++  -- * Inference monad+  Infer,+  runInfer,+  lookup,+  fresh,++  -- * Unification+  substU,+  (=:=),+  HasBindings (..),+  instantiate,+  skolemize,+  generalize,++  -- * Type inferen+  inferTop,+  inferModule,+  infer,+  inferConst,+  check,+  decomposeCmdTy,+  decomposeFunTy,+) where++import Control.Category ((>>>))+import Control.Monad.Except+import Control.Monad.Reader+import Control.Unification hiding (applyBindings, (=:=))+import Control.Unification qualified as U+import Control.Unification.IntVar+import Data.Foldable (fold)+import Data.Functor.Identity+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe+import Data.Set (Set, (\\))+import Data.Set qualified as S+import Swarm.Language.Context hiding (lookup)+import Swarm.Language.Context qualified as Ctx+import Swarm.Language.Parse.QQ (tyQ)+import Swarm.Language.Syntax+import Swarm.Language.Types+import Prelude hiding (lookup)++------------------------------------------------------------+-- Inference monad++-- | The concrete monad used for type inference.  '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))++-- | Run a top-level inference computation, returning either a+--   'TypeErr' or a fully resolved 'TModule'.+runInfer :: TCtx -> Infer UModule -> Either TypeErr TModule+runInfer ctx =+  (>>= applyBindings)+    >>> (>>= \(Module uty uctx) -> Module <$> (fromU <$> generalize uty) <*> pure (fromU uctx))+    >>> flip runReaderT (toU ctx)+    >>> runExceptT+    >>> evalIntBindingT+    >>> runIdentity++-- | 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 :: Location -> Var -> Infer UType+lookup loc x = do+  ctx <- ask+  maybe (throwError $ UnboundVar loc x) instantiate (Ctx.lookup x ctx)++------------------------------------------------------------+-- Dealing with variables: free variables, fresh variables,+-- substitution++-- | @unification-fd@ does not provide an 'Ord' instance for 'IntVar',+--   so we must provide our own, in order to be able to store+--   'IntVar's in a 'Set'.+deriving instance Ord IntVar++-- | A class for getting the free unification variables of a thing.+class FreeVars a where+  freeVars :: a -> Infer (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++-- | We can also get the free variables of a polytype.+instance FreeVars t => FreeVars (Poly t) where+  freeVars (Forall _ t) = freeVars t++-- | We can get the free variables in any polytype in a context.+instance FreeVars UCtx where+  freeVars = fmap S.unions . mapM freeVars . M.elems . unCtx++-- | Generate a fresh unification variable.+fresh :: Infer UType+fresh = UVar <$> lift (lift freeVar)++-- | Perform a substitution over a 'UType', substituting for both type+--   and unification variables.  Note that since 'UType's do not have+--   any binding constructs, we don't have to worry about ignoring+--   bound variables; all variables in a 'UType' are free.+substU :: Map (Either Var IntVar) UType -> UType -> UType+substU m =+  ucata+    (\v -> fromMaybe (UVar v) (M.lookup (Right v) m))+    ( \case+        TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m)+        f -> UTerm f+    )++------------------------------------------------------------+-- Lifted stuff from unification-fd++infix 4 =:=++-- | Constrain two types to be equal.+(=:=) :: UType -> UType -> Infer ()+s =:= t = void (lift $ s U.=:= t)++-- | @unification-fd@ provides a function 'U.applyBindings' which+--   fully substitutes for any bound unification variables (for+--   efficiency, it does not perform such substitution as it goes+--   along).  The 'HasBindings' class is for anything which has+--   unification variables in it and to which we can usefully apply+--   'U.applyBindings'.+class HasBindings u where+  applyBindings :: u -> Infer u++instance HasBindings UType where+  applyBindings = lift . U.applyBindings++instance HasBindings UPolytype where+  applyBindings (Forall xs u) = Forall xs <$> applyBindings u++instance HasBindings UCtx where+  applyBindings = mapM applyBindings++instance HasBindings UModule where+  applyBindings (Module uty uctx) = Module <$> applyBindings uty <*> applyBindings uctx++------------------------------------------------------------+-- Converting between mono- and polytypes++-- | To 'instantiate' a 'UPolytype', we generate a fresh unification+--   variable for each variable bound by the `Forall`, and then+--   substitute them throughout the type.+instantiate :: UPolytype -> Infer UType+instantiate (Forall xs uty) = do+  xs' <- mapM (const fresh) xs+  return $ substU (M.fromList (zip (map Left xs) xs')) uty++-- | 'skolemize' is like 'instantiate', except we substitute fresh+--   /type/ variables instead of unification variables.  Such+--   variables cannot unify with anything other than themselves.  This+--   is used when checking something with a polytype explicitly+--   specified by the user.+skolemize :: UPolytype -> Infer UType+skolemize (Forall xs uty) = do+  xs' <- mapM (const fresh) xs+  return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty+ where+  toSkolem (UVar v) = UTyVar (mkVarName "s" v)+  toSkolem x = error $ "Impossible! Non-UVar in skolemize.toSkolem: " ++ show x++-- | 'generalize' is the opposite of 'instantiate': add a 'Forall'+--   which closes over all free type and unification variables.+generalize :: UType -> Infer UPolytype+generalize uty = do+  uty' <- applyBindings uty+  ctx <- ask+  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')++------------------------------------------------------------+-- Type errors++-- | Errors that can occur during type checking.  The idea is that+--   each error carries information that can be used to help explain+--   what went wrong (though the amount of information carried can and+--   should be very much improved in the future); errors can then+--   separately be pretty-printed to display them to the user.+data TypeErr+  = -- | An undefined variable was encountered.+    UnboundVar Location Var+  | -- | A Skolem variable escaped its local context.+    EscapedSkolem Location Var+  | Infinite IntVar UType+  | -- | The given term was expected to have a certain type, but has a+    -- different type instead.+    Mismatch Location (TypeF UType) (TypeF UType)+  | -- | A definition was encountered not at the top level.+    DefNotTopLevel Location Term+  | -- | A term was encountered which we cannot infer the type of.+    --   This should never happen.+    CantInfer Location Term+  | -- | An invalid argument was provided to @atomic@.+    InvalidAtomic Location InvalidAtomicReason Term+  deriving (Show)++-- | Various reasons the body of an @atomic@ might be invalid.+data InvalidAtomicReason+  = -- | The arugment has too many tangible commands.+    TooManyTicks Int+  | -- | The argument uses some way to duplicate code: @def@, @let@, or lambda.+    AtomicDupingThing+  | -- | The argument referred to a variable with a non-simple type.+    NonSimpleVarType Var UPolytype+  | -- | The argument had a nested @atomic@+    NestedAtomic+  | -- | The argument contained a long command+    LongConst+  deriving (Show)++instance Fallible TypeF IntVar TypeErr where+  occursFailure = Infinite+  mismatchFailure = Mismatch NoLoc++getTypeErrLocation :: TypeErr -> Maybe Location+getTypeErrLocation 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 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++-- | Infer the signature of a top-level expression which might+--   contain definitions.+inferModule :: Syntax -> Infer UModule+inferModule s@(Syntax _ t) = (`catchError` addLocToTypeErr s) $ 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 _ x Nothing t1 -> do+    xTy <- fresh+    ty <- withBinding x (Forall [] xTy) $ infer t1+    xTy =:= ty+    pty <- generalize ty+    return $ Module (UTyCmd UTyUnit) (singleton x pty)++  -- If a (poly)type signature has been provided, skolemize it and+  -- check the definition.+  SDef _ x (Just pty) t1 -> do+    let upty = toU pty+    uty <- skolemize upty+    withBinding x upty $ check t1 uty+    return $ Module (UTyCmd UTyUnit) (singleton x upty)++  -- To handle a 'TBind', infer the types of both sides, combining the+  -- returned modules appropriately.  Have to be careful to use the+  -- correct context when checking the right-hand side in particular.+  SBind mx c1 c2 -> do+    -- First, infer the left side.+    Module cmda ctx1 <- inferModule c1+    a <- decomposeCmdTy cmda++    -- Now infer the right side under an extended context: things in+    -- scope on the right-hand side include both any definitions+    -- created by the left-hand side, as well as a variable as in @x+    -- <- c1; c2@.  The order of extensions here matters: in theory,+    -- c1 could define something with the same name as x, in which+    -- case the bound x should shadow the defined one; hence, we apply+    -- that binding /after/ (i.e. /within/) the application of @ctx1@.+    withBindings ctx1 $+      maybe id (`withBinding` Forall [] a) mx $ do+        Module cmdb ctx2 <- inferModule c2++        -- We don't actually need the result type since we're just going+        -- to return cmdb, but it's important to ensure it's a command+        -- type anyway.  Otherwise something like 'move; 3' would be+        -- accepted with type int.+        _ <- decomposeCmdTy cmdb++        -- Ctx.union is right-biased, so ctx1 `union` ctx2 means later+        -- definitions will shadow previous ones.  Include the binder+        -- (if any) as well, since binders are made available at the top+        -- level, just like definitions. e.g. if the user writes `r <- build {move}`,+        -- then they will be able to refer to r again later.+        let ctxX = maybe Ctx.empty (`Ctx.singleton` Forall [] a) mx+        return $ Module cmdb (ctx1 `Ctx.union` ctxX `Ctx.union` ctx2)++  -- In all other cases, there can no longer be any definitions in the+  -- term, so delegate to 'infer'.+  _anyOtherTerm -> trivMod <$> infer s++-- | Infer the type of a term which does not contain definitions.+infer :: Syntax -> Infer UType+infer s@(Syntax l t) = (`catchError` addLocToTypeErr s) $ case t of+  TUnit -> return UTyUnit+  TConst c -> instantiate . toU $ inferConst c+  TDir _ -> return UTyDir+  TInt _ -> return UTyInt+  TAntiInt _ -> return UTyInt+  TText _ -> return UTyText+  TAntiText _ -> return UTyText+  TBool _ -> return UTyBool+  TRobot _ -> return UTyRobot+  -- 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 _ -> return $ UTyCmd UTyUnit+  TRequire _ _ -> return $ UTyCmd UTyUnit+  -- To infer the type of a pair, just infer both components.+  SPair t1 t2 -> UTyProd <$> infer t1 <*> infer t2+  -- 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 _ dt -> UTyDelay <$> infer dt+  -- 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+    check at (UTyCmd argTy)+    -- 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 $ UTyCmd argTy++  -- Just look up variables in the context.+  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+    let uargTy = toU argTy+    resTy <- withBinding x (Forall [] uargTy) $ infer lt+    return $ UTyFun uargTy resTy++  -- 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+    resTy <- withBinding x (Forall [] argTy) $ infer lt+    return $ UTyFun argTy resTy++  -- To infer the type of an application:+  SApp f x -> do+    -- Infer the type of the left-hand side and make sure it has a function type.+    fTy <- infer f+    (ty1, ty2) <- decomposeFunTy fTy++    -- Then check that the argument has the right type.+    check x ty1 `catchError` addLocToTypeErr x+    return ty2++  -- We can infer the type of a let whether a type has been provided for+  -- the variable or not.+  SLet _ x Nothing t1 t2 -> do+    xTy <- fresh+    uty <- withBinding x (Forall [] xTy) $ infer t1+    xTy =:= uty+    upty <- generalize uty+    withBinding x upty $ infer t2+  SLet _ 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+    resTy <- withBinding x upty $ do+      check t1 uty `catchError` addLocToTypeErr t1+      infer t2+    -- Make sure no skolem variables have escaped.+    ask >>= mapM_ noSkolems+    return resTy+  SDef {} -> throwError $ DefNotTopLevel l t+  SBind mx c1 c2 -> do+    ty1 <- infer c1+    a <- decomposeCmdTy ty1+    ty2 <- maybe id (`withBinding` Forall [] a) mx $ infer c2+    _ <- decomposeCmdTy ty2+    return ty2+ 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 -> TypeErr -> Infer a+addLocToTypeErr s te = case te of+  Mismatch NoLoc a b -> throwError $ Mismatch (sLoc s) a b+  _ -> throwError te++-- | 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++-- | 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)++-- | Infer the type of a constant.+inferConst :: Const -> Polytype+inferConst c = case c of+  Wait -> [tyQ| int -> cmd unit |]+  Noop -> [tyQ| cmd unit |]+  Selfdestruct -> [tyQ| cmd unit |]+  Move -> [tyQ| cmd unit |]+  Turn -> [tyQ| dir -> cmd unit |]+  Grab -> [tyQ| cmd text |]+  Harvest -> [tyQ| cmd text |]+  Place -> [tyQ| text -> cmd unit |]+  Give -> [tyQ| robot -> text -> cmd unit |]+  Install -> [tyQ| robot -> text -> cmd unit |]+  Make -> [tyQ| text -> cmd unit |]+  Has -> [tyQ| text -> cmd bool |]+  Installed -> [tyQ| text -> cmd bool |]+  Count -> [tyQ| text -> cmd int |]+  Reprogram -> [tyQ| robot -> {cmd a} -> cmd unit |]+  Build -> [tyQ| {cmd a} -> cmd robot |]+  Drill -> [tyQ| dir -> cmd unit |]+  Salvage -> [tyQ| cmd unit |]+  Say -> [tyQ| text -> cmd unit |]+  Listen -> [tyQ| cmd text |]+  Log -> [tyQ| text -> cmd unit |]+  View -> [tyQ| robot -> cmd unit |]+  Appear -> [tyQ| text -> cmd unit |]+  Create -> [tyQ| text -> cmd unit |]+  Time -> [tyQ| cmd int |]+  Whereami -> [tyQ| cmd (int * int) |]+  Blocked -> [tyQ| cmd bool |]+  Scan -> [tyQ| dir -> cmd (unit + text) |]+  Upload -> [tyQ| robot -> cmd unit |]+  Ishere -> [tyQ| text -> cmd bool |]+  Self -> [tyQ| robot |]+  Parent -> [tyQ| robot |]+  Base -> [tyQ| robot |]+  Whoami -> [tyQ| cmd text |]+  Setname -> [tyQ| text -> cmd unit |]+  Random -> [tyQ| int -> cmd int |]+  Run -> [tyQ| text -> cmd unit |]+  If -> [tyQ| bool -> {a} -> {a} -> a |]+  Inl -> [tyQ| a -> a + b |]+  Inr -> [tyQ| b -> a + b |]+  Case -> [tyQ|a + b -> (a -> c) -> (b -> c) -> c |]+  Fst -> [tyQ| a * b -> a |]+  Snd -> [tyQ| a * b -> b |]+  Force -> [tyQ| {a} -> a |]+  Return -> [tyQ| a -> cmd a |]+  Try -> [tyQ| {cmd a} -> {cmd a} -> cmd a |]+  Undefined -> [tyQ| a |]+  Fail -> [tyQ| text -> a |]+  Not -> [tyQ| bool -> bool |]+  Neg -> [tyQ| int -> int |]+  Eq -> cmpBinT+  Neq -> cmpBinT+  Lt -> cmpBinT+  Gt -> cmpBinT+  Leq -> cmpBinT+  Geq -> cmpBinT+  And -> [tyQ| bool -> bool -> bool|]+  Or -> [tyQ| bool -> bool -> bool|]+  Add -> arithBinT+  Sub -> arithBinT+  Mul -> arithBinT+  Div -> arithBinT+  Exp -> arithBinT+  Format -> [tyQ| a -> text |]+  Concat -> [tyQ| text -> text -> text |]+  Chars -> [tyQ| text -> int |]+  Split -> [tyQ| int -> text -> (text * text) |]+  AppF -> [tyQ| (a -> b) -> a -> b |]+  Swap -> [tyQ| text -> cmd text |]+  Atomic -> [tyQ| cmd a -> cmd a |]+  Teleport -> [tyQ| robot -> (int * int) -> cmd unit |]+  As -> [tyQ| robot -> {cmd a} -> cmd a |]+  RobotNamed -> [tyQ| text -> cmd robot |]+  RobotNumbered -> [tyQ| int -> cmd robot |]+  Knows -> [tyQ| text -> cmd bool |]+ where+  cmpBinT = [tyQ| a -> a -> bool |]+  arithBinT = [tyQ| int -> int -> int |]++-- | @check t ty@ checks that @t@ has type @ty@.+check :: Syntax -> UType -> Infer ()+check t ty = do+  ty' <- infer t+  _ <- ty =:= ty'+  return ()++-- | Ensure a term is a valid argument to @atomic@.  Valid arguments+--   may not contain @def@, @let@, or lambda. Any variables which are+--   referenced must have a primitive, first-order type such as+--   @text@ or @int@ (in particular, no functions, @cmd@, or+--   @delay@).  We simply assume that any locally bound variables are+--   OK without checking their type: the only way to bind a variable+--   locally is with a binder of the form @x <- c1; c2@, where @c1@ is+--   some primitive command (since we can't refer to external+--   variables of type @cmd a@).  If we wanted to do something more+--   sophisticated with locally bound variables we would have to+--   inline this analysis into typechecking proper, instead of having+--   it be a separate, out-of-band check.+--+--   The goal is to ensure that any argument to @atomic@ is guaranteed+--   to evaluate and execute in some small, finite amount of time, so+--   that it's impossible to write a term which runs atomically for an+--   indefinite amount of time and freezes the rest of the game.  Of+--   course, nothing prevents one from writing a large amount of code+--   inside an @atomic@ block; but we want the execution time to be+--   linear in the size of the code.+--+--   We also ensure that the atomic block takes at most one tick,+--   i.e. contains at most one tangible command. For example, @atomic+--   (move; move)@ is invalid, since that would allow robots to move+--   twice as fast as usual by doing both actions in one tick.+validAtomic :: Syntax -> Infer ()+validAtomic s@(Syntax l t) = do+  n <- analyzeAtomic S.empty s+  when (n > 1) $ throwError (InvalidAtomic l (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 locals (Syntax l t) = case t of+  -- Literals, primitives, etc. that are fine and don't require a tick+  -- to evaluate+  TUnit {} -> return 0+  TDir {} -> return 0+  TInt {} -> return 0+  TAntiInt {} -> return 0+  TText {} -> return 0+  TAntiText {} -> return 0+  TBool {} -> return 0+  TRobot {} -> return 0+  TRequireDevice {} -> return 0+  TRequire {} -> return 0+  -- Constants.+  TConst c+    -- Nested 'atomic' is not allowed.+    | c == Atomic -> throwError $ InvalidAtomic l 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+    -- Otherwise, return 1 or 0 depending on whether the command is+    -- tangible.+    | otherwise -> return $ if isTangible c then 1 else 0+  -- Special case for if: number of tangible commands is the *max* of+  -- the branches instead of the sum, since exactly one of them will be+  -- executed.+  TConst If :$: tst :$: thn :$: els ->+    (+) <$> analyzeAtomic locals tst <*> (max <$> analyzeAtomic locals thn <*> analyzeAtomic locals els)+  -- Pairs, application, and delay are simple: just recurse and sum the results.+  SPair s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2+  SApp s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2+  SDelay _ s1 -> analyzeAtomic locals s1+  -- Bind is similarly simple except that we have to keep track of a local variable+  -- bound in the RHS.+  SBind mx s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic (maybe id S.insert mx locals) s2+  -- 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+      case mxTy of+        -- If the variable is undefined, return 0 to indicate the+        -- atomic block is valid, because we'd rather have the error+        -- caught by the real name+type checking.+        Nothing -> return 0+        Just xTy -> do+          -- Use applyBindings to make sure that we apply as much+          -- information as unification has learned at this point.  In+          -- theory, continuing to typecheck other terms elsewhere in+          -- the program could give us further information about xTy,+          -- so we might have incomplete information at this point.+          -- However, since variables referenced in an atomic block+          -- must necessarily have simple types, it's unlikely this+          -- will really make a difference.  The alternative, more+          -- "correct" way to do this would be to simply emit some+          -- constraints at this point saying that xTy must be a+          -- simple type, and check later that the constraint holds,+          -- after performing complete type inference.  However, since+          -- the current approach is much simpler, we'll stick with+          -- this until such time as we have concrete examples showing+          -- that the more correct, complex way is necessary.+          xTy' <- applyBindings xTy+          if isSimpleUPolytype xTy'+            then return 0+            else throwError (InvalidAtomic l (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)+  -- 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)++-- | A simple polytype is a simple type with no quantifiers.+isSimpleUPolytype :: UPolytype -> Bool+isSimpleUPolytype (Forall [] ty) = isSimpleUType ty+isSimpleUPolytype _ = False++-- | A simple type is a sum or product of base types.+isSimpleUType :: UType -> Bool+isSimpleUType = \case+  UTyBase {} -> True+  UTyVar {} -> False+  UTySum ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2+  UTyProd ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2+  UTyFun {} -> False+  UTyCmd {} -> False+  UTyDelay {} -> False+  -- Make the pattern-match coverage checker happy+  UVar {} -> False+  UTerm {} -> False
+ src/Swarm/Language/Types.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- 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.+module Swarm.Language.Types (+  -- * Basic definitions+  BaseTy (..),+  Var,+  TypeF (..),++  -- * @Type@+  Type,+  tyVars,+  pattern TyBase,+  pattern TyVar,+  pattern TyUnit,+  pattern TyInt,+  pattern TyText,+  pattern TyDir,+  pattern TyBool,+  pattern TyRobot,+  pattern (:+:),+  pattern (:*:),+  pattern (:->:),+  pattern TyCmd,+  pattern TyDelay,++  -- * @UType@+  UType,+  pattern UTyBase,+  pattern UTyVar,+  pattern UTyUnit,+  pattern UTyInt,+  pattern UTyText,+  pattern UTyDir,+  pattern UTyBool,+  pattern UTyRobot,+  pattern UTySum,+  pattern UTyProd,+  pattern UTyFun,+  pattern UTyCmd,+  pattern UTyDelay,++  -- ** Utilities+  ucata,+  mkVarName,++  -- * Polytypes+  Poly (..),+  Polytype,+  UPolytype,++  -- * Contexts+  TCtx,+  UCtx,++  -- * Modules+  Module (..),+  TModule,+  UModule,+  trivMod,++  -- * The 'WithU' class+  WithU (..),+) where++import Control.Unification+import Control.Unification.IntVar+import Data.Aeson (FromJSON, ToJSON)+import Data.Data (Data)+import Data.Foldable (fold)+import Data.Functor.Fixedpoint+import Data.Maybe (fromJust)+import Data.Set (Set)+import Data.Set qualified as S+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic, Generic1)+import Swarm.Language.Context+import Witch++------------------------------------------------------------+-- Types+------------------------------------------------------------++-- | Base types.+data BaseTy+  = -- | The unit type, with a single inhabitant.+    BUnit+  | -- | Signed, arbitrary-size integers.+    BInt+  | -- | Unicode strings.+    BText+  | -- | Directions.+    BDir+  | -- | Booleans.+    BBool+  | -- | Robots.+    BRobot+  deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)++-- | A "structure functor" encoding the shape of type expressions.+--   Actual types are then represented by taking a fixed point of this+--   functor.  We represent types in this way, via a "two-level type",+--   so that we can work with the @unification-fd@ package (see+--   https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/).+data TypeF t+  = -- | A base type.+    TyBaseF BaseTy+  | -- | A type variable.+    TyVarF Var+  | -- | Commands, with return type.  Note that+    --   commands form a monad.+    TyCmdF t+  | -- | Type of delayed computations.+    TyDelayF t+  | -- | Sum type.+    TySumF t t+  | -- | Product type.+    TyProdF t t+  | -- | Function type.+    TyFunF t t+  deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Generic1, Unifiable, Data, FromJSON, ToJSON)++-- | @Type@ is now defined as the fixed point of 'TypeF'.  It would be+--   annoying to manually apply and match against 'Fix' constructors+--   everywhere, so we provide pattern synonyms that allow us to work+--   with 'Type' as if it were defined in a directly recursive way.+type Type = Fix TypeF++-- | Get all the type variables contained in a 'Type'.+tyVars :: Type -> Set Var+tyVars = cata (\case TyVarF x -> S.singleton x; f -> fold f)++-- The derived Data instance is so we can make a quasiquoter for types.+deriving instance Data Type++-- | 'UType's are like 'Type's, but also contain unification+--   variables.  'UType' is defined via 'UTerm', which is also a kind+--   of fixed point (in fact, 'UType' is the /free monad/ over 'TypeF').+--+--   Just as with 'Type', we provide a bunch of pattern synonyms for+--   working with 'UType' as if it were defined directly.+type UType = UTerm TypeF IntVar++-- The derived Data instances are so we can make a quasiquoter for+-- types.+deriving instance Data UType+deriving instance Data IntVar++-- | A generic /fold/ for things defined via 'UTerm' (including, in+--   particular, 'UType').  This probably belongs in the+--   @unification-fd@ package, but since it doesn't provide one, we+--   define it here.+ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a+ucata f _ (UVar v) = f v+ucata f g (UTerm t) = g (fmap (ucata f g) t)++-- | A quick-and-dirty method for turning an 'IntVar' (used internally+--   as a unification variable) into a unique variable name, by+--   appending a number to the given name.+mkVarName :: Text -> IntVar -> Var+mkVarName nm (IntVar v) = T.append nm (from @String (show (v + (maxBound :: Int) + 1)))++-- | For convenience, so we can write /e.g./ @"a"@ instead of @TyVar "a"@.+instance IsString Type where+  fromString x = TyVar (from @String x)++instance IsString UType where+  fromString x = UTyVar (from @String x)++------------------------------------------------------------+-- Contexts+------------------------------------------------------------++-- | A @TCtx@ is a mapping from variables to polytypes.  We generally+--   get one of these at the end of the type inference process.+type TCtx = Ctx Polytype++-- | A @UCtx@ is a mapping from variables to polytypes with+--   unification variables.  We generally have one of these while we+--   are in the midst of the type inference process.+type UCtx = Ctx UPolytype++------------------------------------------------------------+-- Polytypes+------------------------------------------------------------++-- | A @Poly t@ is a universally quantified @t@.  The variables in the+--   list are bound inside the @t@.  For example, the type @forall+--   a. a -> a@ would be represented as @Forall ["a"] (TyFun "a" "a")@.+data Poly t = Forall [Var] t deriving (Show, Eq, Functor, Data, Generic, FromJSON, ToJSON)++-- | A polytype without unification variables.+type Polytype = Poly Type++-- | A polytype with unification variables.+type UPolytype = Poly UType++------------------------------------------------------------+-- Modules+------------------------------------------------------------++-- | A module generally represents the result of performing type+--   inference on a top-level expression, which in particular can+--   contain definitions ('Swarm.Language.Syntax.TDef').  A module+--   contains the overall type of the expression, as well as the+--   context giving the types of any defined variables.+data Module s t = Module {moduleTy :: s, moduleCtx :: Ctx t}+  deriving (Show, Eq, Functor, Data, Generic, FromJSON, ToJSON)++-- | A 'TModule' is the final result of the type inference process on+--   an expression: we get a polytype for the expression, and a+--   context of polytypes for the defined variables.+type TModule = Module Polytype Polytype++-- | A 'UModule' represents the type of an expression at some+--   intermediate stage during the type inference process.  We get a+--   'UType' (/not/ a 'UPolytype') for the expression, which may+--   contain some free unification or type variables, as well as a+--   context of 'UPolytype's for any defined variables.+type UModule = Module UType UPolytype++-- | The trivial module for a given @s@, with the empty context.+trivMod :: s -> Module s t+trivMod t = Module t empty++------------------------------------------------------------+-- WithU+------------------------------------------------------------++-- | In several cases we have two versions of something: a "normal"+--   version, and a @U@ version with unification variables in it+--   (/e.g./ 'Type' vs 'UType', 'Polytype' vs 'UPolytype', 'TCtx' vs+--   'UCtx'). This class abstracts over the process of converting back+--   and forth between them.+--+--   In particular, @'WithU' t@ represents the fact that the type @t@+--   also has a @U@ counterpart, with a way to convert back and forth.+--   Note, however, that converting back may be "unsafe" in the sense+--   that it requires an extra burden of proof to guarantee that it is+--   used only on inputs that are safe.+class WithU t where+  -- | The associated "@U@-version" of the type @t@.+  type U t :: *++  -- | Convert from @t@ to its associated "@U@-version".  This+  --   direction is always safe (we simply have no unification+  --   variables even though the type allows it).+  toU :: t -> U t++  -- | Convert from the associated "@U@-version" back to @t@.+  --   Generally, this direction requires somehow knowing that there+  --   are no longer any unification variables in the value being+  --   converted.+  fromU :: U t -> t++-- | 'Type' is an instance of 'WithU', with associated type 'UType'.+instance WithU Type where+  type U Type = UType+  toU = unfreeze+  fromU = fromJust . 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+  type U (f t) = f (U t)+  toU = fmap toU+  fromU = fmap fromU++------------------------------------------------------------+-- Pattern synonyms+------------------------------------------------------------++pattern TyBase :: BaseTy -> Type+pattern TyBase b = Fix (TyBaseF b)++pattern TyVar :: Var -> Type+pattern TyVar v = Fix (TyVarF v)++pattern TyUnit :: Type+pattern TyUnit = Fix (TyBaseF BUnit)++pattern TyInt :: Type+pattern TyInt = Fix (TyBaseF BInt)++pattern TyText :: Type+pattern TyText = Fix (TyBaseF BText)++pattern TyDir :: Type+pattern TyDir = Fix (TyBaseF BDir)++pattern TyBool :: Type+pattern TyBool = Fix (TyBaseF BBool)++pattern TyRobot :: Type+pattern TyRobot = Fix (TyBaseF BRobot)++infixr 5 :+:++pattern (:+:) :: Type -> Type -> Type+pattern ty1 :+: ty2 = Fix (TySumF ty1 ty2)++infixr 6 :*:++pattern (:*:) :: Type -> Type -> Type+pattern ty1 :*: ty2 = Fix (TyProdF ty1 ty2)++infixr 1 :->:++pattern (:->:) :: Type -> Type -> Type+pattern ty1 :->: ty2 = Fix (TyFunF ty1 ty2)++pattern TyCmd :: Type -> Type+pattern TyCmd ty1 = Fix (TyCmdF ty1)++pattern TyDelay :: Type -> Type+pattern TyDelay ty1 = Fix (TyDelayF ty1)++pattern UTyBase :: BaseTy -> UType+pattern UTyBase b = UTerm (TyBaseF b)++pattern UTyVar :: Var -> UType+pattern UTyVar v = UTerm (TyVarF v)++pattern UTyUnit :: UType+pattern UTyUnit = UTerm (TyBaseF BUnit)++pattern UTyInt :: UType+pattern UTyInt = UTerm (TyBaseF BInt)++pattern UTyText :: UType+pattern UTyText = UTerm (TyBaseF BText)++pattern UTyDir :: UType+pattern UTyDir = UTerm (TyBaseF BDir)++pattern UTyBool :: UType+pattern UTyBool = UTerm (TyBaseF BBool)++pattern UTyRobot :: UType+pattern UTyRobot = UTerm (TyBaseF BRobot)++pattern UTySum :: UType -> UType -> UType+pattern UTySum ty1 ty2 = UTerm (TySumF ty1 ty2)++pattern UTyProd :: UType -> UType -> UType+pattern UTyProd ty1 ty2 = UTerm (TyProdF ty1 ty2)++pattern UTyFun :: UType -> UType -> UType+pattern UTyFun ty1 ty2 = UTerm (TyFunF ty1 ty2)++pattern UTyCmd :: UType -> UType+pattern UTyCmd ty1 = UTerm (TyCmdF ty1)++pattern UTyDelay :: UType -> UType+pattern UTyDelay ty1 = UTerm (TyDelayF ty1)++-- Derive aeson instances for type serialization+deriving instance Generic Type+deriving instance ToJSON Type+deriving instance FromJSON Type
+ src/Swarm/TUI/Attr.hs view
@@ -0,0 +1,175 @@+{-# 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,+-- styles, /etc./) used by the Swarm TUI.+--+-- We export constants only for those we use in the Haskell code+-- and not those used in the world map, to avoid abusing attributes.+-- For example using the robot attribute to highlight some text.+--+-- The few attributes that we use for drawing the logo are an exeption.+module Swarm.TUI.Attr (+  swarmAttrMap,+  worldAttributes,+  worldPrefix,++  -- ** Terrain attributes+  dirtAttr,+  grassAttr,+  stoneAttr,+  waterAttr,+  iceAttr,++  -- ** Common attributes+  entityAttr,+  robotAttr,+  rockAttr,+  plantAttr,++  -- ** Swarm TUI Attributes+  highlightAttr,+  notifAttr,+  infoAttr,+  boldAttr,+  dimAttr,+  cyanAttr,+  yellowAttr,+  blueAttr,+  greenAttr,+  redAttr,+  defAttr,+) where++import Brick+import Brick.Forms+import Brick.Widgets.Dialog+import Brick.Widgets.List+import Data.Bifunctor (bimap)+import Data.Yaml+import Graphics.Vty qualified as V+import Witch (from)++-- | A mapping from the defined attribute names to TUI attributes.+swarmAttrMap :: AttrMap+swarmAttrMap =+  attrMap+    V.defAttr+    $ worldAttributes+      <> [(waterAttr, V.white `on` V.blue)]+      <> terrainAttr+      <> [ -- Robot attribute+           (robotAttr, fg V.white `V.withStyle` V.bold)+         , -- UI rendering attributes+           (highlightAttr, fg V.cyan)+         , (invalidFormInputAttr, fg V.red)+         , (focusedFormInputAttr, V.defAttr)+         , (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)+         , -- Basic colors+           (redAttr, fg V.red)+         , (greenAttr, fg V.green)+         , (blueAttr, fg V.blue)+         , (yellowAttr, fg V.yellow)+         , (cyanAttr, fg V.cyan)+         , -- Default attribute+           (defAttr, V.defAttr)+         ]++entityAttr :: AttrName+entityAttr = fst $ head worldAttributes++worldPrefix :: AttrName+worldPrefix = attrName "world"++-- | Colors of entities in the world.+--+-- Also used to color messages, so water is special and excluded.+worldAttributes :: [(AttrName, V.Attr)]+worldAttributes =+  bimap ((worldPrefix <>) . attrName) fg+    <$> [ ("entity", V.white)+        , ("device", V.brightYellow)+        , ("plant", V.green)+        , ("rock", V.rgbColor @Int 80 80 80)+        , ("wood", V.rgbColor @Int 139 69 19)+        , ("flower", V.rgbColor @Int 200 0 200)+        , ("rubber", V.rgbColor @Int 245 224 179)+        , ("copper", V.yellow)+        , ("copper'", V.rgbColor @Int 78 117 102)+        , ("iron", V.rgbColor @Int 97 102 106)+        , ("iron'", V.rgbColor @Int 183 65 14)+        , ("quartz", V.white)+        , ("silver", V.rgbColor @Int 192 192 192)+        , ("gold", V.rgbColor @Int 255 215 0)+        , ("snow", V.white)+        , ("sand", V.rgbColor @Int 194 178 128)+        , ("fire", V.brightRed)+        , ("red", V.red)+        , ("green", V.green)+        , ("blue", V.blue)+        ]++terrainPrefix :: AttrName+terrainPrefix = attrName "terrain"++terrainAttr :: [(AttrName, V.Attr)]+terrainAttr =+  [ (dirtAttr, fg (V.rgbColor @Int 165 42 42))+  , (grassAttr, fg (V.rgbColor @Int 0 32 0)) -- dark green+  , (stoneAttr, fg (V.rgbColor @Int 32 32 32))+  , (iceAttr, bg V.white)+  ]++-- | The default robot attribute.+robotAttr :: AttrName+robotAttr = attrName "robot"++dirtAttr, grassAttr, stoneAttr, iceAttr, waterAttr, rockAttr, plantAttr :: AttrName+dirtAttr = terrainPrefix <> attrName "dirt"+grassAttr = terrainPrefix <> attrName "grass"+stoneAttr = terrainPrefix <> attrName "stone"+iceAttr = terrainPrefix <> attrName "ice"+waterAttr = worldPrefix <> attrName "water"+rockAttr = worldPrefix <> attrName "rock"+plantAttr = worldPrefix <> attrName "plant"++-- | Some defined attribute names used in the Swarm TUI.+highlightAttr+  , notifAttr+  , infoAttr+  , boldAttr+  , dimAttr+  , defAttr ::+    AttrName+highlightAttr = attrName "highlight"+notifAttr = attrName "notif"+infoAttr = attrName "info"+boldAttr = attrName "bold"+dimAttr = attrName "dim"+defAttr = attrName "def"++-- | Some basic colors used in TUI.+redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr :: AttrName+redAttr = attrName "red"+greenAttr = attrName "green"+blueAttr = attrName "blue"+yellowAttr = attrName "yellow"+cyanAttr = attrName "cyan"++instance ToJSON AttrName where+  toJSON = toJSON . head . attrNameComponents++instance FromJSON AttrName where+  parseJSON = withText "AttrName" (pure . attrName . from)
+ src/Swarm/TUI/Border.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-----------------------------------------------------------------------------+{-# 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+-- places than just the top center.+module Swarm.TUI.Border (+  -- * Horizontal border labels+  HBorderLabels,+  plainHBorder,+  leftLabel,+  centerLabel,+  rightLabel,++  -- * Rectangular border labels+  BorderLabels,+  plainBorder,+  topLabels,+  bottomLabels,++  -- * Border-drawing functions+  hBorderWithLabels,+  borderWithLabels,+) where++import Brick+import Brick.Widgets.Border+import Control.Lens (makeLenses, to, (^.))+import Data.Function ((&))+import Graphics.Vty qualified as V++-- | Labels for a horizontal border, with optional left, middle, and+--   right labels.+data HBorderLabels n = HBorderLabels+  { _leftLabel :: Maybe (Widget n)+  , _centerLabel :: Maybe (Widget n)+  , _rightLabel :: Maybe (Widget n)+  }++-- | A plain horizontal border with no labels.+plainHBorder :: HBorderLabels n+plainHBorder = HBorderLabels Nothing Nothing Nothing++-- | Labels for a rectangular border, with optional left, middle, and+--   right labels on the top and bottom.+data BorderLabels n = BorderLabels+  { _topLabels :: HBorderLabels n+  , _bottomLabels :: HBorderLabels n+  }++-- | A plain rectangular border with no labels.+plainBorder :: BorderLabels n+plainBorder = BorderLabels plainHBorder plainHBorder++makeLenses ''HBorderLabels+makeLenses ''BorderLabels++-- | Draw a horizontal border with three optional labels.  The left+--   label (if present) will be placed two units away from the left+--   end of the border, and the right label will be placed two units+--   away from the right end.  The center label, if present, will+--   always be centered in the border overall, regardless of the width+--   of the left and right labels.  This ensures that when the labels+--   change width, they do not cause the other labels to wiggle.+hBorderWithLabels ::+  HBorderLabels n -> Widget n+hBorderWithLabels (HBorderLabels l c r) =+  Widget Greedy Fixed $ do+    let renderLabel = render . maybe emptyWidget (vLimit 1)+    rl <- renderLabel l+    rc <- renderLabel c+    rr <- renderLabel r++    -- Figure out how wide the whole border is supposed to be+    ctx <- getContext+    let w = ctx ^. availWidthL++        -- Get the widths of the labels+        lw = V.imageWidth (image rl)+        cw = V.imageWidth (image rc)++    -- Now render the border with labels.+    render $+      hBox+        [ hLimit 2 hBorder+        , Widget Fixed Fixed (return rl)+        , -- We calculate the specific width of border between the left+          -- and center labels needed to ensure that the center label is+          -- in the right place.  Note, using (cw + 1) `div` 2, as+          -- opposed to cw `div` 2, means that the placement of the+          -- center label will be left-biased: if it does not fit+          -- exactly at the center it will be placed just to the left of+          -- center.+          hLimit (w `div` 2 - 2 - lw - (cw + 1) `div` 2) hBorder+        , Widget Fixed Fixed (return rc)+        , -- The border between center and right greedily fills up any+          -- remaining width.+          hBorder+        , Widget Fixed Fixed (return rr)+        , hLimit 2 hBorder+        ]++-- | Put a rectangular border around the specified widget with the+--   specified label widgets placed around the border.+borderWithLabels :: BorderLabels n -> Widget n -> Widget n+borderWithLabels labels wrapped =+  Widget (hSize wrapped) (vSize wrapped) $ do+    c <- getContext++    middleResult <-+      wrapped+        & vLimit (c ^. availHeightL - 2)+        & hLimit (c ^. availWidthL - 2)+        & render++    let tl = joinableBorder (Edges False True False True)+        tr = joinableBorder (Edges False True True False)+        bl = joinableBorder (Edges True False False True)+        br = joinableBorder (Edges True False True False)+        top = tl <+> hBorderWithLabels (labels ^. topLabels) <+> tr+        bottom = bl <+> hBorderWithLabels (labels ^. bottomLabels) <+> br+        middle = vBorder <+> Widget Fixed Fixed (return middleResult) <+> vBorder+        total = top <=> middle <=> bottom++    total+      & vLimit (middleResult ^. imageL . to V.imageHeight + 2)+      & hLimit (middleResult ^. imageL . to V.imageWidth + 2)+      & render
+ src/Swarm/TUI/Controller.hs view
@@ -0,0 +1,946 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- Module      :  Swarm.TUI.Controller+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Event handlers for the TUI.+module Swarm.TUI.Controller (+  -- * Event handling+  handleEvent,+  quitGame,++  -- ** Handling 'Frame' events+  runFrameUI,+  runFrame,+  runFrameTicks,+  runGameTickUI,+  runGameTick,+  updateUI,++  -- ** REPL panel+  handleREPLEvent,+  validateREPLForm,+  adjReplHistIndex,+  TimeDir (..),++  -- ** World panel+  handleWorldEvent,+  keyToDir,+  scrollView,+  adjustTPS,++  -- ** Info panel+  handleInfoPanelEvent,+) where++import Brick hiding (Direction)+import Brick.Focus+import Brick.Forms+import Brick.Widgets.Dialog+import Brick.Widgets.List (handleListEvent)+import Brick.Widgets.List qualified as BL+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.Monad.State+import Data.Bits+import Data.Either (isRight)+import Data.Int (Int64)+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.Text qualified as T+import Data.Text.IO qualified as T+import Data.Time (getZonedTime)+import Graphics.Vty qualified as V+import Linear+import Swarm.Game.CESK (cancel, emptyStore, initMachine)+import Swarm.Game.Entity hiding (empty)+import Swarm.Game.Robot+import Swarm.Game.ScenarioInfo+import Swarm.Game.State+import Swarm.Game.Step (gameTick)+import Swarm.Game.Value (Value (VUnit), prettyValue)+import Swarm.Game.World qualified as W+import Swarm.Language.Capability (Capability (CMake))+import Swarm.Language.Context+import Swarm.Language.Parse (reservedWords)+import Swarm.Language.Pipeline+import Swarm.Language.Pretty+import Swarm.Language.Requirement qualified as R+import Swarm.Language.Syntax+import Swarm.Language.Types+import Swarm.TUI.List+import Swarm.TUI.Model+import Swarm.TUI.View (generateModal)+import Swarm.Util hiding ((<<.=))+import Swarm.Version (NewReleaseFailure (..))+import System.Clock+import Witch (into)++-- | Pattern synonyms to simplify brick event handler+pattern Key :: V.Key -> BrickEvent n e+pattern Key k = VtyEvent (V.EvKey k [])++pattern CharKey, ControlKey, MetaKey :: Char -> BrickEvent n e+pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) [])+pattern ControlKey c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl])+pattern MetaKey c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])++pattern EscapeKey :: BrickEvent n e+pattern EscapeKey = VtyEvent (V.EvKey V.KEsc [])++pattern FKey :: Int -> BrickEvent n e+pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])++-- | The top-level event handler for the TUI.+handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()+handleEvent = \case+  -- the query for upstream version could finish at any time, so we have to handle it here+  AppEvent (UpstreamVersion ev) -> do+    let logReleaseEvent l e = runtimeState . eventLog %= logEvent l ("Release", -7) (T.pack $ show e)+    case ev of+      Left e@(FailedReleaseQuery _e) -> logReleaseEvent ErrorTrace e+      Left e -> logReleaseEvent Said e+      Right _ -> pure ()+    runtimeState . upstreamRelease .= ev+  e -> do+    s <- get+    if s ^. uiState . uiPlaying+      then handleMainEvent e+      else+        e & case s ^. uiState . uiMenu of+          -- If we reach the NoMenu case when uiPlaying is False, just+          -- quit the app.  We should actually never reach this code (the+          -- quitGame function would have already halted the app).+          NoMenu -> const halt+          MainMenu l -> handleMainMenuEvent l+          NewGameMenu l -> handleNewGameMenuEvent l+          MessagesMenu -> handleMainMessagesEvent+          AboutMenu -> pressAnyKey (MainMenu (mainMenu About))++-- | The event handler for the main menu.+handleMainMenuEvent ::+  BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState ()+handleMainMenuEvent menu = \case+  Key V.KEnter ->+    case snd <$> BL.listSelectedElement menu of+      Nothing -> continueWithoutRedraw+      Just x0 -> case x0 of+        NewGame -> do+          cheat <- use $ uiState . uiCheatMode+          ss <- use $ gameState . 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+          let tutorialCollection = getTutorials ss+              topMenu =+                BL.listFindBy+                  ((== "Tutorials") . scenarioItemName)+                  (mkScenarioList cheat ss)+              tutorialMenu = mkScenarioList cheat tutorialCollection+              menuStack = NE.fromList [tutorialMenu, topMenu]+          uiState . uiMenu .= NewGameMenu menuStack++          -- Extract the first tutorial challenge and run it+          let firstTutorial = case scOrder tutorialCollection of+                Just (t : _) -> case M.lookup t (scMap tutorialCollection) of+                  Just (SISingle scene si) -> (scene, si)+                  _ -> error "No first tutorial found!"+                _ -> error "No first tutorial found!"+          uncurry startGame firstTutorial Nothing+        Messages -> do+          runtimeState . eventLog . notificationsCount .= 0+          uiState . uiMenu .= MessagesMenu+        About -> uiState . uiMenu .= AboutMenu+        Quit -> halt+  CharKey 'q' -> halt+  ControlKey 'q' -> halt+  VtyEvent ev -> do+    menu' <- nestEventM' menu (handleListEvent ev)+    uiState . uiMenu .= MainMenu menu'+  _ -> continueWithoutRedraw++getTutorials :: ScenarioCollection -> ScenarioCollection+getTutorials sc = case M.lookup "Tutorials" (scMap sc) of+  Just (SICollection _ c) -> c+  _ -> error "No tutorials exist!"++-- | If we are in a New Game menu, advance the menu to the next item in order.+advanceMenu :: Menu -> Menu+advanceMenu = _NewGameMenu . ix 0 %~ BL.listMoveDown++handleMainMessagesEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()+handleMainMessagesEvent = \case+  Key V.KEsc -> returnToMainMenu+  CharKey 'q' -> returnToMainMenu+  ControlKey 'q' -> returnToMainMenu+  _ -> return ()+ where+  returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages)++handleNewGameMenuEvent :: NonEmpty (BL.List Name ScenarioItem) -> BrickEvent Name AppEvent -> EventM Name AppState ()+handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case+  Key V.KEnter ->+    case snd <$> BL.listSelectedElement curMenu of+      Nothing -> continueWithoutRedraw+      Just (SISingle scene si) -> startGame scene si Nothing+      Just (SICollection _ c) -> do+        cheat <- use $ uiState . uiCheatMode+        uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack)+  Key V.KEsc -> exitNewGameMenu scenarioStack+  CharKey 'q' -> exitNewGameMenu scenarioStack+  ControlKey 'q' -> halt+  VtyEvent ev -> do+    menu' <- nestEventM' curMenu (handleListEvent ev)+    uiState . uiMenu .= NewGameMenu (menu' :| rest)+  _ -> continueWithoutRedraw++exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState ()+exitNewGameMenu stk = do+  uiState . uiMenu+    .= case snd (NE.uncons stk) of+      Nothing -> MainMenu (mainMenu NewGame)+      Just stk' -> NewGameMenu stk'++pressAnyKey :: Menu -> BrickEvent Name AppEvent -> EventM Name AppState ()+pressAnyKey m (VtyEvent (V.EvKey _ _)) = uiState . uiMenu .= m+pressAnyKey _ _ = continueWithoutRedraw++-- | The top-level event handler while we are running the game itself.+handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()+handleMainEvent ev = do+  s <- get+  mt <- preuse $ uiState . uiModal . _Just . modalType+  let isRunning = maybe True isRunningModal mt+  case ev of+    AppEvent Frame+      | s ^. gameState . paused -> continueWithoutRedraw+      | otherwise -> runFrameUI+    -- ctrl-q works everywhere+    ControlKey 'q' ->+      case s ^. gameState . winCondition of+        Won _ -> toggleModal WinModal+        _ -> toggleModal QuitModal+    VtyEvent (V.EvResize _ _) -> invalidateCacheEntry WorldCache+    Key V.KEsc+      | isJust (s ^. uiState . uiError) -> uiState . uiError .= Nothing+      | Just m <- s ^. uiState . uiModal -> do+        safeAutoUnpause+        uiState . uiModal .= Nothing+        -- message modal is not autopaused, so update notifications when leaving it+        when (m ^. modalType == MessagesModal) $ do+          gameState . lastSeenMessageTime .= s ^. gameState . ticks+    FKey 1 -> toggleModal HelpModal+    FKey 2 -> toggleModal RobotsModal+    FKey 3 | not (null (s ^. gameState . availableRecipes . notificationsContent)) -> do+      toggleModal RecipesModal+      gameState . availableRecipes . notificationsCount .= 0+    FKey 4 | not (null (s ^. gameState . availableCommands . notificationsContent)) -> do+      toggleModal CommandsModal+      gameState . availableCommands . notificationsCount .= 0+    FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do+      toggleModal MessagesModal+      gameState . lastSeenMessageTime .= s ^. gameState . ticks+    ControlKey 'g' -> case s ^. uiState . uiGoal of+      Just g | g /= [] -> toggleModal (GoalModal g)+      _ -> continueWithoutRedraw+    -- pausing and stepping+    ControlKey 'p' | isRunning -> safeTogglePause+    ControlKey 'o' | isRunning -> do+      gameState . runStatus .= ManualPause+      runGameTickUI+    -- speed controls+    ControlKey 'x' | isRunning -> modify $ adjustTPS (+)+    ControlKey 'z' | isRunning -> modify $ adjustTPS (-)+    -- special keys that work on all panels+    MetaKey 'w' -> setFocus WorldPanel+    MetaKey 'e' -> setFocus RobotPanel+    MetaKey 'r' -> setFocus REPLPanel+    MetaKey 't' -> setFocus InfoPanel+    -- pass keys on to modal event handler if a modal is open+    VtyEvent vev+      | isJust (s ^. uiState . uiModal) -> handleModalEvent vev+    -- toggle creative mode if in "cheat mode"+    ControlKey 'v'+      | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not+    MouseDown n _ _ mouseLoc ->+      case n of+        WorldPanel -> do+          mouseCoordsM <- Brick.zoom gameState (mouseLocToWorldCoords mouseLoc)+          uiState . uiWorldCursor .= mouseCoordsM+        REPLPanel ->+          -- Do not clear the world cursor when going back to the REPL+          continueWithoutRedraw+        _ -> uiState . uiWorldCursor .= Nothing >> continueWithoutRedraw+    MouseUp n _ _mouseLoc -> do+      case n of+        InventoryListItem pos -> uiState . uiInventory . traverse . _2 %= BL.listMoveTo pos+        _ -> return ()+      setFocus $ case n of+        -- Adapt click event origin to their right panel.+        -- For the REPL and the World view, using 'Brick.Widgets.Core.clickable' correctly set the origin.+        -- However this does not seems to work for the robot and info panel.+        -- Thus we force the destination focus here.+        InventoryList -> RobotPanel+        InventoryListItem _ -> RobotPanel+        InfoViewport -> InfoPanel+        _ -> n+    -- dispatch any other events to the focused panel handler+    _ev -> do+      fring <- use $ uiState . uiFocusRing+      case focusGetCurrent fring of+        Just REPLPanel -> handleREPLEvent ev+        Just WorldPanel -> handleWorldEvent ev+        Just RobotPanel -> handleRobotPanelEvent ev+        Just InfoPanel -> handleInfoPanelEvent infoScroll ev+        _ -> 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)++setFocus :: Name -> EventM Name AppState ()+setFocus name = uiState . uiFocusRing %= focusSetCurrent name++-- | Set the game to Running if it was (auto) paused otherwise to paused.+--+-- Also resets the last frame time to now. If we are pausing, it+-- doesn't matter; if we are unpausing, this is critical to+-- ensure the next frame doesn't think it has to catch up from+-- whenever the game was paused!+safeTogglePause :: EventM Name AppState ()+safeTogglePause = do+  curTime <- liftIO $ getTime Monotonic+  uiState . lastFrameTime .= curTime+  gameState . runStatus %= toggleRunStatus++-- | Only unpause the game if leaving autopaused modal.+--+-- Note that the game could have been paused before opening+-- the modal, in that case, leave the game paused.+safeAutoUnpause :: EventM Name AppState ()+safeAutoUnpause = do+  runs <- use $ gameState . runStatus+  when (runs == AutoPause) safeTogglePause++toggleModal :: ModalType -> EventM Name AppState ()+toggleModal mt = do+  modal <- use $ uiState . uiModal+  case modal of+    Nothing -> do+      newModal <- gets $ flip generateModal mt+      ensurePause+      uiState . uiModal ?= newModal+    Just _ -> uiState . uiModal .= Nothing >> safeAutoUnpause+ where+  -- Set the game to AutoPause if needed+  ensurePause = do+    pause <- use $ gameState . paused+    unless (pause || isRunningModal mt) $ do+      gameState . runStatus .= AutoPause++-- | The running modals do not autopause the game.+isRunningModal :: ModalType -> Bool+isRunningModal mt = mt `elem` [RobotsModal, MessagesModal]++handleModalEvent :: V.Event -> EventM Name AppState ()+handleModalEvent = \case+  V.EvKey V.KEnter [] -> do+    mdialog <- preuse $ uiState . uiModal . _Just . modalDialog+    toggleModal QuitModal+    case dialogSelection <$> mdialog of+      Just (Just QuitButton) -> quitGame+      Just (Just (NextButton scene)) -> saveScenarioInfoOnQuit >> uncurry startGame scene Nothing+      _ -> return ()+  ev -> do+    Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev)+    modal <- preuse $ uiState . uiModal . _Just . modalType+    case modal of+      Just _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)+      _ -> return ()++-- | 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+  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+      Nothing -> return ()+      Just p' -> do+        gs <- use $ gameState . scenarios+        p <- liftIO $ normalizeScenarioPath gs p'+        t <- liftIO getZonedTime+        won <- isJust <$> preuse (gameState . winCondition . _Won)+        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 -> liftIO $ saveScenarioInfo p si++        -- See what scenario is currently focused in the menu.  Depending on how the+        -- previous scenario ended (via quit vs. via win), it might be the same as+        -- currentScenarioPath or it might be different.+        curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath+        -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo,+        -- being sure to preserve the same focused scenario.+        sc <- use $ gameState . scenarios+        forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=)++-- | Quit a game.+--+-- * writes out the updated REPL history to a @.swarm_history@ file+-- * saves current scenario status (InProgress/Completed)+-- * returns to the previous menu+quitGame :: EventM Name AppState ()+quitGame = do+  history <- use $ uiState . uiReplHistory+  let hist = mapMaybe getREPLEntry $ getLatestREPLHistoryItems maxBound history+  liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True+  saveScenarioInfoOnQuit+  menu <- use $ uiState . uiMenu+  case menu of+    NoMenu -> halt+    _ -> uiState . uiPlaying .= False++------------------------------------------------------------+-- Handling Frame events+------------------------------------------------------------++-- | Run the game for a single /frame/ (/i.e./ screen redraw), then+--   update the UI.  Depending on how long it is taking to draw each+--   frame, and how many ticks per second we are trying to achieve,+--   this may involve stepping the game any number of ticks (including+--   zero).+runFrameUI :: EventM Name AppState ()+runFrameUI = do+  runFrame+  redraw <- updateUI+  unless redraw continueWithoutRedraw++-- | Run the game for a single frame, without updating the UI.+runFrame :: EventM Name AppState ()+runFrame = do+  -- Reset the needsRedraw flag.  While procssing the frame and stepping the robots,+  -- the flag will get set to true if anything changes that requires redrawing the+  -- world (e.g. a robot moving or disappearing).+  gameState . needsRedraw .= False++  -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ .++  -- Find out how long the previous frame took, by subtracting the+  -- previous time from the current time.+  prevTime <- use (uiState . lastFrameTime)+  curTime <- liftIO $ getTime Monotonic+  let frameTime = diffTimeSpec curTime prevTime++  -- Remember now as the new previous time.+  uiState . lastFrameTime .= curTime++  -- We now have some additional accumulated time to play with.  The+  -- idea is to now "catch up" by doing as many ticks as are supposed+  -- to fit in the accumulated time.  Some accumulated time may be+  -- left over, but it will roll over to the next frame.  This way we+  -- deal smoothly with things like a variable frame rate, the frame+  -- rate not being a nice multiple of the desired ticks per second,+  -- etc.+  uiState . accumulatedTime += frameTime++  -- Figure out how many ticks per second we're supposed to do,+  -- and compute the timestep `dt` for a single tick.+  lgTPS <- use (uiState . lgTicksPerSecond)+  let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds+      dt+        | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS)+        | otherwise = oneSecond * (1 `shiftL` abs lgTPS)++  -- Update TPS/FPS counters every second+  infoUpdateTime <- use (uiState . lastInfoTime)+  let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime+  when (updateTime >= oneSecond) $ do+    -- Wait for at least one second to have elapsed+    when (infoUpdateTime /= 0) $ do+      -- set how much frame got processed per second+      frames <- use (uiState . frameCount)+      uiState . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime++      -- set how much ticks got processed per frame+      uiTicks <- use (uiState . tickCount)+      uiState . uiTPF .= fromIntegral uiTicks / fromIntegral frames++      -- ensure this frame gets drawn+      gameState . needsRedraw .= True++    -- Reset the counter and wait another seconds for the next update+    uiState . tickCount .= 0+    uiState . frameCount .= 0+    uiState . lastInfoTime .= curTime++  -- Increment the frame count+  uiState . frameCount += 1++  -- Now do as many ticks as we need to catch up.+  uiState . frameTickCount .= 0+  runFrameTicks (fromNanoSecs dt)++ticksPerFrameCap :: Int+ticksPerFrameCap = 30++-- | Do zero or more ticks, with each tick notionally taking the given+--   timestep, until we have used up all available accumulated time,+--   OR until we have hit the cap on ticks per frame, whichever comes+--   first.+runFrameTicks :: TimeSpec -> EventM Name AppState ()+runFrameTicks dt = do+  a <- use (uiState . accumulatedTime)+  t <- use (uiState . frameTickCount)++  -- Is there still time left?  Or have we hit the cap on ticks per frame?+  when (a >= dt && t < ticksPerFrameCap) $ do+    -- If so, do a tick, count it, subtract dt from the accumulated time,+    -- and loop!+    runGameTick+    uiState . tickCount += 1+    uiState . frameTickCount += 1+    uiState . accumulatedTime -= dt+    runFrameTicks dt++-- | Run the game for a single tick, and update the UI.+runGameTickUI :: EventM Name AppState ()+runGameTickUI = runGameTick >> void updateUI++-- | Modifies the game state using a fused-effect state action.+zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (Fused.LiftC IO) a -> m ()+zoomGameState f = do+  gs <- use gameState+  gs' <- liftIO (Fused.runM (Fused.execState gs f))+  gameState .= gs'++-- | Run the game for a single tick (/without/ updating the UI).+--   Every robot is given a certain amount of maximum computation to+--   perform a single world action (like moving, turning, grabbing,+--   etc.).+runGameTick :: EventM Name AppState ()+runGameTick = zoomGameState gameTick++-- | Update the UI.  This function is used after running the+--   game for some number of ticks.+updateUI :: EventM Name AppState Bool+updateUI = do+  loadVisibleRegion++  -- If the game state indicates a redraw is needed, invalidate the+  -- world cache so it will be redrawn.+  g <- use gameState+  when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache++  -- 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)++  fr <- use (gameState . to focusedRobot)+  let focusedRobotHash = view inventoryHash <$> fr+  -- The hash of the focused robot (if any)++  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.+  inventoryUpdated <-+    if listRobotHash /= focusedRobotHash || shouldUpdate+      then do+        Brick.zoom uiState $ populateInventoryList fr+        (uiState . uiInventoryShouldUpdate) .= False+        pure True+      else pure False++  -- Now check if the base finished running a program entered at the REPL.+  replUpdated <- case g ^. replStatus of+    -- It did, and the result was the unit value.  Just reset replStatus.+    REPLWorking _ (Just VUnit) -> do+      gameState . replStatus .= REPLDone+      pure True++    -- It did, and returned some other value.  Pretty-print the+    -- result as a REPL output, with its type, and reset the replStatus.+    REPLWorking pty (Just v) -> do+      let out = T.intercalate " " [into (prettyValue v), ":", prettyText (stripCmd pty)]+      uiState . uiReplHistory %= addREPLItem (REPLOutput out)+      gameState . replStatus .= REPLDone+      pure True++    -- Otherwise, do nothing.+    _ -> pure False++  -- If the focused robot's log has been updated, attempt to+  -- automatically switch to it and scroll all the way down so the new+  -- message can be seen.+  uiState . uiScrollToEnd .= False+  logUpdated <- do+    case maybe False (view robotLogUpdated) fr of+      False -> pure False+      True -> do+        -- Reset the log updated flag+        zoomGameState clearFocusedRobotLogUpdated++        -- Find and focus an installed "logger" device in the inventory list.+        let isLogger (InstalledEntry e) = e ^. entityName == "logger"+            isLogger _ = False+            focusLogger = BL.listFindBy isLogger++        uiState . uiInventory . _Just . _2 %= focusLogger++        -- Now inform the UI that it should scroll the info panel to+        -- the very end.+        uiState . uiScrollToEnd .= True+        pure True++  -- Decide whether the info panel has more content scrolled off the+  -- top and/or bottom, so we can draw some indicators to show it if+  -- so.  Note, because we only know the update size and position of+  -- the viewport *after* it has been rendered, this means the top and+  -- bottom indicators will only be updated one frame *after* the info+  -- panel updates, but this isn't really that big of deal.+  infoPanelUpdated <- do+    mvp <- lookupViewport InfoViewport+    case mvp of+      Nothing -> return False+      Just vp -> do+        let topMore = (vp ^. vpTop) > 0+            botMore = (vp ^. vpTop + snd (vp ^. vpSize)) < snd (vp ^. vpContentSize)+        oldTopMore <- uiState . uiMoreInfoTop <<.= topMore+        oldBotMore <- uiState . uiMoreInfoBot <<.= botMore+        return $ oldTopMore /= topMore || oldBotMore /= botMore++  -- Decide whether we need to update the current goal text, and pop+  -- up a modal dialog.+  curGoal <- use (uiState . uiGoal)+  newGoal <-+    preuse (gameState . winCondition . _WinConditions . _NonEmpty . _1 . objectiveGoal)++  let goalUpdated = curGoal /= newGoal+  when goalUpdated $ do+    uiState . uiGoal .= newGoal+    case newGoal of+      Just goal | goal /= [] -> do+        toggleModal (GoalModal goal)+      _ -> return ()++  -- Decide whether to show a pop-up modal congratulating the user on+  -- successfully completing the current challenge.+  winModalUpdated <- do+    w <- use (gameState . winCondition)+    case w of+      Won False -> do+        gameState . winCondition .= Won True+        toggleModal WinModal+        uiState . uiMenu %= advanceMenu+        return True+      _ -> return False++  let redraw = g ^. needsRedraw || inventoryUpdated || replUpdated || logUpdated || infoPanelUpdated || goalUpdated || winModalUpdated+  pure redraw++-- | 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))++stripCmd :: Polytype -> Polytype+stripCmd (Forall xs (TyCmd ty)) = Forall xs ty+stripCmd pty = pty++------------------------------------------------------------+-- REPL events+------------------------------------------------------------++-- | Handle a user input event for the REPL.+handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()+handleREPLEvent = \case+  ControlKey 'c' -> do+    gameState . robotMap . ix 0 . machine %= cancel+    uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "")+  Key V.KEnter -> do+    s <- get+    let entry = formState (s ^. uiState . uiReplForm)+        topTypeCtx = s ^. gameState . robotMap . ix 0 . robotContext . defTypes+        topReqCtx = s ^. gameState . robotMap . ix 0 . robotContext . defReqs+        topValCtx = s ^. gameState . robotMap . ix 0 . robotContext . defVals+        topStore =+          fromMaybe emptyStore $+            s ^? gameState . robotMap . at 0 . _Just . robotContext . defStore+        startBaseProgram t@(ProcessedTerm _ (Module ty _) _ _) =+          (gameState . replStatus .~ REPLWorking ty Nothing)+            . (gameState . robotMap . ix 0 . machine .~ initMachine t topValCtx topStore)+            . (gameState %~ execState (activateRobot 0))++    if not $ s ^. gameState . replWorking+      then case entry of+        CmdPrompt uinput _ ->+          case processTerm' topTypeCtx topReqCtx uinput of+            Right mt -> do+              uiState %= resetWithREPLForm (set promptUpdateL "" (s ^. uiState))+              uiState . uiReplHistory %= addREPLItem (REPLEntry uinput)+              modify $ maybe id startBaseProgram mt+            Left err -> uiState . uiError ?= err+        SearchPrompt t hist ->+          case lastEntry t hist of+            Nothing -> uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "")+            Just found+              | T.null t -> uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "")+              | otherwise -> do+                uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt found)+                modify validateREPLForm+      else continueWithoutRedraw+  Key V.KUp -> modify $ adjReplHistIndex Older+  Key V.KDown -> modify $ adjReplHistIndex Newer+  ControlKey 'r' -> do+    s <- get+    case s ^. uiState . uiReplForm . to formState of+      CmdPrompt uinput _ ->+        let newform = mkReplForm $ SearchPrompt uinput (s ^. uiState . uiReplHistory)+         in uiState . uiReplForm .= newform+      SearchPrompt ftext rh -> case lastEntry ftext rh of+        Nothing -> pure ()+        Just found ->+          let newform = mkReplForm $ SearchPrompt ftext (removeEntry found rh)+           in uiState . uiReplForm .= newform+  CharKey '\t' -> do+    formSt <- use $ uiState . uiReplForm . to formState+    newform <- gets $ mkReplForm . flip tabComplete formSt+    uiState . uiReplForm .= newform+    modify validateREPLForm+  EscapeKey -> do+    formSt <- use $ uiState . uiReplForm . to formState+    case formSt of+      CmdPrompt {} -> continueWithoutRedraw+      SearchPrompt _ _ ->+        uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "")+  ev -> do+    replForm <- use $ uiState . uiReplForm+    f' <- nestEventM' replForm (handleFormEvent ev)+    case formState f' of+      CmdPrompt {} -> do+        uiState . uiReplForm .= f'+        modify validateREPLForm+      SearchPrompt t _ -> do+        -- TODO: why does promptUpdateL not update the uiState?+        newform <- use $ uiState . to (set promptUpdateL t)+        uiState . uiReplForm .= newform++-- | Try to complete the last word in a partially entered REPL prompt using+--   things reserved words and names in scope.+tabComplete :: AppState -> REPLPrompt -> REPLPrompt+tabComplete _ p@(SearchPrompt {}) = p+tabComplete s (CmdPrompt t mms)+  | (m : ms) <- mms = CmdPrompt (replaceLast m t) (ms ++ [m])+  | T.null lastWord = CmdPrompt t []+  | otherwise = case matches of+    [] -> CmdPrompt t []+    [m] -> CmdPrompt (completeWith m) []+    (m : ms) -> CmdPrompt (completeWith m) (ms ++ [m])+ where+  completeWith m = T.append t (T.drop (T.length lastWord) m)+  lastWord = T.takeWhileEnd isIdentChar t+  names = s ^.. gameState . robotMap . ix 0 . robotContext . defTypes . to assocs . traverse . _1+  possibleWords = reservedWords ++ names+  matches = filter (lastWord `T.isPrefixOf`) possibleWords++-- | Validate the REPL input when it changes: see if it parses and+--   typechecks, and set the color accordingly.+validateREPLForm :: AppState -> AppState+validateREPLForm s =+  case replPrompt of+    CmdPrompt uinput _ ->+      let result = processTerm' topTypeCtx topReqCtx uinput+          theType = case result of+            Right (Just (ProcessedTerm _ (Module ty _) _ _)) -> Just ty+            _ -> Nothing+       in s & uiState . uiReplForm %~ validate result+            & uiState . uiReplType .~ theType+    SearchPrompt _ _ -> s+ where+  replPrompt = s ^. uiState . uiReplForm . to formState+  topTypeCtx = s ^. gameState . robotMap . ix 0 . robotContext . defTypes+  topReqCtx = s ^. gameState . robotMap . ix 0 . robotContext . defReqs+  validate result = setFieldValid (isRight result) REPLInput++-- | Update our current position in the REPL history.+adjReplHistIndex :: TimeDir -> AppState -> AppState+adjReplHistIndex d s =+  ns+    & (if replIndexIsAtInput (s ^. repl) then saveLastEntry else id)+    & (if oldEntry /= newEntry then showNewEntry else id)+    & validateREPLForm+ where+  -- new AppState after moving the repl index+  ns = s & repl %~ moveReplHistIndex d oldEntry++  repl :: Lens' AppState REPLHistory+  repl = uiState . uiReplHistory++  replLast = s ^. uiState . uiReplLast+  saveLastEntry = uiState . uiReplLast .~ (s ^. uiState . uiReplForm . to formState . promptTextL)+  showNewEntry = uiState . uiReplForm %~ updateFormState (mkCmdPrompt newEntry)+  -- get REPL data+  getCurrEntry = fromMaybe replLast . getCurrentItemText . view repl+  oldEntry = getCurrEntry s+  newEntry = getCurrEntry ns++------------------------------------------------------------+-- World events+------------------------------------------------------------++worldScrollDist :: Int64+worldScrollDist = 8++-- | 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))+  CharKey 'c' -> do+    invalidateCacheEntry WorldCache+    gameState . viewCenterRule .= VCRobot 0+  -- show fps+  CharKey 'f' -> uiState . uiShowFPS %= not+  -- Fall-through case: don't do anything.+  _ -> continueWithoutRedraw+ where+  onlyCreative a = do+    c <- use $ gameState . creativeMode+    when c a+  moveKeys =+    [ V.KUp+    , V.KDown+    , V.KLeft+    , V.KRight+    , V.KChar 'h'+    , V.KChar 'j'+    , V.KChar 'k'+    , V.KChar 'l'+    ]++-- | Manually scroll the world view.+scrollView :: (V2 Int64 -> V2 Int64) -> EventM Name AppState ()+scrollView update = do+  -- Manually invalidate the 'WorldCache' instead of just setting+  -- 'needsRedraw'.  I don't quite understand why the latter doesn't+  -- always work, but there seems to be some sort of race condition+  -- where 'needsRedraw' gets reset before the UI drawing code runs.+  invalidateCacheEntry WorldCache+  gameState %= modifyViewCenter update++-- | Convert a directional key into a direction.+keyToDir :: V.Key -> V2 Int64+keyToDir V.KUp = north+keyToDir V.KDown = south+keyToDir V.KRight = east+keyToDir V.KLeft = west+keyToDir (V.KChar 'h') = west+keyToDir (V.KChar 'j') = south+keyToDir (V.KChar 'k') = north+keyToDir (V.KChar 'l') = east+keyToDir _ = V2 0 0++-- | Adjust the ticks per second speed.+adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState+adjustTPS (+/-) = uiState . lgTicksPerSecond %~ (+/- 1)++------------------------------------------------------------+-- Robot panel events+------------------------------------------------------------++-- | Handle user input events in the robot panel.+handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()+handleRobotPanelEvent = \case+  (Key V.KEnter) ->+    gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal+  (CharKey 'm') ->+    gets focusedEntity >>= maybe continueWithoutRedraw makeEntity+  (CharKey '0') -> do+    uiState . uiInventoryShouldUpdate .= True+    uiState . uiShowZero %= not+  (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'+  _ -> continueWithoutRedraw++-- | Attempt to make an entity selected from the inventory, if the+--   base is not currently busy.+makeEntity :: Entity -> EventM Name AppState ()+makeEntity e = do+  s <- get+  let mkTy = Forall [] $ TyCmd TyUnit+      mkProg = TApp (TConst Make) (TText (e ^. entityName))+      mkPT = ProcessedTerm mkProg (Module mkTy empty) (R.singletonCap CMake) empty+      topStore =+        fromMaybe emptyStore $+          s ^? gameState . robotMap . at 0 . _Just . robotContext . defStore++  case isActive <$> (s ^. gameState . robotMap . at 0) of+    Just False -> do+      gameState . replStatus .= REPLWorking mkTy Nothing+      gameState . robotMap . ix 0 . machine .= initMachine mkPT empty topStore+      gameState %= execState (activateRobot 0)+    _ -> continueWithoutRedraw++-- | Display a modal window with the description of an entity.+descriptionModal :: Entity -> EventM Name AppState ()+descriptionModal e = do+  s <- get+  uiState . uiModal ?= generateModal s (DescriptionModal e)++------------------------------------------------------------+-- Info panel events+------------------------------------------------------------++-- | Handle user events in the info panel (just scrolling).+handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState ()+handleInfoPanelEvent vs = \case+  Key V.KDown -> vScrollBy vs 1+  Key V.KUp -> vScrollBy vs (-1)+  CharKey 'k' -> vScrollBy vs 1+  CharKey 'j' -> vScrollBy vs (-1)+  Key V.KPageDown -> vScrollPage vs Brick.Down+  Key V.KPageUp -> vScrollPage vs Brick.Up+  Key V.KHome -> vScrollToBeginning vs+  Key V.KEnd -> vScrollToEnd vs+  _ -> return ()
+ src/Swarm/TUI/List.hs view
@@ -0,0 +1,102 @@+-- |+-- 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'+-- to deal with skipping over separators.+module Swarm.TUI.List (handleListEventWithSeparators) where++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 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) =>+  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 ()+ 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
+ src/Swarm/TUI/Model.hs view
@@ -0,0 +1,999 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# 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.+module Swarm.TUI.Model (+  -- * Custom UI label types+  -- $uilabel+  AppEvent (..),+  Name (..),++  -- * Menus and dialogs+  ModalType (..),+  ButtonSelection (..),+  Modal (..),+  modalType,+  modalDialog,+  MainMenuEntry (..),+  mainMenu,+  Menu (..),+  _NewGameMenu,+  mkScenarioList,+  mkNewGameMenu,++  -- * UI state++  -- ** REPL+  REPLHistItem (..),+  replItemText,+  isREPLEntry,+  getREPLEntry,+  REPLHistory,+  replIndex,+  replLength,+  replSeq,+  newREPLHistory,+  addREPLItem,+  restartREPLHistory,+  getLatestREPLHistoryItems,+  moveReplHistIndex,+  getCurrentItemText,+  replIndexIsAtInput,+  TimeDir (..),++  -- ** Prompt utils+  REPLPrompt (..),+  mkCmdPrompt,+  replPromptAsWidget,+  promptTextL,+  promptUpdateL,+  mkReplForm,+  removeEntry,+  resetWithREPLForm,++  -- ** Inventory+  InventoryListEntry (..),+  _Separator,+  _InventoryEntry,+  _InstalledEntry,++  -- ** UI Model+  UIState,+  uiMenu,+  uiPlaying,+  uiCheatMode,+  uiFocusRing,+  uiWorldCursor,+  uiReplForm,+  uiReplType,+  uiReplHistory,+  uiReplLast,+  uiInventory,+  uiMoreInfoTop,+  uiMoreInfoBot,+  uiScrollToEnd,+  uiError,+  uiModal,+  uiGoal,+  lgTicksPerSecond,+  lastFrameTime,+  accumulatedTime,+  tickCount,+  frameCount,+  frameTickCount,+  lastInfoTime,+  uiShowFPS,+  uiShowZero,+  uiInventoryShouldUpdate,+  uiTPF,+  uiFPS,+  appData,++  -- ** Initialization+  initFocusRing,+  defaultPrompt,+  initReplForm,+  initLgTicksPerSecond,+  initUIState,+  lastEntry,++  -- ** Updating+  populateInventoryList,+  infoScroll,+  modalScroll,++  -- * Runtime state+  RuntimeState,+  webPort,+  upstreamRelease,+  eventLog,+  logEvent,++  -- * App state+  AppState,+  gameState,+  uiState,+  runtimeState,++  -- ** Initialization+  AppOpts (..),+  initAppState,+  startGame,+  scenarioToAppState,+  Seed,++  -- ** Utility+  focusedItem,+  focusedEntity,+  nextScenario,+  initRuntimeState,+) where++import Brick+import Brick.Focus+import Brick.Forms+import Brick.Widgets.Dialog (Dialog)+import Brick.Widgets.List qualified as BL+import Control.Applicative (Applicative (liftA2))+import Control.Lens hiding (from, (<.>))+import Control.Monad.Except+import Control.Monad.State+import Data.Bits (FiniteBits (finiteBitSize))+import Data.Foldable (toList)+import Data.List (findIndex, sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isJust)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (getZonedTime)+import Data.Vector qualified as V+import Linear (zero)+import Network.Wai.Handler.Warp (Port)+import Swarm.Game.Entity as E+import Swarm.Game.Robot+import Swarm.Game.Scenario (Scenario, loadScenario)+import Swarm.Game.ScenarioInfo (+  ScenarioCollection,+  ScenarioInfo (..),+  ScenarioItem (..),+  ScenarioStatus (..),+  normalizeScenarioPath,+  scMap,+  scenarioCollectionToList,+  scenarioItemByPath,+  scenarioPath,+  scenarioStatus,+  _SISingle,+ )+import Swarm.Game.State+import Swarm.Game.World qualified as W+import Swarm.Language.Types+import Swarm.Util+import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease))+import System.Clock+import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName)+import Witch (into)++------------------------------------------------------------+-- Custom UI label types+------------------------------------------------------------++-- $uilabel These types are used as parameters to various @brick@+-- types.++-- | '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+--   it can, telling the TUI to render a new frame.+data AppEvent+  = Frame+  | UpstreamVersion (Either NewReleaseFailure String)+  deriving (Show)++-- | 'Name' represents names to uniquely identify various components+--   of the UI, such as forms, panels, caches, extents, and lists.+data Name+  = -- | The panel containing the REPL.+    REPLPanel+  | -- | The panel containing the world view.+    WorldPanel+  | -- | The panel showing robot info and inventory on the top left.+    RobotPanel+  | -- | The info panel on the bottom left.+    InfoPanel+  | -- | The REPL input form.+    REPLInput+  | -- | The render cache for the world view.+    WorldCache+  | -- | The cached extent for the world view.+    WorldExtent+  | -- | The list of inventory items for the currently+    --   focused robot.+    InventoryList+  | -- | The inventory item position in the InventoryList.+    InventoryListItem Int+  | -- | The list of main menu choices.+    MenuList+  | -- | The list of scenario choices.+    ScenarioList+  | -- | The scrollable viewport for the info panel.+    InfoViewport+  | -- | The scrollable viewport for any modal dialog.+    ModalViewport+  deriving (Eq, Ord, Show, Read)++infoScroll :: ViewportScroll Name+infoScroll = viewportScroll InfoViewport++modalScroll :: ViewportScroll Name+modalScroll = viewportScroll ModalViewport++------------------------------------------------------------+-- REPL History+------------------------------------------------------------++-- | An item in the REPL history.+data REPLHistItem+  = -- | Something entered by the user.+    REPLEntry Text+  | -- | A response printed by the system.+    REPLOutput Text+  deriving (Eq, Ord, Show, Read)++-- | Useful helper function to only get user input text.+getREPLEntry :: REPLHistItem -> Maybe Text+getREPLEntry = \case+  REPLEntry t -> Just t+  _ -> Nothing++-- | Useful helper function to filter out REPL output.+isREPLEntry :: REPLHistItem -> Bool+isREPLEntry = isJust . getREPLEntry++-- | Get the text of REPL input/output.+replItemText :: REPLHistItem -> Text+replItemText = \case+  REPLEntry t -> t+  REPLOutput t -> t++-- | History of the REPL with indices (0 is first entry) to the current+--   line and to the first entry since loading saved history.+--   We also (ab)use the length of the REPL as the index of current+--   input line, since that number is one past the index of last entry.+data REPLHistory = REPLHistory+  { _replSeq :: Seq REPLHistItem+  , _replIndex :: Int+  , _replStart :: Int+  }++makeLensesWith (lensRules & generateSignatures .~ False) ''REPLHistory++-- | Sequence of REPL inputs and outputs, oldest entry is leftmost.+replSeq :: Lens' REPLHistory (Seq REPLHistItem)++-- | The current index in the REPL history (if the user is going back+--   through the history using up/down keys).+replIndex :: Lens' REPLHistory Int++-- | The index of the first entry since loading saved history.+--+-- It will be set on load and reset on save (happens during exit).+replStart :: Lens' REPLHistory Int++-- | Create new REPL history (i.e. from loaded history file lines).+newREPLHistory :: [REPLHistItem] -> REPLHistory+newREPLHistory xs =+  let s = Seq.fromList xs+   in REPLHistory+        { _replSeq = s+        , _replStart = length s+        , _replIndex = length s+        }++-- | Point the start of REPL history after current last line. See 'replStart'.+restartREPLHistory :: REPLHistory -> REPLHistory+restartREPLHistory h = h & replStart .~ replLength h++-- | Current number lines of the REPL history - (ab)used as index of input buffer.+replLength :: REPLHistory -> Int+replLength = length . _replSeq++-- | Add new REPL input - the index must have been pointing one past+--   the last element already, so we increment it to keep it that way.+addREPLItem :: REPLHistItem -> REPLHistory -> REPLHistory+addREPLItem t h =+  h+    & replSeq %~ (|> t)+    & replIndex .~ 1 + replLength h++-- | Get the latest N items in history, starting with the oldest one.+--+-- This is used to show previous REPL lines in UI, so we need the items+-- sorted in the order they were entered and will be drawn top to bottom.+getLatestREPLHistoryItems :: Int -> REPLHistory -> [REPLHistItem]+getLatestREPLHistoryItems n h = toList latestN+ where+  latestN = Seq.drop oldestIndex $ h ^. replSeq+  oldestIndex = max (h ^. replStart) $ length (h ^. replSeq) - n++data TimeDir = Newer | Older deriving (Eq, Ord, Show)++moveReplHistIndex :: TimeDir -> Text -> REPLHistory -> REPLHistory+moveReplHistIndex d lastEntered history = history & replIndex .~ newIndex+ where+  historyLen = replLength history+  curText = fromMaybe lastEntered $ getCurrentItemText history+  curIndex = history ^. replIndex+  entries = history ^. replSeq+  -- split repl at index+  (olderP, newer) = Seq.splitAt curIndex entries+  -- find first different entry in direction+  notSameEntry = \case+    REPLEntry t -> t /= curText+    _ -> False+  newIndex = case d of+    Newer -> maybe historyLen (curIndex +) $ Seq.findIndexL notSameEntry newer+    Older -> fromMaybe curIndex $ Seq.findIndexR notSameEntry olderP++getCurrentItemText :: REPLHistory -> Maybe Text+getCurrentItemText history = replItemText <$> Seq.lookup (history ^. replIndex) (history ^. replSeq)++replIndexIsAtInput :: REPLHistory -> Bool+replIndexIsAtInput repl = repl ^. replIndex == replLength repl++------------------------------------------------------------+-- Repl Prompt+------------------------------------------------------------++-- | This data type represent what is prompted to the player+--   and how the REPL show interpret the user input.+data REPLPrompt+  = -- | Interpret the given text as a regular command.+    --   The list is for potential completions, which we can+    --   cycle through by hitting Tab repeatedly+    CmdPrompt Text [Text]+  | -- | Interpret the given text as "search this text in history"+    SearchPrompt Text REPLHistory++-- | Get the last REPLEntry in REPLHistory matching the given text+lastEntry :: Text -> REPLHistory -> Maybe Text+lastEntry t h =+  case Seq.viewr $ Seq.filter matchEntry $ h ^. replSeq of+    Seq.EmptyR -> Nothing+    _ Seq.:> a -> Just (replItemText a)+ where+  matchesText histItem = t `T.isInfixOf` replItemText histItem+  matchEntry = liftA2 (&&) matchesText isREPLEntry++-- | Given some text,  removes the REPLEntry within REPLHistory which is equal to that.+--   This is used when the user enters in search mode and want to traverse the history.+--   If a command has been used many times, the history will be populated with it causing+--   the effect that search command always finds the same command.+removeEntry :: Text -> REPLHistory -> REPLHistory+removeEntry foundtext hist = hist & replSeq %~ Seq.filter (/= REPLEntry foundtext)++mkCmdPrompt :: Text -> REPLPrompt+mkCmdPrompt t = CmdPrompt t []++defaultPrompt :: REPLPrompt+defaultPrompt = mkCmdPrompt ""++-- | Lens for accesing the text of the prompt.+--   Notice that setting the text clears any pending completions.+promptTextL :: Lens' REPLPrompt Text+promptTextL = lens g s+ where+  -- Notice that the prompt ADT must have a Text field in every constructor (representing what the user writes).+  -- This should be force in the ADT itself... right know this here+  -- The compiler will complain about "Non complete patterns" on this two function.+  g :: REPLPrompt -> Text+  g (CmdPrompt t _) = t+  g (SearchPrompt t _) = t++  s :: REPLPrompt -> Text -> REPLPrompt+  s (CmdPrompt _ _) t = mkCmdPrompt t+  s (SearchPrompt _ h) t = SearchPrompt t h++-- | Turn the repl prompt into a decorator for the form+replPromptAsWidget :: REPLPrompt -> Widget Name+replPromptAsWidget (CmdPrompt {}) = txt "> "+replPromptAsWidget (SearchPrompt t rh) =+  case lastEntry t rh of+    Nothing -> txt "[nothing found] "+    Just lastentry+      | T.null t -> txt "[find] "+      | otherwise -> txt $ "[found: \"" <> lastentry <> "\"] "++-- | Creates the repl form as a decorated form.+mkReplForm :: REPLPrompt -> Form REPLPrompt AppEvent Name+mkReplForm r = newForm [(replPromptAsWidget r <+>) @@= editTextField promptTextL REPLInput (Just 1)] r++------------------------------------------------------------+-- Menus and dialogs+------------------------------------------------------------++data ModalType+  = HelpModal+  | RecipesModal+  | CommandsModal+  | MessagesModal+  | RobotsModal+  | WinModal+  | QuitModal+  | DescriptionModal Entity+  | GoalModal [Text]+  deriving (Eq, Show)++data ButtonSelection = CancelButton | QuitButton | NextButton (Scenario, ScenarioInfo)++data Modal = Modal+  { _modalType :: ModalType+  , _modalDialog :: Dialog ButtonSelection+  }++makeLenses ''Modal++data MainMenuEntry = NewGame | Tutorial | Messages | About | Quit+  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data Menu+  = NoMenu -- We started playing directly from command line, no menu to show+  | MainMenu (BL.List Name MainMenuEntry)+  | NewGameMenu (NonEmpty (BL.List Name ScenarioItem)) -- stack of scenario item lists+  | MessagesMenu+  | AboutMenu++mainMenu :: MainMenuEntry -> BL.List Name MainMenuEntry+mainMenu e = BL.list MenuList (V.fromList [minBound .. maxBound]) 1 & BL.listMoveToElement e++makePrisms ''Menu++-- | Create a brick 'BL.List' of scenario items from a 'ScenarioCollection'.+mkScenarioList :: Bool -> ScenarioCollection -> BL.List Name ScenarioItem+mkScenarioList cheat = flip (BL.list ScenarioList) 1 . V.fromList . filterTest . scenarioCollectionToList+ where+  filterTest = if cheat then id else filter (\case SICollection n _ -> n /= "Testing"; _ -> True)++-- | Given a 'ScenarioCollection' and a 'FilePath' which is the canonical+--   path to some folder or scenario, construct a 'NewGameMenu' stack+--   focused on the given item, if possible.+mkNewGameMenu :: Bool -> ScenarioCollection -> FilePath -> Maybe Menu+mkNewGameMenu cheat sc path = NewGameMenu . NE.fromList <$> go (Just sc) (splitPath path) []+ where+  go :: Maybe ScenarioCollection -> [FilePath] -> [BL.List Name ScenarioItem] -> Maybe [BL.List Name ScenarioItem]+  go _ [] stk = Just stk+  go Nothing _ _ = Nothing+  go (Just curSC) (thing : rest) stk = go nextSC rest (lst : stk)+   where+    hasName :: ScenarioItem -> Bool+    hasName (SISingle _ (ScenarioInfo pth _ _ _)) = takeFileName pth == thing+    hasName (SICollection nm _) = nm == into @Text (dropTrailingPathSeparator thing)++    lst = BL.listFindBy hasName (mkScenarioList cheat curSC)++    nextSC = case M.lookup (dropTrailingPathSeparator thing) (scMap curSC) of+      Just (SICollection _ c) -> Just c+      _ -> Nothing++------------------------------------------------------------+-- Inventory list entries+------------------------------------------------------------++-- | An entry in the inventory list displayed in the info panel.  We+--   can either have an entity with a count in the robot's inventory,+--   an entity installed on the robot, or a labelled separator.  The+--   purpose of the separators is to show a clear distinction between+--   the robot's /inventory/ and its /installed devices/.+data InventoryListEntry+  = Separator Text+  | InventoryEntry Count Entity+  | InstalledEntry Entity+  deriving (Eq)++makePrisms ''InventoryListEntry++------------------------------------------------------------+-- UI state+------------------------------------------------------------++-- | The main record holding the UI state.  For access to the fields,+-- see the lenses below.+data UIState = UIState+  { _uiMenu :: Menu+  , _uiPlaying :: Bool+  , _uiCheatMode :: Bool+  , _uiFocusRing :: FocusRing Name+  , _uiWorldCursor :: Maybe W.Coords+  , _uiReplForm :: Form REPLPrompt AppEvent Name+  , _uiReplType :: Maybe Polytype+  , _uiReplLast :: Text+  , _uiReplHistory :: REPLHistory+  , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry)+  , _uiMoreInfoTop :: Bool+  , _uiMoreInfoBot :: Bool+  , _uiScrollToEnd :: Bool+  , _uiError :: Maybe Text+  , _uiModal :: Maybe Modal+  , _uiGoal :: Maybe [Text]+  , _uiShowFPS :: Bool+  , _uiShowZero :: Bool+  , _uiInventoryShouldUpdate :: Bool+  , _uiTPF :: Double+  , _uiFPS :: Double+  , _lgTicksPerSecond :: Int+  , _tickCount :: Int+  , _frameCount :: Int+  , _frameTickCount :: Int+  , _lastFrameTime :: TimeSpec+  , _accumulatedTime :: TimeSpec+  , _lastInfoTime :: TimeSpec+  , _appData :: Map Text Text+  }++--------------------------------------------------+-- 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++-- | The current menu state.+uiMenu :: Lens' UIState Menu++-- | Are we currently playing the game?  True = we are playing, and+--   should thus display a world, REPL, etc.; False = we should+--   display the current menu.+uiPlaying :: Lens' UIState Bool++-- | Cheat mode, i.e. are we allowed to turn creative mode on and off?+uiCheatMode :: Lens' UIState Bool++-- | 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)++-- | The form where the user can type input at the REPL.+uiReplForm :: Lens' UIState (Form REPLPrompt AppEvent Name)++-- | The type of the current REPL input which should be displayed to+--   the user (if any).+uiReplType :: Lens' UIState (Maybe Polytype)++-- | The last thing the user has typed which isn't part of the history.+--   This is used to restore the repl form after the user visited the history.+uiReplLast :: Lens' UIState Text++-- | History of things the user has typed at the REPL, interleaved+--   with outputs the system has generated.+uiReplHistory :: Lens' UIState REPLHistory++-- | The hash value of the focused robot entity (so we can tell if its+--   inventory changed) along with a list of the items in the+--   focused robot's inventory.+uiInventory :: Lens' UIState (Maybe (Int, BL.List Name InventoryListEntry))++-- | Does the info panel contain more content past the top of the panel?+uiMoreInfoTop :: Lens' UIState Bool++-- | Does the info panel contain more content past the bottom of the panel?+uiMoreInfoBot :: Lens' UIState Bool++-- | A flag telling the UI to scroll the info panel to the very end+--   (used when a new log message is appended).+uiScrollToEnd :: Lens' UIState Bool++-- | When this is @Just@, it represents a popup box containing an+--   error message that is shown on top of the rest of the UI.+uiError :: Lens' UIState (Maybe Text)++-- | When this is @Just@, it represents a modal to be displayed on+--   top of the UI, e.g. for the Help screen.+uiModal :: Lens' UIState (Maybe Modal)++-- | Status of the scenario goal: whether there is one, and whether it+--   has been displayed to the user initially.+uiGoal :: Lens' UIState (Maybe [Text])++-- | A toggle to show the FPS by pressing `f`+uiShowFPS :: Lens' UIState Bool++-- | A toggle to show or hide inventory items with count 0 by pressing `0`+uiShowZero :: Lens' UIState Bool++-- | Whether the Inventory ui panel should update+uiInventoryShouldUpdate :: Lens' UIState Bool++-- | Computed ticks per milli seconds+uiTPF :: Lens' UIState Double++-- | Computed frames per milli seconds+uiFPS :: Lens' UIState Double++-- | The base-2 logarithm of the current game speed in ticks/second.+--   Note that we cap this value to the range of +/- log2 INTMAX.+lgTicksPerSecond :: Lens' UIState Int+lgTicksPerSecond = lens _lgTicksPerSecond safeSetLgTicks+ where+  maxLog = finiteBitSize (maxBound :: Int)+  maxTicks = maxLog - 2+  minTicks = 2 - maxLog+  safeSetLgTicks ui lTicks+    | lTicks < minTicks = setLgTicks ui minTicks+    | lTicks > maxTicks = setLgTicks ui maxTicks+    | otherwise = setLgTicks ui lTicks+  setLgTicks ui lTicks = ui {_lgTicksPerSecond = lTicks}++-- | A counter used to track how many ticks have happened since the+--   last time we updated the ticks/frame statistics.+tickCount :: Lens' UIState Int++-- | A counter used to track how many frames have been rendered since the+--   last time we updated the ticks/frame statistics.+frameCount :: Lens' UIState Int++-- | A counter used to track how many ticks have happened in the+--   current frame, so we can stop when we get to the tick cap.+frameTickCount :: Lens' UIState Int++-- | The time of the last info widget update+lastInfoTime :: Lens' UIState TimeSpec++-- | The time of the last 'Frame' event.+lastFrameTime :: Lens' UIState TimeSpec++-- | The amount of accumulated real time.  Every time we get a 'Frame'+--   event, we accumulate the amount of real time that happened since+--   the last frame, then attempt to take an appropriate number of+--   ticks to "catch up", based on the target tick rate.+--+--   See https://gafferongames.com/post/fix_your_timestep/ .+accumulatedTime :: Lens' UIState TimeSpec++-- | Free-form data loaded from the @data@ directory, for things like+--   the logo, about page, tutorial story, etc.+appData :: Lens' UIState (Map Text Text)++-- | Lens for accesing the text of the prompt.+--   Notice that setting the text clears any pending completions.+promptUpdateL :: Lens UIState (Form REPLPrompt AppEvent Name) Text Text+promptUpdateL = lens g s+ where+  -- Notice that the prompt ADT must have a Text field in every constructor (representing what the user writes).+  -- This should be force in the ADT itself... right know this here+  -- The compiler will complain about "Non complete patterns" on this two function.+  g :: UIState -> Text+  g ui = case formState (ui ^. uiReplForm) of+    CmdPrompt t _ -> t+    SearchPrompt t _ -> t++  s :: UIState -> Text -> Form REPLPrompt AppEvent Name+  s ui inputText = case formState (ui ^. uiReplForm) of+    CmdPrompt _ _ -> mkReplForm $ mkCmdPrompt inputText+    SearchPrompt _ _ -> mkReplForm $ SearchPrompt inputText (ui ^. uiReplHistory)++-- ----------------------------------------------------------------------------+--                                Runtime state                              --+-- ----------------------------------------------------------------------------++data RuntimeState = RuntimeState+  { _webPort :: Maybe Port+  , _upstreamRelease :: Either NewReleaseFailure String+  , _eventLog :: Notifications LogEntry+  }++initRuntimeState :: RuntimeState+initRuntimeState =+  RuntimeState+    { _webPort = Nothing+    , _upstreamRelease = Left (NoMainUpstreamRelease [])+    , _eventLog = mempty+    }++makeLensesWith (lensRules & generateSignatures .~ False) ''RuntimeState++-- | The port on which the HTTP debug service is running.+webPort :: Lens' RuntimeState (Maybe Port)++-- | The upstream release version.+upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String)++-- | A log of runtime events.+--+-- This logging is separate from the logging done during game-play.+-- If some error happens before a game is even selected, this is the+-- place to log it.+eventLog :: Lens' RuntimeState (Notifications LogEntry)++-- | Simply log to the runtime event log.+logEvent :: LogSource -> (Text, RID) -> Text -> Notifications LogEntry -> Notifications LogEntry+logEvent src (who, rid) msg el =+  el+    & notificationsCount %~ succ+    & notificationsContent %~ (l :)+ where+  l = LogEntry 0 src who rid zero msg++-- ----------------------------------------------------------------------------+--                                   APPSTATE                                --+-- ----------------------------------------------------------------------------++-- | The 'AppState' just stores together the other states.+--+-- This is so you can use a smaller state when e.g. writing some game logic+-- or updating the UI. Also consider that GameState can change when loading+-- a new scenario - if the state should persist games, use RuntimeState.+data AppState = AppState+  { _gameState :: GameState+  , _uiState :: UIState+  , _runtimeState :: RuntimeState+  }++--------------------------------------------------+-- Lenses for AppState++makeLensesWith (lensRules & generateSignatures .~ False) ''AppState++-- | The 'GameState' record.+gameState :: Lens' AppState GameState++-- | The 'UIState' record.+uiState :: Lens' AppState UIState++-- | The 'RuntimeState' record+runtimeState :: Lens' AppState RuntimeState++--------------------------------------------------+-- Utility functions++-- | Get the currently focused 'InventoryListEntry' from the robot+--   info panel (if any).+focusedItem :: AppState -> Maybe InventoryListEntry+focusedItem s = do+  list <- s ^? uiState . uiInventory . _Just . _2+  (_, entry) <- BL.listSelectedElement list+  return entry++-- | Get the currently focused entity from the robot info panel (if+--   any).  This is just like 'focusedItem' but forgets the+--   distinction between plain inventory items and installed devices.+focusedEntity :: AppState -> Maybe Entity+focusedEntity =+  focusedItem >=> \case+    Separator _ -> Nothing+    InventoryEntry _ e -> Just e+    InstalledEntry e -> Just e++--------------------------------------------------+-- UIState initialization++-- | The initial state of the focus ring.+initFocusRing :: FocusRing Name+initFocusRing = focusRing [REPLPanel, InfoPanel, RobotPanel, WorldPanel]++-- | The initial state of the REPL entry form.+initReplForm :: Form REPLPrompt AppEvent Name+initReplForm =+  newForm+    [(replPromptAsWidget defaultPrompt <+>) @@= editTextField promptTextL REPLInput (Just 1)]+    (mkCmdPrompt "")++-- | The initial tick speed.+initLgTicksPerSecond :: Int+initLgTicksPerSecond = 4 -- 2^4 = 16 ticks / second++-- | 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 UIState+initUIState showMainMenu cheatMode = liftIO $ do+  historyT <- readFileMayT =<< getSwarmHistoryPath False+  appDataMap <- readAppData+  let history = maybe [] (map REPLEntry . T.lines) historyT+  startTime <- getTime Monotonic+  return $+    UIState+      { _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu+      , _uiPlaying = not showMainMenu+      , _uiCheatMode = cheatMode+      , _uiFocusRing = initFocusRing+      , _uiWorldCursor = Nothing+      , _uiReplForm = initReplForm+      , _uiReplType = Nothing+      , _uiReplHistory = newREPLHistory history+      , _uiReplLast = ""+      , _uiInventory = Nothing+      , _uiMoreInfoTop = False+      , _uiMoreInfoBot = False+      , _uiScrollToEnd = False+      , _uiError = Nothing+      , _uiModal = Nothing+      , _uiGoal = Nothing+      , _uiShowFPS = False+      , _uiShowZero = True+      , _uiInventoryShouldUpdate = False+      , _uiTPF = 0+      , _uiFPS = 0+      , _lgTicksPerSecond = initLgTicksPerSecond+      , _lastFrameTime = startTime+      , _accumulatedTime = 0+      , _lastInfoTime = 0+      , _tickCount = 0+      , _frameCount = 0+      , _frameTickCount = 0+      , _appData = appDataMap+      }++------------------------------------------------------------+-- Functions for updating the UI state+------------------------------------------------------------++-- | Given the focused robot, populate the UI inventory list in the info+--   panel with information about its inventory.+populateInventoryList :: MonadState UIState m => Maybe Robot -> m ()+populateInventoryList Nothing = uiInventory .= Nothing+populateInventoryList (Just r) = do+  mList <- preuse (uiInventory . _Just . _2)+  showZero <- use uiShowZero+  let mkInvEntry (n, e) = InventoryEntry n e+      mkInstEntry (_, e) = InstalledEntry e+      itemList mk label =+        (\case [] -> []; xs -> Separator label : xs)+          . map mk+          . sortOn (view entityName . snd)+          . filter shouldDisplay+          . elems++      -- Display items if we have a positive number of them, or they+      -- aren't an installed device.  In other words we don't need to+      -- display installed devices twice unless we actually have some+      -- in our inventory in addition to being installed.+      shouldDisplay (n, e) = n > 0 || showZero && not ((r ^. installedDevices) `E.contains` e)++      items =+        (r ^. robotInventory . to (itemList mkInvEntry "Inventory"))+          ++ (r ^. installedDevices . to (itemList mkInstEntry "Installed devices"))++      -- Attempt to keep the selected element steady.+      sel = mList >>= BL.listSelectedElement -- Get the currently selected element+index.+      idx = case sel of+        -- If there is no currently selected element, just focus on+        -- index 1 (not 0, to avoid the separator).+        Nothing -> 1+        -- Otherwise, try to find the same entry in the list;+        -- if it's not there, keep the index the same.+        Just (selIdx, InventoryEntry _ e) ->+          fromMaybe selIdx (findIndex ((== Just e) . preview (_InventoryEntry . _2)) items)+        Just (selIdx, InstalledEntry e) ->+          fromMaybe selIdx (findIndex ((== Just e) . preview _InstalledEntry) items)+        Just (selIdx, _) -> selIdx++      -- Create the new list, focused at the desired index.+      lst = BL.listMoveTo idx $ BL.list InventoryList (V.fromList items) 1++  -- Finally, populate the newly created list in the UI, and remember+  -- the hash of the current robot.+  uiInventory .= Just (r ^. inventoryHash, lst)++-- | Set the REPLForm to the given value, resetting type error checks to Nothing+--   and removing uiError.+resetWithREPLForm :: Form REPLPrompt AppEvent Name -> UIState -> UIState+resetWithREPLForm f =+  (uiReplForm .~ f)+    . (uiReplType .~ Nothing)+    . (uiError .~ Nothing)++------------------------------------------------------------+-- App state (= UI state + game state) initialization+------------------------------------------------------------++-- | Command-line options for configuring the app.+data AppOpts = AppOpts+  { -- | Explicit seed chosen by the user.+    userSeed :: Maybe Seed+  , -- | Scenario the user wants to play.+    userScenario :: Maybe FilePath+  , -- | Code to be run on base.+    toRun :: Maybe FilePath+  , -- | Should cheat mode be enabled?+    cheatMode :: Bool+  , -- | Explicit port on which to run the web API+    userWebPort :: Maybe Port+  }++-- | Initialize the 'AppState'.+initAppState :: AppOpts -> ExceptT Text IO AppState+initAppState AppOpts {..} = do+  let skipMenu = isJust userScenario || isJust toRun || isJust userSeed+  gs <- initGameState+  ui <- initUIState (not skipMenu) cheatMode+  let rs = initRuntimeState+  case skipMenu of+    False -> return $ AppState gs ui rs+    True -> do+      (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap)+      execStateT+        (startGameWithSeed userSeed scenario (ScenarioInfo path NotStarted NotStarted NotStarted) toRun)+        (AppState gs ui rs)++-- | Load a 'Scenario' and start playing the game.+startGame :: (MonadIO m, MonadState AppState m) => Scenario -> ScenarioInfo -> Maybe FilePath -> m ()+startGame = startGameWithSeed Nothing++-- | Load a 'Scenario' and start playing the game, with the+--   possibility for the user to override the seed.+startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> Scenario -> ScenarioInfo -> Maybe FilePath -> m ()+startGameWithSeed userSeed scene si toRun = do+  t <- liftIO getZonedTime+  ss <- use $ gameState . scenarios+  p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath)+  gameState . currentScenarioPath .= Just p+  gameState . scenarios . scenarioItemByPath p . _SISingle . _2 . scenarioStatus .= InProgress t 0 0+  scenarioToAppState scene userSeed toRun++-- | Extract the scenario which would come next in the menu from the+--   currently selected scenario (if any).  Can return @Nothing@ if+--   either we are not in the @NewGameMenu@, or the current scenario+--   is the last among its siblings.+nextScenario :: Menu -> Maybe (Scenario, ScenarioInfo)+nextScenario = \case+  NewGameMenu (curMenu :| _) ->+    let nextMenuList = BL.listMoveDown curMenu+        isLastScenario = BL.listSelected curMenu == Just (length (BL.listElements curMenu) - 1)+     in if isLastScenario+          then Nothing+          else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd+  _ -> Nothing++-- XXX do we need to keep an old entity map around???++-- | Modify the 'AppState' appropriately when starting a new scenario.+scenarioToAppState :: (MonadIO m, MonadState AppState m) => Scenario -> Maybe Seed -> Maybe String -> m ()+scenarioToAppState scene userSeed toRun = do+  withLensIO gameState $ scenarioToGameState scene userSeed toRun+  withLensIO uiState $ scenarioToUIState scene+ where+  withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m ()+  withLensIO l a = do+    x <- use l+    x' <- liftIO $ a x+    l .= x'++-- | Modify the UI state appropriately when starting a new scenario.+scenarioToUIState :: Scenario -> UIState -> IO UIState+scenarioToUIState _scene u =+  return $+    u+      & uiPlaying .~ True+      & uiGoal .~ Nothing+      & uiFocusRing .~ initFocusRing+      & uiInventory .~ Nothing+      & uiShowFPS .~ False+      & uiShowZero .~ True+      & lgTicksPerSecond .~ initLgTicksPerSecond+      & resetWithREPLForm (mkReplForm $ mkCmdPrompt "")+      & uiReplHistory %~ restartREPLHistory
+ src/Swarm/TUI/Panel.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-----------------------------------------------------------------------------+{-# 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+-- a border around some content, with the color of the border+-- depending on whether the panel is currently focused.  Panels exist+-- within a 'FocusRing' such that the user can cycle between the+-- panels (using /e.g./ the @Tab@ key).+module Swarm.TUI.Panel (+  panel,+) where++import Brick+import Brick.Focus+import Brick.Widgets.Border+import Control.Lens+import Swarm.TUI.Border++data Panel n = Panel+  {_panelName :: n, _panelLabels :: BorderLabels n, _panelContent :: Widget n}++makeLenses ''Panel++instance Named (Panel n) n where+  getName = view panelName++drawPanel :: Eq n => AttrName -> FocusRing n -> Panel n -> Widget n+drawPanel attr fr = withFocusRing fr drawPanel'+ where+  drawPanel' :: Bool -> Panel n -> Widget n+  drawPanel' focused p =+    (if focused then overrideAttr borderAttr attr else id) $+      borderWithLabels (p ^. panelLabels) (p ^. panelContent)++-- | Create a panel.+panel ::+  Eq n =>+  -- | Border attribute to use when the panel is focused.+  AttrName ->+  -- | Focus ring the panel should be part of.+  FocusRing n ->+  -- | The name of the panel. Must be unique.+  n ->+  -- | The labels to use around the border.+  BorderLabels n ->+  -- | The content of the panel.+  Widget n ->+  Widget n+panel attr fr nm labs w = drawPanel attr fr (Panel nm labs w)
+ src/Swarm/TUI/View.hs view
@@ -0,0 +1,1136 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Swarm.TUI.View+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Code for drawing the TUI.+module Swarm.TUI.View (+  drawUI,+  drawTPS,++  -- * Dialog box+  drawDialog,+  generateModal,+  chooseCursor,++  -- * Key hint menu+  drawKeyMenu,+  drawModalMenu,+  drawKeyCmd,++  -- * World+  drawWorld,++  -- * Robot panel+  drawRobotPanel,+  drawItem,+  drawLabelledEntityName,++  -- * Info panel+  drawInfoPanel,+  explainFocusedItem,++  -- * REPL+  drawREPL,+) where++import Brick hiding (Direction)+import Brick.Focus+import Brick.Forms+import Brick.Widgets.Border (hBorder, hBorderWithLabel, joinableBorder, vBorder)+import Brick.Widgets.Center (center, centerLayer, hCenter)+import Brick.Widgets.Dialog+import Brick.Widgets.List qualified as BL+import Brick.Widgets.Table qualified as BT+import Control.Lens hiding (Const, from)+import Control.Monad (guard)+import Control.Monad.Reader (withReaderT)+import Data.Array (range)+import Data.Bits (shiftL, shiftR, (.&.))+import Data.Foldable qualified as F+import Data.Functor (($>))+import Data.IntMap qualified as IM+import Data.List (intersperse)+import Data.List qualified as L+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.List.Split (chunksOf)+import Data.Map qualified as M+import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)+import Data.Semigroup (sconcat)+import Data.Sequence qualified as Seq+import Data.String (fromString)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime)+import Graphics.Vty qualified as V+import Linear+import Network.Wai.Handler.Warp (Port)+import Swarm.Game.CESK (CESK (..))+import Swarm.Game.Display+import Swarm.Game.Entity as E+import Swarm.Game.Recipe+import Swarm.Game.Robot+import Swarm.Game.Scenario (scenarioAuthor, scenarioDescription, scenarioName, scenarioObjectives)+import Swarm.Game.ScenarioInfo (+  ScenarioItem (..),+  ScenarioStatus (..),+  scenarioBestTicks,+  scenarioBestTime,+  scenarioItemName,+  scenarioStatus,+ )+import Swarm.Game.State+import Swarm.Game.Terrain (terrainMap)+import Swarm.Game.World qualified as W+import Swarm.Language.Pretty (prettyText)+import Swarm.Language.Syntax+import Swarm.Language.Typecheck (inferConst)+import Swarm.Language.Types (Polytype)+import Swarm.TUI.Attr+import Swarm.TUI.Border+import Swarm.TUI.Model+import Swarm.TUI.Panel+import Swarm.Util+import Swarm.Version (NewReleaseFailure (..))+import System.Clock (TimeSpec (..))+import Text.Printf+import Text.Wrap+import Witch (from, into)++-- | The main entry point for drawing the entire UI.  Figures out+--   which menu screen we should show (if any), or just the game itself.+drawUI :: AppState -> [Widget Name]+drawUI s+  | s ^. uiState . uiPlaying = drawGameUI s+  | otherwise = case s ^. uiState . uiMenu of+    -- We should never reach the NoMenu case if uiPlaying is false; we would have+    -- quit the app instead.  But just in case, we display the main menu anyway.+    NoMenu -> [drawMainMenuUI s (mainMenu NewGame)]+    MainMenu l -> [drawMainMenuUI s l]+    NewGameMenu stk -> [drawNewGameMenuUI stk]+    MessagesMenu -> [drawMainMessages s]+    AboutMenu -> [drawAboutMenuUI (s ^. uiState . appData . at "about")]++drawMainMessages :: AppState -> Widget Name+drawMainMessages s = renderDialog dial . padBottom Max . scrollList $ drawLogs ls+ where+  ls = reverse $ s ^. runtimeState . eventLog . notificationsContent+  dial = dialog (Just "Messages") Nothing maxModalWindowWidth+  scrollList = withVScrollBars OnRight . vBox+  drawLogs = map (drawLogEntry True)++drawMainMenuUI :: AppState -> BL.List Name MainMenuEntry -> Widget Name+drawMainMenuUI s l =+  vBox . catMaybes $+    [ drawLogo <$> logo+    , hCenter . padTopBottom 2 <$> newVersionWidget version+    , Just . centerLayer . vLimit 5 . hLimit 20 $+        BL.renderList (const (hCenter . drawMainMenuEntry s)) True l+    ]+ where+  logo = s ^. uiState . appData . at "logo"+  version = s ^. runtimeState . upstreamRelease++newVersionWidget :: Either NewReleaseFailure String -> Maybe (Widget n)+newVersionWidget = \case+  Right ver -> Just . txt $ "New version " <> T.pack ver <> " is available!"+  Left (OnDevelopmentBranch _b) -> Just . txt $ "Good luck developing!"+  Left (FailedReleaseQuery _f) -> Nothing+  Left (NoMainUpstreamRelease _fails) -> Nothing+  Left (OldUpstreamRelease _up _my) -> Nothing++drawLogo :: Text -> Widget Name+drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws) []) . T.lines+ where+  drawThing :: Char -> Widget Name+  drawThing c = withAttr (attrFor c) $ str [c]++  attrFor :: Char -> AttrName+  attrFor c+    | c `elem` ("<>v^" :: String) = robotAttr+  attrFor 'T' = plantAttr+  attrFor '@' = rockAttr+  attrFor '~' = waterAttr+  attrFor '▒' = dirtAttr+  attrFor _ = defAttr++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))+      ]+ where+  drawScenarioItem (SISingle s si) = padRight (Pad 1) (drawStatusInfo s si) <+> txt (s ^. scenarioName)+  drawScenarioItem (SICollection nm _) = padRight (Pad 1) (withAttr boldAttr $ txt " > ") <+> txt nm+  drawStatusInfo s si = case si ^. scenarioBestTime of+    NotStarted -> txt " ○ "+    InProgress {} -> case s ^. scenarioObjectives of+      [] -> withAttr cyanAttr $ txt " ◉ "+      _ -> withAttr yellowAttr $ txt " ◎ "+    Complete {} -> withAttr greenAttr $ txt " ● "++  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"++  breadcrumbs :: [BL.List Name ScenarioItem] -> Text+  breadcrumbs =+    T.intercalate " > "+      . ("Scenarios" :)+      . reverse+      . mapMaybe (fmap (scenarioItemName . snd) . BL.listSelectedElement)++  drawDescription :: ScenarioItem -> Widget Name+  drawDescription (SICollection _ _) = txtWrap " "+  drawDescription (SISingle s si) = 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)+      ]++  nonBlank "" = " "+  nonBlank t = t++drawMainMenuEntry :: AppState -> MainMenuEntry -> Widget Name+drawMainMenuEntry s = \case+  NewGame -> txt "New game"+  Tutorial -> txt "Tutorial"+  About -> txt "About"+  Messages -> highlightMessages $ txt "Messages"+  Quit -> txt "Quit"+ where+  highlightMessages =+    if s ^. runtimeState . eventLog . notificationsCount > 0+      then withAttr notifAttr+      else id++drawAboutMenuUI :: Maybe Text -> Widget Name+drawAboutMenuUI Nothing = centerLayer $ txt "About swarm!"+drawAboutMenuUI (Just t) = centerLayer . vBox . map (hCenter . txt . nonblank) $ T.lines t+ where+  -- Turn blank lines into a space so they will take up vertical space as widgets+  nonblank "" = " "+  nonblank s = s++-- | Draw the main game UI.  Generates a list of widgets, where each+--   represents a layer.  Right now we just generate two layers: the+--   main layer and a layer for a floating dialog that can be on top.+drawGameUI :: AppState -> [Widget Name]+drawGameUI s =+  [ drawDialog s+  , joinBorders $+      hBox+        [ hLimitPercent 25 $+            vBox+              [ vLimitPercent 50 $ panel highlightAttr fr RobotPanel plainBorder $ drawRobotPanel s+              , panel+                  highlightAttr+                  fr+                  InfoPanel+                  ( plainBorder+                      & topLabels . centerLabel+                      .~ (if moreTop then Just (txt " · · · ") else Nothing)+                      & bottomLabels . centerLabel+                      .~ (if moreBot then Just (txt " · · · ") else Nothing)+                  )+                  $ drawInfoPanel s+              ]+        , vBox+            [ panel+                highlightAttr+                fr+                WorldPanel+                ( plainBorder+                    & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s)+                    & topLabels . leftLabel ?~ drawModalMenu s+                    & addCursorPos+                    & addClock+                )+                (drawWorld $ s ^. gameState)+            , drawKeyMenu s+            , clickable REPLPanel $+                panel+                  highlightAttr+                  fr+                  REPLPanel+                  ( plainBorder+                      & topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiReplType))+                  )+                  ( vLimit replHeight+                      . padBottom Max+                      . padLeftRight 1+                      $ drawREPL s+                  )+            ]+        ]+  ]+ where+  addCursorPos = case s ^. uiState . uiWorldCursor of+    Just coord -> bottomLabels . leftLabel ?~ padLeftRight 1 (drawWorldCursorInfo (s ^. gameState) coord)+    Nothing -> id+  -- Add clock display in top right of the world view if focused robot+  -- has a clock installed+  addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay $ s ^. gameState)+  fr = s ^. uiState . uiFocusRing+  moreTop = s ^. uiState . uiMoreInfoTop+  moreBot = s ^. uiState . uiMoreInfoBot++drawWorldCursorInfo :: GameState -> W.Coords -> Widget Name+drawWorldCursorInfo g i@(W.Coords (y, x)) =+  hBox [drawLoc g i, txt $ " at " <> from (show x) <> " " <> from (show (y * (-1)))]++-- | 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]+ where+  clockWidget = maybeDrawTime (gs ^. ticks) (gs ^. paused) gs+  pauseWidget = guard (gs ^. paused) $> txt "(PAUSED)"++-- | Check whether the currently focused robot (if any) has a clock+--   device installed.+clockInstalled :: GameState -> Bool+clockInstalled gs = case focusedRobot gs of+  Nothing -> False+  Just r+    | countByName "clock" (r ^. installedDevices) > 0 -> True+    | 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))+    ]+      ++ if showTicks then [".", printf "%x" (t .&. ((1 `shiftL` 4) - 1))] else []++-- | Return a possible time display, if the currently focused robot+--   has a clock device installed.  The first argument is the number+--   of ticks (e.g. 943 = 0x3af), and the second argument indicates+--   whether the time should be shown down to single-tick resolution+--   (e.g. 0:00:3a.f) or not (e.g. 0:00:3a).+maybeDrawTime :: Integer -> Bool -> GameState -> Maybe (Widget n)+maybeDrawTime t showTicks gs = guard (clockInstalled gs) $> drawTime t showTicks++-- | 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 info about the current number of ticks per second.+drawTPS :: AppState -> Widget Name+drawTPS s = hBox (tpsInfo : rateInfo)+ where+  tpsInfo+    | l >= 0 = hBox [str (show n), txt " ", txt (number n "tick"), txt " / s"]+    | otherwise = hBox [txt "1 tick / ", str (show n), txt " s"]++  rateInfo+    | s ^. uiState . uiShowFPS =+      [ txt " ("+      , str (printf "%0.1f" (s ^. uiState . uiTPF))+      , txt " tpf, "+      , str (printf "%0.1f" (s ^. uiState . uiFPS))+      , txt " fps)"+      ]+    | otherwise = []++  l = s ^. uiState . lgTicksPerSecond+  n = 2 ^ abs l++-- | The height of the REPL box.  Perhaps in the future this should be+--   configurable.+replHeight :: Int+replHeight = 10++-- | Hide the cursor when a modal is set+chooseCursor :: AppState -> [CursorLocation n] -> Maybe (CursorLocation n)+chooseCursor s locs = case s ^. uiState . uiModal of+  Nothing -> showFirstCursor s locs+  Just _ -> Nothing++-- | Width cap for modal and error message windows+maxModalWindowWidth :: Int+maxModalWindowWidth = 500++-- | Render the error dialog window with a given error message+renderErrorDialog :: Text -> Widget Name+renderErrorDialog err = renderDialog (dialog (Just "Error") Nothing (maxModalWindowWidth `min` requiredWidth)) errContent+ where+  errContent = txtWrapWith indent2 {preserveIndentation = True} err+  requiredWidth = 2 + maximum (textWidth <$> T.lines err)++-- | Draw the error dialog window, if it should be displayed right now.+drawDialog :: AppState -> Widget Name+drawDialog s = case s ^. uiState . uiModal of+  Just (Modal mt d) -> renderDialog d (maybeScroll ModalViewport $ drawModal s mt)+  Nothing -> maybe emptyWidget renderErrorDialog (s ^. uiState . uiError)++-- | Make a widget scrolling if it is bigger than the available+--   vertical space.  Thanks to jtdaugherty for this code.+maybeScroll :: (Ord n, Show n) => n -> Widget n -> Widget n+maybeScroll vpName contents =+  Widget Greedy Greedy $ do+    ctx <- getContext+    result <- withReaderT (availHeightL .~ 10000) (render contents)+    if V.imageHeight (result ^. imageL) <= ctx ^. availHeightL+      then return result+      else+        render $+          withVScrollBars OnRight $+            viewport vpName Vertical $+              Widget Fixed Fixed $+                return result++-- | Draw one of the various types of modal dialog.+drawModal :: AppState -> ModalType -> Widget Name+drawModal s = \case+  HelpModal -> helpWidget (s ^. gameState . seed) (s ^. runtimeState . webPort)+  RobotsModal -> robotsListWidget s+  RecipesModal -> availableListWidget (s ^. gameState) RecipeList+  CommandsModal -> availableListWidget (s ^. gameState) CommandList+  MessagesModal -> availableListWidget (s ^. gameState) MessageList+  WinModal -> padBottom (Pad 1) $ hCenter $ txt "Congratulations!"+  DescriptionModal e -> descriptionWidget s e+  QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg (s ^. uiState . uiMenu))+  GoalModal g -> padLeftRight 1 (displayParagraphs g)++quitMsg :: Menu -> Text+quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress will be lost!"+ where+  quitAction = case m of+    NoMenu -> "quit"+    _ -> "quit and return to the menu"++-- | Generate a fresh modal window of the requested type.+generateModal :: AppState -> ModalType -> Modal+generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth))+ where+  haltingMessage = case s ^. uiState . uiMenu of+    NoMenu -> Just "Quit"+    _ -> Nothing+  descriptionWidth = 100+  helpWidth = 80+  (title, buttons, requiredWidth) =+    case mt of+      HelpModal -> (" Help ", Nothing, helpWidth)+      RobotsModal -> ("Robots", Nothing, descriptionWidth)+      RecipesModal -> ("Available Recipes", Nothing, descriptionWidth)+      CommandsModal -> ("Available Commands", Nothing, descriptionWidth)+      MessagesModal -> ("Messages", Nothing, descriptionWidth)+      WinModal ->+        let nextMsg = "Next challenge!"+            stopMsg = fromMaybe "Return to the menu" haltingMessage+            continueMsg = "Keep playing"+         in ( ""+            , Just+                ( 0+                , [ (nextMsg, NextButton scene)+                  | Just scene <- [nextScenario (s ^. uiState . uiMenu)]+                  ]+                    ++ [ (stopMsg, QuitButton)+                       , (continueMsg, CancelButton)+                       ]+                )+            , sum (map length [nextMsg, stopMsg, continueMsg]) + 32+            )+      DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth)+      QuitModal ->+        let stopMsg = fromMaybe "Quit to menu" haltingMessage+         in ( ""+            , Just (0, [("Keep playing", CancelButton), (stopMsg, QuitButton)])+            , T.length (quitMsg (s ^. uiState . uiMenu)) + 4+            )+      GoalModal _ -> (" Goal ", Nothing, 80)++robotsListWidget :: AppState -> Widget Name+robotsListWidget s = hCenter table+ where+  table =+    BT.renderTable+      . BT.columnBorders False+      . BT.setDefaultColAlignment BT.AlignCenter+      -- Inventory count is right aligned+      . BT.alignRight 4+      . BT.table+      $ map (padLeftRight 1) <$> (headers : robotsTable)+  headers =+    withAttr robotAttr+      <$> [ txt "Name"+          , txt "Age"+          , txt "Position"+          , txt "Inventory"+          , txt "Status"+          , txt "Log"+          ]+  robotsTable = mkRobotRow <$> robots+  mkRobotRow robot =+    [ nameWidget+    , txt $ from ageStr+    , locWidget+    , padRight (Pad 1) (txt $ from $ show rInvCount)+    , statusWidget+    , txt rLog+    ]+   where+    nameWidget = hBox [renderDisplay (robot ^. robotDisplay), higlightSystem . txt $ " " <> robot ^. robotName]+    higlightSystem = if robot ^. systemRobot then withAttr highlightAttr else id++    ageStr+      | age < 60 = show age <> "sec"+      | age < 3600 = show (age `div` 60) <> "min"+      | age < 3600 * 24 = show (age `div` 3600) <> "hour"+      | otherwise = show (age `div` 3600 * 24) <> "day"+     where+      TimeSpec createdAtSec _ = robot ^. robotCreatedAt+      TimeSpec nowSec _ = s ^. uiState . lastFrameTime+      age = nowSec - createdAtSec++    rInvCount = sum $ map fst . E.elems $ robot ^. robotEntity . entityInventory+    rLog+      | robot ^. robotLogUpdated = "x"+      | otherwise = " "++    locWidget = hBox [worldCell, txt $ " " <> locStr]+     where+      rloc@(V2 x y) = robot ^. robotLocation+      worldCell = drawLoc g (W.locToCoords rloc)+      locStr = from (show x) <> " " <> from (show y)++    statusWidget = case robot ^. machine of+      Waiting {} -> txt "waiting"+      _+        | isActive robot -> withAttr notifAttr $ txt "busy"+        | otherwise -> withAttr greenAttr $ txt "idle"++  basePos :: V2 Double+  basePos = realToFrac <$> fromMaybe (V2 0 0) (g ^? robotMap . ix 0 . robotLocation)+  -- Keep the base and non sytem robot (e.g. no seed)+  isRelevant robot = robot ^. robotID == 0 || not (robot ^. systemRobot)+  -- Keep the robot that are less than 32 unit away from the base+  isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation) basePos < 32+  robots :: [Robot]+  robots =+    filter (\robot -> debugging || (isRelevant robot && isNear robot))+      . IM.elems+      $ g ^. robotMap+  creative = g ^. creativeMode+  cheat = s ^. uiState . uiCheatMode+  debugging = creative && cheat+  g = s ^. gameState++helpWidget :: Seed -> Maybe Port -> Widget Name+helpWidget theSeed mport =+  padTop (Pad 1) $+    (hBox . map (padLeftRight 2) $ [helpKeys, info])+      <=> padTop (Pad 1) (hCenter tips)+ where+  tips =+    vBox+      [ txt "Have questions? Want some tips? Check out:"+      , txt " "+      , txt "  - The Swarm wiki, https://github.com/swarm-game/swarm/wiki"+      , txt "  - The #swarm IRC channel on Libera.Chat"+      ]+  info =+    vBox+      [ txt "Configuration"+      , txt " "+      , txt ("Seed: " <> into @Text (show theSeed))+      , txt ("Web server port: " <> maybe "none" (into @Text . show) mport)+      ]+  helpKeys =+    vBox+      [ txt "Keybindings"+      , txt " "+      , mkTable glKeyBindings+      ]+  mkTable =+    BT.renderTable+      . BT.surroundingBorder False+      . BT.rowBorders False+      . BT.table+      . map toRow+  toRow (k, v) = [padRight (Pad 1) $ txt k, padLeft (Pad 1) $ txt v]+  glKeyBindings =+    [ ("F1", "Help")+    , ("F2", "Robots list")+    , ("F3", "Available recipes")+    , ("F4", "Available commands")+    , ("F5", "Messages")+    , ("Ctrl-g", "show goal")+    , ("Ctrl-p", "pause")+    , ("Ctrl-o", "single step")+    , ("Ctrl-z", "decrease speed")+    , ("Ctrl-w", "increase speed")+    , ("Ctrl-q", "quit the game")+    , ("Meta-w", "focus on the world map")+    , ("Meta-e", "focus on the robot inventory")+    , ("Meta-r", "focus on the REPL")+    , ("Meta-t", "focus on the info panel")+    ]++data NotificationList = RecipeList | CommandList | MessageList++availableListWidget :: GameState -> NotificationList -> Widget Name+availableListWidget gs nl = padTop (Pad 1) $ vBox widgetList+ where+  widgetList = case nl of+    RecipeList -> mkAvailableList gs availableRecipes renderRecipe+    CommandList -> mkAvailableList gs availableCommands renderCommand & (<> constWiki) . (padLeftRight 18 constHeader :)+    MessageList -> messagesWidget gs+  renderRecipe = padLeftRight 18 . drawRecipe Nothing (fromMaybe E.empty inv)+  inv = gs ^? to focusedRobot . _Just . robotInventory+  renderCommand = padLeftRight 18 . drawConst++mkAvailableList :: GameState -> Lens' GameState (Notifications a) -> (a -> Widget Name) -> [Widget Name]+mkAvailableList gs notifLens notifRender = map padRender news <> notifSep <> map padRender knowns+ where+  padRender = padBottom (Pad 1) . notifRender+  count = gs ^. notifLens . notificationsCount+  (news, knowns) = splitAt count (gs ^. notifLens . notificationsContent)+  notifSep+    | count > 0 && not (null knowns) =+      [ padBottom (Pad 1) (withAttr redAttr $ hBorderWithLabel (padLeftRight 1 (txt "new↑")))+      ]+    | otherwise = []++constHeader :: Widget Name+constHeader = padBottom (Pad 1) $ withAttr robotAttr $ padLeft (Pad 1) $ txt "command name : type"++constWiki :: [Widget Name]+constWiki =+  padLeftRight 13+    <$> [ padTop (Pad 2) $ txt "For the full list of available commands see the Wiki at:"+        , txt "https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet"+        ]++drawConst :: Const -> Widget Name+drawConst c = hBox [padLeft (Pad $ 13 - T.length constName) (txt constName), txt constSig]+ where+  constName = syntax . constInfo $ c+  constSig = " : " <> prettyText (inferConst c)++descriptionTitle :: Entity -> String+descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " "++-- | Generate a pop-up widget to display the description of an entity.+descriptionWidget :: AppState -> Entity -> Widget Name+descriptionWidget s e = padLeftRight 1 (explainEntry s e)++-- | Draw a widget with messages to the current robot.+messagesWidget :: GameState -> [Widget Name]+messagesWidget gs = widgetList+ where+  widgetList = focusNewest . map drawLogEntry' $ gs ^. messageNotifications . notificationsContent+  focusNewest = if gs ^. paused then id else over _last visible+  drawLogEntry' e =+    withAttr (colorLogs e) $+      hBox+        [ fromMaybe (txt "") $ maybeDrawTime (e ^. leTime) True gs+        , padLeft (Pad 2) . txt $ "[" <> e ^. leRobotName <> "]"+        , padLeft (Pad 1) . txt2 $ e ^. leText+        ]+  txt2 = txtWrapWith indent2++colorLogs :: LogEntry -> AttrName+colorLogs e = case e ^. leSaid of+  Said -> robotColor (e ^. leRobotID)+  Logged -> notifAttr+  ErrorTrace -> redAttr+ where+  -- color each robot message with different color of the world+  robotColor rid = fgCols !! (rid `mod` fgColLen)+  fgCols = map fst worldAttributes+  fgColLen = length fgCols++-- | Draw the F-key modal menu. This is displayed in the top left world corner.+drawModalMenu :: AppState -> Widget Name+drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyCmds+ where+  notificationKey :: Getter GameState (Notifications a) -> Text -> Text -> Maybe (KeyHighlight, Text, Text)+  notificationKey notifLens key name+    | null (s ^. gameState . notifLens . notificationsContent) = Nothing+    | otherwise =+      let highlight+            | s ^. gameState . notifLens . notificationsCount > 0 = Highlighted+            | otherwise = NoHighlight+       in Just (highlight, key, name)++  globalKeyCmds =+    catMaybes+      [ Just (NoHighlight, "F1", "Help")+      , Just (NoHighlight, "F2", "Robots")+      , notificationKey availableRecipes "F3" "Recipes"+      , notificationKey availableCommands "F4" "Commands"+      , notificationKey messageNotifications "F5" "Messages"+      ]++-- | Draw a menu explaining what key commands are available for the+--   current panel.  This menu is displayed as a single line in+--   between the world panel and the REPL.+--+-- This excludes the F-key modals that are shown elsewhere.+drawKeyMenu :: AppState -> Widget Name+drawKeyMenu s =+  vLimit 1+    . hBox+    . (++ [gameModeWidget])+    . map (padLeftRight 1 . drawKeyCmd)+    . (globalKeyCmds ++)+    . map (\(k, n) -> (NoHighlight, k, n))+    . keyCmdsFor+    . focusGetCurrent+    . view (uiState . uiFocusRing)+    $ s+ where+  isReplWorking = s ^. gameState . replWorking+  isPaused = s ^. gameState . paused+  viewingBase = (s ^. gameState . viewCenterRule) == VCRobot 0+  creative = s ^. gameState . creativeMode+  cheat = s ^. uiState . uiCheatMode+  goal = case s ^. uiState . uiGoal of+    Just g | g /= [] -> True+    _ -> False+  showZero = s ^. uiState . uiShowZero++  gameModeWidget =+    padLeft Max . padLeftRight 1+      . txt+      . (<> " mode")+      $ case creative of+        False -> "Classic"+        True -> "Creative"+  globalKeyCmds =+    catMaybes+      [ may goal (NoHighlight, "^g", "goal")+      , may cheat (NoHighlight, "^v", "creative")+      , Just (NoHighlight, "^p", if isPaused then "unpause" else "pause")+      , Just (NoHighlight, "^o", "step")+      , Just (NoHighlight, "^zx", "speed")+      ]+  may b = if b then Just else const Nothing++  keyCmdsFor (Just REPLPanel) =+    [ ("↓↑", "history")+    ]+      ++ [("Ret", "execute") | not isReplWorking]+      ++ [("^c", "cancel") | isReplWorking]+  keyCmdsFor (Just WorldPanel) =+    [ ("←↓↑→ / hjkl", "scroll") | creative+    ]+      ++ [("c", "recenter") | not viewingBase]+  keyCmdsFor (Just RobotPanel) =+    [ ("Ret", "focus")+    , ("m", "make")+    , ("0", (if showZero then "hide" else "show") <> " 0")+    ]+  keyCmdsFor (Just InfoPanel) = []+  keyCmdsFor _ = []++data KeyHighlight = NoHighlight | Highlighted++-- | Draw a single key command in the menu.+drawKeyCmd :: (KeyHighlight, Text, Text) -> Widget Name+drawKeyCmd (Highlighted, key, cmd) = hBox [withAttr notifAttr (txt $ T.concat ["[", key, "] "]), txt cmd]+drawKeyCmd (NoHighlight, key, cmd) = txt $ T.concat ["[", key, "] ", cmd]++------------------------------------------------------------+-- World panel+------------------------------------------------------------++-- | Draw the current world view.+drawWorld :: GameState -> Widget Name+drawWorld g =+  center+    . cached WorldCache+    . reportExtent WorldExtent+    -- Set the clickable request after the extent to play nice with the cache+    . clickable WorldPanel+    . Widget Fixed Fixed+    $ do+      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 g) $ ixs++-- | Render the 'Display' for a specific location.+drawLoc :: GameState -> W.Coords -> Widget Name+drawLoc g = renderDisplay . displayLoc g++-- | Get the 'Display' for a specific location, by combining the+--   'Display's for the terrain, entity, and robots at the location.+displayLoc :: GameState -> W.Coords -> Display+displayLoc g coords =+  sconcat . NE.fromList $+    [terrainMap M.! toEnum (W.lookupTerrain coords (g ^. world))]+      ++ maybeToList (displayForEntity <$> W.lookupEntity coords (g ^. world))+      ++ map (view robotDisplay) (robotsAtLocation (W.coordsToLoc coords) g)+ where+  displayForEntity :: Entity -> Display+  displayForEntity e = (if known e then id else hidden) (e ^. entityDisplay)++  known e =+    e `hasProperty` Known+      || (e ^. entityName) `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++------------------------------------------------------------+-- Robot inventory panel+------------------------------------------------------------++-- | Draw info about the currently focused robot, such as its name,+--   position, orientation, and inventory.+drawRobotPanel :: AppState -> Widget Name+drawRobotPanel s = case (s ^. gameState . to focusedRobot, s ^. uiState . uiInventory) of+  (Just r, Just (_, lst)) ->+    let V2 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 " "++-- | Draw an inventory entry.+drawItem ::+  -- | The index of the currently selected inventory entry+  Maybe Int ->+  -- | The index of the entry we are drawing+  Int ->+  -- | Whether this entry is selected; we can ignore this+  --   because it will automatically have a special attribute+  --   applied to it.+  Bool ->+  -- | The entry to draw.+  InventoryListEntry ->+  Widget Name+drawItem sel i _ (Separator l) =+  -- Make sure a separator right before the focused element is+  -- visible. Otherwise, when a separator occurs as the very first+  -- element of the list, once it scrolls off the top of the viewport+  -- it will never become visible again.+  -- See https://github.com/jtdaugherty/brick/issues/336#issuecomment-921220025+  (if sel == Just (i + 1) then visible else id) $ hBorderWithLabel (txt l)+drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n+ where+  showCount = padLeft Max . str . show+drawItem _ _ _ (InstalledEntry e) = drawLabelledEntityName e <+> padLeft Max (str " ")++-- | Draw the name of an entity, labelled with its visual+--   representation as a cell in the world.+drawLabelledEntityName :: Entity -> Widget Name+drawLabelledEntityName e =+  hBox+    [ padRight (Pad 2) (renderDisplay (e ^. entityDisplay))+    , txt (e ^. entityName)+    ]++------------------------------------------------------------+-- Info panel+------------------------------------------------------------++-- | Draw the info panel in the bottom-left corner, which shows info+--   about the currently focused inventory item.+drawInfoPanel :: AppState -> Widget Name+drawInfoPanel s =+  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 (InstalledEntry e) ->+    explainEntry s e+      -- Special case: installed logger device displays the robot's log.+      <=> if e ^. entityName == "logger" then drawRobotLog s else emptyWidget+  _ -> txt " "++explainEntry :: AppState -> Entity -> Widget Name+explainEntry s e =+  vBox+    [ displayProperties (e ^. entityProperties)+    , displayParagraphs (e ^. entityDescription)+    , explainRecipes s e+    ]++displayProperties :: [EntityProperty] -> Widget Name+displayProperties = displayList . mapMaybe showProperty+ where+  showProperty Growable = Just "growing"+  showProperty Infinite = Just "infinite"+  showProperty Liquid = Just "liquid"+  showProperty Unwalkable = Just "blocking"+  -- Most things are portable so we don't show that.+  showProperty Portable = Nothing+  -- 'Known' is just a technical detail of how we handle some entities+  -- in challenge scenarios and not really something the player needs+  -- to know.+  showProperty Known = Nothing++  displayList [] = emptyWidget+  displayList ps =+    vBox+      [ hBox . L.intersperse (txt ", ") . map (withAttr robotAttr . txt) $ ps+      , txt " "+      ]++explainRecipes :: AppState -> Entity -> Widget Name+explainRecipes s e+  | null recipes = emptyWidget+  | otherwise =+    vBox+      [ padBottom (Pad 1) (hBorderWithLabel (txt "Recipes"))+      , padLeftRight 2 $+          hCenter $+            vBox $+              map (hLimit widthLimit . padBottom (Pad 1) . drawRecipe (Just e) inv) recipes+      ]+ where+  recipes = recipesWith s e++  inv = fromMaybe E.empty $ s ^? gameState . to focusedRobot . _Just . robotInventory++  width (n, ingr) =+    length (show n) + 1 + maximum0 (map T.length . T.words $ ingr ^. entityName)++  maxInputWidth =+    fromMaybe 0 $+      maximumOf (traverse . recipeInputs . traverse . to width) recipes+  maxOutputWidth =+    fromMaybe 0 $+      maximumOf (traverse . recipeOutputs . traverse . to width) recipes+  widthLimit = 2 * max maxInputWidth maxOutputWidth + 11++-- | Return all recipes that involve a given entity.+recipesWith :: AppState -> Entity -> [Recipe Entity]+recipesWith s e =+  let getRecipes select = recipesFor (s ^. gameState . select) e+   in -- The order here is chosen intentionally.  See https://github.com/swarm-game/swarm/issues/418.+      --+      --   1. Recipes where the entity is an input --- these should go+      --     first since the first thing you will want to know when you+      --     obtain a new entity is what you can do with it.+      --+      --   2. Recipes where it serves as a catalyst --- for the same reason.+      --+      --   3. Recipes where it is an output --- these should go last,+      --      since if you have it, you probably already figured out how+      --      to make it.+      L.nub $ getRecipes recipesIn ++ getRecipes recipesReq ++ getRecipes recipesOut++-- | Draw an ASCII art representation of a recipe.  For now, the+--   weight is not shown.+drawRecipe :: Maybe Entity -> Inventory -> Recipe Entity -> Widget Name+drawRecipe me inv (Recipe ins outs reqs time _weight) =+  vBox+    -- any requirements (e.g. furnace) go on top.+    [ hCenter $ drawReqs reqs+    , -- then we draw inputs, a connector, and outputs.+      hBox+        [ vBox (zipWith drawIn [0 ..] (ins <> times))+        , connector+        , vBox (zipWith drawOut [0 ..] outs)+        ]+    ]+ where+  -- The connector is either just a horizontal line ─────+  -- or, if there are requirements, a horizontal line with+  -- a vertical piece coming out of the center, ──┴── .+  connector+    | null reqs = hLimit 5 hBorder+    | otherwise =+      hBox+        [ hLimit 2 hBorder+        , joinableBorder (Edges True False True True)+        , hLimit 2 hBorder+        ]+  inLen = length ins + length times+  outLen = length outs+  times = [(fromIntegral time, timeE) | time /= 1]++  -- Draw inputs and outputs.+  drawIn, drawOut :: Int -> (Count, Entity) -> Widget Name+  drawIn i (n, ingr) =+    hBox+      [ padRight (Pad 1) $ str (show n) -- how many?+      , fmtEntityName missing ingr -- name of the input+      , padLeft (Pad 1) $ -- a connecting line:   ─────┬+          hBorder+            <+> ( joinableBorder (Edges (i /= 0) (i /= inLen - 1) True False) -- ...maybe plus vert ext:   │+                    <=> if i /= inLen - 1+                      then vLimit (subtract 1 . length . T.words $ ingr ^. entityName) vBorder+                      else emptyWidget+                )+      ]+   where+    missing = E.lookup ingr inv < n++  drawOut i (n, ingr) =+    hBox+      [ padRight (Pad 1) $+          ( joinableBorder (Edges (i /= 0) (i /= outLen - 1) False True)+              <=> if i /= outLen - 1+                then vLimit (subtract 1 . length . T.words $ ingr ^. entityName) vBorder+                else emptyWidget+          )+            <+> hBorder+      , fmtEntityName False ingr+      , padLeft (Pad 1) $ str (show n)+      ]++  -- If it's the focused entity, draw it highlighted.+  -- If the robot doesn't have any, draw it in red.+  fmtEntityName missing ingr+    | Just ingr == me = withAttr highlightAttr $ txtLines nm+    | ingr == timeE = withAttr yellowAttr $ txtLines nm+    | missing = withAttr invalidFormInputAttr $ txtLines nm+    | otherwise = txtLines nm+   where+    -- Split up multi-word names, one line per word+    nm = ingr ^. entityName+    txtLines = vBox . map txt . T.words++-- | Ad-hoc entity to represent time - only used in recipe drawing+timeE :: Entity+timeE = mkEntity (defaultEntityDisplay '.') "ticks" [] [] []++drawReqs :: IngredientList Entity -> Widget Name+drawReqs = vBox . map (hCenter . drawReq)+ where+  drawReq (1, e) = txt $ e ^. entityName+  drawReq (n, e) = str (show n) <+> txt " " <+> txt (e ^. entityName)++indent2 :: WrapSettings+indent2 = defaultWrapSettings {fillStrategy = FillIndent 2}++drawRobotLog :: AppState -> Widget Name+drawRobotLog s =+  vBox+    [ padBottom (Pad 1) (hBorderWithLabel (txt "Log"))+    , vBox . imap drawEntry $ logEntries+    ]+ where+  logEntries =+    s+      & view (gameState . to focusedRobot . _Just . robotLog)+      & Seq.sort+      & F.toList+      & uniq++  rn = s ^? gameState . to focusedRobot . _Just . robotName+  n = length logEntries++  allMe = all ((== rn) . Just . view leRobotName) logEntries++  drawEntry i e =+    (if i == n - 1 && s ^. uiState . uiScrollToEnd then visible else id) $+      drawLogEntry (not allMe) e++-- | Draw one log entry with an optional robot name first.+drawLogEntry :: Bool -> LogEntry -> Widget a+drawLogEntry addName e = withAttr (colorLogs e) . txtWrapWith indent2 $ if addName then name else t+ where+  t = e ^. leText+  name = "[" <> view leRobotName e <> "] " <> (if e ^. leSaid == Said then "said " <> quote t else t)++------------------------------------------------------------+-- REPL panel+------------------------------------------------------------++-- | Draw the REPL.+drawREPL :: AppState -> Widget Name+drawREPL s =+  vBox $+    map fmt (getLatestREPLHistoryItems (replHeight - inputLines) history)+      ++ case isActive <$> base of+        Just False -> [renderForm (s ^. uiState . uiReplForm)]+        _ -> [padRight Max $ txt "..."]+      ++ [padRight Max $ txt histIdx | debugging]+ where+  debugging = False -- Turn ON to get extra line with history index+  inputLines = 1 + fromEnum debugging+  history = s ^. uiState . uiReplHistory+  base = s ^. gameState . robotMap . at 0+  histIdx = fromString $ show (history ^. replIndex)+  fmt (REPLEntry e) = txt $ "> " <> e+  fmt (REPLOutput t) = txt t++------------------------------------------------------------+-- Utility+------------------------------------------------------------++-- | Display a list of text-wrapped paragraphs with one blank line after+--   each.+displayParagraphs :: [Text] -> Widget Name+displayParagraphs = vBox . map (padBottom (Pad 1) . txtWrap)
+ src/Swarm/Util.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# 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+-- be) used throughout the code base.+module Swarm.Util (+  -- * Miscellaneous utilities+  (?),+  maxOn,+  maximum0,+  cycleEnum,+  uniq,+  getElemsInArea,+  manhattan,++  -- * Directory utilities+  readFileMay,+  readFileMayT,+  getSwarmDataPath,+  getSwarmSavePath,+  getSwarmHistoryPath,+  readAppData,++  -- * Text utilities+  isIdentChar,+  replaceLast,++  -- * English language utilities+  reflow,+  quote,+  squote,+  commaList,+  indefinite,+  indefiniteQ,+  singularSubjectVerb,+  plural,+  number,++  -- * Validation utilities+  holdsOr,+  isJustOr,+  isRightOr,+  isSuccessOr,++  -- * Template Haskell utilities+  liftText,++  -- * Lens utilities+  (%%=),+  (<%=),+  (<+=),+  (<<.=),+  (<>=),+  _NonEmpty,++  -- * Utilities for NP-hard approximation+  smallHittingSet,+  getDataDirSafe,+  getDataFileNameSafe,+  dataNotFound,+) where++import Control.Algebra (Has)+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.Aeson (FromJSONKey, ToJSONKey)+import Data.Bifunctor (first)+import Data.Char (isAlphaNum)+import Data.Either.Validation+import Data.Int (Int64)+import Data.List (maximumBy, partition)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map (Map)+import Data.Map qualified as M+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Ord (comparing)+import Data.Set (Set)+import Data.Set qualified as S+import Data.Text (Text, toUpper)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Tuple (swap)+import Data.Yaml+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)+import Linear (V2 (V2))+import NLP.Minimorph.English qualified as MM+import NLP.Minimorph.Util ((<+>))+import Paths_swarm (getDataDir)+import System.Clock (TimeSpec)+import System.Directory (+  XdgDirectory (XdgData),+  createDirectoryIfMissing,+  doesDirectoryExist,+  doesFileExist,+  getXdgDirectory,+  listDirectory,+ )+import System.FilePath+import System.IO+import System.IO.Error (catchIOError)+import Witch++-- $setup+-- >>> import qualified Data.Map as M+-- >>> import Linear.V2++infixr 1 ?+infix 4 %%=, <+=, <%=, <<.=, <>=++-- | A convenient infix flipped version of 'fromMaybe': @Just a ? b =+--   a@, and @Nothing ? b = b@. It can also be chained, as in @x ? y ?+--   z ? def@, which takes the value inside the first @Just@,+--   defaulting to @def@ as a last resort.+(?) :: Maybe a -> a -> a+(?) = flip fromMaybe++-- | Find the maximum of two values, comparing them according to a+--   custom projection function.+maxOn :: Ord b => (a -> b) -> a -> a -> a+maxOn f x y+  | f x > f y = x+  | otherwise = y++-- | Find the maximum of a list of numbers, defaulting to 0 if the+--   list is empty.+maximum0 :: (Num a, Ord a) => [a] -> a+maximum0 [] = 0+maximum0 xs = maximum xs++-- | Take the successor of an 'Enum' type, wrapping around when it+--   reaches the end.+cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e+cycleEnum e+  | e == maxBound = minBound+  | otherwise = succ e++-- | Drop repeated elements that are adjacent to each other.+--+-- >>> uniq []+-- []+-- >>> uniq [1..5]+-- [1,2,3,4,5]+-- >>> uniq (replicate 10 'a')+-- "a"+-- >>> uniq "abbbccd"+-- "abcd"+uniq :: Eq a => [a] -> [a]+uniq = \case+  [] -> []+  (x : xs) -> x : uniq (dropWhile (== x) xs)++-- | Manhattan distance between world locations.+manhattan :: V2 Int64 -> V2 Int64 -> Int64+manhattan (V2 x1 y1) (V2 x2 y2) = abs (x1 - x2) + abs (y1 - y2)++-- | Get elements that are in manhattan distance from location.+--+-- >>> v2s i = [(v, manhattan (V2 0 0) v) | x <- [-i..i], y <- [-i..i], let v = V2 x y]+-- >>> v2s 0+-- [(V2 0 0,0)]+-- >>> map (\i -> length (getElemsInArea (V2 0 0) 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 :: V2 Int64 -> Int64 -> Map (V2 Int64) e -> [e]+getElemsInArea o@(V2 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 (V2 (x - d) (y - 1)) -- A+      & snd -- A<+      & M.split (V2 (x + d) (y + 1)) -- B+      & fst -- B>+  sm' = M.filterWithKey (const . (<= d) . manhattan o) sm++------------------------------------------------------------+-- Directory stuff++-- | Safely attempt to read a file.+readFileMay :: FilePath -> IO (Maybe String)+readFileMay = catchIO . readFile++-- | Safely attempt to (efficiently) read a file.+readFileMayT :: FilePath -> IO (Maybe Text)+readFileMayT = catchIO . T.readFile++-- | Turns any IO error into Nothing.+catchIO :: IO a -> IO (Maybe a)+catchIO act = (Just <$> act) `catchIOError` (\_ -> return Nothing)++getDataDirSafe :: FilePath -> IO (Maybe FilePath)+getDataDirSafe p = do+  d <- mySubdir <$> getDataDir+  de <- doesDirectoryExist d+  if de+    then return $ Just d+    else do+      xd <- mySubdir . (</> "data") <$> getSwarmDataPath False+      xde <- doesDirectoryExist xd+      return $ if xde then Just xd else Nothing+ where+  mySubdir d = d `appDir` p+  appDir r = \case+    "" -> r+    "." -> r+    d -> r </> d++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++dataNotFound :: FilePath -> IO Text+dataNotFound f = do+  d <- getSwarmDataPath 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+      ]++-- | Get path to swarm data, optionally creating necessary+--   directories.+getSwarmDataPath :: Bool -> IO FilePath+getSwarmDataPath createDirs = do+  swarmData <- getXdgDirectory XdgData "swarm"+  when createDirs (createDirectoryIfMissing True swarmData)+  pure swarmData++-- | Get path to swarm saves, optionally creating necessary+--   directories.+getSwarmSavePath :: Bool -> IO FilePath+getSwarmSavePath createDirs = do+  swarmSave <- getXdgDirectory XdgData ("swarm" </> "saves")+  when createDirs (createDirectoryIfMissing True swarmSave)+  pure swarmSave++-- | Get path to swarm history, optionally creating necessary+--   directories. This could fail if user has bad permissions+--   on his own $HOME or $XDG_DATA_HOME which is unlikely.+getSwarmHistoryPath :: Bool -> IO FilePath+getSwarmHistoryPath createDirs =+  (</> "history") <$> getSwarmDataPath createDirs++-- | 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++-- | Predicate to test for characters which can be part of a valid+--   identifier: alphanumeric, underscore, or single quote.+--+-- >>> isIdentChar 'A' && isIdentChar 'b' && isIdentChar '9'+-- True+-- >>> isIdentChar '_' && isIdentChar '\''+-- True+-- >>> isIdentChar '$' || isIdentChar '.' || isIdentChar ' '+-- False+isIdentChar :: Char -> Bool+isIdentChar c = isAlphaNum c || c == '_' || c == '\''++-- | @replaceLast r t@ replaces the last word of @t@ with @r@.+--+-- >>> :set -XOverloadedStrings+-- >>> replaceLast "foo" "bar baz quux"+-- "bar baz foo"+-- >>> replaceLast "move" "(make"+-- "(move"+replaceLast :: Text -> Text -> Text+replaceLast r t = T.append (T.dropWhileEnd isIdentChar t) r++------------------------------------------------------------+-- Some language-y stuff++-- | Reflow text by removing newlines and condensing whitespace.+reflow :: Text -> Text+reflow = T.unwords . T.words++-- | Prepend a noun with the proper indefinite article (\"a\" or \"an\").+indefinite :: Text -> Text+indefinite w = MM.indefiniteDet w <+> w++-- | Prepend a noun with the proper indefinite article, and surround+--   the noun in single quotes.+indefiniteQ :: Text -> Text+indefiniteQ w = MM.indefiniteDet w <+> squote w++-- | Combine the subject word with the simple present tense of the verb.+--+-- Only some irregular verbs are handled, but it should be enough+-- to scrap some error message boilerplate and have fun!+--+-- >>> :set -XOverloadedStrings+-- >>> singularSubjectVerb "I" "be"+-- "I am"+-- >>> singularSubjectVerb "he" "can"+-- "he can"+-- >>> singularSubjectVerb "The target robot" "do"+-- "The target robot does"+singularSubjectVerb :: Text -> Text -> Text+singularSubjectVerb sub verb+  | verb == "be" = case toUpper sub of+    "I" -> "I am"+    "YOU" -> sub <+> "are"+    _ -> sub <+> "is"+  | otherwise = sub <+> (if is3rdPerson then verb3rd else verb)+ where+  is3rdPerson = toUpper sub `notElem` ["I", "YOU"]+  verb3rd+    | verb == "have" = "has"+    | verb == "can" = "can"+    | otherwise = fst $ MM.defaultVerbStuff verb++-- | Pluralize a noun.+plural :: Text -> Text+plural = MM.defaultNounPlural++-- For now, it is just MM.defaultNounPlural, which only uses heuristics;+-- in the future, if we discover specific nouns that it gets wrong,+-- we can add a lookup table.++-- | Either pluralize a noun or not, depending on the value of the+--   number.+number :: Int -> Text -> Text+number 1 = id+number _ = plural++-- | Surround some text in single quotes.+squote :: Text -> Text+squote t = T.concat ["'", t, "'"]++-- | Surround some text in double quotes.+quote :: Text -> Text+quote t = T.concat ["\"", t, "\""]++-- | Make a list of things with commas and the word "and".+commaList :: [Text] -> Text+commaList [] = ""+commaList [t] = t+commaList [s, t] = T.unwords [s, "and", t]+commaList ts = T.unwords $ map (`T.append` ",") (init ts) ++ ["and", last ts]++------------------------------------------------------------+-- Some orphan instances++deriving instance ToJSON (V2 Int64)+deriving instance FromJSON (V2 Int64)++deriving instance FromJSONKey (V2 Int64)+deriving instance ToJSONKey (V2 Int64)++deriving instance FromJSON TimeSpec+deriving instance ToJSON TimeSpec++------------------------------------------------------------+-- Validation utilities++-- | Require that a Boolean value is @True@, or throw an exception.+holdsOr :: Has (Throw e) sig m => Bool -> e -> m ()+holdsOr b e = unless b $ throwError e++-- | Require that a 'Maybe' value is 'Just', or throw an exception.+isJustOr :: Has (Throw e) sig m => Maybe a -> e -> m a+Just a `isJustOr` _ = return a+Nothing `isJustOr` e = throwError e++-- | Require that an 'Either' value is 'Right', or throw an exception+--   based on the value in the 'Left'.+isRightOr :: Has (Throw e) sig m => Either b a -> (b -> e) -> m a+Right a `isRightOr` _ = return a+Left b `isRightOr` f = throwError (f b)++-- | Require that a 'Validation' value is 'Success', or throw an exception+--   based on the value in the 'Failure'.+isSuccessOr :: Has (Throw e) sig m => Validation b a -> (b -> e) -> m a+Success a `isSuccessOr` _ = return a+Failure b `isSuccessOr` f = throwError (f b)++------------------------------------------------------------+-- Template Haskell utilities++-- See https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable+liftText :: T.Text -> Q Exp+liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt)++------------------------------------------------------------+-- Fused-Effects Lens utilities++(<+=) :: (Has (State s) sig m, Num a) => LensLike' ((,) a) s a -> a -> m a+l <+= a = l <%= (+ a)+{-# INLINE (<+=) #-}++(<%=) :: (Has (State s) sig m) => LensLike' ((,) a) s a -> (a -> a) -> m a+l <%= f = l %%= (\b -> (b, b)) . f+{-# INLINE (<%=) #-}++(%%=) :: (Has (State s) sig m) => Over p ((,) r) s s a b -> p a (r, b) -> m r+l %%= f = state (swap . l f)+{-# INLINE (%%=) #-}++(<<.=) :: (Has (State s) sig m) => LensLike ((,) a) s s a b -> b -> m a+l <<.= b = l %%= (,b)+{-# INLINE (<<.=) #-}++(<>=) :: (Has (State s) sig m, Semigroup a) => ASetter' s a -> a -> m ()+l <>= a = modify (l <>~ a)+{-# INLINE (<>=) #-}++------------------------------------------------------------+-- Other lens utilities++_NonEmpty :: Lens' (NonEmpty a) (a, [a])+_NonEmpty = lens (\(x :| xs) -> (x, xs)) (const (uncurry (:|)))++------------------------------------------------------------+-- Some utilities for NP-hard approximation++-- | Given a list of /nonempty/ sets, find a hitting set, that is, a+--   set which has at least one element in common with each set in the+--   list.  It is not guaranteed to be the /smallest possible/ such+--   set, because that is NP-hard.  Instead, we use a greedy algorithm+--   that will give us a reasonably small hitting set: first, choose+--   all elements in singleton sets, since those must necessarily be+--   chosen.  Now take any sets which are still not hit, and find an+--   element which occurs in the largest possible number of remaining+--   sets. Add this element to the set of chosen elements, and filter+--   out all the sets it hits.  Repeat, choosing a new element to hit+--   the largest number of unhit sets at each step, until all sets are+--   hit.  This algorithm produces a hitting set which might be larger+--   than optimal by a factor of lg(m), where m is the number of sets+--   in the input.+--+-- >>> import qualified Data.Set as S+-- >>> shs = smallHittingSet . map S.fromList+--+-- >>> shs ["a"]+-- fromList "a"+--+-- >>> shs ["ab", "b"]+-- fromList "b"+--+-- >>> shs ["ab", "bc"]+-- fromList "b"+--+-- >>> shs ["acd", "c", "aef", "a"]+-- fromList "ac"+--+-- >>> shs ["abc", "abd", "acd", "bcd"]+-- fromList "cd"+--+-- Here is an example of an input for which @smallHittingSet@ does+-- /not/ produce a minimal hitting set. "bc" is also a hitting set and+-- is smaller.  b, c, and d all occur in exactly two sets, but d is+-- unluckily chosen first, leaving "be" and "ac" unhit and+-- necessitating choosing one more element from each.+--+-- >>> shs ["bd", "be", "ac", "cd"]+-- fromList "cde"+smallHittingSet :: Ord a => [Set a] -> Set a+smallHittingSet ss = go fixed (filter (S.null . S.intersection fixed) choices)+ where+  (fixed, choices) = first S.unions . partition ((== 1) . S.size) . filter (not . S.null) $ ss++  go !soFar [] = soFar+  go !soFar cs = go (S.insert best soFar) (filter (not . (best `S.member`)) cs)+   where+    best = mostCommon cs++  -- Given a nonempty collection of sets, find an element which is shared among+  -- as many of them as possible.+  mostCommon :: Ord a => [Set a] -> a+  mostCommon = fst . maximumBy (comparing snd) . M.assocs . M.fromListWith (+) . map (,1 :: Int) . concatMap S.toList
+ src/Swarm/Util/Yaml.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingVia #-}+{-# 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.+module Swarm.Util.Yaml (+  With (..),+  ParserE,+  liftE,+  localE,+  withE,+  getE,+  FromJSONE (..),+  decodeFileEitherE,+  (..:),+  (..:?),+  (..!=),+  withTextE,+  withObjectE,+  withArrayE,+) where++import Control.Monad.Reader+import Data.Aeson.Key (fromText)+import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe)+import Data.Bifunctor (first)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Vector qualified as V+import Data.Yaml as Y++------------------------------------------------------------+-- WithEntities wrapper+------------------------------------------------------------++-- | A generic wrapper for computations which also depend on knowing a+--   value of type @e@.+newtype With e f a = E {runE :: e -> f a}+  deriving (Functor)+  deriving (Applicative, Monad, MonadFail) via (ReaderT e f)++-- | A 'ParserE' is a YAML 'Parser' that can also depend on knowing an+--   value of type @e@.  The @E@ used to stand for @EntityMap@, but now+--   that it is generalized, it stands for Environment.+type ParserE e = With e Parser++-- | Lift a computation that does not care about the environment+--   value.+liftE :: Functor f => f a -> With e f a+liftE = E . const++-- | Locally modify an environment.+localE :: (e' -> e) -> With e f a -> With e' f a+localE g (E f) = E (f . g)++-- | Locally merge an environment with the current one for given action.+withE :: Semigroup e => e -> With e f a -> With e f a+withE e = localE (<> e)++-- | Get the current environment.+getE :: (Monad f) => With e f e+getE = E return++------------------------------------------------------------+-- FromJSONE+------------------------------------------------------------++-- | 'FromJSONE' governs values that can be parsed from a YAML (or+--   JSON) file, but which also have access to an extra, read-only+--   environment value.+--+--   For things that don't care about the environment, the default+--   implementation of 'parseJSONE' simply calls 'parseJSON' from a+--   'FromJSON' instance.+class FromJSONE e a where+  parseJSONE :: Value -> ParserE e a+  default parseJSONE :: FromJSON a => Value -> ParserE e a+  parseJSONE = liftE . parseJSON++  parseJSONE' :: e -> Value -> Parser a+  parseJSONE' e = ($ e) . runE . parseJSONE++instance FromJSONE e Int++instance FromJSONE e a => FromJSONE e [a] where+  parseJSONE = withArrayE "[]" (traverse parseJSONE . V.toList)++instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where+  parseJSONE = withArrayE "(a, b)" $ \t ->+    let n = V.length t+     in if n == 2+          then+            (,)+              <$> parseJSONE (V.unsafeIndex t 0)+              <*> parseJSONE (V.unsafeIndex t 1)+          else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2"++------------------------------------------------------------+-- Decoding+------------------------------------------------------------++-- | Read a value from a YAML file, providing the needed extra+--   environment.+decodeFileEitherE :: FromJSONE e a => e -> FilePath -> IO (Either ParseException a)+decodeFileEitherE e file = do+  res <- decodeFileEither file :: IO (Either ParseException Value)+  return $ case res of+    Left err -> Left err+    Right v -> first AesonException $ parseEither (parseJSONE' e) v++------------------------------------------------------------+-- Accessors+------------------------------------------------------------++-- | A variant of '.:' for 'ParserE': project out a field of an+--   'Object', passing along the extra environment.+(..:) :: FromJSONE e a => Object -> Text -> ParserE e a+v ..: x = E $ \e -> explicitParseField (parseJSONE' e) v (fromText x)++-- | A variant of '.:?' for 'ParserE': project out an optional field of an+--   'Object', passing along the extra environment.+(..:?) :: FromJSONE e a => Object -> Text -> ParserE e (Maybe a)+v ..:? x = E $ \e -> explicitParseFieldMaybe (parseJSONE' e) v (fromText x)++-- | A variant of '.!=' for any functor.+(..!=) :: Functor f => f (Maybe a) -> a -> f a+p ..!= a = fromMaybe a <$> p++------------------------------------------------------------+-- Helpers+------------------------------------------------------------++withThingE ::+  (forall b. String -> (thing -> Parser b) -> Value -> Parser b) ->+  (String -> (thing -> ParserE e a) -> Value -> ParserE e a)+withThingE withThing name f = E . (\v es -> withThing name (($ es) . runE . f) v)++-- | @'withTextE' name f value@ applies @f@ to the 'Text' when @value@ is+--   a @String@ and fails otherwise.+withTextE :: String -> (Text -> ParserE e a) -> Value -> ParserE e a+withTextE = withThingE withText++-- | @'withObjectE' name f value@ applies @f@ to the 'Object' when @value@ is+--   an 'Object' and fails otherwise.+withObjectE :: String -> (Object -> ParserE e a) -> Value -> ParserE e a+withObjectE = withThingE withObject++-- | @'withArrayE' name f value@ applies @f@ to the 'Array' when @value@ is+--   an 'Array' and fails otherwise.+withArrayE :: String -> (Y.Array -> ParserE e a) -> Value -> ParserE e a+withArrayE = withThingE withArray
+ src/Swarm/Version.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      :  Swarm.Version+-- Copyright   :  Brent Yorgey+-- Maintainer  :  byorgey@gmail.com+--+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Query current and upstream Swarm version.+module Swarm.Version (+  -- * Git info+  gitInfo,+  commitInfo,+  CommitHash,+  tagVersion,++  -- * PVP version+  isSwarmReleaseTag,+  version,++  -- ** Upstream release+  tagToVersion,+  upstreamReleaseVersion,+  getNewerReleaseVersion,+  NewReleaseFailure (..),+) where++import Control.Exception (catch, displayException)+import Data.Aeson (Array, Value (..), (.:))+import Data.Bifunctor (first)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Char (isDigit)+import Data.Either (lefts, rights)+import Data.Foldable (toList)+import Data.List.Extra (breakOnEnd)+import Data.Maybe (listToMaybe)+import Data.Version (Version (..), parseVersion, showVersion)+import Data.Yaml (ParseException, Parser, decodeEither', parseEither)+import GitHash (GitInfo, giBranch, giHash, giTag, tGitInfoCwdTry)+import Network.HTTP.Client (+  HttpException,+  Request (requestHeaders),+  Response (responseBody),+  httpLbs,+  newManager,+  parseRequest,+ )+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (hUserAgent)+import Paths_swarm qualified+import Text.ParserCombinators.ReadP (readP_to_S)++-- $setup+-- >>> import Data.Bifunctor (first)+-- >>> import Data.Version (Version (..), parseVersion)+-- >>> import Text.ParserCombinators.ReadP (readP_to_S)++gitInfo :: Either String GitInfo+gitInfo = $$tGitInfoCwdTry++commitInfo :: String+commitInfo = case gitInfo of+  Left _ -> ""+  Right git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")"++type CommitHash = String++-- | Check that the tag follows the PVP versioning policy.+--+-- Note that this filters out VS Code plugin releases.+isSwarmReleaseTag :: String -> Bool+isSwarmReleaseTag = all (\c -> isDigit c || c == '.')++tagVersion :: Maybe (CommitHash, String)+tagVersion = case gitInfo of+  Left _ -> Nothing+  Right gi ->+    let t = giTag gi+        ((ta, _num), ghash) = first (first init . breakOnEnd "-" . init) $ breakOnEnd "-" t+     in if isSwarmReleaseTag ta+          then Just (ghash, ta)+          else Nothing++version :: String+version =+  let v = showVersion Paths_swarm.version+   in if v == "0.0.0.1" then "pre-alpha version" else v++-- | Get the current upstream release version if any.+upstreamReleaseVersion :: IO (Either NewReleaseFailure String)+upstreamReleaseVersion =+  catch+    (either parseFailure getRelease . decodeResp <$> sendRequest)+    (return . Left . queryFailure)+ where+  -- ------------------------------+  -- send request to GitHub API+  sendRequest :: IO (Response BSL.ByteString)+  sendRequest = do+    manager <- newManager tlsManagerSettings+    request <- parseRequest "https://api.github.com/repos/swarm-game/swarm/releases"+    httpLbs+      request {requestHeaders = [(hUserAgent, "swarm-game/swarm-swarmversion")]}+      manager+  -- ------------------------------+  -- get the latest actual release+  getRelease :: Array -> Either NewReleaseFailure String+  getRelease rs =+    let ts = parseReleases rs+        maybeRel = listToMaybe $ rights ts+     in case maybeRel of+          Nothing -> Left $ NoMainUpstreamRelease (lefts ts)+          Just rel -> Right rel+  -- ------------------------------+  -- pretty print failures+  parseFailure :: ParseException -> Either NewReleaseFailure String+  parseFailure e = Left . FailedReleaseQuery $ "Failure during response parsing: " <> displayException e+  queryFailure :: HttpException -> NewReleaseFailure+  queryFailure e = FailedReleaseQuery $ "Failure requesting GitHub releases: " <> displayException e+  -- ------------------------------+  -- parsing helpers+  decodeResp :: Response BSL.ByteString -> Either ParseException Array+  decodeResp resp = decodeEither' (BS.pack . BSL.unpack $ responseBody resp)+  parseReleases :: Array -> [Either String String]+  parseReleases = map (parseEither parseRelease) . toList++parseRelease :: Value -> Parser String+parseRelease = \case+  Object o -> do+    pre <- o .: "prerelease"+    if pre+      then fail "Not a real release!"+      else do+        t <- o .: "tag_name"+        if isSwarmReleaseTag t+          then return t+          else fail $ "The release '" <> t <> "' is not main Swarm release!"+  _otherValue -> fail "The JSON release is not an Object!"++data NewReleaseFailure where+  FailedReleaseQuery :: String -> NewReleaseFailure+  NoMainUpstreamRelease :: [String] -> NewReleaseFailure+  OnDevelopmentBranch :: String -> NewReleaseFailure+  OldUpstreamRelease :: Version -> Version -> NewReleaseFailure++instance Show NewReleaseFailure where+  show = \case+    FailedReleaseQuery e -> "Failed to query upstream release: " <> e+    NoMainUpstreamRelease fs ->+      "No upstream releases found."+        <> if null fs+          then ""+          else " Rejected:\n" <> unlines (zipWith ((<>) . show @Int) [1 ..] fs)+    OnDevelopmentBranch br -> "Currently on development branch '" <> br <> "', skipping release query."+    OldUpstreamRelease up my ->+      "Upstream release '"+        <> showVersion up+        <> "' is not newer than mine ('"+        <> showVersion my+        <> "')."++-- | Read Swarm tag as Version.+--+-- Swarm tags follow the PVP versioning scheme, so comparing them makes sense.+--+-- >>> map (first versionBranch) $ readP_to_S parseVersion "0.1.0.0"+-- [([0],".1.0.0"),([0,1],".0.0"),([0,1,0],".0"),([0,1,0,0],"")]+-- >>> Version [0,0,0,1] [] < tagToVersion "0.1.0.0"+-- True+tagToVersion :: String -> Version+tagToVersion = fst . last . readP_to_S parseVersion++-- | Get a newer upstream release version.+--+-- This function can fail if the current branch is not main,+-- if there is no Internet connection or no newer release.+getNewerReleaseVersion :: IO (Either NewReleaseFailure String)+getNewerReleaseVersion =+  case gitInfo of+    -- when using cabal install, the git info is unavailable, which is of no interest to players+    Left _e -> upstreamReleaseVersion+    Right gi ->+      if giBranch gi /= "main"+        then return . Left . OnDevelopmentBranch $ giBranch gi+        else (>>= getUpVer) <$> upstreamReleaseVersion+ where+  myVer :: Version+  myVer = Paths_swarm.version+  getUpVer :: String -> Either NewReleaseFailure String+  getUpVer upTag =+    let upVer = tagToVersion upTag+     in if myVer >= upVer+          then Left $ OldUpstreamRelease upVer myVer+          else Right upTag
+ src/Swarm/Web.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- A web service for Swarm.+--+-- The service can be started using the `--port 5357` command line argument,+-- or through the REPL by calling `Swarm.App.demoWeb`.+--+-- Once running, here are the available endpoints:+--+--   * /robots : return the list of robots+--   * /robot/ID : return a single robot identified by its id+--+-- Missing endpoints:+--+--   * TODO: #625 run endpoint to load definitions+--   * TODO: #493 export the whole game state+module Swarm.Web where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Control.Exception (Exception (displayException), IOException, catch, throwIO)+import Control.Lens ((^.))+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (IORef, readIORef)+import Data.IntMap qualified as IM+import Data.Maybe (fromMaybe)+import Network.Wai qualified+import Network.Wai.Handler.Warp qualified as Warp+import Servant+import Swarm.Game.Robot+import Swarm.Game.State+import System.Timeout (timeout)++type SwarmApi =+  "robots" :> Get '[JSON] [Robot]+    :<|> "robot" :> Capture "id" Int :> Get '[JSON] (Maybe Robot)++mkApp :: IORef GameState -> Servant.Server SwarmApi+mkApp gsRef =+  robotsHandler+    :<|> robotHandler+ where+  robotsHandler = do+    g <- liftIO (readIORef gsRef)+    pure $ IM.elems $ g ^. robotMap+  robotHandler rid = do+    g <- liftIO (readIORef gsRef)+    pure $ IM.lookup rid (g ^. robotMap)++webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef GameState -> IO ()+webMain baton port gsRef = 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 ())+    Nothing -> id+  app :: Network.Wai.Application+  app = Servant.serve (Proxy @SwarmApi) (mkApp gsRef)+  handleErr :: IOException -> IO ()+  handleErr e = case baton of+    Just mv -> putMVar mv (Left $ displayException e)+    Nothing -> throwIO e++defaultPort :: Warp.Port+defaultPort = 5357++-- | Attempt to start a web thread on the requested port, or a default+--   one if none is requested (or don't start a web thread if the+--   requested port is 0).  If an explicit port was requested, fail if+--   startup doesn't work.  Otherwise, ignore the failure.  In any+--   case, return a @Maybe Port@ value representing whether a web+--   server is actually running, and if so, what port it is on.+startWebThread :: Maybe Warp.Port -> IORef GameState -> 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 gsRef = do+  baton <- newEmptyMVar+  let port = fromMaybe defaultPort portM+  void $ forkIO $ webMain (Just baton) port gsRef+  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
+ swarm.cabal view
@@ -0,0 +1,273 @@+cabal-version:      2.4+name:               swarm+version:            0.1.0.0+synopsis:           2D resource gathering game with programmable robots++description:        Swarm is a 2D programming and resource gathering+                    game. Program your robots to explore the world and+                    collect resources, which in turn allows you to+                    build upgraded robots that can run more+                    interesting and complex programs. See the README+                    for more information and instructions on how to+                    play or contribute!++license:            BSD-3-Clause+license-file:       LICENSE+author:             Brent Yorgey+maintainer:         byorgey@gmail.com+bug-reports:        https://github.com/swarm-game/swarm/issues+copyright:          Brent Yorgey 2021+category:           Game+tested-with:        GHC ==8.10.7 || ==9.0.2 || ==9.2.4+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++source-repository head+    type:     git+    location: git://github.com/swarm-game/swarm.git++flag ci+  description: Make warnings error+  default:     False+  manual:      True++common common+  if flag(ci)+    ghc-options:    -Werror+  ghc-options:      -Wall+                    -Wcompat+                    -Widentities+                    -Wincomplete-uni-patterns+                    -Wincomplete-record-updates+                    -Wno-star-is-type+  if impl(ghc >= 8.4)+    ghc-options:    -Wpartial-fields+  default-language: Haskell2010++common stan-config+    ghc-options:      -fwrite-ide-info+                      -hiedir=.hie++-- Harmless extensions from GHC2021+common ghc2021-extensions+    ghc-options:  -Wprepositive-qualified-module+    default-extensions:+      BangPatterns+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      ExplicitForAll+      FlexibleContexts+      FlexibleInstances+      GADTSyntax+      MultiParamTypeClasses+      NumericUnderscores+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      -- Note we warn on prequalified+      ImportQualifiedPost+      -- Not GHC2021, but until we get \cases we use \case a lot+      LambdaCase++library+    import:           stan-config, common, ghc2021-extensions+    exposed-modules:  Swarm.Language.Context+                      Swarm.Language.Types+                      Swarm.Language.Syntax+                      Swarm.Language.Capability+                      Swarm.Language.Requirement+                      Swarm.Language.Parse+                      Swarm.Language.Parse.QQ+                      Swarm.Language.Pretty+                      Swarm.Language.Typecheck+                      Swarm.Language.Elaborate+                      Swarm.Language.LSP+                      Swarm.Language.Pipeline+                      Swarm.Language.Pipeline.QQ+                      Swarm.Game.CESK+                      Swarm.Game.Scenario+                      Swarm.Game.ScenarioInfo+                      Swarm.Game.Display+                      Swarm.Game.Entity+                      Swarm.Game.Exception+                      Swarm.Game.Recipe+                      Swarm.Game.Robot+                      Swarm.Game.State+                      Swarm.Game.Step+                      Swarm.Game.Terrain+                      Swarm.Game.Value+                      Swarm.Game.World+                      Swarm.Game.WorldGen+                      Swarm.TUI.Attr+                      Swarm.TUI.Border+                      Swarm.TUI.List+                      Swarm.TUI.Panel+                      Swarm.TUI.Model+                      Swarm.TUI.View+                      Swarm.TUI.Controller+                      Swarm.App+                      Swarm.Version+                      Swarm.Web+                      Swarm.Util+                      Swarm.DocGen+                      Swarm.Util.Yaml+    other-modules:    Paths_swarm+    autogen-modules:  Paths_swarm++    build-depends:    base                          >= 4.14 && < 4.17,+                      aeson                         >= 2 && < 2.1,+                      array                         >= 0.5.4 && < 0.6,+                      brick                         >= 1.0 && < 1.1,+                      bytestring                    >= 0.10 && < 0.12,+                      clock                         >= 0.8.2 && < 0.9,+                      containers                    >= 0.6.2 && < 0.7,+                      directory                     >= 1.3 && < 1.4,+                      dotgen                        >= 0.4 && < 0.5,+                      either                        >= 5.0 && < 5.1,+                      extra                         >= 1.7 && < 1.8,+                      filepath                      >= 1.4 && < 1.5,+                      fused-effects                 >= 1.1.1.1 && < 1.2,+                      fused-effects-lens            >= 1.2.0.1 && < 1.3,+                      githash                       >= 0.1.6 && < 0.2,+                      hashable                      >= 1.3.4 && < 1.5,+                      hsnoise                       >= 0.0.2 && < 0.1,+                      http-client                   >= 0.7 && < 0.8,+                      http-client-tls               >= 0.3 && < 0.4,+                      http-types                    >= 0.12 && < 0.13,+                      lens                          >= 4.19 && < 5.2,+                      linear                        >= 1.21.6 && < 1.22,+                      lsp                           >= 1.2 && < 1.5,+                      megaparsec                    >= 9.0 && < 9.3,+                      minimorph                     >= 0.3 && < 0.4,+                      mtl                           >= 2.2.2 && < 2.3,+                      murmur3                       >= 1.0.4 && < 1.1,+                      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,+                      simple-enumeration            >= 0.2 && < 0.3,+                      split                         >= 0.2.3 && < 0.3,+                      stm                           >= 2.5.0 && < 2.6,+                      syb                           >= 0.7 && < 0.8,+                      template-haskell              >= 2.16 && < 2.19,+                      text                          >= 1.2.4 && < 2.1,+                      time                          >= 1.9 && < 1.14,+                      unification-fd                >= 0.11  && < 0.12,+                      unordered-containers          >= 0.2.14 && < 0.3,+                      vector                        >= 0.12 && < 0.13,+                      vty                           >= 5.33 && < 5.37,+                      wai                           >= 3.2 && < 3.3,+                      warp                          >= 3.2 && < 3.4,+                      witch                         >= 0.3.4 && < 1.1,+                      word-wrap                     >= 0.5 && < 0.6,+                      yaml                          >= 0.11 && < 0.12,++                      -- Temporary workaround for TomMD/entropy#75.+                      -- We should be able to remove this bound once+                      -- it is fixed.+                      entropy                       <= 0.4.1.7,+    hs-source-dirs:   src+    default-language: Haskell2010+    default-extensions:+      -- Avoid unexpected unevaluated thunk buildup+      -- See discussion in #415+      StrictData++executable swarm+    import:           stan-config, common+    main-is:          Main.hs+    build-depends:    optparse-applicative          >= 0.16 && < 0.18,+                      githash                       >= 0.1.6 && < 0.2,+                      -- Imports shared with the library don't need bounds+                      base,+                      text,+                      swarm+    hs-source-dirs:   app+    default-language: Haskell2010+    ghc-options:      -threaded+    default-extensions: ImportQualifiedPost++test-suite swarm-unit+    import:           stan-config, common, ghc2021-extensions+    main-is:          Main.hs+    type:             exitcode-stdio-1.0+    other-modules:    TestEval+                      TestInventory+                      TestModel+                      TestNotification+                      TestLanguagePipeline+                      TestPretty+                      TestUtil++    build-depends:    tasty                         >= 0.10 && < 1.5,+                      tasty-hunit                   >= 0.10 && < 0.11,+                      tasty-quickcheck              >= 0.10 && < 0.11,+                      QuickCheck                    >= 2.14 && < 2.15,+                      -- Imports shared with the library don't need bounds+                      aeson,+                      base,+                      containers,+                      filepath,+                      hashable,+                      lens,+                      linear,+                      mtl,+                      swarm,+                      text,+                      witch+    hs-source-dirs:   test/unit+    default-language: Haskell2010+    ghc-options:      -threaded++test-suite swarm-integration+    import:           stan-config, common, ghc2021-extensions+    main-is:          Main.hs+    type:             exitcode-stdio-1.0++    build-depends:    tasty                         >= 0.10 && < 1.5,+                      tasty-hunit                   >= 0.10 && < 0.11,+                      tasty-expected-failure        >= 0.12 && < 0.13,+                      -- Imports shared with the library don't need bounds+                      base,+                      containers,+                      directory,+                      filepath,+                      lens,+                      linear,+                      mtl,+                      swarm,+                      text,+                      transformers,+                      witch,+                      yaml+    hs-source-dirs:   test/integration+    default-language: Haskell2010+    ghc-options:      -threaded++benchmark benchmark+  import:         stan-config, common, ghc2021-extensions+  main-is:        Benchmark.hs+  hs-source-dirs: bench+  type:           exitcode-stdio-1.0+  build-depends:  criterion                         >= 1.6.0.0 && < 1.7,+                  -- Import shared with the library don't need bounds+                  base,+                  lens,+                  linear,+                  mtl,+                  random,+                  swarm,+                  text+  default-language: Haskell2010+  ghc-options:      -threaded
+ test/integration/Main.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Swarm integration tests+module Main where++import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (^.), (^?!))+import Control.Monad (filterM, forM_, unless, void, 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)+import Data.IntSet qualified as IS+import Data.Map qualified as M+import Data.Maybe (isJust)+import Data.Text (Text)+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)+import Swarm.Game.Robot (leText, machine, robotLog, waitingUntil)+import Swarm.Game.Scenario (Scenario)+import Swarm.Game.State (+  GameState,+  WinCondition (Won),+  activeRobots,+  initGameStateForScenario,+  messageQueue,+  robotMap,+  ticks,+  waitingRobots,+  winCondition,+  winSolution,+ )+import Swarm.Game.Step (gameTick)+import Swarm.Language.Context qualified as Ctx+import Swarm.Language.Pipeline (processTerm)+import Swarm.Util.Yaml (decodeFileEitherE)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.Environment (getEnvironment)+import System.FilePath.Posix (takeExtension, (</>))+import System.Timeout (timeout)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.ExpectedFailure (expectFailBecause)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase)+import Witch (into)++main :: IO ()+main = do+  examplePaths <- acquire "example" "sw"+  scenarioPaths <- acquire "data/scenarios" "yaml"+  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+          , scenarioTests em scenarioPaths+          , testScenarioSolution ci em+          , testEditorFiles+          ]++exampleTests :: [(FilePath, String)] -> TestTree+exampleTests inputs = testGroup "Test example" (map exampleTest inputs)++exampleTest :: (FilePath, String) -> TestTree+exampleTest (path, fileContent) =+  testCase ("processTerm for contents of " ++ show path) $ do+    either (assertFailure . into @String) (const . return $ ()) value+ where+  value = processTerm $ into @Text fileContent++scenarioTests :: EntityMap -> [(FilePath, String)] -> TestTree+scenarioTests em inputs = testGroup "Test scenarios" (map (scenarioTest em) inputs)++scenarioTest :: EntityMap -> (FilePath, String) -> TestTree+scenarioTest em (path, _) =+  testCase ("parse scenario " ++ show path) (void $ getScenario em path)++getScenario :: EntityMap -> FilePath -> IO Scenario+getScenario em p = do+  res <- decodeFileEitherE em p :: IO (Either ParseException Scenario)+  case res of+    Left err -> assertFailure (prettyPrintParseException err)+    Right s -> return s++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+  | -- | You can specify more seconds if you need to.+    Sec Int+  | -- | If you absolutely have to, you can ignore timeout.+    None++time :: Time -> Int+time = \case+  Default -> 1 * sec+  Sec s -> s * sec+  None -> -1+ where+  sec :: Int+  sec = 10 ^ (6 :: Int)++testScenarioSolution :: Bool -> EntityMap -> TestTree+testScenarioSolution _ci _em =+  testGroup+    "Test scenario solutions"+    [ testGroup+        "Tutorial"+        [ testSolution Default "Tutorials/backstory"+        , testSolution (Sec 3) "Tutorials/move"+        , testSolution Default "Tutorials/craft"+        , testSolution Default "Tutorials/grab"+        , testSolution Default "Tutorials/place"+        , testSolution Default "Tutorials/types"+        , testSolution Default "Tutorials/type-errors"+        , testSolution Default "Tutorials/bind"+        , testSolution Default "Tutorials/install"+        , testSolution Default "Tutorials/build"+        , testSolution' Default "Tutorials/crash" $ \g -> do+            let rs = toList $ g ^. robotMap+            let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog+            let win = isJust $ find hints rs+            assertBool "Could not find a robot with winning instructions!" win+        , testSolution Default "Tutorials/scan"+        , testSolution Default "Tutorials/def"+        , testSolution Default "Tutorials/lambda"+        , testSolution Default "Tutorials/require"+        , testSolution Default "Tutorials/requireinv"+        , testSolution Default "Tutorials/conditionals"+        , testSolution (Sec 5) "Tutorials/farming"+        ]+    , testGroup+        "Challenges"+        [ testSolution Default "Challenges/chess_horse"+        , testSolution Default "Challenges/teleport"+        , testSolution (Sec 5) "Challenges/2048"+        , testSolution (Sec 10) "Challenges/hanoi"+        , testGroup+            "Mazes"+            [ testSolution Default "Challenges/Mazes/easy_cave_maze"+            , testSolution Default "Challenges/Mazes/easy_spiral_maze"+            , testSolution Default "Challenges/Mazes/invisible_maze"+            , testSolution Default "Challenges/Mazes/loopy_maze"+            ]+        ]+    , testGroup+        "Regression tests"+        [ expectFailBecause "Awaiting fix (#394)" $+            testSolution Default "Testing/394-build-drill"+        , testSolution Default "Testing/373-drill"+        , testSolution Default "Testing/428-drowning-destroy"+        , testSolution' Default "Testing/475-wait-one" $ \g -> do+            let t = g ^. ticks+                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 one tick" $ t == 1+            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+        , testSolution Default "Testing/490-harvest"+        , testSolution Default "Testing/504-teleport-self"+        , testSolution Default "Testing/508-capability-subset"+        , testGroup+            "Require (#201)"+            [ testSolution Default "Testing/201-require/201-require-device"+            , testSolution Default "Testing/201-require/201-require-device-creative"+            , testSolution Default "Testing/201-require/201-require-device-creative1"+            , testSolution Default "Testing/201-require/201-require-entities"+            , expectFailBecause "Awaiting fix (#540)" $+                testSolution Default "Testing/201-require/201-require-entities-def"+            , testSolution Default "Testing/201-require/533-reprogram-simple"+            , testSolution Default "Testing/201-require/533-reprogram"+            ]+        , testSolution Default "Testing/479-atomic-race"+        , testSolution (Sec 5) "Testing/479-atomic"+        , testSolution Default "Testing/555-teleport-location"+        , expectFailBecause "Awaiting fix (#540)" $+            testSolution (Sec 10) "Testing/562-lodestone"+        , testSolution Default "Testing/378-objectives"+        , testSolution Default "Testing/684-swap"+        , testSolution Default "Testing/699-movement-fail/699-move-blocked"+        , testSolution Default "Testing/699-movement-fail/699-move-liquid"+        , testSolution Default "Testing/699-movement-fail/699-teleport-blocked"+        , testSolution Default "Testing/710-multi-robot"+        ]+    ]+ where+  -- expectFailIf :: Bool -> String -> TestTree -> TestTree+  -- expectFailIf b = if b then expectFailBecause else (\_ x -> x)++  testSolution :: Time -> FilePath -> TestTree+  testSolution s p = testSolution' s p (const $ pure ())++  testSolution' :: Time -> FilePath -> (GameState -> Assertion) -> TestTree+  testSolution' s p verify = testCase p $ do+    Right gs <- runExceptT $ initGameStateForScenario p Nothing Nothing+    case gs ^. winSolution of+      Nothing -> assertFailure "No solution to test!"+      Just sol -> do+        let gs' = gs & robotMap . ix 0 . machine .~ initMachine sol Ctx.empty emptyStore+        m <- timeout (time s) (snd <$> runStateT playUntilWin gs')+        case m of+          Nothing -> assertFailure "Timed out - this likely means that the solution did not work."+          Just g -> do+            -- When debugging, try logging all robot messages.+            -- printAllLogs+            noBadErrors g+            verify g++  playUntilWin :: StateT GameState IO ()+  playUntilWin = do+    w <- use winCondition+    b <- gets badErrorsInLogs+    when (null b) $ case w of+      Won _ -> return ()+      _ -> gameTick >> playUntilWin++noBadErrors :: GameState -> Assertion+noBadErrors g = do+  let bad = badErrorsInLogs g+  unless (null bad) (assertFailure . T.unpack . T.unlines . take 5 $ nubOrd bad)++badErrorsInLogs :: GameState -> [Text]+badErrorsInLogs g =+  concatMap+    (\r -> filter isBad (seqToTexts $ r ^. robotLog))+    (g ^. robotMap)+    <> filter isBad (seqToTexts $ g ^. messageQueue)+ where+  seqToTexts = map (view leText) . toList+  isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m++printAllLogs :: GameState -> IO ()+printAllLogs g =+  mapM_+    (\r -> forM_ (r ^. robotLog) (putStrLn . T.unpack . view leText))+    (g ^. robotMap)++-- | Test that editor files are up-to-date.+testEditorFiles :: TestTree+testEditorFiles =+  testGroup+    "editors"+    [ testGroup+        "VS Code"+        [ testTextInVSCode "operators" (const DocGen.operatorNames)+        , testTextInVSCode "builtin" DocGen.builtinFunctionList+        , testTextInVSCode "commands" DocGen.keywordsCommands+        , testTextInVSCode "directions" DocGen.keywordsDirections+        ]+    , testGroup+        "Emacs"+        [ testTextInEmacs "builtin" DocGen.builtinFunctionList+        , testTextInEmacs "commands" DocGen.keywordsCommands+        , testTextInEmacs "directions" DocGen.keywordsDirections+        ]+    ]+ where+  testTextInVSCode name tf = testTextInFile False name (tf VSCode) "editors/vscode/syntaxes/swarm.tmLanguage.json"+  testTextInEmacs name tf = testTextInFile True name (tf Emacs) "editors/emacs/swarm-mode.el"+  testTextInFile :: Bool -> String -> Text -> FilePath -> TestTree+  testTextInFile whitespace name t fp = testCase name $ do+    let removeLW' = T.unlines . map (T.dropWhile isSpace) . T.lines+        removeLW = if whitespace then removeLW' else id+    f <- T.readFile fp+    assertBool+      ( "EDITOR FILE IS NOT UP TO DATE!\n"+          <> "I could not find the text:\n"+          <> T.unpack t+          <> "\nin file "+          <> fp+      )+      (removeLW t `T.isInfixOf` removeLW f)
+ test/unit/Main.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Swarm unit tests+module Main where++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 Test.QuickCheck qualified as QC+import Test.QuickCheck.Poly qualified as QC+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertFailure)+import Test.Tasty.QuickCheck (+  Arbitrary (arbitrary),+  Property,+  testProperty,+  (==>),+ )+import TestEval (testEval)+import TestInventory (testInventory)+import TestLanguagePipeline (testLanguagePipeline)+import TestModel (testModel)+import TestNotification (testNotification)+import TestPretty (testPrettyConst)+import Witch (from)++main :: IO ()+main = do+  mg <- runExceptT classicGame0+  case mg of+    Left err -> assertFailure (from err)+    Right g -> defaultMain (tests g)++tests :: GameState -> TestTree+tests g =+  testGroup+    "Tests"+    [ testLanguagePipeline+    , testPrettyConst+    , testEval g+    , testModel+    , testInventory+    , testNotification g+    , testMisc+    ]++testMisc :: TestTree+testMisc =+  testGroup+    "Miscellaneous"+    [ testProperty+        "smallHittingSet produces hitting sets"+        (prop_hittingSet @QC.OrdA)+    ]++prop_hittingSet :: Ord a => [Set a] -> Property+prop_hittingSet ss = not (any S.null ss) ==> isHittingSet (smallHittingSet ss) ss++isHittingSet :: (Foldable t, Ord a) => Set a -> t (Set a) -> Bool+isHittingSet hs = not . any (S.null . S.intersection hs)++-- This property does *not* hold (and should not, because the problem+-- of producing a minimal hitting set is NP-hard), but we can use it+-- to generate counterexamples.+prop_hittingSetMinimal :: [Set El] -> Property+prop_hittingSetMinimal ss = not (any S.null ss) ==> all ((S.size hs <=) . S.size) allHittingSets+ where+  allElts = S.unions ss+  allSubsets = map S.fromList . subsequences . S.toList $ allElts+  allHittingSets = filter (`isHittingSet` ss) allSubsets+  hs = smallHittingSet ss++-- Five elements seem to be the minimum necessary for a+-- counterexample, but providing 6 helps QuickCheck find a+-- counterexample much more quickly.+data El = AA | BB | CC | DD | EE | FF+  deriving (Eq, Ord, Show, Bounded, Enum)++instance QC.Arbitrary El where+  arbitrary = QC.arbitraryBoundedEnum
+ test/unit/TestEval.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Swarm unit tests+module TestEval where++import Control.Lens ((^.), _3)+import Data.Text (Text)+import Data.Text qualified as T+import Swarm.Game.State+import Swarm.Game.Value+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import TestUtil+import Witch (from)++testEval :: GameState -> TestTree+testEval g =+  testGroup+    "Language - evaluation"+    [ testGroup+        "arithmetic"+        [ testProperty+            "addition"+            (\a b -> binOp a "+" b `evaluatesToP` VInt (a + b))+        , testProperty+            "subtraction"+            (\a b -> binOp a "-" b `evaluatesToP` VInt (a - b))+        , testProperty+            "multiplication"+            (\a b -> binOp a "*" b `evaluatesToP` VInt (a * b))+        , testProperty+            "division"+            (\a (NonZero b) -> binOp a "/" b `evaluatesToP` VInt (a `div` b))+        , testProperty+            "exponentiation"+            (\a (NonNegative b) -> binOp a "^" b `evaluatesToP` VInt (a ^ (b :: Integer)))+        ]+    , testGroup+        "int comparison"+        [ testProperty+            "=="+            (\a b -> binOp a "==" b `evaluatesToP` VBool ((a :: Integer) == b))+        , testProperty+            "<"+            (\a b -> binOp a "<" b `evaluatesToP` VBool ((a :: Integer) < b))+        , testProperty+            "<="+            (\a b -> binOp a "<=" b `evaluatesToP` VBool ((a :: Integer) <= b))+        , testProperty+            ">"+            (\a b -> binOp a ">" b `evaluatesToP` VBool ((a :: Integer) > b))+        , testProperty+            ">="+            (\a b -> binOp a ">=" b `evaluatesToP` VBool ((a :: Integer) >= b))+        , testProperty+            "!="+            (\a b -> binOp a "!=" b `evaluatesToP` VBool ((a :: Integer) /= b))+        ]+    , testGroup+        "pair comparison"+        [ testProperty+            "=="+            (\a b -> binOp a "==" b `evaluatesToP` VBool ((a :: (Integer, Integer)) == b))+        , testProperty+            "<"+            (\a b -> binOp a "<" b `evaluatesToP` VBool ((a :: (Integer, Integer)) < b))+        , testProperty+            "<="+            (\a b -> binOp a "<=" b `evaluatesToP` VBool ((a :: (Integer, Integer)) <= b))+        , testProperty+            ">"+            (\a b -> binOp a ">" b `evaluatesToP` VBool ((a :: (Integer, Integer)) > b))+        , testProperty+            ">="+            (\a b -> binOp a ">=" b `evaluatesToP` VBool ((a :: (Integer, Integer)) >= b))+        , testProperty+            "!="+            (\a b -> binOp a "!=" b `evaluatesToP` VBool ((a :: (Integer, Integer)) /= b))+        ]+    , testGroup+        "boolean operators"+        [ testCase+            "and"+            ("true && false" `evaluatesTo` VBool False)+        , testCase+            "or"+            ("true || false" `evaluatesTo` VBool True)+        ]+    , testGroup+        "sum types #224"+        [ testCase+            "inl"+            ("inl 3" `evaluatesTo` VInj False (VInt 3))+        , testCase+            "inr"+            ("inr \"hi\"" `evaluatesTo` VInj True (VText "hi"))+        , testCase+            "inl a < inl b"+            ("inl 3 < inl 4" `evaluatesTo` VBool True)+        , testCase+            "inl b < inl a"+            ("inl 4 < inl 3" `evaluatesTo` VBool False)+        , testCase+            "inl < inr"+            ("inl 3 < inr true" `evaluatesTo` VBool True)+        , testCase+            "inl 4 < inr 3"+            ("inl 4 < inr 3" `evaluatesTo` VBool True)+        , testCase+            "inr < inl"+            ("inr 3 < inl true" `evaluatesTo` VBool False)+        , testCase+            "inr 3 < inl 4"+            ("inr 3 < inl 4" `evaluatesTo` VBool False)+        , testCase+            "inr a < inr b"+            ("inr 3 < inr 4" `evaluatesTo` VBool True)+        , testCase+            "inr b < inr a"+            ("inr 4 < inr 3" `evaluatesTo` VBool False)+        , testCase+            "case inl"+            ("case (inl 2) (\\x. x + 1) (\\y. y * 17)" `evaluatesTo` VInt 3)+        , testCase+            "case inr"+            ("case (inr 2) (\\x. x + 1) (\\y. y * 17)" `evaluatesTo` VInt 34)+        , testCase+            "nested 1"+            ("(\\x : int + bool + text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inl 3)" `evaluatesTo` VInt 1)+        , testCase+            "nested 2"+            ("(\\x : int + bool + text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inr (inl false))" `evaluatesTo` VInt 2)+        , testCase+            "nested 2"+            ("(\\x : int + bool + text. case x (\\q. 1) (\\s. case s (\\y. 2) (\\z. 3))) (inr (inr \"hi\"))" `evaluatesTo` VInt 3)+        ]+    , testGroup+        "operator evaluation"+        [ testCase+            "application operator #239"+            ("fst $ snd $ (1,2,3)" `evaluatesTo` VInt 2)+        ]+    , testGroup+        "recursive bindings"+        [ testCase+            "factorial"+            ("let fac = \\n. if (n==0) {1} {n * fac (n-1)} in fac 15" `evaluatesTo` VInt 1307674368000)+        , testCase+            "loop detected"+            ("let x = x in x" `throwsError` ("loop detected" `T.isInfixOf`))+        ]+    , testGroup+        "delay"+        [ testCase+            "force / delay"+            ("force {10}" `evaluatesTo` VInt 10)+        , testCase+            "force x2 / delay x2"+            ("force (force { {10} })" `evaluatesTo` VInt 10)+        , testCase+            "if is lazy"+            ("if true {1} {1/0}" `evaluatesTo` VInt 1)+        , testCase+            "function with if is not lazy"+            ( "let f = \\x. \\y. if true {x} {y} in f 1 (1/0)"+                `throwsError` ("by zero" `T.isInfixOf`)+            )+        , testCase+            "memoization baseline"+            ( "def fac = \\n. if (n==0) {1} {n * fac (n-1)} end; def f10 = fac 10 end; let x = f10 in noop"+                `evaluatesToInAtMost` (VUnit, 535)+            )+        , testCase+            "memoization"+            ( "def fac = \\n. if (n==0) {1} {n * fac (n-1)} end; def f10 = fac 10 end; let x = f10 in let y = f10 in noop"+                `evaluatesToInAtMost` (VUnit, 540)+            )+        ]+    , testGroup+        "conditions"+        [ testCase+            "if true"+            ("if true {1} {2}" `evaluatesTo` VInt 1)+        , testCase+            "if false"+            ("if false {1} {2}" `evaluatesTo` VInt 2)+        , testCase+            "if (complex condition)"+            ("if (let x = 3 + 7 in not (x < 2^5)) {1} {2}" `evaluatesTo` VInt 2)+        ]+    , testGroup+        "exceptions"+        [ testCase+            "fail"+            ("fail \"foo\"" `throwsError` ("foo" `T.isInfixOf`))+        , testCase+            "try / no exception 1"+            ("try {return 1} {return 2}" `evaluatesTo` VInt 1)+        , testCase+            "try / no exception 2"+            ("try {return 1} {let x = x in x}" `evaluatesTo` VInt 1)+        , testCase+            "try / fail"+            ("try {fail \"foo\"} {return 3}" `evaluatesTo` VInt 3)+        , testCase+            "try / fail / fail"+            ("try {fail \"foo\"} {fail \"bar\"}" `throwsError` ("bar" `T.isInfixOf`))+        , testCase+            "try / div by 0"+            ("try {return (1/0)} {return 3}" `evaluatesTo` VInt 3)+        ]+    , testGroup+        "text"+        [ testCase+            "format int"+            ("format 1" `evaluatesTo` VText "1")+        , testCase+            "format sum"+            ("format (inl 1)" `evaluatesTo` VText "inl 1")+        , testCase+            "format function"+            ("format (\\x. x + 1)" `evaluatesTo` VText "\\x. x + 1")+        , testCase+            "concat"+            ("\"x = \" ++ format (2+3) ++ \"!\"" `evaluatesTo` VText "x = 5!")+        , testProperty+            "number of characters"+            ( \s ->+                ("chars " <> tquote s) `evaluatesToP` VInt (fromIntegral $ length s)+            )+        , testProperty+            "split undo concatenation"+            ( \s1 s2 ->+                -- \s1.\s2. (s1,s2) == split (chars s1) (s1 ++ s2)+                let (t1, t2) = (tquote s1, tquote s2)+                 in T.concat ["(", t1, ",", t2, ") == split (chars ", t1, ") (", t1, " ++ ", t2, ")"]+                      `evaluatesToP` VBool True+            )+        ]+    ]+ where+  tquote :: String -> Text+  tquote = T.pack . show+  throwsError :: Text -> (Text -> Bool) -> Assertion+  throwsError tm p = do+    result <- evaluate tm+    case result of+      Right _ -> assertFailure "Unexpected success"+      Left err ->+        p err+          @? "Expected predicate did not hold on error message "+          ++ from @Text @String err++  evaluatesTo :: Text -> Value -> Assertion+  evaluatesTo tm val = do+    result <- evaluate tm+    assertEqual "" (Right val) (fst <$> result)++  evaluatesToP :: Text -> Value -> Property+  evaluatesToP tm val = ioProperty $ do+    result <- evaluate tm+    return $ Right val === (fst <$> result)++  evaluatesToInAtMost :: Text -> (Value, Int) -> Assertion+  evaluatesToInAtMost tm (val, maxSteps) = do+    result <- evaluate tm+    case result of+      Left err -> assertFailure ("Evaluation failed: " ++ from @Text @String err)+      Right (v, steps) -> do+        assertEqual "" val v+        assertBool ("Took more than " ++ show maxSteps ++ " steps!") (steps <= maxSteps)++  evaluate :: Text -> IO (Either Text (Value, Int))+  evaluate = fmap (^. _3) . eval g++binOp :: Show a => a -> String -> a -> Text+binOp a op b = from @String (p (show a) ++ op ++ p (show b))+ where+  p x = "(" ++ x ++ ")"
+ test/unit/TestInventory.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Swarm unit tests+module TestInventory where++import Control.Lens ((^.))+import Data.Hashable+import Swarm.Game.Display+import Swarm.Game.Entity qualified as E+import Test.Tasty+import Test.Tasty.HUnit++testInventory :: TestTree+testInventory =+  testGroup+    "Inventory"+    [ testCase+        "insert 0 / hash"+        ( assertEqual+            "insertCount 0 x empty has same hash as x"+            (x ^. E.entityHash)+            (hash (E.insertCount 0 x E.empty))+        )+    , testCase+        "insert / hash"+        ( assertEqual+            "insert x empty has same hash as 2*x"+            (2 * (x ^. E.entityHash))+            (hash (E.insert x E.empty))+        )+    , testCase+        "insert / insert"+        ( assertEqual+            "insert x y gives same hash as insert y x"+            (hash (E.insert x (E.insert y E.empty)))+            (hash (E.insert y (E.insert x E.empty)))+        )+    , testCase+        "insert 2 / delete"+        ( assertEqual+            "insert 2, delete 1 gives same hash as insert 1"+            (hash (E.insert x E.empty))+            (hash (E.delete x (E.insertCount 2 x E.empty)))+        )+    , testCase+        "insert 2 / delete 3"+        ( assertEqual+            "insert 2, delete 3 gives hash of x"+            (x ^. E.entityHash)+            (hash (E.deleteCount 3 x (E.insertCount 2 x E.empty)))+        )+    , testCase+        "deleteAll"+        ( assertEqual+            "insert 2 x, insert 2 y, deleteAll x same hash as insert 2 y, insertCount 0 x"+            (hash (E.insertCount 0 x (E.insertCount 2 y E.empty)))+            (hash (E.deleteAll x (E.insertCount 2 y (E.insertCount 2 x E.empty))))+        )+    , testCase+        "union"+        ( assertEqual+            "insert 2 x union insert 3 x same as insert 5 x"+            (hash (E.insertCount 5 x E.empty))+            (hash (E.union (E.insertCount 2 x E.empty) (E.insertCount 3 x E.empty)))+        )+    , testCase+        "difference"+        ( assertEqual+            "{(2,x),(3,y)} difference {(3,x),(1,y)} = {(0,x), (2,y)}"+            ( hash+                ( E.insertCount 2 x (E.insertCount 3 y E.empty)+                    `E.difference` E.insertCount 3 x (E.insertCount 1 y E.empty)+                )+            )+            (hash (E.insertCount 0 x (E.insertCount 2 y E.empty)))+        )+    , testCase+        "subset / yes"+        ( assertBool+            "{(0,x),(3,y),(2,z)} isSubsetOf {(3,y),(4,z)}"+            ( E.insertCount 0 x (E.insertCount 3 y (E.insertCount 2 z E.empty))+                `E.isSubsetOf` E.insertCount 3 y (E.insertCount 4 z E.empty)+            )+        )+    , testCase+        "subset / no"+        ( assertBool+            "{(2,x),(3,y)} isSubsetOf {(1,x),(4,y)}"+            ( not+                ( E.insertCount 2 x (E.insertCount 3 y E.empty)+                    `E.isSubsetOf` E.insertCount 1 x (E.insertCount 4 y E.empty)+                )+            )+        )+    , testCase+        "isEmpty / yes"+        ( assertBool+            "isEmpty {(0,x),(0,y)}"+            (E.isEmpty (E.insertCount 0 x (E.insertCount 0 y E.empty)))+        )+    , testCase+        "isEmpty / no"+        ( assertBool+            "isEmpty {(0,x),(1,y)}"+            (not (E.isEmpty (E.insertCount 0 x (E.insertCount 1 y E.empty))))+        )+    ]+ where+  x = E.mkEntity (defaultEntityDisplay 'X') "fooX" [] [] []+  y = E.mkEntity (defaultEntityDisplay 'Y') "fooY" [] [] []+  z = E.mkEntity (defaultEntityDisplay 'Z') "fooZ" [] [] []
+ test/unit/TestLanguagePipeline.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Swarm unit tests+module TestLanguagePipeline where++import Data.Aeson (eitherDecode, encode)+import Data.Either+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Swarm.Language.Pipeline (processTerm)+import Test.Tasty+import Test.Tasty.HUnit+import Witch (from)++testLanguagePipeline :: TestTree+testLanguagePipeline =+  testGroup+    "Language - pipeline"+    [ testCase "end semicolon #79" (valid "def a = 41 end def b = a + 1 end def c = b + 2 end")+    , testCase+        "quantification #148 - implicit"+        (valid "def id : a -> a = \\x. x end; id move")+    , testCase+        "quantification #148 - explicit"+        (valid "def id : forall a. a -> a = \\x. x end; id move")+    , testCase+        "quantification #148 - explicit with free tyvars"+        ( process+            "def id : forall a. b -> b = \\x. x end; id move"+            ( T.unlines+                [ "1:27:"+                , "  |"+                , "1 | def id : forall a. b -> b = \\x. x end; id move"+                , "  |                           ^"+                , "  Type contains free variable(s): b"+                , "  Try adding them to the 'forall'."+                , ""+                ]+            )+        )+    , testCase+        "parsing operators #188 - parse valid operator (!=)"+        (valid "1!=(2)")+    , testCase+        "parsing operators #236 - parse valid operator (<=)"+        (valid "1 <= 2")+    , testCase+        "parsing operators #239 - parse valid operator ($)"+        (valid "fst $ snd $ (1,2,3)")+    , testCase+        "Allow ' in variable names #269 - parse variable name containing '"+        (valid "def a'_' = 0 end")+    , testCase+        "Allow ' in variable names #269 - do not parse variable starting with '"+        ( process+            "def 'a = 0 end"+            ( T.unlines+                [ "1:5:"+                , "  |"+                , "1 | def 'a = 0 end"+                , "  |     ^"+                , "unexpected '''"+                , "expecting variable name"+                ]+            )+        )+    , testCase+        "Parse pair syntax #225"+        (valid "def f : (int -> bool) * (int -> bool) = (\\x. false, \\x. true) end")+    , testCase+        "Nested pair syntax"+        (valid "(1,2,3,4)")+    , testCase+        "Binder at end of block"+        (valid "r <- build {move}")+    , testGroup+        "failure location - #268"+        [ testCase+            "located type error"+            ( process+                "def a =\n 42 + \"oops\"\nend"+                "2: Can't unify int and text"+            )+        , testCase+            "failure inside bind chain"+            ( process+                "move;\n1;\nmove"+                "2: Can't unify int and cmd"+            )+        , testCase+            "failure inside function call"+            ( process+                "if true \n{} \n(move)"+                "3: Can't unify {u0} and cmd unit"+            )+        , testCase+            "parsing operators #236 - report failure on invalid operator start"+            ( process+                "1 <== 2"+                ( T.unlines+                    [ "1:3:"+                    , "  |"+                    , "1 | 1 <== 2"+                    , "  |   ^"+                    , "unexpected '<'"+                    ]+                )+            )+        ]+    , testGroup+        "require - #201"+        [ testCase+            "require device"+            (valid "require \"boat\"")+        , testCase+            "require entities"+            (valid "require 64 \"rock\"")+        , testCase+            "invalid syntax to require"+            ( process+                "require x"+                ( T.unlines+                    [ "1:9:"+                    , "  |"+                    , "1 | require x"+                    , "  |         ^"+                    , "unexpected 'x'"+                    , "expecting device name in double quotes or integer literal"+                    ]+                )+            )+        , testCase+            "invalid syntax to require n"+            ( process+                "require 2 x"+                ( T.unlines+                    [ "1:11:"+                    , "  |"+                    , "1 | require 2 x"+                    , "  |           ^"+                    , "unexpected 'x'"+                    , "expecting entity name in double quotes"+                    ]+                )+            )+        ]+    , testGroup+        "json encoding"+        [ testCase "simple expr" (roundTrip "42 + 43")+        , testCase "module def" (roundTrip "def x = 41 end; def y = 42 end")+        ]+    , testGroup+        "atomic - #479"+        [ testCase+            "atomic move"+            ( valid "atomic move"+            )+        , testCase+            "grabif"+            (valid "def grabif : text -> cmd unit = \\x. atomic (b <- ishere x; if b {grab; return ()} {}) end")+        , testCase+            "placeif"+            (valid "def placeif : text -> cmd bool = \\thing. atomic (res <- scan down; if (res == inl ()) {place thing; return true} {return false}) end")+        , testCase+            "atomic move+move"+            ( process+                "atomic (move; move)"+                "1: 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"+            )+        , 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"+            )+        , testCase+            "atomic nested"+            ( process+                "atomic (move; atomic (if true {} {}))"+                "1: 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"+            )+        , testCase+            "atomic make"+            ( process+                "atomic (make \"PhD thesis\")"+                "1: 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"+            )+        , testCase+            "atomic salvage"+            ( process+                "atomic (salvage)"+                "1: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: salvage"+            )+        ]+    , testGroup+        "integer literals"+        [ testCase+            "binary literal"+            (valid "0b1011011101")+        , testCase+            "invalid binary literal"+            (process "0b101201" "1:6:\n  |\n1 | 0b101201\n  |      ^\nunexpected '2'\n")+        , testCase+            "octal literal"+            (valid "0o3726")+        , testCase+            "invalid octal literal"+            (process "0o3826" "1:4:\n  |\n1 | 0o3826\n  |    ^\nunexpected '8'\n")+        , testCase+            "hex literal"+            (valid "0xabcD6F")+        , testCase+            "invalid hex literal"+            (process "0xabcD6G2" "1:8:\n  |\n1 | 0xabcD6G2\n  |        ^\nunexpected 'G'\n")+        ]+    ]+ where+  valid = flip process ""++  roundTrip txt = assertEqual "rountrip" term (decodeThrow $ encode term)+   where+    decodeThrow v = case eitherDecode v of+      Left e -> error $ "Decoding of " <> from (T.decodeUtf8 (from v)) <> " failed with: " <> from e+      Right x -> x+    term = fromMaybe (error "") $ fromRight (error "") $ processTerm txt++  process :: Text -> Text -> Assertion+  process code expect = case processTerm code of+    Left e+      | not (T.null expect) && expect `T.isPrefixOf` e -> pure ()+      | otherwise -> error $ "Unexpected failure: " <> show e+    Right _+      | expect == "" -> pure ()+      | otherwise -> error "Unexpected success"
+ test/unit/TestModel.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Swarm unit tests+module TestModel where++import Data.String (fromString)+import Data.Text (Text)+import Swarm.TUI.Model+import Test.Tasty+import Test.Tasty.HUnit++testModel :: TestTree+testModel =+  testGroup+    "TUI Model"+    [ testCase+        "latest repl lines at start"+        ( assertEqual+            "get 5 history [0] --> []"+            []+            (getLatestREPLHistoryItems 5 history0)+        )+    , testCase+        "latest repl lines after one input"+        ( assertEqual+            "get 5 history [0|()] --> [()]"+            [REPLEntry "()"]+            (getLatestREPLHistoryItems 5 (addREPLItem (REPLEntry "()") history0))+        )+    , testCase+        "latest repl lines after one input and output"+        ( assertEqual+            "get 5 history [0|1,1:int] --> [1,1:int]"+            [REPLEntry "1", REPLOutput "1:int"]+            (getLatestREPLHistoryItems 5 (addInOutInt 1 history0))+        )+    , testCase+        "latest repl lines after nine inputs and outputs"+        ( assertEqual+            "get 6 history [0|1,1:int .. 9,9:int] --> [7,7:int..9,9:int]"+            (concat [[REPLEntry (toT x), REPLOutput (toT x <> ":int")] | x <- [7 .. 9]])+            (getLatestREPLHistoryItems 6 (foldl (flip addInOutInt) history0 [1 .. 9]))+        )+    , testCase+        "latest repl after restart"+        ( assertEqual+            "get 5 history (restart [0|()]) --> []"+            []+            (getLatestREPLHistoryItems 5 (restartREPLHistory $ addREPLItem (REPLEntry "()") history0))+        )+    , testCase+        "current item at start"+        (assertEqual "getText [0] --> Nothing" (getCurrentItemText history0) Nothing)+    , testCase+        "current item after move to older"+        ( assertEqual+            "getText ([0]<=='') --> Just 0"+            (Just "0")+            (getCurrentItemText $ moveReplHistIndex Older "" history0)+        )+    , testCase+        "current item after move to newer"+        ( assertEqual+            "getText ([0]==>'') --> Nothing"+            Nothing+            (getCurrentItemText $ moveReplHistIndex Newer "" history0)+        )+    , testCase+        "current item after move past output"+        ( assertEqual+            "getText ([0,1,1:int]<=='') --> Just 1"+            (Just "1")+            (getCurrentItemText $ moveReplHistIndex Older "" (addInOutInt 1 history0))+        )+    , testCase+        "current item after move past same"+        ( assertEqual+            "getText ([0,1,1:int]<=='1') --> Just 0"+            (Just "0")+            (getCurrentItemText $ moveReplHistIndex Older "1" (addInOutInt 1 history0))+        )+    ]+ where+  history0 = newREPLHistory [REPLEntry "0"]+  toT :: Int -> Text+  toT = fromString . show+  addInOutInt :: Int -> REPLHistory -> REPLHistory+  addInOutInt i = addREPLItem (REPLOutput $ toT i <> ":int") . addREPLItem (REPLEntry $ toT i)
+ test/unit/TestNotification.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++-- | 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.Robot+import Swarm.Game.State+import Test.Tasty+import Test.Tasty.HUnit+import TestUtil++testNotification :: GameState -> TestTree+testNotification gs =+  testGroup+    "Notifications"+    [ testCase "notifications at start" $ do+        assertBool "There should be no messages in queue" (null (gs ^. messageQueue))+        assertNew gs 0 "messages at game start" messageNotifications+        assertNew gs 0 "recipes at game start" availableRecipes+        assertNew gs 0 "commands at game start" availableCommands+    , testCase "new message after say" $ do+        gs' <- goodPlay "say \"Hello world!\""+        assertBool "There should be one message in queue" (length (gs' ^. messageQueue) == 1)+        assertNew gs' 1 "message" messageNotifications+    , testCase "two new messages after say twice" $ do+        gs' <- goodPlay "say \"Hello!\"; say \"Goodbye!\""+        assertBool "There should be two messages in queue" (length (gs' ^. messageQueue) == 2)+        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+    , testCase "new message after log" $ do+        gs' <- goodPlay "create \"logger\"; install self \"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)+        assertNew gs' 1 "message" messageNotifications+    , testCase "new message after build say" $ do+        gs' <- goodPlay "build {say \"Hello world!\"}; turn back; turn back;"+        assertBool "There should be one message in queue" (length (gs' ^. messageQueue) == 1)+        assertNew gs' 1 "message" messageNotifications+    , testCase "no new message after build log" $ do+        gs' <- goodPlay "build {log \"Hello world!\"}; turn back; turn back;"+        assertNew gs' 0 "message" messageNotifications+    ]+ where+  goodPlay :: Text -> IO GameState+  goodPlay t = do+    (e, g) <- play gs t+    either (assertFailure . T.unpack) pure e+    return g+  assertNew :: s -> Int -> String -> Getter s (Notifications a) -> Assertion+  assertNew g n what l =+    let c = g ^. l . notificationsCount+     in assertEqual ("There should be exactly " <> show n <> " new " <> what) n c
+ test/unit/TestPretty.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Swarm unit tests+module TestPretty where++import Swarm.Language.Pretty+import Swarm.Language.Syntax hiding (mkOp)+import Test.Tasty+import Test.Tasty.HUnit++testPrettyConst :: TestTree+testPrettyConst =+  testGroup+    "Language - pretty"+    [ testCase+        "operators #8 - function application unchanged"+        ( equalPretty "f say" $+            TApp (TVar "f") (TConst Say)+        )+    , testCase+        "operators #8 - double function application unchanged"+        ( equalPretty "f () ()" $+            TApp (TApp (TVar "f") TUnit) TUnit+        )+    , testCase+        "operators #8 - embrace operator parameter"+        ( equalPretty "f (==)" $+            TApp (TVar "f") (TConst Eq)+        )+    , testCase+        "operators #8 - unary negation"+        ( equalPretty "-3" $+            TApp (TConst Neg) (TInt 3)+        )+    , testCase+        "operators #8 - double unary negation"+        ( equalPretty "-(-1)" $+            TApp (TConst Neg) $ TApp (TConst Neg) (TInt 1)+        )+    , 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)+        )+    , 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)+        )+    , testCase+        "operators #8 - simple infix operator"+        ( equalPretty "1 == 2" $+            mkOp' Eq (TInt 1) (TInt 2)+        )+    , testCase+        "operators #8 - infix operator with less fixing inner operator"+        ( equalPretty "1 * (2 + 3)" $+            mkOp' Mul (TInt 1) (mkOp' Add (TInt 2) (TInt 3))+        )+    , testCase+        "operators #8 - infix operator with more fixing inner operator"+        ( equalPretty "1 + 2 * 3" $+            mkOp' Add (TInt 1) (mkOp' Mul (TInt 2) (TInt 3))+        )+    , testCase+        "operators #8 - infix operator right associativity"+        ( equalPretty "2 ^ 4 ^ 8" $+            mkOp' Exp (TInt 2) (mkOp' Exp (TInt 4) (TInt 8))+        )+    , testCase+        "operators #8 - infix operator right associativity not applied to left"+        ( equalPretty "(2 ^ 4) ^ 8" $+            mkOp' Exp (mkOp' Exp (TInt 2) (TInt 4)) (TInt 8)+        )+    , testCase+        "pairs #225 - nested pairs are printed right-associative"+        ( equalPretty "(1, 2, 3)" $+            TPair (TInt 1) (TPair (TInt 2) (TInt 3))+        )+    ]+ where+  equalPretty :: String -> Term -> Assertion+  equalPretty expected term = assertEqual "" expected . show $ ppr term
+ test/unit/TestUtil.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Utility functions+module TestUtil where++import Control.Lens (Ixed (ix), to, use, (&), (.~), (^.), (^?))+import Control.Monad.Except+import Control.Monad.State+import Data.Text (Text)+import Data.Text qualified as T+import Swarm.Game.CESK+import Swarm.Game.Exception+import Swarm.Game.Robot+import Swarm.Game.State+import Swarm.Game.Step (gameTick, hypotheticalRobot, stepCESK)+import Swarm.Game.Value+import Swarm.Language.Context+import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)++eval :: GameState -> Text -> IO (GameState, Robot, Either Text (Value, Int))+eval g = either (return . (g,hypotheticalRobot undefined 0,) . Left) (evalPT g) . processTerm1++processTerm1 :: Text -> Either Text ProcessedTerm+processTerm1 txt = processTerm txt >>= maybe wsErr Right+ where+  wsErr = Left "expecting a term, but got only whitespace"++evalPT :: GameState -> ProcessedTerm -> IO (GameState, Robot, Either Text (Value, Int))+evalPT g t = evalCESK g (initMachine t empty emptyStore)++evalCESK :: GameState -> CESK -> IO (GameState, Robot, Either Text (Value, Int))+evalCESK g cesk =+  runCESK 0 cesk+    & flip runStateT r+    & flip runStateT (g & creativeMode .~ True)+    & fmap orderResult+ where+  r = hypotheticalRobot cesk 0+  orderResult ((res, rr), rg) = (rg, rr, res)++runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value, Int))+runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use entityMap)+runCESK !steps cesk = case finalValue cesk of+  Just (v, _) -> return (Right (v, steps))+  Nothing -> stepCESK cesk >>= runCESK (steps + 1)++play :: GameState -> Text -> IO (Either Text (), GameState)+play g = either (return . (,g) . Left) playPT . processTerm1+ where+  playPT pt = runStateT (playUntilDone (hr ^. robotID)) gs+   where+    cesk = initMachine pt empty emptyStore+    hr = hypotheticalRobot cesk 0+    hid = hr ^. robotID+    gs =+      g+        & execState (addRobot hr)+        & viewCenterRule .~ VCRobot hid+        & creativeMode .~ True++playUntilDone :: RID -> StateT GameState IO (Either Text ())+playUntilDone rid = do+  w <- use robotMap+  case w ^? ix rid . to isActive of+    Just True -> do+      gameTick+      playUntilDone rid+    Just False -> return $ Right ()+    Nothing -> return $ Left . T.pack $ "The robot with ID " <> show rid <> " is nowhere to be found!"