diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmark.hs @@ -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 + ] diff --git a/data/about.txt b/data/about.txt new file mode 100644 --- /dev/null +++ b/data/about.txt @@ -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 diff --git a/data/adjectives.txt b/data/adjectives.txt new file mode 100644 --- /dev/null +++ b/data/adjectives.txt @@ -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 diff --git a/data/entities.yaml b/data/entities.yaml new file mode 100644 --- /dev/null +++ b/data/entities.yaml @@ -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] diff --git a/data/logo.txt b/data/logo.txt new file mode 100644 --- /dev/null +++ b/data/logo.txt @@ -0,0 +1,9 @@ + v + + v<^vv<<@ ^^ vv >^v^T ^^^v< <>< v > + T ^< >^ < >> v> v< >T <<▒^ @><> + <@v^^>> @v > v> >> v@ @@> << ~v < >~ ^~ >> @^ >v + >>^v^^^ < ~ T~v v< <~ >>T + ▒ + ^ ^ v > > diff --git a/data/names.txt b/data/names.txt new file mode 100644 --- /dev/null +++ b/data/names.txt @@ -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 diff --git a/data/recipes.yaml b/data/recipes.yaml new file mode 100644 --- /dev/null +++ b/data/recipes.yaml @@ -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] diff --git a/data/scenarios/00-ORDER.txt b/data/scenarios/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/00-ORDER.txt @@ -0,0 +1,7 @@ +classic.yaml +creative.yaml +Tutorials +Challenges +Fun +Speedruns +Testing diff --git a/data/scenarios/Challenges/00-ORDER.txt b/data/scenarios/Challenges/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/00-ORDER.txt @@ -0,0 +1,5 @@ +chess_horse.yaml +teleport.yaml +2048.yaml +hanoi.yaml +Mazes diff --git a/data/scenarios/Challenges/2048.yaml b/data/scenarios/Challenges/2048.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/2048.yaml @@ -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: | + ┌─┐ + │Ω│ + └─┘ diff --git a/data/scenarios/Challenges/Mazes/00-ORDER.txt b/data/scenarios/Challenges/Mazes/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Mazes/00-ORDER.txt @@ -0,0 +1,4 @@ +easy_cave_maze.yaml +easy_spiral_maze.yaml +invisible_maze.yaml +loopy_maze.yaml diff --git a/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml b/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml @@ -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: | + ██████████████████████████████ + █Ω ████████ █████████████████ + ███ ██████████████████████ █ + █████ ███████████ ██████████ █ + █████ ███████~███ ███ █████ + ████████ ███████████ ██ ██████ + ███ ████ ██████~█~█ █████ + ██~██████████ █████~~███ █ ██ + ████████ █████ █████████~████ + ███ ███████████ ███████~~███ + ███ █ ███ ██████ ██████~~████ + █ ██ ███ ██████ ████████████ + ██ █ █ ██ █████ █████████ + ██~~~~~~~██~~~██████ !█ + ██████████████████████████████ diff --git a/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml b/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml @@ -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: | + ████████████████████████████████████ + ██ ██ + ██ ████████████████████████████ ██ + ██ ██ ██ ██ + ██ ██ ████████████████████ ██ ██ + ██ ██ ██ ██ ██ ██ + ██ ██ ██ ████████████ ██ ██ ██ + ██ ██ ██ ██ ██ ██ ██ ██ + ██ ██ ██ ██ ████ ██ ██ ██ ██ + ██ ██ ██ ██ Ω██ ██ ██ ██ ██ + ██ ██ ██ ████████ ██ ██ ██ ██ + ██ ██ ██ ██ ██ ██ ██ + ██ ██ ████████████████ ██ ██ ██ + ██ ██ ██ ██ ██ + ██ ████████████████████████ ██ ██ + ██ ██ ██ + ████████████████████████████████ ██ + █! ██ + ████████████████████████████████████ diff --git a/data/scenarios/Challenges/Mazes/invisible_maze.yaml b/data/scenarios/Challenges/Mazes/invisible_maze.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Mazes/invisible_maze.yaml @@ -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!@ + @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ diff --git a/data/scenarios/Challenges/Mazes/loopy_maze.yaml b/data/scenarios/Challenges/Mazes/loopy_maze.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Mazes/loopy_maze.yaml @@ -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!@ + @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ diff --git a/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw b/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/Mazes/loopy_maze_sol.sw @@ -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 +} diff --git a/data/scenarios/Challenges/chess_horse.yaml b/data/scenarios/Challenges/chess_horse.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/chess_horse.yaml @@ -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: | + ┌────────┐ + │.#.#.#.#│ + │#.#.#.#.│ + │.#.#.#.#│ + │#.#.#.#.│ + │.#.#.#.#│ + │#.#.#.#.│ + │.#.#.#.#│ + │#.#.#.#.│ + └────────┘ diff --git a/data/scenarios/Challenges/hanoi-count.sw b/data/scenarios/Challenges/hanoi-count.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/hanoi-count.sw @@ -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 ()} + ) +} diff --git a/data/scenarios/Challenges/hanoi-increasing.sw b/data/scenarios/Challenges/hanoi-increasing.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/hanoi-increasing.sw @@ -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 ()} + } {} +) diff --git a/data/scenarios/Challenges/hanoi-invariant.sw b/data/scenarios/Challenges/hanoi-invariant.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/hanoi-invariant.sw @@ -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 ()) +} +)) diff --git a/data/scenarios/Challenges/hanoi-solution.sw b/data/scenarios/Challenges/hanoi-solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/hanoi-solution.sw @@ -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 diff --git a/data/scenarios/Challenges/hanoi.yaml b/data/scenarios/Challenges/hanoi.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/hanoi.yaml @@ -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 diff --git a/data/scenarios/Challenges/teleport.yaml b/data/scenarios/Challenges/teleport.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Challenges/teleport.yaml @@ -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┌┘ ~ + ~└─────┘ ~~└─────┘~ + ~~~ ~ ~ ~ diff --git a/data/scenarios/Fun/00-ORDER.txt b/data/scenarios/Fun/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/00-ORDER.txt @@ -0,0 +1,1 @@ +GoL.yaml diff --git a/data/scenarios/Fun/GoL.yaml b/data/scenarios/Fun/GoL.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Fun/GoL.yaml @@ -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..... + .............................. + .............................. + .............................. diff --git a/data/scenarios/Speedruns/00-ORDER.txt b/data/scenarios/Speedruns/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Speedruns/00-ORDER.txt @@ -0,0 +1,3 @@ +curry.yaml +forester.yaml +mithril.yaml diff --git a/data/scenarios/Speedruns/curry.yaml b/data/scenarios/Speedruns/curry.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Speedruns/curry.yaml @@ -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 diff --git a/data/scenarios/Speedruns/forester.yaml b/data/scenarios/Speedruns/forester.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Speedruns/forester.yaml @@ -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 diff --git a/data/scenarios/Speedruns/mithril.yaml b/data/scenarios/Speedruns/mithril.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Speedruns/mithril.yaml @@ -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 diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/00-ORDER.txt @@ -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 diff --git a/data/scenarios/Testing/201-require/00-ORDER.txt b/data/scenarios/Testing/201-require/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/00-ORDER.txt @@ -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 diff --git a/data/scenarios/Testing/201-require/201-require-device-creative.yaml b/data/scenarios/Testing/201-require/201-require-device-creative.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-require-device-creative.yaml @@ -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: | + ┌───┐ + │.~.│ + └───┘ diff --git a/data/scenarios/Testing/201-require/201-require-device-creative1.yaml b/data/scenarios/Testing/201-require/201-require-device-creative1.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-require-device-creative1.yaml @@ -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 diff --git a/data/scenarios/Testing/201-require/201-require-device.yaml b/data/scenarios/Testing/201-require/201-require-device.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-require-device.yaml @@ -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: | + ┌───┐ + │.~.│ + └───┘ diff --git a/data/scenarios/Testing/201-require/201-require-entities-def.yaml b/data/scenarios/Testing/201-require/201-require-entities-def.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-require-entities-def.yaml @@ -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: | + ┌─────┐ + │.....│ + └─────┘ diff --git a/data/scenarios/Testing/201-require/201-require-entities.yaml b/data/scenarios/Testing/201-require/201-require-entities.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/201-require-entities.yaml @@ -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: | + ┌───┐ + │...│ + └───┘ diff --git a/data/scenarios/Testing/201-require/533-reprogram-simple.yaml b/data/scenarios/Testing/201-require/533-reprogram-simple.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/533-reprogram-simple.yaml @@ -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: | + ┌───┐ + │.~.│ + └───┘ diff --git a/data/scenarios/Testing/201-require/533-reprogram.yaml b/data/scenarios/Testing/201-require/533-reprogram.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/201-require/533-reprogram.yaml @@ -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: | + ┌───┐ + │.~.│ + └───┘ diff --git a/data/scenarios/Testing/373-drill.yaml b/data/scenarios/Testing/373-drill.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/373-drill.yaml @@ -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 diff --git a/data/scenarios/Testing/378-objectives.yaml b/data/scenarios/Testing/378-objectives.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/378-objectives.yaml @@ -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│ + └────────┘ diff --git a/data/scenarios/Testing/394-build-drill.yaml b/data/scenarios/Testing/394-build-drill.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/394-build-drill.yaml @@ -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│ + └───┘ diff --git a/data/scenarios/Testing/428-drowning-destroy.yaml b/data/scenarios/Testing/428-drowning-destroy.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/428-drowning-destroy.yaml @@ -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: | + ┌──┐ + │. │ + │. │ + └──┘ diff --git a/data/scenarios/Testing/475-wait-one.yaml b/data/scenarios/Testing/475-wait-one.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/475-wait-one.yaml @@ -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: | + ┌─────┐ + │..λ..│ + │....λ│ + │...λ.│ + └─────┘ diff --git a/data/scenarios/Testing/479-atomic-race.yaml b/data/scenarios/Testing/479-atomic-race.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/479-atomic-race.yaml @@ -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: | + . diff --git a/data/scenarios/Testing/479-atomic.yaml b/data/scenarios/Testing/479-atomic.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/479-atomic.yaml @@ -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: | + . diff --git a/data/scenarios/Testing/490-harvest.yaml b/data/scenarios/Testing/490-harvest.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/490-harvest.yaml @@ -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│ + │~~~│ + └───┘ diff --git a/data/scenarios/Testing/504-teleport-self.yaml b/data/scenarios/Testing/504-teleport-self.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/504-teleport-self.yaml @@ -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: | + ┌──────┐ + │......│ + └──────┘ diff --git a/data/scenarios/Testing/508-capability-subset.yaml b/data/scenarios/Testing/508-capability-subset.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/508-capability-subset.yaml @@ -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] diff --git a/data/scenarios/Testing/555-teleport-location.yaml b/data/scenarios/Testing/555-teleport-location.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/555-teleport-location.yaml @@ -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] diff --git a/data/scenarios/Testing/562-lodestone.sw b/data/scenarios/Testing/562-lodestone.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/562-lodestone.sw @@ -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" diff --git a/data/scenarios/Testing/562-lodestone.yaml b/data/scenarios/Testing/562-lodestone.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/562-lodestone.yaml @@ -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 diff --git a/data/scenarios/Testing/684-swap.yaml b/data/scenarios/Testing/684-swap.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/684-swap.yaml @@ -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: | + ┌─┐ + │λ│ + └─┘ diff --git a/data/scenarios/Testing/699-movement-fail/00-ORDER.txt b/data/scenarios/Testing/699-movement-fail/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/699-movement-fail/00-ORDER.txt @@ -0,0 +1,3 @@ +699-move-blocked.yaml +699-move-liquid.yaml +699-teleport-blocked.yaml diff --git a/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml b/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml @@ -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@│ + └──┘ diff --git a/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml b/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml @@ -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~│ + └──┘ diff --git a/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml b/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml @@ -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│ + └──────┘ diff --git a/data/scenarios/Testing/710-multi-robot.yaml b/data/scenarios/Testing/710-multi-robot.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Testing/710-multi-robot.yaml @@ -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. diff --git a/data/scenarios/Tutorials/00-ORDER.txt b/data/scenarios/Tutorials/00-ORDER.txt new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/00-ORDER.txt @@ -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 diff --git a/data/scenarios/Tutorials/backstory.yaml b/data/scenarios/Tutorials/backstory.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/backstory.yaml @@ -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 diff --git a/data/scenarios/Tutorials/bind.yaml b/data/scenarios/Tutorials/bind.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/bind.yaml @@ -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│ + └───┘ diff --git a/data/scenarios/Tutorials/build.yaml b/data/scenarios/Tutorials/build.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/build.yaml @@ -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: | + ┌───┐ + │Ω.*│ + │...│ + │~~~│ + └───┘ diff --git a/data/scenarios/Tutorials/conditionals.yaml b/data/scenarios/Tutorials/conditionals.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/conditionals.yaml @@ -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_│ + └─────┘ diff --git a/data/scenarios/Tutorials/craft.yaml b/data/scenarios/Tutorials/craft.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/craft.yaml @@ -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: | + ┌─┐ + │Ω│ + └─┘ diff --git a/data/scenarios/Tutorials/crash-secret.sw b/data/scenarios/Tutorials/crash-secret.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/crash-secret.sw @@ -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!" +) diff --git a/data/scenarios/Tutorials/crash-solution.sw b/data/scenarios/Tutorials/crash-solution.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/crash-solution.sw @@ -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" +}; diff --git a/data/scenarios/Tutorials/crash.yaml b/data/scenarios/Tutorials/crash.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/crash.yaml @@ -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│ + └─────┘ diff --git a/data/scenarios/Tutorials/def.yaml b/data/scenarios/Tutorials/def.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/def.yaml @@ -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: | + ┌─────────────────┐ + │................*│ + │.@@@@@@@@@@@@@@@@│ + │.................│ + │@@@@@@@@@@@@@@@@.│ + │Ω................│ + └─────────────────┘ diff --git a/data/scenarios/Tutorials/farming.sw b/data/scenarios/Tutorials/farming.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/farming.sw @@ -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 +} diff --git a/data/scenarios/Tutorials/farming.yaml b/data/scenarios/Tutorials/farming.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/farming.yaml @@ -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 diff --git a/data/scenarios/Tutorials/grab.yaml b/data/scenarios/Tutorials/grab.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/grab.yaml @@ -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│ + └────────┘ diff --git a/data/scenarios/Tutorials/install.yaml b/data/scenarios/Tutorials/install.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/install.yaml @@ -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..│ + │~~~│ + └───┘ diff --git a/data/scenarios/Tutorials/lambda.yaml b/data/scenarios/Tutorials/lambda.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/lambda.yaml @@ -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: | + ┌─────────────────────────────────┐ + │.......@.......@.......@.......@@│ + │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │.@@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@@│ + │.....@.@.....@.@.....@.@.....@.@@│ + │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ + │Ω....@.......@.......@.......@..*│ + └─────────────────────────────────┘ + + diff --git a/data/scenarios/Tutorials/make_curry.sw b/data/scenarios/Tutorials/make_curry.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/make_curry.sw @@ -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" diff --git a/data/scenarios/Tutorials/move.yaml b/data/scenarios/Tutorials/move.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/move.yaml @@ -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. diff --git a/data/scenarios/Tutorials/move_system.sw b/data/scenarios/Tutorials/move_system.sw new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/move_system.sw @@ -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 ++ "'" +}}} diff --git a/data/scenarios/Tutorials/place.yaml b/data/scenarios/Tutorials/place.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/place.yaml @@ -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.....│ + └────────┘ diff --git a/data/scenarios/Tutorials/require.yaml b/data/scenarios/Tutorials/require.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/require.yaml @@ -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: | + ┌──────┐ + │..~~..│ + │..~~..│ + │Ω.~~.*│ + │..~~..│ + │..~~..│ + └──────┘ diff --git a/data/scenarios/Tutorials/requireinv.yaml b/data/scenarios/Tutorials/requireinv.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/requireinv.yaml @@ -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 ` 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: | + ┌─────┐ + │Ω....│ + │.____│ + │.____│ + │.____│ + │.____│ + └─────┘ diff --git a/data/scenarios/Tutorials/scan.yaml b/data/scenarios/Tutorials/scan.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/scan.yaml @@ -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│ + └─────┘ diff --git a/data/scenarios/Tutorials/type-errors.yaml b/data/scenarios/Tutorials/type-errors.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/type-errors.yaml @@ -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: | + ┌───┐ + │>..│ + │...│ + └───┘ diff --git a/data/scenarios/Tutorials/types.yaml b/data/scenarios/Tutorials/types.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/types.yaml @@ -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: | + ┌───┐ + │>..│ + │...│ + └───┘ diff --git a/data/scenarios/Tutorials/world101.yaml b/data/scenarios/Tutorials/world101.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/Tutorials/world101.yaml @@ -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 diff --git a/data/scenarios/classic.yaml b/data/scenarios/classic.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/classic.yaml @@ -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 diff --git a/data/scenarios/creative.yaml b/data/scenarios/creative.yaml new file mode 100644 --- /dev/null +++ b/data/scenarios/creative.yaml @@ -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 diff --git a/editors/emacs/swarm-mode.el b/editors/emacs/swarm-mode.el new file mode 100644 --- /dev/null +++ b/editors/emacs/swarm-mode.el @@ -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 diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.json b/editors/vscode/syntaxes/swarm.tmLanguage.json new file mode 100644 --- /dev/null +++ b/editors/vscode/syntaxes/swarm.tmLanguage.json @@ -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" +} diff --git a/example/BFS-clear.sw b/example/BFS-clear.sw new file mode 100644 --- /dev/null +++ b/example/BFS-clear.sw @@ -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 diff --git a/example/cat.sw b/example/cat.sw new file mode 100644 --- /dev/null +++ b/example/cat.sw @@ -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" } {} +) diff --git a/example/dfs.sw b/example/dfs.sw new file mode 100644 --- /dev/null +++ b/example/dfs.sw @@ -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 diff --git a/example/fact.sw b/example/fact.sw new file mode 100644 --- /dev/null +++ b/example/fact.sw @@ -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 diff --git a/example/list.sw b/example/list.sw new file mode 100644 --- /dev/null +++ b/example/list.sw @@ -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 diff --git a/example/wander.sw b/example/wander.sw new file mode 100644 --- /dev/null +++ b/example/wander.sw @@ -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 diff --git a/src/Swarm/App.hs b/src/Swarm/App.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/App.hs @@ -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 diff --git a/src/Swarm/DocGen.hs b/src/Swarm/DocGen.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/DocGen.hs @@ -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 diff --git a/src/Swarm/Game/CESK.hs b/src/Swarm/Game/CESK.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/CESK.hs @@ -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 +-- (if +-- you want to read up on them, you may want to start by reading about +-- +-- first). Execution happens simply by iterating a step function, +-- sending one state of the CESK machine to the next. In addition to +-- being relatively efficient, this means we can easily run a bunch of +-- robots synchronously, in parallel, without resorting to any threads +-- (by stepping their machines in a round-robin fashion); pause and +-- single-step the game; save and resume, and so on. +-- +-- Essentially, a CESK machine state has four components: +-- +-- - The __C__ontrol is the thing we are currently focused on: +-- either a 'Term' to evaluate, or a 'Value' that we have +-- just finished evaluating. +-- - The __E__nvironment ('Env') is a mapping from variables that might +-- occur free in the Control to their values. +-- - The __S__tore ('Store') is a mapping from abstract integer +-- /locations/ to values. We use it to store delayed (lazy) values, +-- so they will be computed at most once. +-- - The __K__ontinuation ('Cont') is a stack of 'Frame's, +-- representing the evaluation context, /i.e./ what we are supposed +-- to do after we finish with the currently focused thing. When we +-- reduce the currently focused term to a value, the top frame on +-- the stack tells us how to proceed. +-- +-- You can think of a CESK machine as a defunctionalization of a +-- recursive big-step interpreter, where we explicitly keep track of +-- the call stack and the environments that would be in effect at +-- various places in the recursion. One could probably even derive +-- this mechanically, by writing a recursive big-step interpreter, +-- then converting it to CPS, then defunctionalizing the +-- continuations. +-- +-- The slightly confusing thing about CESK machines is how we +-- have to pass around environments everywhere. Basically, +-- anywhere there can be unevaluated terms containing free +-- variables (in values, in continuation stack frames, ...), we +-- have to store the proper environment alongside so that when +-- we eventually get around to evaluating it, we will be able to +-- pull out the environment to use. +module Swarm.Game.CESK ( + -- * Frames and continuations + Frame (..), + Cont, + + -- ** Wrappers for creating delayed change of state + + -- 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 + -- .) + -- + -- 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 {} = "_ ∪ " +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 diff --git a/src/Swarm/Game/Display.hs b/src/Swarm/Game/Display.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Display.hs @@ -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 diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Entity.hs @@ -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 diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Exception.hs @@ -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" + , "." + ] + 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 diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Recipe.hs @@ -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 diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Robot.hs @@ -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 diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Scenario.hs @@ -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 diff --git a/src/Swarm/Game/ScenarioInfo.hs b/src/Swarm/Game/ScenarioInfo.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/ScenarioInfo.hs @@ -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 diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/State.hs @@ -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 diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Step.hs @@ -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) diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Terrain.hs @@ -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) + ] diff --git a/src/Swarm/Game/Value.hs b/src/Swarm/Game/Value.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/Value.hs @@ -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 diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/World.hs @@ -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) diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Game/WorldGen.hs @@ -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"] diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Capability.hs @@ -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 diff --git a/src/Swarm/Language/Context.hs b/src/Swarm/Language/Context.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Context.hs @@ -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) diff --git a/src/Swarm/Language/Elaborate.hs b/src/Swarm/Language/Elaborate.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Elaborate.hs @@ -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)) diff --git a/src/Swarm/Language/LSP.hs b/src/Swarm/Language/LSP.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/LSP.hs @@ -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) + ] diff --git a/src/Swarm/Language/Parse.hs b/src/Swarm/Language/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Parse.hs @@ -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: +-- : +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 diff --git a/src/Swarm/Language/Parse/QQ.hs b/src/Swarm/Language/Parse/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Parse/QQ.hs @@ -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 diff --git a/src/Swarm/Language/Pipeline.hs b/src/Swarm/Language/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Pipeline.hs @@ -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' diff --git a/src/Swarm/Language/Pipeline/QQ.hs b/src/Swarm/Language/Pipeline/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Pipeline/QQ.hs @@ -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. diff --git a/src/Swarm/Language/Pretty.hs b/src/Swarm/Language/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Pretty.hs @@ -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) = " 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" diff --git a/src/Swarm/Language/Requirement.hs b/src/Swarm/Language/Requirement.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Requirement.hs @@ -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 diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Syntax.hs @@ -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)) diff --git a/src/Swarm/Language/Typecheck.hs b/src/Swarm/Language/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Typecheck.hs @@ -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 diff --git a/src/Swarm/Language/Types.hs b/src/Swarm/Language/Types.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Language/Types.hs @@ -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 diff --git a/src/Swarm/TUI/Attr.hs b/src/Swarm/TUI/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/Attr.hs @@ -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) diff --git a/src/Swarm/TUI/Border.hs b/src/Swarm/TUI/Border.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/Border.hs @@ -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 diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/Controller.hs @@ -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 () diff --git a/src/Swarm/TUI/List.hs b/src/Swarm/TUI/List.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/List.hs @@ -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 diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/Model.hs @@ -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 diff --git a/src/Swarm/TUI/Panel.hs b/src/Swarm/TUI/Panel.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/Panel.hs @@ -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) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/TUI/View.hs @@ -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) diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Util.hs @@ -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 "" + 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 diff --git a/src/Swarm/Util/Yaml.hs b/src/Swarm/Util/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Util/Yaml.hs @@ -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 diff --git a/src/Swarm/Version.hs b/src/Swarm/Version.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Version.hs @@ -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 diff --git a/src/Swarm/Web.hs b/src/Swarm/Web.hs new file mode 100644 --- /dev/null +++ b/src/Swarm/Web.hs @@ -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 diff --git a/swarm.cabal b/swarm.cabal new file mode 100644 --- /dev/null +++ b/swarm.cabal @@ -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 diff --git a/test/integration/Main.hs b/test/integration/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/Main.hs @@ -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) diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -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 diff --git a/test/unit/TestEval.hs b/test/unit/TestEval.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestEval.hs @@ -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 ++ ")" diff --git a/test/unit/TestInventory.hs b/test/unit/TestInventory.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestInventory.hs @@ -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" [] [] [] diff --git a/test/unit/TestLanguagePipeline.hs b/test/unit/TestLanguagePipeline.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestLanguagePipeline.hs @@ -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" diff --git a/test/unit/TestModel.hs b/test/unit/TestModel.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestModel.hs @@ -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) diff --git a/test/unit/TestNotification.hs b/test/unit/TestNotification.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestNotification.hs @@ -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 diff --git a/test/unit/TestPretty.hs b/test/unit/TestPretty.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestPretty.hs @@ -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 diff --git a/test/unit/TestUtil.hs b/test/unit/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/unit/TestUtil.hs @@ -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!"