From 888ee44d18abb926c0af4eb88254c9ba943805c1 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 17 Aug 2023 06:08:42 -0500 Subject: [PATCH] World description DSL (#1376) DSL for programming worlds, towards #1320 and #29 (and, indirectly, toward #50, since the world DSL should make a nice target for world saves) . Eventually this should be able to recreate all the world description/building features we have, though there is still a long way to go. But currently we can at least recreate the "classic" procedurally-generated world. I think this is a solid foundation we can merge as a first step, and then work on adding more features in subsequent PRs. Below are some notes that should help in reviewing. Note that the large number of files changed is due in large part to the elimination of the `default` field in scenario descriptions; see the "changed files" section below for an overview of the important/interesting changes. Issues split off from this one: #1394 #1395 #1396 #1397 Major changes ============ - New `data/worlds` subdirectory - All `.world` files are parsed at load time and saved in a `WorldMap` which gets threaded through, similar to `EntityMap` (perhaps we should think about passing around a single record instead) - Standard "classic" world - Used to be `testWorld2`, defined in Haskell code; now it is defined via the DSL in `worlds/classic.world`. This should make it much easier to experiment with variations. - We can now automatically extract entities mentioned in a world DSL term with `extractEntities`. There used to be an explicit list in `testWorld2Entities`, used to check pedagogy, generate documentation, etc., but it turns out it had (predictably) gotten out of date! This can't happen anymore. - It is now referenced in several tutorials (backstory, farming, world101, speedruns, etc.) - The `default` field of world descriptions is no more: one can use `dsl` to just specify a constant - Note in `Swarm.Game.State`, `dslWF` and `arrayWF` are combined using the `Monoid` instance to create `wf`. - `Erasable` - It used to be the case that if some kind of default terrain + entity was specified (e.g. stone + water), any `map` would completely override the default. However, we want to move towards combining everything with a `Monoid` instance. But by default this means the default entity would show through anywhere the `map` did not specify an entity. So we need a way to explicitly "erase" an entity from a lower layer. - If `e` is a `Semigroup`, then `Maybe e` is a `Monoid` where `Nothing` acts as an identity element. Likewise, `Erasable e` is a `Monoid` but adds two new elements: `ENothing` to be an identity, and `EErase` to be an *annihilator*. i.e. combining with `EErase` is like multiplying by zero. - We can now specify `erase` as an entity to override entity underneath. - There are several Haskell files with only changes related to `Erasable`, relating to e.g. the world editor, `PCells`, etc.; I'm not 100% sure I've always done the right thing here. DSL overview =========== - Integer, float, and Boolean literals. Note that `3` is *always* an `int`, and `3.0` is a `float`. It makes things much easier to not have to deal with `3` possibly being either `int` or `float`, though it does make things slightly more annoying for programmers. - Standard boolean, arithmetic, and comparison operators - `if ... then ... else ...` - `<>` operator for combining via `Semigroup` instance - Cell literals are enclosed in curly braces. Unlike the previous awkward world description syntax with one, two, or three-element lists denoting terrain, terrain + entity, or terrain + entity + robot, there can now be any number of elements in any order. - `{foo}` will be resolved as either terrain, an entity, or a robot, whichever is successful. So if the names are unambiguous one can just write `{tree}` or `{stone}`. - It is possible to explicitly indicate the type of cell value with syntax like `{entity: tree}` or `{terrain: stone}`. - Multiple items separated by commas is syntax sugar for combining with `<>`. e.g. `{tree, entity: boulder, stone} = {tree} <> {entity: boulder} <> {stone}`. - Ability to refer to the `seed` - Refer to the current `x` or `y` coordinates or the `hash` of the current coordinates - `let`-expressions for multiple variables: `let x1 = e1, x2 = e2, ... in ...` - `overlay [e1, e2, ...]` layers `e1` on the bottom, `e2` on top of that, etc., using the `Semigroup` instance for world functions - `"foo"` imports the DSL term in `worlds/foo.world` - `perlin` function to generate perlin noise - `mask` function to mask with a condition Changed files =========== - `Swarm.Util`: moved the `acquire` function here and gave it a more descriptive name. - `Swarm.Doc.Gen`: can now extract mentioned entities directly. - `Swarm.Game.Failure`: added new failure modes - `Swarm.Game.Scenario.Topography.WorldDescription`: get rid of `defaultTerrain` field, add `worldProg` for DSL. - `Swarm.Game.State`: see comment. - `Swarm.Game.World`: a bit of reorganization. Added a bunch of modules under this. - `Swarm.Game.World.Coords`: moved some code here from `Swarm.Game.World`. - `Swarm.Game.World.Gen`: moved some things here from `Swarm.Game.WorldGen` (also deleted a bunch of irrelevant code), and also added the `extractEntities` function to get all entities mentioned by a DSL term. - `Swarm.Game.World.Syntax`: raw, untyped syntax for world DSL terms. - `Swarm.Game.World.Parse`: parser for world DSL terms. Fairly standard. - `Swarm.Game.World.Typecheck`: takes raw, untyped terms produced by the parser and both typechecks and elaborates them into a simpler core language. An interesting feature is that the core language is *type-indexed*, so that the Haskell type system is actually ensuring that our typechecker is correct; every typechecked world DSL term value has a type which is indexed by a Haskell type corresponding to the type of the underlying DSL term. For example, `{entity: tree}` would have a type like `TTerm [] (World CellVall)` etc. Once terms make it through the typechecker, there cannot possibly be any bugs in the rest of the pipeline which would result in a crash, because the Haskell type system. (There could of course be *semantic* bugs.) Understanding exactly how the typechecker works is not too important. Of interest may be the `resolveCell` function, which determines how we decide what `Cell` is represented by a cell expression in curly braces. - `Swarm.Game.World.Abstract`: compile elaborated, typechecked world DSL terms down into an extremely simple core language with only constants and function application. This gives us very fast evaluation of world DSL terms. Understanding this module is not really necessary but there is a link to a blog post for those who are interested in how it works. - `Swarm.Game.World.Compile`: a further processing/compilation step after `Swarm.Game.World.Abstract`. Currently we don't actually use this, since it doesn't seem like it makes a big efficiency difference. - `Swarm.Game.World.Interpret`: interpreter for abstracted world DSL terms. - `Swarm.Game.World.Eval`: just puts together the pieces of the pipeline to evaluate a typechecked world DSL term. - `Swarm.Game.World.Load`: just loading world DSL terms from disk. --- bench/Benchmark.hs | 3 +- data/scenarios/Challenges/2048.yaml | 3 +- .../Challenges/Mazes/easy_cave_maze.yaml | 3 +- .../Challenges/Mazes/easy_spiral_maze.yaml | 3 +- .../Challenges/Mazes/invisible_maze.yaml | 3 +- .../Challenges/Mazes/loopy_maze.yaml | 3 +- .../Challenges/Ranching/capture.yaml | 3 +- .../Challenges/Ranching/gated-paddock.yaml | 9 +- .../Challenges/Ranching/powerset.yaml | 3 +- .../Challenges/Sliding Puzzles/3x3.yaml | 5 +- .../Sokoban/Gadgets/no-reverse.yaml | 7 +- .../Challenges/Sokoban/Gadgets/one-way.yaml | 7 +- .../Challenges/Sokoban/Simple/trapdoor.yaml | 9 +- .../Challenges/Sokoban/foresight.yaml | 11 +- data/scenarios/Challenges/arbitrage.yaml | 5 +- data/scenarios/Challenges/blender.yaml | 17 +- .../scenarios/Challenges/bridge-building.yaml | 1 - data/scenarios/Challenges/bucket-brigade.yaml | 3 +- data/scenarios/Challenges/chess_horse.yaml | 7 +- data/scenarios/Challenges/hackman.yaml | 3 +- data/scenarios/Challenges/hanoi.yaml | 3 +- data/scenarios/Challenges/ice-cream.yaml | 3 +- data/scenarios/Challenges/lights-out.yaml | 3 +- data/scenarios/Challenges/maypole.yaml | 3 +- data/scenarios/Challenges/teleport.yaml | 7 +- .../Challenges/wolf-goat-cabbage.yaml | 3 +- data/scenarios/Challenges/word-search.yaml | 3 +- data/scenarios/Fun/GoL.yaml | 3 +- data/scenarios/Fun/logo-burst.yaml | 1 - data/scenarios/Mechanics/active-trapdoor.yaml | 11 +- data/scenarios/README.md | 19 +- data/scenarios/Speedruns/curry.yaml | 4 +- data/scenarios/Speedruns/forester.yaml | 4 +- data/scenarios/Speedruns/mithril.yaml | 4 +- data/scenarios/Testing/00-ORDER.txt | 1 + data/scenarios/Testing/1007-use-command.yaml | 1 - data/scenarios/Testing/1024-sand.yaml | 1 - .../Testing/1034-custom-attributes.yaml | 3 +- .../1138-structures/flip-and-rotate.yaml | 1 - .../1138-structures/nested-structure.yaml | 1 - .../1138-structures/sibling-precedence.yaml | 3 +- .../Testing/1140-detect-command.yaml | 1 - .../Testing/1157-drill-return-value.yaml | 3 +- .../scenarios/Testing/1171-chirp-command.yaml | 1 - .../Testing/1171-resonate-command.yaml | 9 +- .../scenarios/Testing/1171-sniff-command.yaml | 1 - .../scenarios/Testing/1207-scout-command.yaml | 1 - .../Testing/1218-stride-command.yaml | 1 - data/scenarios/Testing/1234-push-command.yaml | 1 - data/scenarios/Testing/1256-halt-command.yaml | 1 - .../Testing/1295-density-command.yaml | 3 +- .../Testing/1320-world-DSL/00-ORDER.txt | 3 + .../Testing/1320-world-DSL/constant.yaml | 23 + .../Testing/1320-world-DSL/erase.yaml | 30 + .../Testing/1320-world-DSL/override.yaml | 25 + .../automatic-waypoint-patrol.yaml | 1 - .../1356-portals/portals-and-waypoints.yaml | 1 - .../1356-portals/portals-flip-and-rotate.yaml | 1 - .../201-require-device-creative.yaml | 1 - .../201-require-device-creative1.yaml | 1 - .../201-require/201-require-device.yaml | 1 - .../201-require/201-require-entities-def.yaml | 1 - .../201-require/201-require-entities.yaml | 1 - .../201-require/533-reprogram-simple.yaml | 1 - .../Testing/201-require/533-reprogram.yaml | 1 - data/scenarios/Testing/373-drill.yaml | 7 +- data/scenarios/Testing/378-objectives.yaml | 1 - data/scenarios/Testing/394-build-drill.yaml | 1 - data/scenarios/Testing/397-wrong-missing.yaml | 1 - .../Testing/428-drowning-destroy.yaml | 1 - data/scenarios/Testing/475-wait-one.yaml | 1 - data/scenarios/Testing/479-atomic-race.yaml | 1 - data/scenarios/Testing/479-atomic.yaml | 1 - data/scenarios/Testing/490-harvest.yaml | 1 - data/scenarios/Testing/504-teleport-self.yaml | 1 - .../Testing/508-capability-subset.yaml | 5 +- .../Testing/555-teleport-location.yaml | 3 +- data/scenarios/Testing/562-lodestone.yaml | 7 +- data/scenarios/Testing/684-swap.yaml | 1 - data/scenarios/Testing/687-watch-command.yaml | 1 - .../699-movement-fail/699-move-blocked.yaml | 1 - .../699-movement-fail/699-move-liquid.yaml | 1 - .../699-teleport-blocked.yaml | 1 - data/scenarios/Testing/710-multi-robot.yaml | 1 - .../795-prerequisite-and.yaml | 1 - .../795-prerequisite-cycle-with-not.yaml | 1 - .../795-prerequisite-mutually-exclusive.yaml | 1 - .../795-prerequisite/795-prerequisite-or.yaml | 1 - .../858-inventory/858-counting-objective.yaml | 3 +- .../858-nonpossession-objective.yaml | 1 - .../858-possession-objective.yaml | 3 +- data/scenarios/Testing/920-meet.yaml | 1 - data/scenarios/Testing/955-heading.yaml | 1 - data/scenarios/Testing/956-GPS.yaml | 1 - data/scenarios/Testing/958-isempty.yaml | 1 - .../Testing/961-custom-capabilities.yaml | 1 - .../_Validation/1221-duplicate-entities.yaml | 1 - .../1356-ambiguous-portal-entrance.yaml | 1 - .../1356-ambiguous-portal-exit.yaml | 1 - .../1356-waypoint-uniqueness-enforcement.yaml | 1 - .../_Validation/795-prerequisite-cycle.yaml | 1 - ...95-prerequisite-nonexistent-reference.yaml | 1 - .../795-prerequisite-self-reference.yaml | 1 - data/scenarios/Tutorials/backstory.yaml | 2 + data/scenarios/Tutorials/bind2.yaml | 1 - data/scenarios/Tutorials/build.yaml | 1 - data/scenarios/Tutorials/conditionals.yaml | 1 - data/scenarios/Tutorials/craft.yaml | 1 - data/scenarios/Tutorials/crash.yaml | 1 - data/scenarios/Tutorials/def.yaml | 1 - data/scenarios/Tutorials/equip.yaml | 1 - data/scenarios/Tutorials/farming.yaml | 2 + data/scenarios/Tutorials/give.yaml | 1 - data/scenarios/Tutorials/grab.yaml | 1 - data/scenarios/Tutorials/lambda.yaml | 1 - data/scenarios/Tutorials/move.yaml | 1 - data/scenarios/Tutorials/place.yaml | 1 - data/scenarios/Tutorials/require.yaml | 1 - data/scenarios/Tutorials/requireinv.yaml | 1 - data/scenarios/Tutorials/scan.yaml | 1 - data/scenarios/Tutorials/type-errors.yaml | 1 - data/scenarios/Tutorials/types.yaml | 1 - data/scenarios/Tutorials/world101.yaml | 2 + data/scenarios/Vignettes/roadway.yaml | 3 +- data/scenarios/blank.yaml | 3 +- data/scenarios/classic.yaml | 3 +- data/scenarios/creative.yaml | 3 +- data/schema/world.json | 8 +- data/worlds/README.md | 189 +++++ data/worlds/classic.world | 119 +++ fourmolu.yaml | 2 + src/Swarm/Doc/Gen.hs | 34 +- src/Swarm/Doc/Pedagogy.hs | 14 +- src/Swarm/Game/Achievement/Persistence.hs | 2 +- src/Swarm/Game/Entity.hs | 2 +- src/Swarm/Game/Failure.hs | 26 +- src/Swarm/Game/Recipe.hs | 2 +- src/Swarm/Game/Scenario.hs | 31 +- .../Game/Scenario/Scoring/ConcreteMetrics.hs | 2 +- src/Swarm/Game/Scenario/Status.hs | 2 +- src/Swarm/Game/Scenario/Topography/Cell.hs | 24 +- .../Scenario/Topography/WorldDescription.hs | 35 +- .../Game/Scenario/Topography/WorldPalette.hs | 5 +- src/Swarm/Game/ScenarioInfo.hs | 24 +- src/Swarm/Game/State.hs | 31 +- src/Swarm/Game/Terrain.hs | 13 +- src/Swarm/Game/World.hs | 71 +- src/Swarm/Game/World/Abstract.hs | 102 +++ src/Swarm/Game/World/Compile.hs | 126 ++++ src/Swarm/Game/World/Coords.hs | 48 ++ src/Swarm/Game/World/Eval.hs | 39 + src/Swarm/Game/World/Gen.hs | 79 ++ src/Swarm/Game/World/Interpret.hs | 87 +++ src/Swarm/Game/World/Load.hs | 65 ++ src/Swarm/Game/World/Parse.hs | 270 +++++++ src/Swarm/Game/World/Syntax.hs | 119 +++ src/Swarm/Game/World/Typecheck.hs | 687 ++++++++++++++++++ src/Swarm/Game/WorldGen.hs | 204 ------ src/Swarm/Language/Parse.hs | 18 +- src/Swarm/TUI/Editor/Controller.hs | 8 +- src/Swarm/TUI/Editor/Palette.hs | 20 +- src/Swarm/TUI/Editor/Util.hs | 8 +- src/Swarm/TUI/Model.hs | 13 +- src/Swarm/TUI/Model/StateUpdate.hs | 2 +- src/Swarm/Util.hs | 28 +- src/Swarm/Util/Effect.hs | 16 +- src/Swarm/Util/Erasable.hs | 46 ++ src/Swarm/Util/Parse.hs | 19 + swarm.cabal | 15 +- test/integration/Main.hs | 77 +- 170 files changed, 2537 insertions(+), 593 deletions(-) create mode 100644 data/scenarios/Testing/1320-world-DSL/00-ORDER.txt create mode 100644 data/scenarios/Testing/1320-world-DSL/constant.yaml create mode 100644 data/scenarios/Testing/1320-world-DSL/erase.yaml create mode 100644 data/scenarios/Testing/1320-world-DSL/override.yaml create mode 100644 data/worlds/README.md create mode 100644 data/worlds/classic.world create mode 100644 src/Swarm/Game/World/Abstract.hs create mode 100644 src/Swarm/Game/World/Compile.hs create mode 100644 src/Swarm/Game/World/Coords.hs create mode 100644 src/Swarm/Game/World/Eval.hs create mode 100644 src/Swarm/Game/World/Gen.hs create mode 100644 src/Swarm/Game/World/Interpret.hs create mode 100644 src/Swarm/Game/World/Load.hs create mode 100644 src/Swarm/Game/World/Parse.hs create mode 100644 src/Swarm/Game/World/Syntax.hs create mode 100644 src/Swarm/Game/World/Typecheck.hs delete mode 100644 src/Swarm/Game/WorldGen.hs create mode 100644 src/Swarm/Util/Erasable.hs create mode 100644 src/Swarm/Util/Parse.hs diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index cd5fc3e3d..a99694a87 100644 --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -26,6 +26,7 @@ import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.TUI.Model (gameState) import Swarm.TUI.Model.StateUpdate (classicGame0) +import Swarm.Util.Erasable -- | The program of a robot that does nothing. idleProgram :: ProcessedTerm @@ -87,7 +88,7 @@ mkGameState robotMaker numRobots = do (mapM addTRobot robots) ( (initAppState ^. gameState) & creativeMode .~ True - & multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, Nothing))) + & multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, ENothing))) ) -- | Runs numGameTicks ticks of the game. diff --git a/data/scenarios/Challenges/2048.yaml b/data/scenarios/Challenges/2048.yaml index fd51421cd..e4ea5b982 100644 --- a/data/scenarios/Challenges/2048.yaml +++ b/data/scenarios/Challenges/2048.yaml @@ -179,7 +179,8 @@ robots: - [1, "1"] known: [water, wavy water, flower, tree] world: - default: [stone] + dsl: | + {stone} palette: "Ω": [grass, null, base] "┌": [stone, upper left corner] diff --git a/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml b/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml index 6dc3cafa4..94794a54c 100644 --- a/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml +++ b/data/scenarios/Challenges/Mazes/easy_cave_maze.yaml @@ -65,7 +65,8 @@ entities: - The place you're trying to reach! You win by executing `grab` on this item. properties: [known, portable] world: - default: [ice] + dsl: | + {ice} palette: 'Ω': [stone, null, base] ' ': [stone, null] diff --git a/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml b/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml index 2f262b625..665794fb2 100644 --- a/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml +++ b/data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml @@ -65,7 +65,8 @@ entities: - The place you're trying to reach! You win by executing `grab` on this item. properties: [known, portable] world: - default: [ice] + dsl: | + {ice} palette: 'Ω': [stone, null, base] ' ': [stone, null] diff --git a/data/scenarios/Challenges/Mazes/invisible_maze.yaml b/data/scenarios/Challenges/Mazes/invisible_maze.yaml index 7e607460e..aaf523701 100644 --- a/data/scenarios/Challenges/Mazes/invisible_maze.yaml +++ b/data/scenarios/Challenges/Mazes/invisible_maze.yaml @@ -65,7 +65,8 @@ entities: - The place you're trying to reach! You win by executing `grab` on this item. properties: [known, portable] world: - default: [grass] + dsl: | + {grass} palette: 'Ω': [grass, null, base] '.': [grass, null] diff --git a/data/scenarios/Challenges/Mazes/loopy_maze.yaml b/data/scenarios/Challenges/Mazes/loopy_maze.yaml index 4705d478f..61e09af8c 100644 --- a/data/scenarios/Challenges/Mazes/loopy_maze.yaml +++ b/data/scenarios/Challenges/Mazes/loopy_maze.yaml @@ -58,7 +58,8 @@ entities: - The place you're trying to reach! You win by executing `grab` on this item. properties: [known, portable] world: - default: [grass] + dsl: | + {grass} palette: 'Ω': [grass, null, base] '.': [grass, null] diff --git a/data/scenarios/Challenges/Ranching/capture.yaml b/data/scenarios/Challenges/Ranching/capture.yaml index 8090714bd..5740be713 100644 --- a/data/scenarios/Challenges/Ranching/capture.yaml +++ b/data/scenarios/Challenges/Ranching/capture.yaml @@ -140,7 +140,8 @@ entities: properties: [known] known: [flower, tree] world: - default: [grass] + dsl: | + {grass} upperleft: [0, 0] offset: false palette: diff --git a/data/scenarios/Challenges/Ranching/gated-paddock.yaml b/data/scenarios/Challenges/Ranching/gated-paddock.yaml index 9552aaa96..826fc3a2c 100644 --- a/data/scenarios/Challenges/Ranching/gated-paddock.yaml +++ b/data/scenarios/Challenges/Ranching/gated-paddock.yaml @@ -506,14 +506,15 @@ seed: 0 solution: | run "scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw" world: - default: [dirt, water] + dsl: | + {dirt, water} palette: - 'B': [grass, null, base] - '.': [grass] + 'B': [grass, erase, base] + '.': [grass, erase] 't': [dirt, tree] 'x': [stone, mountain] 'c': [stone, cabin] - 's': [grass, null, sheep] + 's': [grass, erase, sheep] '%': [grass, clover, null] 'H': [stone, pier, null] '~': [dirt, water] diff --git a/data/scenarios/Challenges/Ranching/powerset.yaml b/data/scenarios/Challenges/Ranching/powerset.yaml index 77563fbcb..538e84214 100644 --- a/data/scenarios/Challenges/Ranching/powerset.yaml +++ b/data/scenarios/Challenges/Ranching/powerset.yaml @@ -179,7 +179,8 @@ entities: properties: [known, growable, portable] known: [sand] world: - default: [grass] + dsl: | + {grass} upperleft: [-1, -1] offset: false palette: diff --git a/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml b/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml index 43d485649..8758f2f9a 100644 --- a/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml +++ b/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml @@ -721,7 +721,8 @@ recipes: time: 0 known: [] world: - default: [grass] + dsl: | + {grass} upperleft: [-3, 2] offset: false palette: @@ -739,4 +740,4 @@ world: ..x....x.......... ..xxxxxx.......... .................. - zy................ \ No newline at end of file + zy................ diff --git a/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml b/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml index 24440b620..101545b6f 100644 --- a/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml +++ b/data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml @@ -66,12 +66,13 @@ entities: properties: [known, unwalkable, portable] known: [mountain, water, flower] world: - default: [grass, water] + dsl: | + {grass, water} upperleft: [-1, 1] offset: false palette: - 'B': [grass, null, base] - '.': [grass] + 'B': [grass, erase, base] + '.': [grass, erase] '@': [grass, monolith] 'A': [grass, mountain] '*': [grass, flower] diff --git a/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml b/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml index aea2cc6bb..0ef32e6ff 100644 --- a/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml +++ b/data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml @@ -49,12 +49,13 @@ entities: properties: [known, unwalkable, portable] known: [mountain, water, flower] world: - default: [grass, water] + dsl: | + {grass, water} upperleft: [-1, 1] offset: false palette: - 'B': [grass, null, base] - '.': [grass] + 'B': [grass, erase, base] + '.': [grass, erase] '@': [grass, monolith] 'A': [grass, mountain] '*': [grass, flower] diff --git a/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml b/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml index 8bd090ed5..c2ad7d1ad 100644 --- a/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml +++ b/data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml @@ -101,13 +101,14 @@ entities: properties: [known, unwalkable, portable] known: [mountain, water, flower] world: - default: [grass, water] + dsl: | + {grass, water} upperleft: [-1, 1] offset: false palette: - 'B': [ice, null, base] - '.': [grass] - 'x': [dirt] + 'B': [ice, erase, base] + '.': [grass, erase] + 'x': [dirt, erase] '@': [grass, monolith] 'A': [grass, mountain] '*': [grass, flower] diff --git a/data/scenarios/Challenges/Sokoban/foresight.yaml b/data/scenarios/Challenges/Sokoban/foresight.yaml index 5353838bd..dc54b682e 100644 --- a/data/scenarios/Challenges/Sokoban/foresight.yaml +++ b/data/scenarios/Challenges/Sokoban/foresight.yaml @@ -95,12 +95,13 @@ entities: properties: [known, unwalkable] known: [mountain, water, 3D printer, flower] world: - default: [grass, water] + dsl: | + {grass, water} upperleft: [-21, 10] offset: false palette: - 'B': [ice, null, base] - '.': [grass] + 'B': [ice, erase, base] + '.': [grass, erase] '*': [grass, flower] 'b': [grass, boat] '3': [grass, 3D printer] @@ -108,8 +109,8 @@ world: 'c': [grass, crate] 'A': [grass, wall] 'w': [dirt, water] - 'x': [stone] - 'z': [dirt] + 'x': [stone, erase] + 'z': [dirt, erase] map: | ..................3...A. .................AAAA.A* diff --git a/data/scenarios/Challenges/arbitrage.yaml b/data/scenarios/Challenges/arbitrage.yaml index 65ffc9124..d5a671d03 100644 --- a/data/scenarios/Challenges/arbitrage.yaml +++ b/data/scenarios/Challenges/arbitrage.yaml @@ -378,7 +378,8 @@ recipes: - [1, drill] known: [] world: - default: [dirt] + dsl: | + {dirt} upperleft: [0, 0] offset: false palette: @@ -413,4 +414,4 @@ world: ...X****7****1... ........*........ B....p.p.p.p.p... - /.............../ \ No newline at end of file + /.............../ diff --git a/data/scenarios/Challenges/blender.yaml b/data/scenarios/Challenges/blender.yaml index 88561aef0..bf452a418 100644 --- a/data/scenarios/Challenges/blender.yaml +++ b/data/scenarios/Challenges/blender.yaml @@ -190,22 +190,23 @@ recipes: known: [water] seed: 0 world: - default: [stone, water] + dsl: | + {stone, water} upperleft: [0, 0] offset: false palette: '0': [stone, water] '@': [stone, granite boulder] - '.': [grass] - 'L': [stone] + '.': [grass, erase] + 'L': [stone, erase] '>': [stone, bind gt] '=': [stone, bind eq] - H: [dirt] + H: [dirt, erase] A: [grass, water, ccw_robot] a: [grass, water, ccw_robot_down] - B: [grass, null, cw_robot] - b: [grass, null, cw_robot_down] - Ω: [grass, null, base] + B: [grass, erase, cw_robot] + b: [grass, erase, cw_robot_down] + Ω: [grass, erase, base] f: [stone, Amulet of Yoneda] x: [stone, locked door] k: [grass, door key] @@ -225,4 +226,4 @@ world: ..@@@@@@@@@.@@@@@@@.@@@@@@@.@.. ..Ω.........@.....@.........@.. @@@@@@@@@@@@@.>>=.@@@@@@@@@@@.. - ............................... \ No newline at end of file + ............................... diff --git a/data/scenarios/Challenges/bridge-building.yaml b/data/scenarios/Challenges/bridge-building.yaml index 9a073cd2c..7a972b531 100644 --- a/data/scenarios/Challenges/bridge-building.yaml +++ b/data/scenarios/Challenges/bridge-building.yaml @@ -615,7 +615,6 @@ recipes: known: [water, sand, flower, iron mine] seed: 0 world: - default: [blank] palette: '.': [blank] '/': [blank, left roof] diff --git a/data/scenarios/Challenges/bucket-brigade.yaml b/data/scenarios/Challenges/bucket-brigade.yaml index 5a3e3cb92..30e11f48b 100644 --- a/data/scenarios/Challenges/bucket-brigade.yaml +++ b/data/scenarios/Challenges/bucket-brigade.yaml @@ -179,7 +179,8 @@ recipes: known: [boulder, lignite mine] seed: 0 world: - default: [grass] + dsl: | + {grass} palette: 'B': [dirt, null, base] '.': [dirt] diff --git a/data/scenarios/Challenges/chess_horse.yaml b/data/scenarios/Challenges/chess_horse.yaml index ae9029bbc..95b06cb61 100644 --- a/data/scenarios/Challenges/chess_horse.yaml +++ b/data/scenarios/Challenges/chess_horse.yaml @@ -34,10 +34,11 @@ robots: char: '♚' known: [water] world: - default: [ice, water] + dsl: | + {ice, water} palette: - '.': [grass] - '#': [ice] + '.': [grass, erase] + '#': [ice, erase] '┌': [stone, upper left corner] '┐': [stone, upper right corner] '└': [stone, lower left corner] diff --git a/data/scenarios/Challenges/hackman.yaml b/data/scenarios/Challenges/hackman.yaml index a5e0e3fa9..eb45d73f3 100644 --- a/data/scenarios/Challenges/hackman.yaml +++ b/data/scenarios/Challenges/hackman.yaml @@ -264,7 +264,6 @@ solution: known: [] seed: 0 world: - default: [blank] palette: 'B': [blank] 'Ω': [blank, null, base] @@ -307,4 +306,4 @@ world: x.....x....x....x.....x x.xxxxxxxx.x.xxxxxxxx.x x.....................x - xxxxxxxxxxxxxxxxxxxxxxx \ No newline at end of file + xxxxxxxxxxxxxxxxxxxxxxx diff --git a/data/scenarios/Challenges/hanoi.yaml b/data/scenarios/Challenges/hanoi.yaml index da0a67d67..5c6910830 100644 --- a/data/scenarios/Challenges/hanoi.yaml +++ b/data/scenarios/Challenges/hanoi.yaml @@ -155,7 +155,8 @@ known: - blocked two - blocked three world: - default: [grass, null] + dsl: | + {grass} palette: ',': [grass] '_': [stone] diff --git a/data/scenarios/Challenges/ice-cream.yaml b/data/scenarios/Challenges/ice-cream.yaml index a8aa8d96b..c9bb1e454 100644 --- a/data/scenarios/Challenges/ice-cream.yaml +++ b/data/scenarios/Challenges/ice-cream.yaml @@ -206,7 +206,8 @@ recipes: - [1, scoop] known: [] world: - default: [grass] + dsl: | + {grass} upperleft: [0, 0] offset: false palette: diff --git a/data/scenarios/Challenges/lights-out.yaml b/data/scenarios/Challenges/lights-out.yaml index fc0fa8722..c94caf7d3 100644 --- a/data/scenarios/Challenges/lights-out.yaml +++ b/data/scenarios/Challenges/lights-out.yaml @@ -143,7 +143,6 @@ recipes: time: 0 known: [] world: - default: [blank] upperleft: [-1, 1] offset: false palette: @@ -160,4 +159,4 @@ world: .xxxxx. .xxxxx. z...... - \ No newline at end of file + diff --git a/data/scenarios/Challenges/maypole.yaml b/data/scenarios/Challenges/maypole.yaml index d1dd0bca6..d6e976447 100644 --- a/data/scenarios/Challenges/maypole.yaml +++ b/data/scenarios/Challenges/maypole.yaml @@ -100,7 +100,8 @@ entities: properties: [known, unwalkable] known: [bitcoin] world: - default: [grass] + dsl: | + {grass} upperleft: [0, 0] offset: false palette: diff --git a/data/scenarios/Challenges/teleport.yaml b/data/scenarios/Challenges/teleport.yaml index 0717599b9..1fa88724d 100644 --- a/data/scenarios/Challenges/teleport.yaml +++ b/data/scenarios/Challenges/teleport.yaml @@ -56,15 +56,16 @@ robots: ); known: [water, wavy water, flower, tree] world: - default: [ice, water] + dsl: | + {ice, water} palette: ',': [ice, water] ' ': [ice, water] '~': [ice, wavy water] '*': [grass, flower] 'T': [grass, tree] - '.': [grass] - '_': [stone] + '.': [grass, erase] + '_': [stone, erase] '┌': [stone, upper left corner] '┐': [stone, upper right corner] '└': [stone, lower left corner] diff --git a/data/scenarios/Challenges/wolf-goat-cabbage.yaml b/data/scenarios/Challenges/wolf-goat-cabbage.yaml index d214e38fc..dd7d8a752 100644 --- a/data/scenarios/Challenges/wolf-goat-cabbage.yaml +++ b/data/scenarios/Challenges/wolf-goat-cabbage.yaml @@ -98,7 +98,6 @@ entities: known: [water, boulder] seed: 0 world: - default: [blank] palette: 'A': [stone, boulder] 'B': [stone, boulder, base] @@ -122,4 +121,4 @@ world: AAA~~~~~~~~~~~~~~~AAA AAAAA~~~~~~~~~~~AAAAA AAAAAAAA~~~~~AAAAAAAA - AAAAAAAAAAAAAAAAAAAAA \ No newline at end of file + AAAAAAAAAAAAAAAAAAAAA diff --git a/data/scenarios/Challenges/word-search.yaml b/data/scenarios/Challenges/word-search.yaml index 45887e544..01e1afffd 100644 --- a/data/scenarios/Challenges/word-search.yaml +++ b/data/scenarios/Challenges/word-search.yaml @@ -349,7 +349,8 @@ recipes: - [1, highlighter] known: [boulder] world: - default: [dirt] + dsl: | + {dirt} upperleft: [0, 0] offset: false palette: diff --git a/data/scenarios/Fun/GoL.yaml b/data/scenarios/Fun/GoL.yaml index f3e172de8..30b8d6a54 100644 --- a/data/scenarios/Fun/GoL.yaml +++ b/data/scenarios/Fun/GoL.yaml @@ -58,7 +58,8 @@ robots: waitUntil (t <- time; return (mod t 0x20 == 0)) ) world: - default: [ice] + dsl: | + {ice} palette: 'o': [ice, rock, cell] '.': [ice, null, cell] diff --git a/data/scenarios/Fun/logo-burst.yaml b/data/scenarios/Fun/logo-burst.yaml index 665ec5e61..2ad73a030 100644 --- a/data/scenarios/Fun/logo-burst.yaml +++ b/data/scenarios/Fun/logo-burst.yaml @@ -56,7 +56,6 @@ robots: known: [boulder, tree, water, wavy water] world: - default: [blank] upperleft: [0, 0] offset: false palette: diff --git a/data/scenarios/Mechanics/active-trapdoor.yaml b/data/scenarios/Mechanics/active-trapdoor.yaml index 8f093c33c..70f454549 100644 --- a/data/scenarios/Mechanics/active-trapdoor.yaml +++ b/data/scenarios/Mechanics/active-trapdoor.yaml @@ -55,14 +55,14 @@ solution: | known: [water, boulder, flower] seed: 0 world: - default: [stone, water] + dsl: | + {stone, water} upperleft: [0, 0] - offset: false palette: '@': [stone, boulder] - '.': [grass] - G: [stone, null, gate] - Ω: [grass, null, base] + '.': [grass, erase] + G: [stone, erase, gate] + Ω: [grass, erase, base] f: [grass, flower] map: | ..... @@ -78,4 +78,3 @@ world: ..... ..Ω.. ..... - \ No newline at end of file diff --git a/data/scenarios/README.md b/data/scenarios/README.md index 09453fa1d..d264e3a67 100644 --- a/data/scenarios/README.md +++ b/data/scenarios/README.md @@ -26,7 +26,7 @@ request](https://github.com/swarm-game/swarm/blob/main/CONTRIBUTING.md)! The "blessed" scenarios that come with Swarm are stored in `data/scenarios` and can be accessed via the "New game" menu. However, other scenarios can be loaded directly from a file: simply -run swarm with the `--scenario` flag (`-c` for short) and point it to +run swarm with the `--scenario` flag (`-i` for short) and point it to a specific `.yaml` file containing a scenario. For example: ``` @@ -212,7 +212,6 @@ and `drill`. | `required` | `[]` | `(int × string) list` | A list of catalysts required by the recipe. They are neither consumed nor produced, but must be present in order for the recipe to be carried out. It is a list of [count, entity name] tuples just like `in` and `out`. | | `time` | 1 | `int` | The number of ticks the recipe takes to perform. For recipes which take more than 1 tick, the robot will `wait` for a number of ticks until the recipe is complete. For example, this is used for many drilling recipes. | | `weight` | 1 | `int` | Whenever there are multiple recipes that match the relevant criteria, one of them will be chosen at random, with probability proportional to their weights. For example, suppose there are two recipes that both output a `widget`, one with weight `1` and the other with weight `9`. When a robot executes `make "widget"`, the first recipe will be chosen 10% of the time, and the second recipe 90% of the time. | -| | | | | ### World @@ -220,14 +219,14 @@ The top-level `world` field contains a key-value mapping describing the world, that is, a description of the terrain and entities that exist at various locations. -| Key | Default? | Type | Description | -|--------------|----------|---------------|------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| -| `default` | `null` | `string list` | A tuple representing the contents of a default cell (see [Cells](#cells), except that the default cell may not contain a robot). If this key is present, it means that the whole world besides the part specified with the `map` will be filled with this default cell. If omitted, the world besides the part specified with the `map` will be procedurally generated. | -| `offset` | `False` | `boolean` | Whether the `base` robot's position should be moved to the nearest "good" location, currently defined as a location near a tree, in a 16x16 patch which contains at least one each of `tree`, `copper ore`, `bit (0)`, `bit (1)`, `rock`, `lambda`, `water`, and `sand`. The `classic` scenario uses `offset: True` to make sure that the it is not unreasonably difficult to obtain necessary resources in the early game. See https://github.com/swarm-game/swarm/blob/main/src/Swarm/Game/WorldGen.hs#L204 . | -| `scrollable` | `True` | `boolean` | Whether players are allowed to scroll the world map. | -| `palette` | `{}` | `object` | The `palette` maps single character keys to tuples representing contents of cells in the world, so that a world containing entities and robots can be drawn graphically. See [Cells](#cells) for the contents of the tuples representing a cell. | -| `map` | `""` | `string` | A rectangular string, using characters from the `palette`, exactly specifying the contents of a rectangular portion of the world. Leading spaces are ignored. The rest of the world is either filled by the `default` cell, or by procedural generation otherwise. Note that this is optional; if omitted, the world will simply be filled with the `default` cell or procedurally generated. | -| `upperleft` | `[0,0]` | `int × int` | A 2-tuple of `int` values specifying the (x,y) coordinates of the upper left corner of the `map`. | +| Key | Default? | Type | Description | +|--------------|----------|-------------|------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| +| `dsl` | `null` | `string` | An expression of the [Swarm world description DSL](../worlds/README.md). If specified, this will be used as the base layer for the world. | +| `offset` | `False` | `boolean` | Whether the `base` robot's position should be moved to the nearest "good" location, currently defined as a location near a tree, in a 16x16 patch which contains at least one each of `tree`, `copper ore`, `bit (0)`, `bit (1)`, `rock`, `lambda`, `water`, and `sand`. The `classic` scenario uses `offset: True` to make sure that the it is not unreasonably difficult to obtain necessary resources in the early game. See https://github.com/swarm-game/swarm/blob/main/src/Swarm/Game/WorldGen.hs#L204 . | +| `scrollable` | `True` | `boolean` | Whether players are allowed to scroll the world map. | +| `palette` | `{}` | `object` | The `palette` maps single character keys to tuples representing contents of cells in the world, so that a world containing entities and robots can be drawn graphically. See [Cells](#cells) for the contents of the tuples representing a cell. | +| `map` | `""` | `string` | A rectangular string, using characters from the `palette`, exactly specifying the contents of a rectangular portion of the world. Leading spaces are ignored. The rest of the world is either filled by the `default` cell, or by procedural generation otherwise. Note that this is optional; if omitted, the world will simply be filled with the `default` cell or procedurally generated. | +| `upperleft` | `[0,0]` | `int × int` | A 2-tuple of `int` values specifying the (x,y) coordinates of the upper left corner of the `map`. | #### Cells diff --git a/data/scenarios/Speedruns/curry.yaml b/data/scenarios/Speedruns/curry.yaml index 92fc71b5d..9e7c89e8e 100644 --- a/data/scenarios/Speedruns/curry.yaml +++ b/data/scenarios/Speedruns/curry.yaml @@ -33,5 +33,7 @@ robots: - [50, scanner] - [5, toolkit] world: - seed: null offset: true + scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/Speedruns/forester.yaml b/data/scenarios/Speedruns/forester.yaml index 317c81575..1698aa467 100644 --- a/data/scenarios/Speedruns/forester.yaml +++ b/data/scenarios/Speedruns/forester.yaml @@ -33,5 +33,7 @@ robots: - [50, scanner] - [5, toolkit] world: - seed: null offset: true + scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/Speedruns/mithril.yaml b/data/scenarios/Speedruns/mithril.yaml index 1b7dfbc47..c9d24fa0e 100644 --- a/data/scenarios/Speedruns/mithril.yaml +++ b/data/scenarios/Speedruns/mithril.yaml @@ -33,5 +33,7 @@ robots: - [50, scanner] - [5, toolkit] world: - seed: null offset: true + scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index fc90b1a53..4549f666f 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -37,6 +37,7 @@ 1256-halt-command.yaml 1295-density-command.yaml 1138-structures +1320-world-DSL 1356-portals 144-subworlds 1379-single-world-portal-reorientation.yaml diff --git a/data/scenarios/Testing/1007-use-command.yaml b/data/scenarios/Testing/1007-use-command.yaml index bba9fc2d1..fba13e133 100644 --- a/data/scenarios/Testing/1007-use-command.yaml +++ b/data/scenarios/Testing/1007-use-command.yaml @@ -65,7 +65,6 @@ recipes: - [1, gate key] known: [flower] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/1024-sand.yaml b/data/scenarios/Testing/1024-sand.yaml index be0cd4d51..d649848ff 100644 --- a/data/scenarios/Testing/1024-sand.yaml +++ b/data/scenarios/Testing/1024-sand.yaml @@ -37,7 +37,6 @@ robots: - solar panel - treads world: - default: [blank] palette: '>': [grass, null, base] 'Å': [stone, copper mine] diff --git a/data/scenarios/Testing/1034-custom-attributes.yaml b/data/scenarios/Testing/1034-custom-attributes.yaml index 76adf052a..e3b06711a 100644 --- a/data/scenarios/Testing/1034-custom-attributes.yaml +++ b/data/scenarios/Testing/1034-custom-attributes.yaml @@ -179,7 +179,6 @@ entities: properties: [known] robots: [] world: - default: [blank] palette: '.': [blank] '1': [blank, color1] @@ -207,4 +206,4 @@ world: .1234567..Rzzy...IIy .1234567y.R.z....... .abcdefg......C..BBz - .abcdefgyy.yy..Cz.z. \ No newline at end of file + .abcdefgyy.yy..Cz.z. diff --git a/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml b/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml index 9572b0d63..b2691566c 100644 --- a/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml +++ b/data/scenarios/Testing/1138-structures/flip-and-rotate.yaml @@ -8,7 +8,6 @@ robots: dir: [1, 0] known: [flower, bit (0), bit (1)] world: - default: [blank] palette: '.': [grass] '*': [stone, flower] diff --git a/data/scenarios/Testing/1138-structures/nested-structure.yaml b/data/scenarios/Testing/1138-structures/nested-structure.yaml index 396e08cd7..79d3d90d5 100644 --- a/data/scenarios/Testing/1138-structures/nested-structure.yaml +++ b/data/scenarios/Testing/1138-structures/nested-structure.yaml @@ -8,7 +8,6 @@ robots: dir: [1, 0] known: [tree, flower, bit (0), bit (1)] world: - default: [blank] palette: '.': [grass] '*': [stone, flower] diff --git a/data/scenarios/Testing/1138-structures/sibling-precedence.yaml b/data/scenarios/Testing/1138-structures/sibling-precedence.yaml index c90041cbf..abb1c385b 100644 --- a/data/scenarios/Testing/1138-structures/sibling-precedence.yaml +++ b/data/scenarios/Testing/1138-structures/sibling-precedence.yaml @@ -8,7 +8,6 @@ robots: dir: [1, 0] known: [water, sand] world: - default: [blank] palette: '.': [grass] upperleft: [-1, 1] @@ -86,4 +85,4 @@ world: ............ ............ ............ - ............ \ No newline at end of file + ............ diff --git a/data/scenarios/Testing/1140-detect-command.yaml b/data/scenarios/Testing/1140-detect-command.yaml index 1262708dc..775069d3a 100644 --- a/data/scenarios/Testing/1140-detect-command.yaml +++ b/data/scenarios/Testing/1140-detect-command.yaml @@ -35,7 +35,6 @@ robots: - ADT calculator known: [] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/1157-drill-return-value.yaml b/data/scenarios/Testing/1157-drill-return-value.yaml index cabc89c57..8884f1f66 100644 --- a/data/scenarios/Testing/1157-drill-return-value.yaml +++ b/data/scenarios/Testing/1157-drill-return-value.yaml @@ -22,7 +22,6 @@ robots: - ADT calculator known: [] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] @@ -56,4 +55,4 @@ recipes: - [1, gumball] required: - [1, drill] - time: 1 \ No newline at end of file + time: 1 diff --git a/data/scenarios/Testing/1171-chirp-command.yaml b/data/scenarios/Testing/1171-chirp-command.yaml index f61451a94..1bee78311 100644 --- a/data/scenarios/Testing/1171-chirp-command.yaml +++ b/data/scenarios/Testing/1171-chirp-command.yaml @@ -33,7 +33,6 @@ robots: - treads known: [] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/1171-resonate-command.yaml b/data/scenarios/Testing/1171-resonate-command.yaml index 37cdffe18..ab6bbd3d3 100644 --- a/data/scenarios/Testing/1171-resonate-command.yaml +++ b/data/scenarios/Testing/1171-resonate-command.yaml @@ -37,11 +37,12 @@ robots: char: J known: [] world: - default: [blank, boulder] + dsl: | + {blank, boulder} palette: - 'Ω': [grass, null, base] - 'J': [grass, null, judge] - '.': [grass] + 'Ω': [grass, erase, base] + 'J': [grass, erase, judge] + '.': [grass, erase] upperleft: [4, -1] map: | J........ diff --git a/data/scenarios/Testing/1171-sniff-command.yaml b/data/scenarios/Testing/1171-sniff-command.yaml index 97cfbc1da..4b0649ca0 100644 --- a/data/scenarios/Testing/1171-sniff-command.yaml +++ b/data/scenarios/Testing/1171-sniff-command.yaml @@ -42,7 +42,6 @@ robots: - treads known: [] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/1207-scout-command.yaml b/data/scenarios/Testing/1207-scout-command.yaml index dee121e6e..6c462cdcb 100644 --- a/data/scenarios/Testing/1207-scout-command.yaml +++ b/data/scenarios/Testing/1207-scout-command.yaml @@ -69,7 +69,6 @@ robots: attr: robot known: [tree, flower, boulder] world: - default: [blank] palette: 'Ω': [grass, null, base] 'b': [grass, null, bot] diff --git a/data/scenarios/Testing/1218-stride-command.yaml b/data/scenarios/Testing/1218-stride-command.yaml index e62d25aa0..6839caa43 100644 --- a/data/scenarios/Testing/1218-stride-command.yaml +++ b/data/scenarios/Testing/1218-stride-command.yaml @@ -78,7 +78,6 @@ entities: capabilities: [movemultiple] known: [tree, flower, boulder, water] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/1234-push-command.yaml b/data/scenarios/Testing/1234-push-command.yaml index de9a49358..283386ea8 100644 --- a/data/scenarios/Testing/1234-push-command.yaml +++ b/data/scenarios/Testing/1234-push-command.yaml @@ -51,7 +51,6 @@ entities: properties: [known, portable, unwalkable] known: [tree, flower, boulder, water] world: - default: [blank] palette: 'Ω': [grass, null, base] 'j': [stone, null, judge] diff --git a/data/scenarios/Testing/1256-halt-command.yaml b/data/scenarios/Testing/1256-halt-command.yaml index 45911cf66..b00f715c9 100644 --- a/data/scenarios/Testing/1256-halt-command.yaml +++ b/data/scenarios/Testing/1256-halt-command.yaml @@ -41,7 +41,6 @@ robots: def forever = \c. c ; forever c end; forever ( turn right ) world: - default: [blank] palette: 'Ω': [grass, null, base] '^': [grass, null, infinitebot] diff --git a/data/scenarios/Testing/1295-density-command.yaml b/data/scenarios/Testing/1295-density-command.yaml index b6228abcc..46ceec8e3 100644 --- a/data/scenarios/Testing/1295-density-command.yaml +++ b/data/scenarios/Testing/1295-density-command.yaml @@ -35,7 +35,8 @@ robots: char: J known: [] world: - default: [blank, boulder] + dsl: | + {blank, boulder} palette: 'Ω': [grass, tree, base] 'J': [grass, tree, judge] diff --git a/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt b/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt new file mode 100644 index 000000000..8a46bc0af --- /dev/null +++ b/data/scenarios/Testing/1320-world-DSL/00-ORDER.txt @@ -0,0 +1,3 @@ +constant.yaml +erase.yaml +override.yaml diff --git a/data/scenarios/Testing/1320-world-DSL/constant.yaml b/data/scenarios/Testing/1320-world-DSL/constant.yaml new file mode 100644 index 000000000..be7d50bee --- /dev/null +++ b/data/scenarios/Testing/1320-world-DSL/constant.yaml @@ -0,0 +1,23 @@ +version: 1 +name: Constant (uniform) world description +description: | + Test that we can describe a uniform world by giving a + single cell value. +objectives: + - condition: | + as base { n <- count "tree"; return (n >= 4) } + goal: + - Get 4 trees +solution: | + grab; move; grab; move; grab; move; grab +robots: + - name: base + loc: [0,0] + dir: [1,0] + devices: + - logger + - treads + - grabber +world: + dsl: | + {terrain: ice} <> {entity: tree} diff --git a/data/scenarios/Testing/1320-world-DSL/erase.yaml b/data/scenarios/Testing/1320-world-DSL/erase.yaml new file mode 100644 index 000000000..00ad6161a --- /dev/null +++ b/data/scenarios/Testing/1320-world-DSL/erase.yaml @@ -0,0 +1,30 @@ +version: 1 +name: Overlay with erasure +description: | + Test that we can erase entities when overlaying +objectives: + - condition: | + as base { n <- count "tree"; return (n == 0) } + goal: + - Get rid of your trees. +solution: | + place "tree"; move; move; + place "tree"; move; move; + place "tree"; move; move; + place "tree" +robots: + - name: base + loc: [0,0] + dir: [1,0] + devices: + - logger + - treads + - grabber + inventory: + - [4, tree] +world: + dsl: | + overlay + [ {terrain: ice} <> {entity: tree} + , if (x + y) % 2 == 0 then {erase} else {blank} + ] diff --git a/data/scenarios/Testing/1320-world-DSL/override.yaml b/data/scenarios/Testing/1320-world-DSL/override.yaml new file mode 100644 index 000000000..1f64a65bc --- /dev/null +++ b/data/scenarios/Testing/1320-world-DSL/override.yaml @@ -0,0 +1,25 @@ +version: 1 +name: Overlay with overriding +description: | + Test that later entities override earlier ones when overlaying +objectives: + - condition: | + as base { n <- count "tree"; return (n == 1) } + goal: + - Get a tree. +solution: | + grab +robots: + - name: base + loc: [0,0] + dir: [1,0] + devices: + - logger + - treads + - grabber +world: + dsl: | + overlay + [ {terrain: ice} <> {entity: rock} + , {entity: tree} + ] diff --git a/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml b/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml index 1dd0e6058..16304ebd2 100644 --- a/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml +++ b/data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml @@ -18,7 +18,6 @@ robots: known: [flower, boulder] world: upperleft: [-1, 1] - default: [blank] palette: '.': [grass] '*': [stone, flower] diff --git a/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml b/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml index 95f24e3cb..ce7d31aa6 100644 --- a/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml +++ b/data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml @@ -32,7 +32,6 @@ robots: known: [tree, flower, sand, bit (0), bit (1)] world: upperleft: [-4, 7] - default: [blank] palette: '.': [grass] '*': [stone, flower] diff --git a/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml b/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml index f62c97c97..93f185956 100644 --- a/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml +++ b/data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml @@ -50,7 +50,6 @@ robots: - treads known: [flower, bit (0), bit (1), bitcoin] world: - default: [blank] palette: '.': [grass] '*': [stone, flower] diff --git a/data/scenarios/Testing/201-require/201-require-device-creative.yaml b/data/scenarios/Testing/201-require/201-require-device-creative.yaml index 73b3cdf7c..290c080af 100644 --- a/data/scenarios/Testing/201-require/201-require-device-creative.yaml +++ b/data/scenarios/Testing/201-require/201-require-device-creative.yaml @@ -25,7 +25,6 @@ robots: - logger known: [water] world: - default: [blank, null] palette: '.': [grass] '~': [dirt, water] diff --git a/data/scenarios/Testing/201-require/201-require-device-creative1.yaml b/data/scenarios/Testing/201-require/201-require-device-creative1.yaml index 6cdfe38ca..de438f1d3 100644 --- a/data/scenarios/Testing/201-require/201-require-device-creative1.yaml +++ b/data/scenarios/Testing/201-require/201-require-device-creative1.yaml @@ -26,7 +26,6 @@ robots: inventory: - [1, boat] world: - default: [blank, null] palette: '.': [grass] '~': [dirt, knownwater] diff --git a/data/scenarios/Testing/201-require/201-require-device.yaml b/data/scenarios/Testing/201-require/201-require-device.yaml index 06b9ff540..c641176ba 100644 --- a/data/scenarios/Testing/201-require/201-require-device.yaml +++ b/data/scenarios/Testing/201-require/201-require-device.yaml @@ -28,7 +28,6 @@ robots: - [1, treads] known: [water] world: - default: [blank, null] palette: '.': [grass] '~': [dirt, water] diff --git a/data/scenarios/Testing/201-require/201-require-entities-def.yaml b/data/scenarios/Testing/201-require/201-require-entities-def.yaml index f6c54dfc8..6eb0ce336 100644 --- a/data/scenarios/Testing/201-require/201-require-entities-def.yaml +++ b/data/scenarios/Testing/201-require/201-require-entities-def.yaml @@ -30,7 +30,6 @@ robots: - [1, grabber] - [1, logger] world: - default: [blank, null] palette: '.': [grass] '┌': [stone, upper left corner] diff --git a/data/scenarios/Testing/201-require/201-require-entities.yaml b/data/scenarios/Testing/201-require/201-require-entities.yaml index b46e82519..016dafaaa 100644 --- a/data/scenarios/Testing/201-require/201-require-entities.yaml +++ b/data/scenarios/Testing/201-require/201-require-entities.yaml @@ -28,7 +28,6 @@ robots: - [1, grabber] - [1, logger] world: - default: [blank, null] palette: '.': [grass] '┌': [stone, upper left corner] diff --git a/data/scenarios/Testing/201-require/533-reprogram-simple.yaml b/data/scenarios/Testing/201-require/533-reprogram-simple.yaml index 719ea333d..bf136ad06 100644 --- a/data/scenarios/Testing/201-require/533-reprogram-simple.yaml +++ b/data/scenarios/Testing/201-require/533-reprogram-simple.yaml @@ -46,7 +46,6 @@ robots: - [50, rock] known: [water] world: - default: [blank, null] palette: '.': [grass] '~': [dirt, water] diff --git a/data/scenarios/Testing/201-require/533-reprogram.yaml b/data/scenarios/Testing/201-require/533-reprogram.yaml index 8cc282e50..f8ee100e5 100644 --- a/data/scenarios/Testing/201-require/533-reprogram.yaml +++ b/data/scenarios/Testing/201-require/533-reprogram.yaml @@ -46,7 +46,6 @@ robots: - [50, rock] known: [water] world: - default: [blank, null] palette: '.': [grass] '~': [dirt, water] diff --git a/data/scenarios/Testing/373-drill.yaml b/data/scenarios/Testing/373-drill.yaml index b4741c897..b090777e0 100644 --- a/data/scenarios/Testing/373-drill.yaml +++ b/data/scenarios/Testing/373-drill.yaml @@ -40,10 +40,11 @@ robots: - [5, grabber] known: [water, wavy water] world: - default: [ice, water] + dsl: | + {ice, water} palette: - 'Ω': [grass, null, base] - '.': [grass] + 'Ω': [grass, erase, base] + '.': [grass, erase] ' ': [ice, water] '~': [ice, wavy water] 'L': [grass, Linux] diff --git a/data/scenarios/Testing/378-objectives.yaml b/data/scenarios/Testing/378-objectives.yaml index 1c639595e..56fb14939 100644 --- a/data/scenarios/Testing/378-objectives.yaml +++ b/data/scenarios/Testing/378-objectives.yaml @@ -46,7 +46,6 @@ robots: - [10, solar panel] - [0, harvester] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/394-build-drill.yaml b/data/scenarios/Testing/394-build-drill.yaml index 5fd1a09cd..fe844ef4f 100644 --- a/data/scenarios/Testing/394-build-drill.yaml +++ b/data/scenarios/Testing/394-build-drill.yaml @@ -41,7 +41,6 @@ robots: inventory: - [1, detonator] # used to mark win world: - default: [blank] palette: '.': [grass] 'M': [stone, mountain] diff --git a/data/scenarios/Testing/397-wrong-missing.yaml b/data/scenarios/Testing/397-wrong-missing.yaml index 2d6932765..4996f1946 100644 --- a/data/scenarios/Testing/397-wrong-missing.yaml +++ b/data/scenarios/Testing/397-wrong-missing.yaml @@ -28,7 +28,6 @@ robots: - [1, treads] - [1, solar panel] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/428-drowning-destroy.yaml b/data/scenarios/Testing/428-drowning-destroy.yaml index 50f73c2e5..86e8b5b1d 100644 --- a/data/scenarios/Testing/428-drowning-destroy.yaml +++ b/data/scenarios/Testing/428-drowning-destroy.yaml @@ -35,7 +35,6 @@ robots: program: "move" known: [water] world: - default: [blank] palette: '.': [grass] ' ': [ice, water] diff --git a/data/scenarios/Testing/475-wait-one.yaml b/data/scenarios/Testing/475-wait-one.yaml index fc146444d..65dea16aa 100644 --- a/data/scenarios/Testing/475-wait-one.yaml +++ b/data/scenarios/Testing/475-wait-one.yaml @@ -32,7 +32,6 @@ robots: program: | log "I shall sleep"; wait 1; log "I have awoken" world: - default: [blank] palette: '.': [grass] '┌': [stone, upper left corner] diff --git a/data/scenarios/Testing/479-atomic-race.yaml b/data/scenarios/Testing/479-atomic-race.yaml index 63be63545..ae715ce61 100644 --- a/data/scenarios/Testing/479-atomic-race.yaml +++ b/data/scenarios/Testing/479-atomic-race.yaml @@ -77,7 +77,6 @@ entities: - You win! properties: [known, portable] world: - default: [blank] palette: '.': [grass] upperleft: [0,0] diff --git a/data/scenarios/Testing/479-atomic.yaml b/data/scenarios/Testing/479-atomic.yaml index 10ef68dea..32ddc7313 100644 --- a/data/scenarios/Testing/479-atomic.yaml +++ b/data/scenarios/Testing/479-atomic.yaml @@ -59,7 +59,6 @@ entities: properties: [known, portable, growable] growth: [1,2] world: - default: [blank] palette: '.': [grass] upperleft: [0,0] diff --git a/data/scenarios/Testing/490-harvest.yaml b/data/scenarios/Testing/490-harvest.yaml index 8a93d84a8..97f10f843 100644 --- a/data/scenarios/Testing/490-harvest.yaml +++ b/data/scenarios/Testing/490-harvest.yaml @@ -26,7 +26,6 @@ robots: - grabber - boat world: - default: [blank] palette: '.': [grass] 'T': [stone, tree] diff --git a/data/scenarios/Testing/504-teleport-self.yaml b/data/scenarios/Testing/504-teleport-self.yaml index 9dc3118f3..9e1fbd51a 100644 --- a/data/scenarios/Testing/504-teleport-self.yaml +++ b/data/scenarios/Testing/504-teleport-self.yaml @@ -23,7 +23,6 @@ robots: inventory: - [1, tree] world: - default: [blank] palette: '.': [grass] '┌': [stone, upper left corner] diff --git a/data/scenarios/Testing/508-capability-subset.yaml b/data/scenarios/Testing/508-capability-subset.yaml index aee04656d..cf0a47f21 100644 --- a/data/scenarios/Testing/508-capability-subset.yaml +++ b/data/scenarios/Testing/508-capability-subset.yaml @@ -37,9 +37,10 @@ robots: - [1, ADT calculator] known: [water] world: - default: [ice, water] + dsl: | + {ice, water} palette: - '.': [grass] + '.': [grass, erase] ' ': [ice, water] '┌': [stone, upper left corner] '┐': [stone, upper right corner] diff --git a/data/scenarios/Testing/555-teleport-location.yaml b/data/scenarios/Testing/555-teleport-location.yaml index 4a5828bf8..762ab3702 100644 --- a/data/scenarios/Testing/555-teleport-location.yaml +++ b/data/scenarios/Testing/555-teleport-location.yaml @@ -24,4 +24,5 @@ robots: inventory: - [1, rock] world: - default: [grass, null] + dsl: | + {grass} diff --git a/data/scenarios/Testing/562-lodestone.yaml b/data/scenarios/Testing/562-lodestone.yaml index a528a4a5a..6673231e7 100644 --- a/data/scenarios/Testing/562-lodestone.yaml +++ b/data/scenarios/Testing/562-lodestone.yaml @@ -42,9 +42,10 @@ robots: - [0, bit (1)] known: [water, wavy water] world: - default: [ice, water] + dsl: | + {ice, water} palette: - '.': [grass] + '.': [grass, erase] ' ': [ice, water] '~': [ice, wavy water] 'L': [grass, Linux] @@ -58,7 +59,7 @@ world: 'A': [stone, magnetic vein] 'o': [stone, lodestone] '0': [grass, bit (0)] - 'B': [grass, null, base] + 'B': [grass, erase, base] upperleft: [-1, 1] map: | ┌─────┐ ~~ diff --git a/data/scenarios/Testing/684-swap.yaml b/data/scenarios/Testing/684-swap.yaml index 11fb64ebf..0b998becb 100644 --- a/data/scenarios/Testing/684-swap.yaml +++ b/data/scenarios/Testing/684-swap.yaml @@ -45,7 +45,6 @@ robots: ) ) world: - default: [blank] palette: '┌': [stone, upper left corner] '┐': [stone, upper right corner] diff --git a/data/scenarios/Testing/687-watch-command.yaml b/data/scenarios/Testing/687-watch-command.yaml index 23dcb86f6..e37581bc1 100644 --- a/data/scenarios/Testing/687-watch-command.yaml +++ b/data/scenarios/Testing/687-watch-command.yaml @@ -64,7 +64,6 @@ robots: doN 7 (move; wait 4; place "tree";); known: [] world: - default: [blank] palette: 'Ω': [grass, null, base] p : [grass, null, planter] diff --git a/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml b/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml index 791bdfcb8..eecbf4abc 100644 --- a/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml +++ b/data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml @@ -29,7 +29,6 @@ robots: 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] diff --git a/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml b/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml index 59132b7fd..195d4dfcf 100644 --- a/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml +++ b/data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml @@ -35,7 +35,6 @@ robots: 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] diff --git a/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml b/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml index ef9b1e296..fac692a05 100644 --- a/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml +++ b/data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml @@ -33,7 +33,6 @@ robots: dir: [0,-1] system: true world: - default: [blank] palette: '@': [stone, boulder] 'B': [grass, null, base] diff --git a/data/scenarios/Testing/710-multi-robot.yaml b/data/scenarios/Testing/710-multi-robot.yaml index b6f8f488f..1123d81ef 100644 --- a/data/scenarios/Testing/710-multi-robot.yaml +++ b/data/scenarios/Testing/710-multi-robot.yaml @@ -23,7 +23,6 @@ objectives: solution: | move;move;move; move;move;move; move;move;move; world: - default: [blank] palette: '.': [blank] # FIRST ROOM diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml index 53a86f7f2..3ce723cd8 100644 --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml @@ -42,7 +42,6 @@ robots: - [2, board] - [5, rock] world: - default: [blank] palette: 'x': [grass, null, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml index 290468b09..d8e8dff79 100644 --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml @@ -34,7 +34,6 @@ robots: - [2, board] - [5, rock] world: - default: [blank] palette: 'x': [grass, null, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml index 5271697c0..800892811 100644 --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml @@ -53,7 +53,6 @@ robots: - [2, board] - [5, rock] world: - default: [blank] palette: 'x': [grass, flower, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml index c7fdc61d2..0362dc9fc 100644 --- a/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml @@ -41,7 +41,6 @@ robots: - [2, board] - [5, rock] world: - default: [blank] palette: 'x': [grass, flower, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/858-inventory/858-counting-objective.yaml b/data/scenarios/Testing/858-inventory/858-counting-objective.yaml index 2ff0899d1..ade414609 100644 --- a/data/scenarios/Testing/858-inventory/858-counting-objective.yaml +++ b/data/scenarios/Testing/858-inventory/858-counting-objective.yaml @@ -26,11 +26,10 @@ solution: | grab; known: [tree] world: - default: [blank] palette: 'B': [grass, null, base] 'w': [grass, tree] upperleft: [0, 0] map: |- w - B \ No newline at end of file + B diff --git a/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml b/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml index 09cf46ab2..8e9472850 100644 --- a/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml +++ b/data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml @@ -25,7 +25,6 @@ solution: | place "tree"; known: [tree] world: - default: [blank] palette: 'B': [grass, null, base] 'w': [grass] diff --git a/data/scenarios/Testing/858-inventory/858-possession-objective.yaml b/data/scenarios/Testing/858-inventory/858-possession-objective.yaml index dd2781e55..a64f365ae 100644 --- a/data/scenarios/Testing/858-inventory/858-possession-objective.yaml +++ b/data/scenarios/Testing/858-inventory/858-possession-objective.yaml @@ -23,11 +23,10 @@ solution: | grab; known: [tree] world: - default: [blank] palette: 'B': [grass, null, base] 'w': [grass, tree] upperleft: [0, 0] map: |- w - B \ No newline at end of file + B diff --git a/data/scenarios/Testing/920-meet.yaml b/data/scenarios/Testing/920-meet.yaml index ddec2f67f..b29f03223 100644 --- a/data/scenarios/Testing/920-meet.yaml +++ b/data/scenarios/Testing/920-meet.yaml @@ -32,7 +32,6 @@ robots: - name: other dir: [1,0] world: - default: [blank] palette: '.': [grass] 'Ω': [grass, null] diff --git a/data/scenarios/Testing/955-heading.yaml b/data/scenarios/Testing/955-heading.yaml index 9b3a6d788..41a1d104e 100644 --- a/data/scenarios/Testing/955-heading.yaml +++ b/data/scenarios/Testing/955-heading.yaml @@ -17,7 +17,6 @@ robots: - treads - compass world: - default: [blank] palette: '^': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/956-GPS.yaml b/data/scenarios/Testing/956-GPS.yaml index ae1e4e974..06b4a0314 100644 --- a/data/scenarios/Testing/956-GPS.yaml +++ b/data/scenarios/Testing/956-GPS.yaml @@ -47,7 +47,6 @@ robots: y <- random 11; teleport base (x-5, y-5) world: - default: [blank] palette: '.': [grass] upperleft: [-5, 5] diff --git a/data/scenarios/Testing/958-isempty.yaml b/data/scenarios/Testing/958-isempty.yaml index 0888e8035..cedaddaf1 100644 --- a/data/scenarios/Testing/958-isempty.yaml +++ b/data/scenarios/Testing/958-isempty.yaml @@ -39,7 +39,6 @@ entities: - A thing that everyone needs! properties: [portable] world: - default: [blank] palette: '.': [grass] '>': [grass, tree, base] diff --git a/data/scenarios/Testing/961-custom-capabilities.yaml b/data/scenarios/Testing/961-custom-capabilities.yaml index db28545bf..fa5d4d2cf 100644 --- a/data/scenarios/Testing/961-custom-capabilities.yaml +++ b/data/scenarios/Testing/961-custom-capabilities.yaml @@ -32,7 +32,6 @@ robots: - [1, wheels] - [1, solar panel] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Testing/_Validation/1221-duplicate-entities.yaml b/data/scenarios/Testing/_Validation/1221-duplicate-entities.yaml index 92c854119..85965e44b 100644 --- a/data/scenarios/Testing/_Validation/1221-duplicate-entities.yaml +++ b/data/scenarios/Testing/_Validation/1221-duplicate-entities.yaml @@ -15,7 +15,6 @@ entities: description: - Your scooter world: - default: [blank] palette: 'x': [grass, null, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml index efab55c98..1a2a2409b 100644 --- a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml +++ b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml @@ -30,7 +30,6 @@ robots: known: [tree] world: upperleft: [-1, 1] - default: [blank] palette: '.': [grass] 'B': [grass, null, base] diff --git a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml index 0b104636f..647afc54e 100644 --- a/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml +++ b/data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml @@ -30,7 +30,6 @@ robots: known: [tree] world: upperleft: [1, -1] - default: [blank] palette: '.': [grass] 'B': [grass, null, base] diff --git a/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml b/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml index 032f2457b..f67452846 100644 --- a/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml +++ b/data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml @@ -20,7 +20,6 @@ robots: known: [tree] world: upperleft: [1, -1] - default: [blank] palette: '.': [grass] 'B': [grass, null, base] diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml index e967bfd93..8b80fc3ef 100644 --- a/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml +++ b/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml @@ -30,7 +30,6 @@ robots: - [2, board] - [5, rock] world: - default: [blank] palette: 'x': [grass, null, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml index e425c4c9c..830e3a246 100644 --- a/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml +++ b/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml @@ -30,7 +30,6 @@ robots: - [2, board] - [5, rock] world: - default: [blank] palette: 'x': [grass, flower, base] upperleft: [0, 0] diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml index 202097096..b360fa894 100644 --- a/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml +++ b/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml @@ -23,7 +23,6 @@ robots: inventory: - [5, rock] world: - default: [blank] palette: 'x': [grass, null, base] upperleft: [0, 0] diff --git a/data/scenarios/Tutorials/backstory.yaml b/data/scenarios/Tutorials/backstory.yaml index 8ec284750..21fd165c7 100644 --- a/data/scenarios/Tutorials/backstory.yaml +++ b/data/scenarios/Tutorials/backstory.yaml @@ -95,3 +95,5 @@ seed: 0 world: offset: true scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/Tutorials/bind2.yaml b/data/scenarios/Tutorials/bind2.yaml index 71c562b71..1ce1bb56f 100644 --- a/data/scenarios/Tutorials/bind2.yaml +++ b/data/scenarios/Tutorials/bind2.yaml @@ -100,7 +100,6 @@ robots: - name: pedestal system: true world: - default: [blank] palette: '.': [blank, null] 'Ω': [blank, null, base] diff --git a/data/scenarios/Tutorials/build.yaml b/data/scenarios/Tutorials/build.yaml index 2fa71beb8..b3a88ef0c 100644 --- a/data/scenarios/Tutorials/build.yaml +++ b/data/scenarios/Tutorials/build.yaml @@ -51,7 +51,6 @@ robots: - [10, treads] known: [water] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/conditionals.yaml b/data/scenarios/Tutorials/conditionals.yaml index c5f83e2e1..c81d659bf 100644 --- a/data/scenarios/Tutorials/conditionals.yaml +++ b/data/scenarios/Tutorials/conditionals.yaml @@ -98,7 +98,6 @@ entities: - A small rock. It is so small, it is practically invisible. properties: [portable] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/craft.yaml b/data/scenarios/Tutorials/craft.yaml index 885914798..9214b6605 100644 --- a/data/scenarios/Tutorials/craft.yaml +++ b/data/scenarios/Tutorials/craft.yaml @@ -38,7 +38,6 @@ robots: inventory: - [10, tree] world: - default: [blank] palette: 'Ω': [grass, null, base] '┌': [stone, upper left corner] diff --git a/data/scenarios/Tutorials/crash.yaml b/data/scenarios/Tutorials/crash.yaml index b4a808ea9..4ffdd7cd0 100644 --- a/data/scenarios/Tutorials/crash.yaml +++ b/data/scenarios/Tutorials/crash.yaml @@ -80,7 +80,6 @@ robots: run "scenarios/Tutorials/crash-secret.sw" known: [water, tree, mountain] world: - default: [blank] palette: 'Ω': [grass, null, base] '!': [grass, null, secret] diff --git a/data/scenarios/Tutorials/def.yaml b/data/scenarios/Tutorials/def.yaml index 12cf62804..4c6325991 100644 --- a/data/scenarios/Tutorials/def.yaml +++ b/data/scenarios/Tutorials/def.yaml @@ -71,7 +71,6 @@ robots: - [0, flower] known: [boulder] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/equip.yaml b/data/scenarios/Tutorials/equip.yaml index 2c1af3201..74b3cca9f 100644 --- a/data/scenarios/Tutorials/equip.yaml +++ b/data/scenarios/Tutorials/equip.yaml @@ -42,7 +42,6 @@ robots: - [10, logger] known: [3D printer, water] world: - default: [blank] palette: '>': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/farming.yaml b/data/scenarios/Tutorials/farming.yaml index f40b79859..c304feb7c 100644 --- a/data/scenarios/Tutorials/farming.yaml +++ b/data/scenarios/Tutorials/farming.yaml @@ -93,3 +93,5 @@ seed: 0 world: offset: true scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/Tutorials/give.yaml b/data/scenarios/Tutorials/give.yaml index d548ed04a..65d09f9e0 100644 --- a/data/scenarios/Tutorials/give.yaml +++ b/data/scenarios/Tutorials/give.yaml @@ -51,7 +51,6 @@ robots: - [10, solar panel] known: [board, LaTeX, bit (0), copper ore] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/grab.yaml b/data/scenarios/Tutorials/grab.yaml index 55f691a99..816912864 100644 --- a/data/scenarios/Tutorials/grab.yaml +++ b/data/scenarios/Tutorials/grab.yaml @@ -35,7 +35,6 @@ robots: inventory: - [0, tree] world: - default: [blank] palette: '>': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/lambda.yaml b/data/scenarios/Tutorials/lambda.yaml index 5f9c0d869..0ecee5cad 100644 --- a/data/scenarios/Tutorials/lambda.yaml +++ b/data/scenarios/Tutorials/lambda.yaml @@ -60,7 +60,6 @@ robots: - [0, boulder] - [0, flower] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/move.yaml b/data/scenarios/Tutorials/move.yaml index 0d6be79e7..795d70bc4 100644 --- a/data/scenarios/Tutorials/move.yaml +++ b/data/scenarios/Tutorials/move.yaml @@ -95,7 +95,6 @@ solution: | known: - flower world: - default: [blank] palette: '.': [blank] '*': [blank, flower] diff --git a/data/scenarios/Tutorials/place.yaml b/data/scenarios/Tutorials/place.yaml index e17637973..f3e8caa90 100644 --- a/data/scenarios/Tutorials/place.yaml +++ b/data/scenarios/Tutorials/place.yaml @@ -78,7 +78,6 @@ robots: inventory: - [0, spruce] world: - default: [blank] palette: '>': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/require.yaml b/data/scenarios/Tutorials/require.yaml index 1b1803aac..c20ba169d 100644 --- a/data/scenarios/Tutorials/require.yaml +++ b/data/scenarios/Tutorials/require.yaml @@ -60,7 +60,6 @@ robots: - [10, compass] known: [water] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/requireinv.yaml b/data/scenarios/Tutorials/requireinv.yaml index 219a48862..6899cb9d2 100644 --- a/data/scenarios/Tutorials/requireinv.yaml +++ b/data/scenarios/Tutorials/requireinv.yaml @@ -63,7 +63,6 @@ robots: - [16, lambda] - [100, rock] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/scan.yaml b/data/scenarios/Tutorials/scan.yaml index fdba9486b..725ddebd3 100644 --- a/data/scenarios/Tutorials/scan.yaml +++ b/data/scenarios/Tutorials/scan.yaml @@ -45,7 +45,6 @@ robots: - [10, treads] - [10, solar panel] world: - default: [blank] palette: 'Ω': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/type-errors.yaml b/data/scenarios/Tutorials/type-errors.yaml index 75538b2b6..205b77f56 100644 --- a/data/scenarios/Tutorials/type-errors.yaml +++ b/data/scenarios/Tutorials/type-errors.yaml @@ -49,7 +49,6 @@ robots: inventory: - [1, Win] world: - default: [blank] palette: '>': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/types.yaml b/data/scenarios/Tutorials/types.yaml index 4bc4486e8..ef9057979 100644 --- a/data/scenarios/Tutorials/types.yaml +++ b/data/scenarios/Tutorials/types.yaml @@ -58,7 +58,6 @@ robots: inventory: - [1, Win] world: - default: [blank] palette: '>': [grass, null, base] '.': [grass] diff --git a/data/scenarios/Tutorials/world101.yaml b/data/scenarios/Tutorials/world101.yaml index 5fdca2d6b..8326a9883 100644 --- a/data/scenarios/Tutorials/world101.yaml +++ b/data/scenarios/Tutorials/world101.yaml @@ -85,3 +85,5 @@ seed: 0 world: offset: true scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/Vignettes/roadway.yaml b/data/scenarios/Vignettes/roadway.yaml index 4ab426cff..ee3095ca8 100644 --- a/data/scenarios/Vignettes/roadway.yaml +++ b/data/scenarios/Vignettes/roadway.yaml @@ -39,7 +39,6 @@ robots: run "data/scenarios/Vignettes/_roadway/coordinator.sw" version: 1 world: - default: [blank] palette: '.': [grass] 'd': [grass, null, drone] @@ -216,4 +215,4 @@ world: .............................................................................. .............................................................................. .............................................................................. - .............................................................................. \ No newline at end of file + .............................................................................. diff --git a/data/scenarios/blank.yaml b/data/scenarios/blank.yaml index 26c367070..e14554cd4 100644 --- a/data/scenarios/blank.yaml +++ b/data/scenarios/blank.yaml @@ -11,4 +11,5 @@ robots: char: Ω attr: robot world: - default: [grass] + dsl: | + {grass} diff --git a/data/scenarios/classic.yaml b/data/scenarios/classic.yaml index 59cb9438a..982235463 100644 --- a/data/scenarios/classic.yaml +++ b/data/scenarios/classic.yaml @@ -29,6 +29,7 @@ robots: - [50, clock] - [5, toolkit] world: - seed: null offset: true scrollable: false + dsl: | + "classic" diff --git a/data/scenarios/creative.yaml b/data/scenarios/creative.yaml index 30b48fad6..3925dc2fd 100644 --- a/data/scenarios/creative.yaml +++ b/data/scenarios/creative.yaml @@ -12,5 +12,6 @@ robots: char: Ω attr: robot world: - seed: null offset: true + dsl: | + "classic" diff --git a/data/schema/world.json b/data/schema/world.json index 0f700d931..f5411a63e 100644 --- a/data/schema/world.json +++ b/data/schema/world.json @@ -5,10 +5,10 @@ "description": "Description of the world in the Swarm game", "type": "object", "properties": { - "default": { + "dsl": { "default": null, - "type": "array", - "description": "A tuple representing the contents of a default cell (see Cells, except that the default cell may not contain a robot). If this key is present, it means that the whole world besides the part specified with the map will be filled with this default cell. If omitted, the world besides the part specified with the map will be procedurally generated." + "type": "string", + "description": "A term in the Swarm world description DSL. The world it describes will be layered underneath the world described by the rest of the fields." }, "offset": { "default": false, @@ -50,4 +50,4 @@ "description": "A 2-tuple of int values specifying the (x,y) coordinates of the upper left corner of the map." } } -} \ No newline at end of file +} diff --git a/data/worlds/README.md b/data/worlds/README.md new file mode 100644 index 000000000..d2fc2146b --- /dev/null +++ b/data/worlds/README.md @@ -0,0 +1,189 @@ +# World DSL guide + +Swarm has a built-in, special-purpose *domain specific language* for +describing worlds (*i.e.* the terrain, entities, other robots, +etc. which the player sees on the map when a scenario is loaded). It +is somewhat bare bones at the moment, but will continue to develop. + +## Overview + +The basic idea of the world DSL is ultimately to describe a *function* +which specifies a *cell* value for every coordinate. In addition, +this is done in such a way that all randomness used for procedural +generation (if any) is ultimately derived from a single seed, so world +generation is actually 100% deterministic and reproducible by design. + +## Types + +- There are four base types: `bool`, `int`, `float`, and + `cell`. + - `bool` values are written `true` and `false`. + - `int` values are written like `3` or `-5`. + - `float` values are written like `3.2` or `0.0`. Note that `0` is + always an `int`, and `0.0` is always a `float`. If you use `0` + as an argument to a function expecting a `float`, it is a type + error! This may be slightly annoying but it keeps typechecking + much simpler. + - `cell` values describe the contents of a world cell (terrain, + entity, etc.), and are explained in more detail below. + +- In addition, if `b` is a base type, `World b` is a type representing a + "world function" which specifies a value of type `b` at every + coordinate in its domain. + +- Any base type `b` is a subtype of `World b`; that is, a value of + type `b` may be used anywhere a `World b` is expected, or, put + another way, any `b` may be automatically "promoted" to a `World b`. + Semantically, a single value of a base type may be promoted to an + infinite, constant world function which returns that single value at + every coordinate. + +- In general, any function of type `b1 -> ... -> bn` where the `bi` + are all base types may be "lifted" to have type `World b1 -> ... -> + World bn`, which means the function will act "coordinatewise", + i.e. like a giant 2D `zipWith`. + + - For example, the `<` operator has a type like `integer -> + integer -> bool` but that means it could also have type `World + integer -> World integer -> World bool`. + +## Syntax + +Comments are specified by `//` (single line) or `/* ... */` +(multi-line). + +Identifiers consist of any non-empty sequence of letters, digits, +underscores, or single quotes, but must begin with a letter or +underscore. + +The extended BNF syntax `S*,` denotes the syntax `S` repeated zero +or more times, separated by `,`. Likewise, `S+,` denotes one or more +repetitions of `S` separated by `,`. + +``` + ::= integer literal + ::= floating-point literal + ::= any non-reserved identifier + ::= any character other than double quote '"' + + ::= + + | + | 'true' | 'false' + | + | + | 'seed' + | 'x' | 'y' + | 'hash' + | 'if' 'then' 'else' + | 'perlin' + | 'abs' + | 'let' ( '=' )*, 'in' + | 'overlay' '[' +, ']' + | 'mask' + | '"' + '"' + | '(' ')' + + ::= '{' +, '} + ::= | ':' + ::= 'terrain' | 'entity' | 'robot' + ::= 'erase' | * + ::= any single character besides ',', '}', or ']' + + ::= + | + | + | + + ::= 'not' | '-' + +// Infix operators are listed below by precedence, highest precedence +// first. Operators listed on the same line share the same precedence. + + ::= + '*' | '/' | '%' + | '+' | '-' | '<>' + | '==' | '/=' | '<' | '<=' | '>' | '>=' + | '&&' + | '||' +``` + +## Cells + +A *cell* specifies the contents of a specific location in the world, +or any information associated with that location. Currently, a cell +value consists of: + +- An optional terrain value +- An optional entity +- A list of robots + +More may be added in the future; note also that currently the list of +robots is not accessible via the DSL. + +Cells have a monoid structure: + +- The empty cell has no terrain, no entity, and an empty list of + robots. +- To combine two cells, we: + - Take the last non-empty terrain value + - Take the last non-null entity + - Concatenate the robot lists + +The basic syntax for a cell value is either +- `{terrain: }` which specifies a cell with terrain given by + ``, no entity, and no robots +- `{entity: }` which specifies a cell with empty terrain, an + entity given by ``, and no robots + +Optionally, the `terrain` or `entity` tag (and colon) may be omitted, +for example, `{dirt}` or `{tree}`. In this case the parser will try +reading the given name first as a terrain value, then as an entity, +and the first one that works will be chosen. + +Multiple (optionally tagged) names may be written separated by commas +inside the curly braces, which is syntax sugar for combining multiple +values via the monoid combining operation. For example, `{dirt, +entity: tree}` is equivalent to `{dirt} <> {entity: tree}`, and +specifies a cell containing `dirt` terrain and a `tree` entity. + +There is also a special `erase` value for entities, which acts as an +annihilator (like 0 under multiplication). That is, for combining entities, +- `null <> e = e <> null = e` +- `erase <> e = e <> erase = erase` +- Otherwise, `e1 <> e2 = e2` + +`erase` can be used when a previous layer specified an entity but in a +subsequent layer we want the cell to be empty. For example, perhaps a +first layer specified a default entity (say, `water`) everywhere, but +we want to selectively overwrite this default with not only other +entities but also some empty cells. + +## Typechecking and semantics + +- Boolean, arithmetic, and comparison operators are standard. + - Note that arithmetic and comparison operators are overloaded to + work on either ints or floats + - The division operator '/' denotes either floating-point or integer + division depending on the type of its arguments. +- `if ... then ... else ...` is standard. +- `let ... in ...` is standard. +- The `<>` operator combines `cell` values according to their + semigroup structure. +- The special `seed : int` variable contains the value of the world seed. +- The special `x : World int` and `y : World int` variables always + contain the current coordinate's `x` or `y` value, respectively. +- The special `hash : World int` variable contains a (non-coherent) + hash of the current coordinates. +- `overlay [e1, e2, ...]` layers `e1` on the bottom, `e2` on top of + that, etc., using the semigroup structure for world functions. +- `perlin s o k p` creates a Perlin noise function, which associates a + floating-point value on the interval [-1,1] to every coordinate in + a way that is random yet continuous (i.e. nearby coordinates have + close floating-point values). The four parameters represent seed, + octaves, scale, and persistence. For an explanation of how these + parameters affect the resulting noise function, see + https://libnoise.sourceforge.net/glossary/index.html#perlinnoise +- `mask b e` takes the value of `e` where `b` is true, and is empty + elsewhere. +- `"foo"` imports the DSL term in `worlds/foo.world`. diff --git a/data/worlds/classic.world b/data/worlds/classic.world new file mode 100644 index 000000000..5dc03ebad --- /dev/null +++ b/data/worlds/classic.world @@ -0,0 +1,119 @@ +/* See README.md for a thorough description of the world DSL. Some + comments are provided below to help explain the language by + example. */ + +let + /* pn0, pn1, pn2 are Perlin noise functions, which + associate a floating-point value to every coordinate + in a way that is random yet continuous (i.e. nearby + coordinates have close floating-point values). We use + these to determine "biomes". The four parameters + represent seed, octaves, scale, and persistence. For + an explanation of how these parameters affect + the resulting noise function, see + https://libnoise.sourceforge.net/glossary/index.html#perlinnoise + + 'seed' is a special constant which holds the value of the seed used + for world generation (whether chosen by the user, chosen randomly, etc.) + */ + pn0 = perlin seed 6 0.05 0.6, + pn1 = perlin (seed + 1) 6 0.05 0.6, + pn2 = perlin (seed + 2) 6 0.05 0.6, + + // cl is another Perlin noise function that we use to generate + // "clumps" of things inside biomes + cl = perlin seed 4 0.08 0.5, + + /* We now define some Boolean variables for determining which + biome we are in. Note that implicitly, as with everything + in this world description DSL, these are actually + parameterized over coordinates --- that is, we can get a different + Boolean value associated to each coordinate. + */ + big = pn0 > 0.0, // 'big' is true for coordinates where pn0 > 0.0, and false otherwise + hard = pn1 > 0.0, // etc. + artificial = pn2 > 0.0, + small = not big, + soft = not hard, + natural = not artificial +in +/* The world is built up by a series of layers, with each layer thought of as a function + from coordinates to cell values. The first layer is bottommost. + The layers are combined coordinatewise according to the semigroup operation for + cells. + + 'mask b e' takes the value of 'e' where 'b' is true, and is empty elsewhere. + + '{x1, x2, ...}' specifies the value of a cell with a list of contents. A cell + can have at most one terrain value, and at most one entity, which are disambiguated + by name (though one can also write e.g. '{entity: tree}' or '{terrain: dirt}' to + disambiguate). + + 'hash' is a special variable which takes on the value of a murmur3 hash applied + to the coordinates; it can be used to obtain non-coherent randomness (i.e. + random values such that nearby values are not correlated). + + 'x' and 'y' are special variables which always take on the x- or y-value of the + coordinates. +*/ +overlay +[ mask (big && hard && artificial) + (if (cl > 0.85) then {stone, copper ore} else {stone}) +, mask (big && hard && natural) + ( overlay + [ {grass} // grass by default + // clumps of forest with LaTeX sprinkled in + , mask (cl > 0.0) (if (hash % 30 == 1) then {dirt, LaTeX} else {dirt, tree}) + // random boulders scattered around + , mask (hash % 30 == 0) {stone, boulder} + // mountains in the middle of forests + , mask (cl > 0.5) {stone, mountain} + ] + ) +, mask (small && hard && natural) + ( overlay + [ {stone} + , mask (hash % 10 == 0) {stone, rock} + , mask (hash % 100 == 0) {stone, lodestone} + ] + ) +, mask (big && soft && natural) + ( overlay + [ {dirt, water} + , mask ((x + y) % 2 == 0) {dirt, wavy water} + , mask (abs pn1 < 0.1) {dirt, sand} + ] + ) +, mask (small && soft && natural) + ( overlay + [ {grass} + , mask (hash % 20 == 10) {grass, cotton} + , mask (hash % 20 == 0) {grass, flower} + ] + ) +, mask (small && soft && artificial) + ( overlay + [ {grass} + , mask (hash % 10 == 0) + (if (x + y) % 2 == 0 then {grass, bit (0)} else {grass, bit (1)}) + ] + ) +, mask (big && soft && artificial) + ( overlay + [ {dirt} + , mask (cl > 0.5) {grass} + , mask (hash % 5000 == 0) {dirt, Linux} + ] + ) +, mask (small && hard && artificial) + ( overlay + [ {stone} + , mask (hash % 50 == 0) + let i = (x - y) % 3 in + if (i == 0) then {stone, pixel (R)} + else if (i == 1) then {stone, pixel (G)} + else {stone, pixel (B)} + , mask (hash % 120 == 1) {stone, lambda} + ] + ) +] diff --git a/fourmolu.yaml b/fourmolu.yaml index 56d9ce84a..2f9a2d843 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -11,3 +11,5 @@ newlines-between-decls: 1 reexports: - module Text.Megaparsec exports Control.Applicative - module Options.Applicative exports Control.Applicative +fixities: + - infixl 9 ".:" diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs index 003440e11..cd8f813c5 100644 --- a/src/Swarm/Doc/Gen.hs +++ b/src/Swarm/Doc/Gen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -24,16 +25,16 @@ module Swarm.Doc.Gen ( ) where import Control.Effect.Lift -import Control.Effect.Throw import Control.Lens (view, (^.)) import Control.Lens.Combinators (to) import Control.Monad (zipWithM, zipWithM_) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (find, toList) import Data.List (transpose) -import Data.Map.Lazy (Map) +import Data.Map.Lazy (Map, (!)) import Data.Map.Lazy qualified as Map import Data.Maybe (fromMaybe, isJust) +import Data.Sequence (Seq) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text, unpack) @@ -48,7 +49,9 @@ import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight) import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory) import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots) -import Swarm.Game.WorldGen (testWorld2Entites) +import Swarm.Game.World.Gen (extractEntities) +import Swarm.Game.World.Load (loadWorlds) +import Swarm.Game.World.Typecheck (Some (..), TTerm) import Swarm.Language.Capability (Capability) import Swarm.Language.Capability qualified as Capability import Swarm.Language.Key (specialKeyNames) @@ -58,7 +61,7 @@ import Swarm.Language.Syntax qualified as Syntax import Swarm.Language.Text.Markdown as Markdown (docToMark) import Swarm.Language.Typecheck (inferConst) import Swarm.Util (both, listEnums, quote) -import Swarm.Util.Effect (simpleErrorHandle) +import Swarm.Util.Effect (ignoreWarnings, simpleErrorHandle) import Text.Dot (Dot, NodeId, (.->.)) import Text.Dot qualified as Dot @@ -417,11 +420,12 @@ generateRecipe :: IO String generateRecipe = simpleErrorHandle $ do entities <- loadEntities recipes <- loadRecipes entities - classic <- classicScenario - return . Dot.showDot $ recipesToDot classic entities recipes + worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities + classic <- fst <$> loadScenario "data/scenarios/classic.yaml" entities worlds + return . Dot.showDot $ recipesToDot classic (worlds ! "classic") entities recipes -recipesToDot :: Scenario -> EntityMap -> [Recipe Entity] -> Dot () -recipesToDot classic emap recipes = do +recipesToDot :: Scenario -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot () +recipesToDot classic classicTerm emap recipes = do Dot.attribute ("rankdir", "LR") Dot.attribute ("ranksep", "2") world <- diamond "World" @@ -441,8 +445,8 @@ recipesToDot classic emap recipes = do -- 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]) + worldEntities = case classicTerm of Some _ t -> extractEntities t + levels = recipeLevels recipes (Set.unions [worldEntities, devs]) -- -------------------------------------------------------------------------- -- Base inventory (_bc, ()) <- Dot.cluster $ do @@ -455,7 +459,7 @@ recipesToDot classic emap recipes = do (_wc, ()) <- Dot.cluster $ do Dot.attribute ("style", "filled") Dot.attribute ("color", "forestgreen") - mapM_ ((uncurry (Dot..->.) . (world,)) . getE) (toList testWorld2Entites) + mapM_ (uncurry (Dot..->.) . (world,) . getE . view entityName) (toList worldEntities) -- -------------------------------------------------------------------------- let -- put a hidden node above and below entities and connect them by hidden edges wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId) @@ -485,7 +489,7 @@ recipesToDot classic emap recipes = do -- -------------------------------------------------------------------------- -- order entities into clusters based on how "far" they are from -- what is available at the start - see 'recipeLevels'. - bottom <- wrapBelowAbove worldEntites + bottom <- wrapBelowAbove worldEntities ls <- zipWithM subLevel [1 ..] (tail levels) let invisibleLine = zipWithM_ (.~>.) tls <- mapM (const hiddenNode) levels @@ -536,12 +540,6 @@ recipeLevels recipes start = levels then ls else go (n : ls) (Set.union n known) --- | Get classic scenario to figure out starting entities. -classicScenario :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => m Scenario -classicScenario = do - entities <- loadEntities - fst <$> loadScenario "data/scenarios/classic.yaml" entities - startingHelper :: Scenario -> Robot startingHelper = instantiateRobot 0 . head . view scenarioRobots diff --git a/src/Swarm/Doc/Pedagogy.hs b/src/Swarm/Doc/Pedagogy.hs index f1a2a1cdd..c9db1ebe4 100644 --- a/src/Swarm/Doc/Pedagogy.hs +++ b/src/Swarm/Doc/Pedagogy.hs @@ -16,7 +16,6 @@ module Swarm.Doc.Pedagogy ( TutorialInfo (..), ) where -import Control.Carrier.Accum.FixedStrict (evalAccum) import Control.Lens (universe, view, (^.)) import Control.Monad (guard) import Data.List (foldl', intercalate, sort, sortOn) @@ -35,13 +34,14 @@ import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Scenario (Scenario, scenarioDescription, scenarioName, scenarioObjectives, scenarioSolution) import Swarm.Game.Scenario.Objective (objectiveGoal) import Swarm.Game.ScenarioInfo (ScenarioCollection, ScenarioInfoPair, flatten, loadScenarios, scenarioCollectionToList, scenarioPath) +import Swarm.Game.World.Load (loadWorlds) import Swarm.Language.Module (Module (..)) import Swarm.Language.Pipeline (ProcessedTerm (..)) import Swarm.Language.Syntax import Swarm.Language.Text.Markdown (findCode) import Swarm.Language.Types (Polytype) import Swarm.TUI.Controller (getTutorials) -import Swarm.Util.Effect (simpleErrorHandle) +import Swarm.Util.Effect (ignoreWarnings, simpleErrorHandle) -- * Constants @@ -158,12 +158,12 @@ generateIntroductionsSequence = loadScenarioCollection :: IO ScenarioCollection loadScenarioCollection = simpleErrorHandle $ do entities <- loadEntities - - -- Note we ignore any warnings generated by 'loadScenarios' below, - -- using 'evalAccum'. Any warnings will be caught when loading all - -- the scenarios via the usual code path; we do not need to do + -- Note we ignore any warnings generated by 'loadWorlds' and + -- 'loadScenarios' below. Any warnings will be caught when loading + -- all the scenarios via the usual code path; we do not need to do -- anything with them here while simply rendering pedagogy info. - evalAccum (mempty :: Seq SystemFailure) $ loadScenarios entities + worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities + ignoreWarnings @(Seq SystemFailure) $ loadScenarios entities worlds renderUsagesMarkdown :: CoverageInfo -> Text renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) = diff --git a/src/Swarm/Game/Achievement/Persistence.hs b/src/Swarm/Game/Achievement/Persistence.hs index 274e7edbf..52dc0dbb8 100644 --- a/src/Swarm/Game/Achievement/Persistence.hs +++ b/src/Swarm/Game/Achievement/Persistence.hs @@ -42,7 +42,7 @@ loadAchievementsInfo = do if isFile then do eitherDecodedFile <- sendIO (Y.decodeFileEither fullPath) - return $ left (AssetNotLoaded Achievement p . CanNotParse) eitherDecodedFile + return $ left (AssetNotLoaded Achievement p . CanNotParseYaml) eitherDecodedFile else return . Left $ AssetNotLoaded Achievement p (EntryNot File) else do warn $ AssetNotLoaded Achievement "." $ DoesNotExist Directory diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index ab307629a..5471b9d50 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -383,7 +383,7 @@ loadEntities = do entityFailure = AssetNotLoaded (Data Entities) entityFile fileName <- getDataFileNameSafe Entities entityFile decoded <- - withThrow (entityFailure . CanNotParse) . (liftEither <=< sendIO) $ + withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ decodeFileEither fileName withThrow entityFailure $ buildEntityMap decoded diff --git a/src/Swarm/Game/Failure.hs b/src/Swarm/Game/Failure.hs index 0fe3fcd13..2cb0c5156 100644 --- a/src/Swarm/Game/Failure.hs +++ b/src/Swarm/Game/Failure.hs @@ -20,16 +20,18 @@ import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Text (Text) import Data.Text qualified as T +import Data.Void import Data.Yaml (ParseException, prettyPrintParseException) import Prettyprinter (Pretty (pretty), nest, squotes, vcat, (<+>)) import Swarm.Language.Pretty import Swarm.Util (showLowT) +import Text.Megaparsec (ParseErrorBundle, errorBundlePretty) import Witch (into) ------------------------------------------------------------ -- Failure descriptions -data AssetData = AppAsset | NameGeneration | Entities | Recipes | Scenarios | Script +data AssetData = AppAsset | NameGeneration | Entities | Recipes | Worlds | Scenarios | Script deriving (Eq, Show) data Asset = Achievement | Data AssetData | History | Save @@ -41,11 +43,21 @@ data Entry = Directory | File data LoadingFailure = DoesNotExist Entry | EntryNot Entry - | CanNotParse ParseException + | CanNotParseYaml ParseException + | CanNotParseMegaparsec (ParseErrorBundle Text Void) + | DoesNotTypecheck Text -- See Note [Typechecking errors] | Duplicate AssetData Text | CustomMessage Text deriving (Show) +-- ~~~~ Note [Pretty-printing typechecking errors] +-- +-- It would make sense to store a CheckErr in DoesNotTypecheck; +-- however, Swarm.Game.Failure is imported in lots of places, and +-- CheckErr can contain high-level things like TTerms etc., so it +-- would lead to an import cycle. Instead, we choose to just +-- pretty-print typechecking errors before storing them here. + data OrderFileWarning = NoOrderFile | MissingFiles (NonEmpty FilePath) @@ -80,10 +92,18 @@ instance PrettyPrec LoadingFailure where prettyPrec _ = \case DoesNotExist e -> "The" <+> ppr e <+> "is missing!" EntryNot e -> "The entry is not a" <+> ppr e <> "!" - CanNotParse p -> + CanNotParseYaml p -> nest 2 . vcat $ "Parse failure:" : map pretty (T.lines (into @Text (prettyPrintParseException p))) + CanNotParseMegaparsec p -> + nest 2 . vcat $ + "Parse failure:" + : map pretty (T.lines (into @Text (errorBundlePretty p))) + DoesNotTypecheck t -> + nest 2 . vcat $ + "Parse failure:" + : map pretty (T.lines t) Duplicate thing duped -> "Duplicate" <+> ppr thing <> ":" <+> squotes (pretty duped) CustomMessage m -> pretty m diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs index c2c3a8361..2f7b45420 100644 --- a/src/Swarm/Game/Recipe.hs +++ b/src/Swarm/Game/Recipe.hs @@ -154,7 +154,7 @@ loadRecipes :: loadRecipes em = do fileName <- getDataFileNameSafe Recipes f textRecipes <- - withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParse) + withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParseYaml) . (liftEither <=< sendIO) $ decodeFileEither @[Recipe Text] fileName withThrow (AssetNotLoaded (Data Recipes) fileName . CustomMessage) diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 733cde2e1..950637eb8 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -74,6 +74,7 @@ import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Universe +import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Pretty (prettyText) import Swarm.Util (binTuples, failT) @@ -107,11 +108,11 @@ data Scenario = Scenario , _scenarioSolution :: Maybe ProcessedTerm , _scenarioStepsPerTick :: Maybe Int } - deriving (Eq, Show) + deriving (Show) makeLensesNoSigs ''Scenario -instance FromJSONE EntityMap Scenario where +instance FromJSONE (EntityMap, WorldMap) Scenario where parseJSONE = withObjectE "scenario" $ \v -> do -- parse custom entities emRaw <- liftE (v .:? "entities" .!= []) @@ -119,8 +120,12 @@ instance FromJSONE EntityMap Scenario where Right x -> return x Left x -> failT [prettyText @LoadingFailure x] - -- extend ambient EntityMap with custom entities - withE em $ do + -- Save the passed in WorldMap for later + worldMap <- snd <$> getE + + -- Get rid of WorldMap from context locally, and combine EntityMap + -- with any custom entities parsed above + localE fst $ withE em $ do -- parse 'known' entity names and make sure they exist known <- liftE (v .:? "known" .!= []) em' <- getE @@ -132,9 +137,11 @@ instance FromJSONE EntityMap Scenario where rs <- v ..: "robots" let rsMap = buildRobotMap rs - rootLevelSharedStructures <- localE (,rsMap) $ v ..:? "structures" ..!= [] + rootLevelSharedStructures :: Structure.InheritedStructureDefs <- + localE (,rsMap) $ + v ..:? "structures" ..!= [] - allWorlds <- localE (\x -> (rootLevelSharedStructures :: Structure.InheritedStructureDefs, (x, rsMap))) $ do + allWorlds <- localE (worldMap,rootLevelSharedStructures,,rsMap) $ do rootWorld <- v ..: "world" subworlds <- v ..:? "subworlds" ..!= [] return $ rootWorld :| subworlds @@ -261,20 +268,22 @@ loadScenario :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => FilePath -> EntityMap -> + WorldMap -> m (Scenario, FilePath) -loadScenario scenario em = do +loadScenario scenario em worldMap = do mfileName <- getScenarioPath scenario fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName - (,fileName) <$> loadScenarioFile em fileName + (,fileName) <$> loadScenarioFile em worldMap fileName -- | Load a scenario from a file. loadScenarioFile :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => EntityMap -> + WorldMap -> FilePath -> m Scenario -loadScenarioFile em fileName = +loadScenarioFile em worldMap fileName = (withThrow adaptError . (liftEither <=< sendIO)) $ - decodeFileEitherE em fileName + decodeFileEitherE (em, worldMap) fileName where - adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParse + adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml diff --git a/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs b/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs index 843b9e817..363ad5906 100644 --- a/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs +++ b/src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs @@ -14,7 +14,7 @@ import Swarm.Game.Scenario.Scoring.CodeSize scenarioOptions :: Options scenarioOptions = defaultOptions - { fieldLabelModifier = map toLower . drop (length "_scenario") + { fieldLabelModifier = map toLower . drop (length ("_scenario" :: String)) } data DurationMetrics = DurationMetrics diff --git a/src/Swarm/Game/Scenario/Status.hs b/src/Swarm/Game/Scenario/Status.hs index afd5503d8..f0897f1cd 100644 --- a/src/Swarm/Game/Scenario/Status.hs +++ b/src/Swarm/Game/Scenario/Status.hs @@ -22,7 +22,7 @@ import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.CodeSize import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics -import Swarm.Game.WorldGen (Seed) +import Swarm.Game.World.Gen (Seed) import Swarm.Util.Lens (makeLensesNoSigs) -- | These launch parameters are used in a number of ways: diff --git a/src/Swarm/Game/Scenario/Topography/Cell.hs b/src/Swarm/Game/Scenario/Topography/Cell.hs index 3dae3043f..9aa1f0ffd 100644 --- a/src/Swarm/Game/Scenario/Topography/Cell.hs +++ b/src/Swarm/Game/Scenario/Topography/Cell.hs @@ -22,6 +22,7 @@ import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig) import Swarm.Game.Terrain +import Swarm.Util.Erasable (Erasable (..)) import Swarm.Util.Yaml ------------------------------------------------------------ @@ -34,7 +35,7 @@ import Swarm.Util.Yaml -- stateful versions of the Entity type in rendering scenario data. data PCell e = Cell { cellTerrain :: TerrainType - , cellEntity :: Maybe e + , cellEntity :: Erasable e , cellRobots :: [IndexedTRobot] } deriving (Eq, Show) @@ -51,17 +52,20 @@ data AugmentedCell e = AugmentedCell deriving (Eq, Show) -- | Re-usable serialization for variants of "PCell" -mkPCellJson :: ToJSON b => (a -> b) -> PCell a -> Value +mkPCellJson :: ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value mkPCellJson modifier x = toJSON $ catMaybes [ Just . toJSON . getTerrainWord $ cellTerrain x - , toJSON . modifier <$> cellEntity x + , fmap toJSON . modifier $ cellEntity x , listToMaybe [] ] instance ToJSON Cell where - toJSON = mkPCellJson $ view entityName + toJSON = mkPCellJson $ \case + EErase -> Just "erase" + ENothing -> Nothing + EJust e -> Just (e ^. entityName) instance FromJSONE (EntityMap, RobotMap) Cell where parseJSONE = withArrayE "tuple" $ \v -> do @@ -71,10 +75,13 @@ instance FromJSONE (EntityMap, RobotMap) Cell where terr <- liftE $ parseJSON (head tup) ent <- case tup ^? ix 1 of - Nothing -> return Nothing + Nothing -> return ENothing Just e -> do meName <- liftE $ parseJSON @(Maybe Text) e - traverse (localE fst . getEntity) meName + case meName of + Nothing -> return ENothing + Just "erase" -> return EErase + Just name -> fmap EJust . localE fst $ getEntity name let name2rob r = do mrName <- liftE $ parseJSON @(Maybe RobotName) r @@ -110,4 +117,7 @@ type CellPaintDisplay = PCell EntityFacade -- Note: This instance is used only for the purpose of WorldPalette instance ToJSON CellPaintDisplay where - toJSON = mkPCellJson id + toJSON = mkPCellJson $ \case + ENothing -> Nothing + EErase -> Just $ EntityFacade "erase" mempty + EJust e -> Just e diff --git a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs index f87b7b046..21a210009 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,6 +6,9 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.WorldDescription where +import Control.Carrier.Reader (runReader) +import Control.Carrier.Throw.Either +import Control.Monad (forM) import Data.Functor.Identity import Data.Maybe (catMaybes) import Data.Yaml as Y @@ -21,6 +25,10 @@ import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedS import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Universe +import Swarm.Game.World.Parse () +import Swarm.Game.World.Syntax +import Swarm.Game.World.Typecheck +import Swarm.Language.Pretty (prettyString) import Swarm.Util.Yaml ------------------------------------------------------------ @@ -31,27 +39,26 @@ import Swarm.Util.Yaml -- This type is parameterized to accommodate Cells that -- utilize a less stateful Entity type. data PWorldDescription e = WorldDescription - { defaultTerrain :: Maybe (PCell e) - , offsetOrigin :: Bool + { offsetOrigin :: Bool , scrollable :: Bool , palette :: WorldPalette e , ul :: Location , area :: [[PCell e]] , navigation :: Navigation Identity WaypointName , worldName :: SubworldName + , worldProg :: Maybe (TTerm '[] (World CellVal)) } - deriving (Eq, Show) + deriving (Show) type WorldDescription = PWorldDescription Entity -instance FromJSONE (InheritedStructureDefs, (EntityMap, RobotMap)) WorldDescription where +instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) WorldDescription where parseJSONE = withObjectE "world description" $ \v -> do - (scenarioLevelStructureDefs, (em, rm)) <- getE - (pal, terr, rootWorldStructureDefs) <- localE (const (em, rm)) $ do + (worldMap, scenarioLevelStructureDefs, em, rm) <- getE + (pal, rootWorldStructureDefs) <- localE (const (em, rm)) $ do pal <- v ..:? "palette" ..!= WorldPalette mempty - terr <- v ..:? "default" rootWorldStructs <- v ..:? "structures" ..!= [] - return (pal, terr, rootWorldStructs) + return (pal, rootWorldStructs) waypointDefs <- liftE $ v .:? "waypoints" .!= [] portalDefs <- liftE $ v .:? "portals" .!= [] @@ -72,7 +79,13 @@ instance FromJSONE (InheritedStructureDefs, (EntityMap, RobotMap)) WorldDescript unmergedWaypoints portalDefs - WorldDescription terr + mwexp <- liftE (v .:? "dsl") + dslTerm <- forM mwexp $ \wexp -> do + let checkResult = + run . runThrow @CheckErr . runReader worldMap . runReader em $ + check CNil (TTyWorld TTyCell) wexp + either (fail . prettyString) return checkResult + WorldDescription <$> liftE (v .:? "offset" .!= False) <*> liftE (v .:? "scrollable" .!= True) <*> pure pal @@ -80,6 +93,7 @@ instance FromJSONE (InheritedStructureDefs, (EntityMap, RobotMap)) WorldDescript <*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells. <*> pure validatedNavigation <*> pure subWorldName + <*> pure dslTerm ------------------------------------------------------------ -- World editor @@ -92,8 +106,7 @@ type WorldDescriptionPaint = PWorldDescription EntityFacade instance ToJSON WorldDescriptionPaint where toJSON w = object - [ "default" .= defaultTerrain w - , "offset" .= offsetOrigin w + [ "offset" .= offsetOrigin w , "palette" .= Y.toJSON paletteKeymap , "upperleft" .= ul w , "map" .= Y.toJSON mapText diff --git a/src/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/Swarm/Game/Scenario/Topography/WorldPalette.hs index 691f846f9..236384856 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/src/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -18,6 +18,7 @@ import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Terrain (TerrainType) +import Swarm.Util.Erasable import Swarm.Util.Yaml -- | A world palette maps characters to 'Cell' values. @@ -28,10 +29,10 @@ newtype WorldPalette e = WorldPalette instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE -type TerrainWith a = (TerrainType, Maybe a) +type TerrainWith a = (TerrainType, Erasable a) cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade -cellToTerrainPair (Cell terrain maybeEntity _) = (terrain, maybeEntity) +cellToTerrainPair (Cell terrain erasableEntity _) = (terrain, erasableEntity) toCellPaintDisplay :: Cell -> CellPaintDisplay toCellPaintDisplay (Cell terrain maybeEntity r) = diff --git a/src/Swarm/Game/ScenarioInfo.hs b/src/Swarm/Game/ScenarioInfo.hs index 76428c0b0..acd907ef0 100644 --- a/src/Swarm/Game/ScenarioInfo.hs +++ b/src/Swarm/Game/ScenarioInfo.hs @@ -64,6 +64,7 @@ import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath) import Swarm.Game.Scenario import Swarm.Game.Scenario.Scoring.CodeSize import Swarm.Game.Scenario.Status +import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Util.Effect (warn, withThrow) import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), ()) @@ -76,7 +77,7 @@ import Witch (into) -- | A scenario item is either a specific scenario, or a collection of -- scenarios (*e.g.* the scenarios contained in a subdirectory). data ScenarioItem = SISingle ScenarioInfoPair | SICollection Text ScenarioCollection - deriving (Eq, Show) + deriving (Show) -- | Retrieve the name of a scenario item. scenarioItemName :: ScenarioItem -> Text @@ -90,7 +91,7 @@ data ScenarioCollection = SC { scOrder :: Maybe [FilePath] , scMap :: Map FilePath ScenarioItem } - deriving (Eq, Show) + deriving (Show) -- | Access and modify ScenarioItems in collection based on their path. scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem @@ -138,14 +139,15 @@ flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c loadScenarios :: (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => EntityMap -> + WorldMap -> m ScenarioCollection -loadScenarios em = do +loadScenarios em worldMap = do res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios" case res of Left err -> do warn err return $ SC mempty mempty - Right dataDir -> loadScenarioDir em dataDir + Right dataDir -> loadScenarioDir em worldMap dataDir -- | The name of the special file which indicates the order of -- scenarios in a folder. @@ -161,9 +163,10 @@ readOrderFile orderFile = loadScenarioDir :: (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => EntityMap -> + WorldMap -> FilePath -> m ScenarioCollection -loadScenarioDir em dir = do +loadScenarioDir em worldMap dir = do let orderFile = dir orderFileName dirName = takeBaseName dir orderExists <- sendIO $ doesFileExist orderFile @@ -194,7 +197,7 @@ loadScenarioDir em dir = do -- Only keep the files from 00-ORDER.txt that actually exist. let morder' = filter (`elem` itemPaths) <$> morder loadItem filepath = do - item <- loadScenarioItem em (dir filepath) + item <- loadScenarioItem em worldMap (dir filepath) return (filepath, item) scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths let (failures, successes) = partitionEithers scenarios @@ -235,7 +238,7 @@ loadScenarioInfo p = do return $ ScenarioInfo path NotStarted else - withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParse) + withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParseYaml) . (liftEither <=< sendIO) $ decodeFileEither infoPath @@ -256,15 +259,16 @@ loadScenarioItem :: , Has (Lift IO) sig m ) => EntityMap -> + WorldMap -> FilePath -> m ScenarioItem -loadScenarioItem em path = do +loadScenarioItem em worldMap path = do isDir <- sendIO $ doesDirectoryExist path let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path case isDir of - True -> SICollection collectionName <$> loadScenarioDir em path + True -> SICollection collectionName <$> loadScenarioDir em worldMap path False -> do - s <- loadScenarioFile em path + s <- loadScenarioFile em worldMap path eitherSi <- runThrow @SystemFailure (loadScenarioInfo path) case eitherSi of Right si -> return $ SISingle (s, si) diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 277aae9fb..de6f4f5aa 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -142,6 +142,7 @@ import Data.IntSet (IntSet) import Data.IntSet qualified as IS import Data.IntSet.Lens (setOf) import Data.List (partition, sortOn) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M @@ -179,7 +180,9 @@ import Swarm.Game.Terrain (TerrainType (..)) import Swarm.Game.Universe as U import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray) import Swarm.Game.World qualified as W -import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray) +import Swarm.Game.World.Eval (runWorld) +import Swarm.Game.World.Gen (Seed, findGoodOrigin) +import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Language.Capability (constCaps) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Module (Module (Module)) @@ -188,7 +191,8 @@ import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst) import Swarm.Language.Typed (Typed (Typed)) import Swarm.Language.Types import Swarm.Language.Value (Value) -import Swarm.Util (binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?)) +import Swarm.Util (applyWhen, binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?)) +import Swarm.Util.Erasable import Swarm.Util.Lens (makeLensesExcluding) import System.Clock qualified as Clock import System.Random (StdGen, mkStdGen, randomRIO) @@ -1014,6 +1018,7 @@ data GameStateConfig = GameStateConfig , initNameList :: Array Int Text , initEntities :: EntityMap , initRecipes :: [Recipe Entity] + , initWorldMap :: WorldMap } -- | Create an initial, fresh game state record when starting a new scenario. @@ -1207,12 +1212,15 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) -- Subworld order as encountered in the scenario YAML file is preserved for -- the purpose of numbering robots, other than the "root" subworld -- guaranteed to be first. + genRobots :: [(Int, TRobot)] genRobots = concat $ NE.toList $ NE.map (fst . snd) builtWorldTuples + builtWorldTuples :: NonEmpty (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int Entity)) builtWorldTuples = - NE.map (worldName &&& buildWorld em) $ + NE.map (worldName &&& buildWorld) $ scenario ^. scenarioWorlds + allSubworldsMap :: Seed -> W.MultiWorld Int Entity allSubworldsMap s = M.map genWorld . M.fromList @@ -1232,23 +1240,24 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) -- | Take a world description, parsed from a scenario file, and turn -- it into a list of located robots and a world function. -buildWorld :: EntityMap -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) -buildWorld em WorldDescription {..} = (robots worldName, first fromEnum . wf) +buildWorld :: WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) +buildWorld WorldDescription {..} = (robots worldName, first fromEnum . wf) where rs = fromIntegral $ length area cs = fromIntegral $ length (head area) Coords (ulr, ulc) = locToCoords ul - worldGrid :: [[(TerrainType, Maybe Entity)]] + worldGrid :: [[(TerrainType, Erasable Entity)]] worldGrid = (map . map) (cellTerrain &&& cellEntity) area - worldArray :: Array (Int32, Int32) (TerrainType, Maybe Entity) + worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity) worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid) - wf = case defaultTerrain of - Nothing -> - (if offsetOrigin then findGoodOrigin else id) . testWorld2FromArray em worldArray - Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e)) + dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity + dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg + arrayWF = const (worldFunFromArray worldArray) + + wf = dslWF <> arrayWF -- Get all the robots described in cells and set their locations appropriately robots :: SubworldName -> [IndexedTRobot] diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs index c7004a063..c1252c043 100644 --- a/src/Swarm/Game/Terrain.hs +++ b/src/Swarm/Game/Terrain.hs @@ -7,6 +7,7 @@ module Swarm.Game.Terrain ( -- * Terrain TerrainType (..), + readTerrain, terrainMap, getTerrainDefaultPaletteChar, getTerrainWord, @@ -31,9 +32,19 @@ data TerrainType | BlankT deriving (Eq, Ord, Show, Read, Bounded, Enum) +readTerrain :: T.Text -> Maybe TerrainType +readTerrain t = readMaybe (into @String (T.toTitle t) ++ "T") + +instance Semigroup TerrainType where + t <> BlankT = t + _ <> t = t + +instance Monoid TerrainType where + mempty = BlankT + instance FromJSON TerrainType where parseJSON = withText "text" $ \t -> - case readMaybe (into @String (T.toTitle t) ++ "T") of + case readTerrain t of Just ter -> return ter Nothing -> failT ["Unknown terrain type:", t] diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index 4d0ff3f51..d519fd83f 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -10,8 +12,8 @@ -- mutable /entity/ layer, with at most one entity per cell. -- -- A world is technically finite but practically infinite (worlds are --- indexed by 64-bit signed integers, so they correspond to a --- \( 2^{64} \times 2^{64} \) torus). +-- indexed by 32-bit signed integers, so they correspond to a +-- \( 2^{32} \times 2^{32} \) torus). module Swarm.Game.World ( -- * World coordinates Coords (..), @@ -21,6 +23,7 @@ module Swarm.Game.World ( -- * Worlds WorldFun (..), + runWF, worldFunFromArray, World, MultiWorld, @@ -31,7 +34,6 @@ module Swarm.Game.World ( -- ** World functions newWorld, - emptyWorld, lookupCosmicTerrain, lookupTerrain, lookupCosmicEntity, @@ -54,50 +56,25 @@ import Control.Lens import Data.Array qualified as A import Data.Array.IArray import Data.Array.Unboxed qualified as U +import Data.Bifunctor (second) import Data.Bits import Data.Foldable (foldl') import Data.Function (on) import Data.Int (Int32) import Data.Map (Map) import Data.Map.Strict qualified as M +import Data.Semigroup (Last (..)) import Data.Yaml (FromJSON, ToJSON) import GHC.Generics (Generic) import Swarm.Game.Entity (Entity, entityHash) import Swarm.Game.Location import Swarm.Game.Terrain (TerrainType (BlankT)) import Swarm.Game.Universe +import Swarm.Game.World.Coords import Swarm.Util ((?)) +import Swarm.Util.Erasable import Prelude hiding (lookup) ------------------------------------------------------------- --- World coordinates ------------------------------------------------------------- - --- | World coordinates use (row,column) format, with the row --- increasing as we move down the screen. We use this format for --- indexing worlds internally, since it plays nicely with things --- like drawing the screen, and reading maps from configuration --- files. The 'locToCoords' and 'coordsToLoc' functions convert back --- and forth between this type and 'Location', which is used when --- presenting coordinates externally to the player. -newtype Coords = Coords {unCoords :: (Int32, Int32)} - deriving (Eq, Ord, Show, Ix, Generic) - -instance Rewrapped Coords t -instance Wrapped Coords - --- | Convert an external (x,y) location to an internal 'Coords' value. -locToCoords :: Location -> Coords -locToCoords (Location x y) = Coords (-y, x) - --- | Convert an internal 'Coords' value to an external (x,y) location. -coordsToLoc :: Coords -> Location -coordsToLoc (Coords (r, c)) = Location c (-r) - --- | Represents the top-left and bottom-right coordinates --- of a bounding rectangle of cells in the world map -type BoundsRectangle = (Coords, Coords) - ------------------------------------------------------------ -- World function ------------------------------------------------------------ @@ -105,19 +82,22 @@ type BoundsRectangle = (Coords, Coords) -- | 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)} - deriving (Functor) +newtype WorldFun t e = WF {getWF :: Coords -> (t, Erasable (Last e))} + deriving stock (Functor) + deriving newtype (Semigroup, Monoid) + +runWF :: WorldFun t e -> Coords -> (t, Maybe e) +runWF wf = second (erasableToMaybe . fmap getLast) . getWF wf instance Bifunctor WorldFun where - bimap g h (WF z) = WF (bimap g (fmap h) . z) + bimap g h (WF z) = WF (bimap g (fmap (fmap h)) . z) --- | Create a world function from a finite array of specified cells --- plus a single default cell to use everywhere else. -worldFunFromArray :: Array (Int32, Int32) (t, Maybe e) -> (t, Maybe e) -> WorldFun t e -worldFunFromArray arr def = WF $ \(Coords (r, c)) -> +-- | Create a world function from a finite array of specified cells. +worldFunFromArray :: Monoid t => Array (Int32, Int32) (t, Erasable e) -> WorldFun t e +worldFunFromArray arr = WF $ \(Coords (r, c)) -> if inRange bnds (r, c) - then arr ! (r, c) - else def + then second (fmap Last) (arr ! (r, c)) + else mempty where bnds = bounds arr @@ -217,11 +197,6 @@ data World t e = World newWorld :: WorldFun t e -> World t e newWorld f = World f M.empty M.empty --- | Create a new empty 'World' consisting of nothing but the given --- terrain. -emptyWorld :: t -> World t e -emptyWorld t = newWorld (WF $ const (t, Nothing)) - lookupCosmicTerrain :: IArray U.UArray Int => Cosmic Coords -> @@ -336,9 +311,9 @@ loadRegion reg (World f t m) = World f t' m tileCorner = tileOrigin tc (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds) --- ------------------------------------------------------------------ +--------------------------------------------------------------------- -- Runtime world update --- ------------------------------------------------------------------ +--------------------------------------------------------------------- -- | Update world in an inspectable way. -- diff --git a/src/Swarm/Game/World/Abstract.hs b/src/Swarm/Game/World/Abstract.hs new file mode 100644 index 000000000..b959404cc --- /dev/null +++ b/src/Swarm/Game/World/Abstract.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Explicitly type-preserving bracket abstraction, a la Oleg Kiselyov. +-- Turn elaborated, type-indexed terms into variableless, type-indexed +-- terms with only constants and application. +-- +-- For more information, see: +-- +-- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ +module Swarm.Game.World.Abstract where + +import Data.Kind (Type) +import Swarm.Game.World.Typecheck (Applicable (..), Const (..), HasConst (..), Idx (..), TTerm (..), ($$.), (.$$), (.$$.)) + +------------------------------------------------------------ +-- Bracket abstraction +------------------------------------------------------------ + +-------------------------------------------------- +-- Closed terms + +-- | Closed, fully abstracted terms. All computation is represented +-- by combinators. This is the ultimate target for the bracket +-- abstraction operation. +data BTerm :: Type -> Type where + BApp :: BTerm (a -> b) -> BTerm a -> BTerm b + BConst :: Const a -> BTerm a + +deriving instance Show (BTerm t) + +instance Applicable BTerm where + ($$) = BApp + +instance HasConst BTerm where + embed = BConst + +-------------------------------------------------- +-- Open terms + +-- | These explicitly open terms are an intermediate stage in the +-- bracket abstraction algorithm, /i.e./ they represent terms which have +-- been only partially abstracted. +data OTerm :: [Type] -> Type -> Type where + -- Embedded closed term. + E :: BTerm a -> OTerm g a + -- Reference to the innermost/top environment variable, i.e. Z + V :: OTerm (a ': g) a + -- Internalize the topmost env variable as a function argument + N :: OTerm g (a -> b) -> OTerm (a ': g) b + -- Ignore the topmost env variable + W :: OTerm g b -> OTerm (a ': g) b + +instance HasConst (OTerm g) where + embed = E . embed + +-- | Bracket abstraction: convert the 'TTerm' to an 'OTerm', then +-- project out the embedded 'BTerm'. GHC can see this is total +-- since 'E' is the only constructor that can produce an 'OTerm' +-- with an empty environment. +bracket :: TTerm '[] a -> BTerm a +bracket t = case conv t of + E t' -> t' + +-- | Type-preserving conversion from 'TTerm' to 'OTerm' ('conv' + the +-- 'Applicable' instance). Taken directly from Kiselyov. +conv :: TTerm g a -> OTerm g a +conv (TVar VZ) = V +conv (TVar (VS x)) = W (conv (TVar x)) +conv (TLam t) = case conv t of + V -> E (BConst I) + E d -> E (K .$$ d) + N e -> e + W e -> K .$$ e +conv (TApp t1 t2) = conv t1 $$ conv t2 +conv (TConst c) = embed c + +instance Applicable (OTerm g) where + ($$) :: OTerm g (a -> b) -> OTerm g a -> OTerm g b + W e1 $$ W e2 = W (e1 $$ e2) + W e $$ E d = W (e $$ E d) + E d $$ W e = W (E d $$ e) + W e $$ V = N e + V $$ W e = N (E (C .$$. I) $$ e) + W e1 $$ N e2 = N (B .$$ e1 $$ e2) + N e1 $$ W e2 = N (C .$$ e1 $$ e2) + N e1 $$ N e2 = N (S .$$ e1 $$ e2) + N e $$ V = N (S .$$ e $$. I) + V $$ N e = N (E (S .$$. I) $$ e) + E d $$ N e = N (E (B .$$ d) $$ e) + E d $$ V = N (E d) + V $$ E d = N (E (C .$$. I $$ d)) + N e $$ E d = N (E (C .$$. C $$ d) $$ e) + E d1 $$ E d2 = E (d1 $$ d2) + +-- There are only 15 cases above: GHC can tell that V $$ V is +-- impossible (it would be ill-typed)! diff --git a/src/Swarm/Game/World/Compile.hs b/src/Swarm/Game/World/Compile.hs new file mode 100644 index 000000000..9325d824a --- /dev/null +++ b/src/Swarm/Game/World/Compile.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Compiling abstracted combinator expressions ('BTerm') to native +-- Haskell terms. This can supposedly be more efficient than directly +-- interpreting 'BTerm's, but some benchmarking is probably needed to +-- decide whether we want this or not. +-- +-- For more info, see: +-- +-- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ +module Swarm.Game.World.Compile where + +import Data.ByteString (ByteString) +import Data.Hash.Murmur (murmur3) +import Data.Kind (Constraint) +import Data.Tagged (Tagged (unTagged)) +import Numeric.Noise.Perlin (noiseValue, perlin) +import Swarm.Game.Location (pattern Location) +import Swarm.Game.World.Abstract (BTerm (..)) +import Swarm.Game.World.Coords (Coords (..), coordsToLoc) +import Swarm.Game.World.Gen (Seed) +import Swarm.Game.World.Interpret (interpReflect, interpRot) +import Swarm.Game.World.Syntax (Axis (..), Rot, World) +import Swarm.Game.World.Typecheck (Applicable (..), Const (..), Empty (..), NotFun, Over (..)) +import Witch (from) +import Witch.Encoding qualified as Encoding + +data CTerm a where + CFun :: (CTerm a -> CTerm b) -> CTerm (a -> b) + CConst :: (NotFun a) => a -> CTerm a + +instance Applicable CTerm where + CFun f $$ x = f x + +compile :: Seed -> BTerm a -> CTerm a +compile seed (BApp b1 b2) = compile seed b1 $$ compile seed b2 +compile seed (BConst c) = compileConst seed c + +compileConst :: Seed -> Const a -> CTerm a +compileConst seed = \case + CLit i -> CConst i + CCell c -> CConst c + CFI -> unary fromIntegral + CIf -> CFun $ \(CConst b) -> CFun $ \t -> CFun $ \e -> if b then t else e + CNot -> unary not + CNeg -> unary negate + CAbs -> unary abs + CAnd -> binary (&&) + COr -> binary (||) + CAdd -> binary (+) + CSub -> binary (-) + CMul -> binary (*) + CDiv -> binary (/) + CIDiv -> binary div + CMod -> binary mod + CEq -> binary (==) + CNeq -> binary (/=) + CLt -> binary (<) + CLeq -> binary (<=) + CGt -> binary (>) + CGeq -> binary (>=) + CMask -> compileMask + CSeed -> CConst (fromIntegral seed) + CCoord ax -> CFun $ \(CConst (coordsToLoc -> Location x y)) -> CConst (fromIntegral (case ax of X -> x; Y -> y)) + CHash -> compileHash + CPerlin -> compilePerlin + CReflect ax -> compileReflect ax + CRot rot -> compileRot rot + COver -> binary () + K -> CFun $ \x -> CFun $ const x + S -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ x $$ (g $$ x) + I -> CFun id + B -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ (g $$ x) + C -> CFun $ \f -> CFun $ \x -> CFun $ \y -> f $$ y $$ x + Φ -> CFun $ \c -> CFun $ \f -> CFun $ \g -> CFun $ \x -> c $$ (f $$ x) $$ (g $$ x) + +unary :: (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b) +unary op = CFun $ \(CConst x) -> CConst (op x) + +binary :: (NotFun a, NotFun b, NotFun c) => (a -> b -> c) -> CTerm (a -> b -> c) +binary op = CFun $ \(CConst x) -> CFun $ \(CConst y) -> CConst (op x y) + +-- Note we could desugar 'mask p a -> if p a empty' but that would +-- require an explicit 'empty' node, whose type can't be inferred. +compileMask :: (NotFun a, Empty a) => CTerm (World Bool -> World a -> World a) +compileMask = CFun $ \p -> CFun $ \a -> CFun $ \ix -> + case p $$ ix of + CConst b -> if b then a $$ ix else CConst empty + +compileHash :: CTerm (Coords -> Integer) +compileHash = CFun $ \(CConst (Coords ix)) -> CConst (fromIntegral (h ix)) + where + h = murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show + +compilePerlin :: CTerm (Integer -> Integer -> Double -> Double -> World Double) +compilePerlin = + CFun $ \(CConst s) -> + CFun $ \(CConst o) -> + CFun $ \(CConst k) -> + CFun $ \(CConst p) -> + let noise = perlin (fromIntegral s) (fromIntegral o) k p + in CFun $ \(CConst (Coords ix)) -> CConst (sample ix noise) + where + sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) + +compileReflect :: Axis -> CTerm (World a -> World a) +compileReflect ax = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpReflect ax c) + +compileRot :: Rot -> CTerm (World a -> World a) +compileRot rot = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpRot rot c) + +type family NoFunParams a :: Constraint where + NoFunParams (a -> b) = (NotFun a, NoFunParams b) + NoFunParams _ = () + +-- | Interpret a compiled term into the host language. +runCTerm :: (NoFunParams a) => CTerm a -> a +runCTerm (CConst a) = a +runCTerm (CFun f) = runCTerm . f . CConst diff --git a/src/Swarm/Game/World/Coords.hs b/src/Swarm/Game/World/Coords.hs new file mode 100644 index 000000000..085dcdd24 --- /dev/null +++ b/src/Swarm/Game/World/Coords.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- World coordinates. +module Swarm.Game.World.Coords ( + Coords (..), + locToCoords, + coordsToLoc, + BoundsRectangle, +) +where + +import Control.Lens (Rewrapped, Wrapped) +import Data.Array.IArray (Ix) +import Data.Int (Int32) +import GHC.Generics (Generic) +import Swarm.Game.Location (Location, pattern Location) + +------------------------------------------------------------ +-- World coordinates +------------------------------------------------------------ + +-- | World coordinates use (row,column) format, with the row +-- increasing as we move down the screen. We use this format for +-- indexing worlds internally, since it plays nicely with things +-- like drawing the screen, and reading maps from configuration +-- files. The 'locToCoords' and 'coordsToLoc' functions convert back +-- and forth between this type and 'Location', which is used when +-- presenting coordinates externally to the player. +newtype Coords = Coords {unCoords :: (Int32, Int32)} + deriving (Eq, Ord, Show, Ix, Generic) + +instance Rewrapped Coords t +instance Wrapped Coords + +-- | Convert an external (x,y) location to an internal 'Coords' value. +locToCoords :: Location -> Coords +locToCoords (Location x y) = Coords (-y, x) + +-- | Convert an internal 'Coords' value to an external (x,y) location. +coordsToLoc :: Coords -> Location +coordsToLoc (Coords (r, c)) = Location c (-r) + +-- | Represents the top-left and bottom-right coordinates +-- of a bounding rectangle of cells in the world map +type BoundsRectangle = (Coords, Coords) diff --git a/src/Swarm/Game/World/Eval.hs b/src/Swarm/Game/World/Eval.hs new file mode 100644 index 000000000..5ee5a44b3 --- /dev/null +++ b/src/Swarm/Game/World/Eval.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Evaluation for the Swarm world description DSL. +module Swarm.Game.World.Eval ( + runWorld, +) where + +import Swarm.Game.Entity (Entity) +import Swarm.Game.Terrain (TerrainType (..)) +import Swarm.Game.World (WorldFun (..)) +import Swarm.Game.World.Abstract (bracket) +import Swarm.Game.World.Coords (Coords) +import Swarm.Game.World.Gen (Seed) +import Swarm.Game.World.Interpret (interpBTerm) +import Swarm.Game.World.Syntax +import Swarm.Game.World.Typecheck + +-- | Run a typechecked world description DSL term to produce a +-- 'WorldFun'. +runWorld :: TTerm '[] (World CellVal) -> Seed -> WorldFun TerrainType Entity +runWorld t seed = convertWF . interpBTerm seed . bracket $ t + +-- Currently we run a DSL term by performing bracket abstraction, +-- producing a 'BTerm', then directly interpreting the 'BTerm' with +-- 'interpBTerm'. We could also compile the 'BTerm' to a 'CTerm' and +-- run it, i.e. +-- +-- convertWF . runCTerm . compile seed . bracket $ t +-- +-- which can supposedly give a performance boost, but it is unclear +-- whether this actually makes a difference in our case. + +-- | Simple adapter function to convert a plain @Coords -> CellVal@ +-- function into a 'WorldFun' value. +convertWF :: (Coords -> CellVal) -> WorldFun TerrainType Entity +convertWF f = WF ((\(CellVal t e _) -> (t, e)) . f) diff --git a/src/Swarm/Game/World/Gen.hs b/src/Swarm/Game/World/Gen.hs new file mode 100644 index 000000000..10399da2a --- /dev/null +++ b/src/Swarm/Game/World/Gen.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for working with procedurally generated worlds. +module Swarm.Game.World.Gen where + +import Control.Lens (view) +import Data.Enumeration +import Data.Int (Int32) +import Data.List (find) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Semigroup (Last (..), getLast) +import Data.Set qualified as S +import Data.Text (Text) +import Swarm.Game.Entity +import Swarm.Game.World +import Swarm.Game.World.Syntax (CellVal (..)) +import Swarm.Game.World.Typecheck (Const (CCell), TTerm (..)) +import Swarm.Util.Erasable + +type Seed = Int + +-- | Extract a list of all entities mentioned in a given world DSL term. +extractEntities :: TTerm g a -> S.Set Entity +extractEntities (TLam t) = extractEntities t +extractEntities (TApp t1 t2) = extractEntities t1 <> extractEntities t2 +extractEntities (TConst (CCell (CellVal _ ee _))) = getEntity ee + where + getEntity (EJust (Last e)) = S.singleton e + getEntity _ = S.empty +extractEntities _ = S.empty + +-- | Offset a world by a multiple of the @skip@ in such a way that it +-- satisfies the given predicate. +findOffset :: Integer -> ((Coords -> (t, Erasable (Last e))) -> Bool) -> WorldFun t e -> WorldFun t e +findOffset skip isGood (WF f) = WF f' + where + offset :: Enumeration Int32 + offset = fromIntegral . (skip *) <$> int + + f' = + fromMaybe (error "the impossible happened, no offsets were found!") + . find isGood + . map shift + . enumerate + $ offset >< offset + + shift (dr, dc) (Coords (r, c)) = f (Coords (r - dr, c - dc)) + +-- | Offset the world so the base starts in a 32x32 patch containing at least one +-- of each of a list of required entities. +findPatchWith :: [Text] -> WorldFun t Entity -> WorldFun t Entity +findPatchWith reqs = findOffset 32 isGoodPatch + where + patchCoords = [(r, c) | r <- [-16 .. 16], c <- [-16 .. 16]] + isGoodPatch f = all (`S.member` es) reqs + where + es = S.fromList . map (view entityName) . mapMaybe (erasableToMaybe . fmap getLast . snd . f . Coords) $ patchCoords + +-- | Offset the world so the base starts on empty spot next to tree and grass. +findTreeOffset :: WorldFun t Entity -> WorldFun t Entity +findTreeOffset = findOffset 1 isGoodPlace + where + isGoodPlace f = + hasEntity Nothing (0, 0) + && any (hasEntity (Just "tree")) neighbors + && all (\c -> hasEntity (Just "tree") c || hasEntity Nothing c) neighbors + where + hasEntity mayE = (== mayE) . erasableToMaybe . fmap (view entityName . getLast) . snd . f . Coords + + neighbors = [(r, c) | r <- [-1 .. 1], c <- [-1 .. 1]] + +-- | Offset the world so the base starts in a good patch (near +-- necessary items), next to a tree. +findGoodOrigin :: WorldFun t Entity -> WorldFun t Entity +findGoodOrigin = findTreeOffset . findPatchWith ["tree", "copper ore", "bit (0)", "bit (1)", "rock", "lambda", "water", "sand"] diff --git a/src/Swarm/Game/World/Interpret.hs b/src/Swarm/Game/World/Interpret.hs new file mode 100644 index 000000000..3437af9c8 --- /dev/null +++ b/src/Swarm/Game/World/Interpret.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GADTs #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Interpreter for the Swarm world description DSL. +module Swarm.Game.World.Interpret ( + interpBTerm, + interpConst, + interpReflect, + interpRot, +) where + +import Control.Applicative (Applicative (..)) +import Data.ByteString (ByteString) +import Data.Hash.Murmur (murmur3) +import Data.Tagged (unTagged) +import Numeric.Noise.Perlin (noiseValue, perlin) +import Swarm.Game.World.Abstract (BTerm (..)) +import Swarm.Game.World.Coords (Coords (..)) +import Swarm.Game.World.Gen (Seed) +import Swarm.Game.World.Syntax (Axis (..), Rot (..)) +import Swarm.Game.World.Typecheck (Const (..), Empty (..), Over (..)) +import Witch (from) +import Witch.Encoding qualified as Encoding +import Prelude hiding (Applicative (..)) + +-- | Interpret an abstracted term into the host language. +interpBTerm :: Seed -> BTerm a -> a +interpBTerm seed (BApp f x) = interpBTerm seed f (interpBTerm seed x) +interpBTerm seed (BConst c) = interpConst seed c + +-- | Interpret a constant into the host language. +interpConst :: Seed -> Const a -> a +interpConst seed = \case + CLit a -> a + CCell c -> c + CIf -> \b t e -> if b then t else e + CNot -> not + CNeg -> negate + CAbs -> abs + CAnd -> (&&) + COr -> (||) + CAdd -> (+) + CSub -> (-) + CMul -> (*) + CDiv -> (/) + CIDiv -> div + CMod -> mod + CEq -> (==) + CNeq -> (/=) + CLt -> (<) + CLeq -> (<=) + CGt -> (>) + CGeq -> (>=) + CMask -> \b x c -> if b c then x c else empty + CSeed -> fromIntegral seed + CCoord ax -> \(Coords (x, y)) -> fromIntegral (case ax of X -> x; Y -> y) + CHash -> \(Coords ix) -> fromIntegral . murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix + CPerlin -> \s o k p -> + let noise = perlin (fromIntegral s) (fromIntegral o) k p + sample (i, j) = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) + in \(Coords ix) -> sample ix + CReflect ax -> \w -> w . interpReflect ax + CRot r -> \w -> w . interpRot r + CFI -> fromInteger + COver -> () + K -> const + S -> (<*>) + I -> id + B -> (.) + C -> flip + Φ -> liftA2 + +-- | Interprect a reflection. +interpReflect :: Axis -> Coords -> Coords +interpReflect ax (Coords (r, c)) = Coords (case ax of X -> (r, -c); Y -> (-r, c)) + +-- | Interpret a rotation. +interpRot :: Rot -> Coords -> Coords +interpRot rot (Coords crd) = Coords (rotTuple rot crd) + where + rotTuple = \case + Rot0 -> id + Rot90 -> \(r, c) -> (-c, r) + Rot180 -> \(r, c) -> (-r, -c) + Rot270 -> \(r, c) -> (c, -r) diff --git a/src/Swarm/Game/World/Load.hs b/src/Swarm/Game/World/Load.hs new file mode 100644 index 000000000..67fe131c8 --- /dev/null +++ b/src/Swarm/Game/World/Load.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Loading world descriptions from `worlds/*.world`. +module Swarm.Game.World.Load where + +import Control.Algebra (Has) +import Control.Arrow (left) +import Control.Carrier.Accum.FixedStrict (Accum) +import Control.Carrier.Lift (Lift, sendIO) +import Control.Carrier.Reader (runReader) +import Control.Effect.Throw (Throw, liftEither) +import Data.Map qualified as M +import Data.Maybe (catMaybes) +import Data.Sequence (Seq) +import Data.Text (Text) +import Swarm.Game.Entity (EntityMap) +import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Game.ResourceLoading (getDataDirSafe) +import Swarm.Game.World.Parse (parseWExp, runParser) +import Swarm.Game.World.Typecheck +import Swarm.Language.Pretty (prettyText) +import Swarm.Util (acquireAllWithExt) +import Swarm.Util.Effect (throwToWarning, withThrow) +import System.FilePath (dropExtension, joinPath, splitPath) +import Witch (into) + +-- | Load and typecheck all world descriptions from `worlds/*.world`. +-- Emit a warning for each one which fails to parse or typecheck. +loadWorlds :: + (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + EntityMap -> + m WorldMap +loadWorlds em = do + res <- throwToWarning @SystemFailure $ getDataDirSafe Worlds "worlds" + case res of + Nothing -> return M.empty + Just dir -> do + worldFiles <- sendIO $ acquireAllWithExt dir "world" + ws <- mapM (throwToWarning @SystemFailure . loadWorld dir em) worldFiles + return . M.fromList . catMaybes $ ws + +-- | Load a file containing a world DSL term, throwing an exception if +-- it fails to parse or typecheck. +loadWorld :: + (Has (Throw SystemFailure) sig m) => + FilePath -> + EntityMap -> + (FilePath, String) -> + m (Text, Some (TTerm '[])) +loadWorld dir em (fp, src) = do + wexp <- + liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $ + runParser parseWExp (into @Text src) + t <- + withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $ + runReader em . runReader @WorldMap M.empty $ + infer CNil wexp + return (into @Text (dropExtension (stripDir dir fp)), t) + +-- | Strip a leading directory from a 'FilePath'. +stripDir :: FilePath -> FilePath -> FilePath +stripDir dir fp = joinPath (drop (length (splitPath dir)) (splitPath fp)) diff --git a/src/Swarm/Game/World/Parse.hs b/src/Swarm/Game/World/Parse.hs new file mode 100644 index 000000000..edb9ed4d9 --- /dev/null +++ b/src/Swarm/Game/World/Parse.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- FromJSON WExp +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parser for the Swarm world description DSL. +module Swarm.Game.World.Parse where + +import Control.Monad (MonadPlus, void) +import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void +import Data.Yaml (FromJSON (parseJSON), withText) +import Swarm.Game.World.Syntax +import Swarm.Util (failT, showT, squote) +import Swarm.Util.Parse (fully) +import Text.Megaparsec hiding (runParser) +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L +import Witch (into) + +type Parser = Parsec Void Text +type ParserError = ParseErrorBundle Text Void + +------------------------------------------------------------ +-- Utility + +sepByNE :: (MonadPlus m) => m a -> m sep -> m (NonEmpty a) +sepByNE p sep = NE.fromList <$> p `sepBy1` sep + +------------------------------------------------------------ +-- Lexing + +reservedWords :: [Text] +reservedWords = + [ "not" + , "true" + , "false" + , "seed" + , "x" + , "y" + , "hash" + , "let" + , "in" + , "overlay" + , "hcat" + , "vcat" + , "if" + , "then" + , "else" + , "perlin" + , "mask" + , "empty" + , "abs" + ] + +-- | Skip spaces and comments. +sc :: Parser () +sc = + L.space + space1 + (L.skipLineComment "//") + (L.skipBlockComment "/*" "*/") + +-- | In general, we follow the convention that every token parser +-- assumes no leading whitespace and consumes all trailing +-- whitespace. Concretely, we achieve this by wrapping every token +-- parser using 'lexeme'. +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +-- | A lexeme consisting of a literal string. +symbol :: Text -> Parser Text +symbol = L.symbol sc + +operatorChar :: Parser Char +operatorChar = oneOf ("!@#$%^&*=+-/<>" :: String) + +operator :: Text -> Parser Text +operator op = (lexeme . try) $ string op <* notFollowedBy operatorChar + +-- | A positive integer literal token. +integerOrFloat :: Parser (Either Integer Double) +integerOrFloat = + label "numeric literal" $ + lexeme (Right <$> try L.float <|> Left <$> L.decimal) + +-- | Parse a case-insensitive reserved word, making sure it is not a +-- prefix of a longer variable name, and allowing the parser to +-- backtrack if it fails. +reserved :: Text -> Parser () +reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_') + +-- | Parse an identifier, i.e. any non-reserved string containing +-- alphanumeric characters and underscores and not starting with a +-- number. +identifier :: Parser Var +identifier = (lexeme . try) (p >>= check) "variable name" + where + p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'') + check (into @Text -> t) + | T.toLower t `elem` reservedWords = + failT ["reserved word", squote t, "cannot be used as variable name"] + | otherwise = return t + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +braces :: Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +comma :: Parser () +comma = void $ symbol "," + +------------------------------------------------------------ +-- Parser + +---------------------------------------------------------------------- +-- NOTE: when updating the parser, be sure to update the BNF in +-- data/worlds/README.md to match! +---------------------------------------------------------------------- + +parseWExpAtom :: Parser WExp +parseWExpAtom = + either WInt WFloat <$> integerOrFloat + <|> WBool <$> (True <$ reserved "true" <|> False <$ reserved "false") + <|> parseCell + <|> WVar <$> identifier + <|> WSeed <$ reserved "seed" + <|> WCoord <$> (X <$ reserved "x" <|> Y <$ reserved "y") + <|> WHash <$ reserved "hash" + <|> parseIf + <|> parsePerlin + <|> parseAbs + <|> parseLet + <|> parseOverlay + <|> parseMask + <|> parseImport + -- <|> parseCat + -- <|> parseStruct + <|> parens parseWExp + +parseWExp :: Parser WExp +parseWExp = + makeExprParser + parseWExpAtom + [ + [ Prefix (unary Not <$ reserved "not") + , Prefix (unary Neg <$ operator "-") + ] + , + [ InfixL (binary Mul <$ operator "*") + , InfixL (binary Div <$ operator "/") + , InfixL (binary Mod <$ operator "%") + ] + , + [ InfixL (binary Add <$ operator "+") + , InfixL (binary Sub <$ operator "-") + , InfixR (binary Overlay <$ operator "<>") + ] + , + [ InfixN (binary Eq <$ operator "==") + , InfixN (binary Neq <$ operator "/=") + , InfixN (binary Lt <$ operator "<") + , InfixN (binary Leq <$ operator "<=") + , InfixN (binary Gt <$ operator ">") + , InfixN (binary Geq <$ operator ">=") + ] + , [InfixR (binary And <$ operator "&&")] + , [InfixR (binary Or <$ operator "||")] + ] + where + unary op x = WOp op [x] + binary op x1 x2 = WOp op [x1, x2] + +parseCell :: Parser WExp +parseCell = + braces $ WCell <$> parseCellItem `sepBy1` comma + +parseCellItem :: Parser (Maybe CellTag, Text) +parseCellItem = + (,) + <$> optional (try (parseCellTag <* symbol ":")) + <*> parseName + +parseCellTag :: Parser CellTag +parseCellTag = choice (map mkCellTagParser [minBound .. maxBound :: CellTag]) + where + mkCellTagParser ct = ct <$ string' (T.drop 4 $ showT ct) + +parseName :: Parser Text +parseName = + into @Text + <$> manyTill anySingle (lookAhead (satisfy (\c -> c == ',' || c == '}' || c == ']'))) + +parseIf :: Parser WExp +parseIf = + (\i t e -> WOp If [i, t, e]) + <$> (reserved "if" *> parseWExp) + <*> (reserved "then" *> parseWExp) + <*> (reserved "else" *> parseWExp) + +parsePerlin :: Parser WExp +parsePerlin = + (\s o k p -> WOp Perlin [s, o, k, p]) + <$> (reserved "perlin" *> parseWExpAtom) + <*> parseWExpAtom + <*> parseWExpAtom + <*> parseWExpAtom + +parseAbs :: Parser WExp +parseAbs = + WOp Abs . (: []) <$> (reserved "abs" *> parseWExpAtom) + +parseLet :: Parser WExp +parseLet = + WLet + <$> ( reserved "let" + *> (((,) <$> identifier <*> (symbol "=" *> parseWExp)) `sepBy` comma) + ) + <*> (reserved "in" *> parseWExp) + +parseOverlay :: Parser WExp +parseOverlay = do + reserved "overlay" + brackets $ WOverlay <$> parseWExp `sepByNE` comma + +parseMask :: Parser WExp +parseMask = do + reserved "mask" + w1 <- parseWExpAtom + w2 <- parseWExpAtom + return $ WOp Mask [w1, w2] + +parseImport :: Parser WExp +parseImport = WImport . into @Text <$> between (symbol "\"") (symbol "\"") (some (satisfy (/= '"'))) + +-- parseCat :: Parser WExp +-- parseCat = +-- WCat +-- <$> (X <$ reserved "hcat" <|> Y <$ reserved "vcat") +-- <*> brackets (parseWExp `sepBy` comma) + +-- parseStruct :: Parser WExp +-- parseStruct = reserved "struct" *> fail "struct not implemented" + +------------------------------------------------------------ +-- Utility + +runParser :: Parser a -> Text -> Either ParserError a +runParser p = parse (fully sc p) "" + +------------------------------------------------------------ +-- JSON instance + +instance FromJSON WExp where + parseJSON = withText "World DSL program" $ \t -> + case runParser parseWExp t of + Left err -> error (errorBundlePretty err) + Right wexp -> return wexp diff --git a/src/Swarm/Game/World/Syntax.hs b/src/Swarm/Game/World/Syntax.hs new file mode 100644 index 000000000..4efcfc028 --- /dev/null +++ b/src/Swarm/Game/World/Syntax.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Abstract syntax for the Swarm world description DSL. +module Swarm.Game.World.Syntax ( + -- | Various component types + World, + RawCellVal, + CellTag (..), + CellVal (..), + Rot (..), + Var, + Axis (..), + Op (..), + -- | The main AST type + WExp (..), +) +where + +import Control.Lens (view, (^.)) +import Data.List.NonEmpty qualified as NE +import Data.Semigroup (Last (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Prettyprinter +import Swarm.Game.Entity (Entity, entityName) +import Swarm.Game.Robot (Robot, robotName) +import Swarm.Game.Terrain +import Swarm.Game.World.Coords +import Swarm.Language.Pretty +import Swarm.Util (showT) +import Swarm.Util.Erasable + +------------------------------------------------------------ +-- Bits and bobs + +type World b = Coords -> b + +data CellTag = CellTerrain | CellEntity | CellRobot + deriving (Eq, Ord, Show, Enum, Bounded) + +instance PrettyPrec CellTag where + prettyPrec _ = \case + CellTerrain -> "terrain" + CellEntity -> "an entity" + CellRobot -> "a robot" + +type RawCellVal = [(Maybe CellTag, Text)] + +prettyRawCellItem :: (Maybe CellTag, Text) -> Doc ann +prettyRawCellItem (Nothing, t) = pretty t +prettyRawCellItem (Just tag, t) = pretty (T.toLower . T.drop 4 . showT $ tag) <> ":" <> pretty t + +data CellVal = CellVal TerrainType (Erasable (Last Entity)) [Robot] + deriving (Eq, Show) + +instance PrettyPrec CellVal where + prettyPrec _ (CellVal terr ent rs) = + "{" <> hsep (punctuate "," (map prettyRawCellItem items)) <> "}" + where + items = + [(Just CellTerrain, getTerrainWord terr) | terr /= BlankT] + ++ [(Just CellEntity, e ^. entityName) | EJust (Last e) <- [ent]] + ++ map ((Just CellRobot,) . view robotName) rs + +data Rot = Rot0 | Rot90 | Rot180 | Rot270 + deriving (Eq, Ord, Show, Bounded, Enum) + +instance PrettyPrec Rot where + prettyPrec _ = \case + Rot0 -> "rot0" + Rot90 -> "rot90" + Rot180 -> "rot180" + Rot270 -> "rot270" + +type Var = Text + +data Axis = X | Y + deriving (Eq, Ord, Show, Bounded, Enum) + +instance PrettyPrec Axis where + prettyPrec _ = \case X -> "x"; Y -> "y" + +data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Reflect Axis | Rot Rot | Mask | Overlay | Abs + deriving (Eq, Ord, Show) + +------------------------------------------------------------ +-- Main AST + +data WExp where + WInt :: Integer -> WExp + WFloat :: Double -> WExp + WBool :: Bool -> WExp + WCell :: RawCellVal -> WExp + WVar :: Text -> WExp + -- Require all operators to be fully saturated. Just embedding + -- operators as constants and including function application would + -- be a more elegant encoding, but it requires being more clever + -- with type inference. + WOp :: Op -> [WExp] -> WExp + WSeed :: WExp + WCoord :: Axis -> WExp + WHash :: WExp + WLet :: [(Var, WExp)] -> WExp -> WExp + WOverlay :: NE.NonEmpty WExp -> WExp + WImport :: Text -> WExp + deriving (Eq, Show) + +-- We don't have an explicit Empty case because we can't infer its +-- type. It could be done but it would require a lot more care with +-- inference vs checking mode. + +-- TODO (#1394): Add hcat and vcat operations +-- WCat :: Axis -> [WExp] -> WExp + +-- TODO (#1394): Add support for structures +-- WStruct :: WorldPalette Text -> [Text] -> WExp diff --git a/src/Swarm/Game/World/Typecheck.hs b/src/Swarm/Game/World/Typecheck.hs new file mode 100644 index 000000000..14fbc4625 --- /dev/null +++ b/src/Swarm/Game/World/Typecheck.hs @@ -0,0 +1,687 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Typechecking and elaboration for the Swarm world DSL. For more +-- information, see: +-- +-- https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/ +module Swarm.Game.World.Typecheck where + +import Control.Algebra (Has) +import Control.Effect.Reader (Reader, ask) +import Control.Effect.Throw (Throw, throwError) +import Data.Foldable qualified as F +import Data.Functor.Const qualified as F +import Data.Kind (Type) +import Data.List (foldl') +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Semigroup (Last (..)) +import Data.Text (Text) +import Data.Type.Equality (TestEquality (..), type (:~:) (Refl)) +import Prettyprinter +import Swarm.Game.Entity (EntityMap, lookupEntityName) +import Swarm.Game.Terrain (readTerrain) +import Swarm.Game.World.Syntax +import Swarm.Language.Pretty +import Swarm.Util (showT) +import Swarm.Util.Erasable +import Prelude hiding (lookup) + +------------------------------------------------------------ +-- Type classes for monoidal world values + +-- We could use Semigroup and Monoid, but we want to use the two +-- classes separately and make instances for base types, so it's +-- cleaner to just make our own classes (the instances would be +-- orphans if we used Semigroup and Monoid). + +class Empty e where + empty :: e + +instance Empty CellVal where + empty = CellVal mempty mempty mempty + +class Over m where + () :: m -> m -> m + +instance Over Bool where + _ x = x + +instance Over Integer where + _ x = x + +instance Over Double where + _ x = x + +instance Over CellVal where + CellVal t1 e1 r1 CellVal t2 e2 r2 = CellVal (t1 <> t2) (e1 <> e2) (r1 <> r2) + +------------------------------------------------------------ +-- Type class for type-indexed application + +infixl 1 $$ +class Applicable t where + ($$) :: t (a -> b) -> t a -> t b + +------------------------------------------------------------ +-- Distinguishing functions and non-functions at the type level + +-- In several places, for efficiency we will require something to be +-- not a function, which we can enforce using the 'NotFun' constraint. + +type family IsFun a where + IsFun (_ -> _) = 'True + IsFun _ = 'False + +type NotFun a = IsFun a ~ 'False + +------------------------------------------------------------ +-- Type-indexed constants + +-- | Type-indexed constants. These include both language built-ins +-- (@if@, arithmetic, comparison, @<>@, etc.) as well as combinators +-- (@S@, @I@, @C@, @K@, @B@, @Φ@) we will use both for elaboration +-- and later as a compilation target. +data Const :: Type -> Type where + CLit :: (Show a, NotFun a) => a -> Const a + CCell :: CellVal -> Const CellVal + -- We have a separate CCell instead of using CLit for cells so that we can + -- later extract all the entities from a world expression. + CFI :: Const (Integer -> Double) + CIf :: Const (Bool -> a -> a -> a) + CNot :: Const (Bool -> Bool) + CNeg :: (Num a, NotFun a) => Const (a -> a) + CAbs :: (Num a, NotFun a) => Const (a -> a) + CAnd :: Const (Bool -> Bool -> Bool) + COr :: Const (Bool -> Bool -> Bool) + CAdd :: (Num a, NotFun a) => Const (a -> a -> a) + CSub :: (Num a, NotFun a) => Const (a -> a -> a) + CMul :: (Num a, NotFun a) => Const (a -> a -> a) + CDiv :: (Fractional a, NotFun a) => Const (a -> a -> a) + CIDiv :: (Integral a, NotFun a) => Const (a -> a -> a) + CMod :: (Integral a, NotFun a) => Const (a -> a -> a) + CEq :: (Eq a, NotFun a) => Const (a -> a -> Bool) + CNeq :: (Eq a, NotFun a) => Const (a -> a -> Bool) + CLt :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CLeq :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CGt :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CGeq :: (Ord a, NotFun a) => Const (a -> a -> Bool) + CMask :: (Empty a, NotFun a) => Const (World Bool -> World a -> World a) + CSeed :: Const Integer + CCoord :: Axis -> Const (World Integer) + CHash :: Const (World Integer) + CPerlin :: Const (Integer -> Integer -> Double -> Double -> World Double) + CReflect :: Axis -> Const (World a -> World a) + CRot :: Rot -> Const (World a -> World a) + COver :: (Over a, NotFun a) => Const (a -> a -> a) + -- Combinators generated during elaboration + variable abstraction + K :: Const (a -> b -> a) + S :: Const ((a -> b -> c) -> (a -> b) -> a -> c) + I :: Const (a -> a) + B :: Const ((b -> c) -> (a -> b) -> a -> c) + C :: Const ((a -> b -> c) -> b -> a -> c) + -- Phoenix combinator, aka liftA2. Including this combinator in the + -- target set is not typical, but it turns out to be very helpful in + -- elaborating the "over" operation. + Φ :: Const ((a -> b -> c) -> (d -> a) -> (d -> b) -> (d -> c)) + +deriving instance Show (Const ty) + +class HasConst t where + embed :: Const a -> t a + +infixl 1 .$$ +(.$$) :: (HasConst t, Applicable t) => Const (a -> b) -> t a -> t b +c .$$ t = embed c $$ t + +infixl 1 $$. +($$.) :: (HasConst t, Applicable t) => t (a -> b) -> Const a -> t b +t $$. c = t $$ embed c + +infixl 1 .$$. +(.$$.) :: (HasConst t, Applicable t) => Const (a -> b) -> Const a -> t b +c1 .$$. c2 = embed c1 $$ embed c2 + +instance PrettyPrec (Const α) where + prettyPrec _ = \case + CLit a -> pretty (showT a) + CCell c -> ppr c + CFI -> "fromIntegral" + CIf -> "if" + CNot -> "not" + CNeg -> "negate" + CAbs -> "abs" + CAnd -> "and" + COr -> "or" + CAdd -> "add" + CSub -> "sub" + CMul -> "mul" + CDiv -> "div" + CIDiv -> "idiv" + CMod -> "mod" + CEq -> "eq" + CNeq -> "neq" + CLt -> "lt" + CLeq -> "leq" + CGt -> "gt" + CGeq -> "geq" + CMask -> "mask" + CSeed -> "seed" + CCoord ax -> ppr ax + CHash -> "hash" + CPerlin -> "perlin" + CReflect ax -> case ax of X -> "vreflect"; Y -> "hreflect" + CRot rot -> ppr rot + COver -> "over" + K -> "K" + S -> "S" + I -> "I" + B -> "B" + C -> "C" + Φ -> "Φ" + +------------------------------------------------------------ +-- Intrinsically typed core language + +-- | Type-level list append. +type family Append (xs :: [k]) (ys :: [k]) :: [k] where + Append '[] ys = ys + Append (x ': xs) ys = x ': Append xs ys + +-- | Type- and context-indexed de Bruijn indices. (v :: Idx g a) means +-- v represents a variable with type a in a type context g. +data Idx :: [Type] -> Type -> Type where + VZ :: Idx (ty ': g) ty + VS :: Idx g ty -> Idx (x ': g) ty + +deriving instance Show (Idx g ty) + +idxToNat :: Idx g a -> Int +idxToNat VZ = 0 +idxToNat (VS x) = 1 + idxToNat x + +-- | A variable valid in one context is also valid in another extended +-- context with additional variables. +weakenVar :: forall h g a. Idx g a -> Idx (Append g h) a +weakenVar VZ = VZ +weakenVar (VS x) = VS (weakenVar @h x) + +-- | Type-indexed terms. Note this is a stripped-down core language, +-- with only variables, lambdas, application, and constants. +data TTerm :: [Type] -> Type -> Type where + TVar :: Idx g a -> TTerm g a + TLam :: TTerm (ty1 ': g) ty2 -> TTerm g (ty1 -> ty2) + TApp :: TTerm g (a -> b) -> TTerm g a -> TTerm g b + TConst :: Const a -> TTerm g a + +deriving instance Show (TTerm g ty) + +instance Applicable (TTerm g) where + TConst I $$ x = x + f $$ x = TApp f x + +instance HasConst (TTerm g) where + embed = TConst + +instance PrettyPrec (TTerm g α) where + prettyPrec :: Int -> TTerm g α -> Doc ann + prettyPrec p = \case + TVar ix -> pretty (idxToNat ix) + TLam t -> + pparens (p > 0) $ + "λ." <+> ppr t + TApp t1 t2 -> + pparens (p > 1) $ + prettyPrec 1 t1 <+> prettyPrec 2 t2 + TConst c -> ppr c + +-- | A term valid in one context is also valid in another extended +-- context with additional variables (which the term does not use). +weaken :: forall h g a. TTerm g a -> TTerm (Append g h) a +weaken (TVar x) = TVar (weakenVar @h x) +weaken (TLam t) = TLam (weaken @h t) +weaken (TApp t1 t2) = TApp (weaken @h t1) (weaken @h t2) +weaken (TConst c) = TConst c + +------------------------------------------------------------ +-- Errors + +-- | Errors that can occur during typechecking/elaboration. +data CheckErr where + ApplyErr :: Some (TTerm g) -> Some (TTerm g) -> CheckErr + NoInstance :: Text -> TTy a -> CheckErr + Unbound :: Text -> CheckErr + BadType :: Some (TTerm g) -> TTy b -> CheckErr + BadDivType :: TTy a -> CheckErr + UnknownImport :: Text -> CheckErr + NotAThing :: Text -> CellTag -> CheckErr + NotAnything :: Text -> CheckErr + +deriving instance Show CheckErr + +instance PrettyPrec CheckErr where + prettyPrec _ = \case + ApplyErr (Some ty1 t1) (Some ty2 t2) -> + nest 2 . vsep $ + [ "Error in application:" + , squotes (ppr t1) <> " has type " <> squotes (ppr ty1) + , "and cannot be applied to" + , squotes (ppr t2) <> " which has type " <> squotes (ppr ty2) + ] + NoInstance cls ty -> squotes (ppr ty) <+> "is not an instance of" <+> pretty cls + Unbound x -> "Undefined variable" <+> pretty x + BadType (Some tty t) ty -> + hsep + [squotes (ppr t), "has type", squotes (ppr tty), "and cannot be given type", squotes (ppr ty)] + BadDivType ty -> "Division operator used at type" <+> squotes (ppr ty) + UnknownImport key -> "Import" <+> squotes (pretty key) <+> "not found" + NotAThing item tag -> squotes (pretty item) <+> "is not" <+> ppr tag + NotAnything item -> "Cannot resolve cell item" <+> squotes (pretty item) + +------------------------------------------------------------ +-- Type representations + +-- | Base types. +data Base :: Type -> Type where + BInt :: Base Integer + BFloat :: Base Double + BBool :: Base Bool + BCell :: Base CellVal + +deriving instance Show (Base ty) + +-- | Testing base type representations for equality to yield reflected +-- type-level equalities. +instance TestEquality Base where + testEquality BInt BInt = Just Refl + testEquality BFloat BFloat = Just Refl + testEquality BBool BBool = Just Refl + testEquality BCell BCell = Just Refl + testEquality _ _ = Nothing + +instance PrettyPrec (Base α) where + prettyPrec _ = \case + BInt -> "int" + BFloat -> "float" + BBool -> "bool" + BCell -> "cell" + +-- | Type representations indexed by the corresponding host language +-- type. +data TTy :: Type -> Type where + TTyBase :: Base t -> TTy t + (:->:) :: TTy a -> TTy b -> TTy (a -> b) + TTyWorld :: TTy t -> TTy (World t) + +infixr 0 :->: + +pattern TTyBool :: TTy Bool +pattern TTyBool = TTyBase BBool + +pattern TTyInt :: TTy Integer +pattern TTyInt = TTyBase BInt + +pattern TTyFloat :: TTy Double +pattern TTyFloat = TTyBase BFloat + +pattern TTyCell :: TTy CellVal +pattern TTyCell = TTyBase BCell + +deriving instance Show (TTy ty) + +-- | Testing type representations for equality to yield reflected +-- type-level equalities. +instance TestEquality TTy where + testEquality (TTyBase b1) (TTyBase b2) = testEquality b1 b2 + testEquality (TTyWorld b1) (TTyWorld b2) = + case testEquality b1 b2 of + Just Refl -> Just Refl + Nothing -> Nothing + testEquality _ _ = Nothing + +instance PrettyPrec (TTy ty) where + prettyPrec :: Int -> TTy ty -> Doc ann + prettyPrec _ (TTyBase b) = ppr b + prettyPrec p (α :->: β) = + pparens (p > 0) $ + prettyPrec 1 α <+> "->" <+> prettyPrec 0 β + prettyPrec p (TTyWorld t) = + pparens (p > 1) $ + "World" <+> prettyPrec 2 t + +------------------------------------------------------------ +-- Instance checking + +-- | Check that a particular type has an 'Eq' instance, and run a +-- computation in a context provided with an 'Eq' constraint. The +-- other @checkX@ functions are similar. +checkEq :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Eq ty, NotFun ty) => m a) -> m a +checkEq (TTyBase BBool) a = a +checkEq (TTyBase BInt) a = a +checkEq (TTyBase BFloat) a = a +checkEq ty _ = throwError $ NoInstance "Eq" ty + +checkOrd :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Ord ty, NotFun ty) => m a) -> m a +checkOrd (TTyBase BBool) a = a +checkOrd (TTyBase BInt) a = a +checkOrd (TTyBase BFloat) a = a +checkOrd ty _ = throwError $ NoInstance "Ord" ty + +checkNum :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Num ty, NotFun ty) => m a) -> m a +checkNum (TTyBase BInt) a = a +checkNum (TTyBase BFloat) a = a +checkNum ty _ = throwError $ NoInstance "Num" ty + +checkIntegral :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Integral ty, NotFun ty) => m a) -> m a +checkIntegral (TTyBase BInt) a = a +checkIntegral ty _ = throwError $ NoInstance "Integral" ty + +checkEmpty :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Empty ty, NotFun ty) => m a) -> m a +checkEmpty (TTyBase BCell) a = a +checkEmpty ty _ = throwError $ NoInstance "Empty" ty + +checkOver :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Over ty, NotFun ty) => m a) -> m a +checkOver (TTyBase BBool) a = a +checkOver (TTyBase BInt) a = a +checkOver (TTyBase BFloat) a = a +checkOver (TTyBase BCell) a = a +checkOver ty _ = throwError $ NoInstance "Over" ty + +------------------------------------------------------------ +-- Existential wrappers + +-- | Wrap up a type-indexed thing to hide the type index, but package +-- it with a 'TTy' which we can pattern-match on to recover the type +-- later. +data Some :: (Type -> Type) -> Type where + Some :: TTy α -> t α -> Some t + +deriving instance (forall α. Show (t α)) => Show (Some t) + +mapSome :: (forall α. s α -> t α) -> Some s -> Some t +mapSome f (Some ty t) = Some ty (f t) + +type SomeTy = Some (F.Const ()) + +pattern SomeTy :: TTy α -> SomeTy +pattern SomeTy α = Some α (F.Const ()) +{-# COMPLETE SomeTy #-} + +------------------------------------------------------------ +-- Type inference/checking + elaboration + +type WorldMap = Map Text (Some (TTerm '[])) + +-- | Type contexts, indexed by a type-level list of types of all the +-- variables in the context. +data Ctx :: [Type] -> Type where + CNil :: Ctx '[] + CCons :: Text -> TTy ty -> Ctx g -> Ctx (ty ': g) + +-- | Look up a variable name in the context, returning a type-indexed +-- de Bruijn index. +lookup :: (Has (Throw CheckErr) sig m) => Text -> Ctx g -> m (Some (Idx g)) +lookup x CNil = throwError $ Unbound x +lookup x (CCons y ty ctx) + | x == y = return $ Some ty VZ + | otherwise = mapSome VS <$> lookup x ctx + +-- | Check that a term has a given type, and if so, return a +-- corresponding elaborated and type-indexed term. Note that this +-- also deals with subtyping: for example, if we check that the term +-- @3@ has type @World Int@, we will get back a suitably lifted +-- value (/i.e./ @const 3@). +check :: + ( Has (Throw CheckErr) sig m + , Has (Reader EntityMap) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + TTy t -> + WExp -> + m (TTerm g t) +check e ty t = do + t1 <- infer e t + Some ty' t' <- apply (Some (ty :->: ty) (embed I)) t1 + case testEquality ty ty' of + Nothing -> throwError $ BadType t1 ty + Just Refl -> return t' + +-- | Get the underlying base type of a term which either has a base +-- type or a World type. +getBaseType :: Some (TTerm g) -> SomeTy +getBaseType (Some (TTyWorld ty) _) = SomeTy ty +getBaseType (Some ty _) = SomeTy ty + +-- | Apply one term to another term, automatically handling promotion +-- and lifting, via the fact that World is Applicative. That is, +-- (1) if a term of type T is used where a term of type World T is +-- expected, it will automatically be promoted (by an application of +-- const); (2) if a function of type (T1 -> T2 -> ... -> Tn) is +-- applied to any arguments of type (World Ti), the function will be +-- lifted to (World T1 -> World T2 -> ... -> World Tn). +apply :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g)) +-- Normal function application +apply (Some (ty11 :->: ty12) t1) (Some ty2 t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ t2) +-- (World T -> ...) applied to T: promote the argument to (World T) with const +apply (Some (TTyWorld ty11 :->: ty12) t1) (Some ty2 t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ (K .$$ t2)) +-- (S -> T) applied to (World S): lift the function to (World S -> World T). +apply (Some (ty11 :->: ty12) t1) (Some (TTyWorld ty2) t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (B .$$ t1 $$ t2) +-- World (S -> T) applied to S. Note this case and the next are +-- needed because in the previous case, when (S -> T) is lifted to +-- (World S -> World T), T may itself be a function type. +apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some ty2 t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ (K .$$ t2)) +-- World (S -> T) applied to (World S) +apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some (TTyWorld ty2) t2) + | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ t2) +apply t1 t2 = throwError $ ApplyErr t1 t2 + +applyTo :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g)) +applyTo = flip apply + +-- | Infer the type of an operator: turn a raw operator into a +-- type-indexed constant. However, some operators are polymorphic, +-- so we also provide a list of type arguments. For example, the +-- type of the negation operator can be either (Int -> Int) or +-- (Float -> Float) so we provide it as an argument. +-- +-- Currently, all operators take at most one type argument, so +-- (Maybe SomeTy) might seem more appropriate than [SomeTy], but +-- that is just a coincidence; in general one can easily imagine +-- operators that are polymorphic in more than one type variable, +-- and we may wish to add such in the future. +inferOp :: (Has (Throw CheckErr) sig m) => [SomeTy] -> Op -> m (Some (TTerm g)) +inferOp _ Not = return $ Some (TTyBool :->: TTyBool) (embed CNot) +inferOp [SomeTy tyA] Neg = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CNeg) +inferOp _ And = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed CAnd) +inferOp _ Or = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed COr) +inferOp [SomeTy tyA] Abs = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CAbs) +inferOp [SomeTy tyA] Add = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CAdd) +inferOp [SomeTy tyA] Sub = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CSub) +inferOp [SomeTy tyA] Mul = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CMul) +inferOp [SomeTy tyA] Div = case tyA of + TTyBase BInt -> return $ Some (tyA :->: tyA :->: tyA) (embed CIDiv) + TTyBase BFloat -> return $ Some (tyA :->: tyA :->: tyA) (embed CDiv) + _ -> throwError $ BadDivType tyA +inferOp [SomeTy tyA] Mod = Some (tyA :->: tyA :->: tyA) <$> checkIntegral tyA (return $ embed CMod) +inferOp [SomeTy tyA] Eq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CEq) +inferOp [SomeTy tyA] Neq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CNeq) +inferOp [SomeTy tyA] Lt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLt) +inferOp [SomeTy tyA] Leq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLeq) +inferOp [SomeTy tyA] Gt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGt) +inferOp [SomeTy tyA] Geq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGeq) +inferOp [SomeTy tyA] If = return $ Some (TTyBool :->: tyA :->: tyA :->: tyA) (embed CIf) +inferOp _ Perlin = return $ Some (TTyInt :->: TTyInt :->: TTyFloat :->: TTyFloat :->: TTyWorld TTyFloat) (embed CPerlin) +inferOp [SomeTy tyA] (Reflect r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CReflect r)) +inferOp [SomeTy tyA] (Rot r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CRot r)) +inferOp [SomeTy tyA] Mask = Some (TTyWorld TTyBool :->: TTyWorld tyA :->: TTyWorld tyA) <$> checkEmpty tyA (return $ embed CMask) +inferOp [SomeTy tyA] Overlay = Some (tyA :->: tyA :->: tyA) <$> checkOver tyA (return $ embed COver) +inferOp tys op = error $ "bad call to inferOp: " ++ show tys ++ " " ++ show op + +-- | Given a raw operator and the terms the operator is applied to, +-- select which types should be supplied as the type arguments to +-- the operator. For example, for an operator like @+@ we can just +-- select the type of its first argument; for an operator like @if@, +-- we must select the type of its second argument, since @if : Bool +-- -> a -> a -> a@. In all cases we must also select the underlying +-- base type in case the argument has a @World@ type. For example +-- if @+@ is applied to an argument of type @World Int@ we still +-- want to give @+@ the type @Int -> Int -> Int@. It can be lifted +-- to have type @World Int -> World Int -> World Int@ but that will +-- be taken care of by application, which will insert the right +-- combinators to do the lifting. +typeArgsFor :: Op -> [Some (TTerm g)] -> [SomeTy] +typeArgsFor op (t : _) + | op `elem` [Neg, Abs, Add, Sub, Mul, Div, Mod, Eq, Neq, Lt, Leq, Gt, Geq] = [getBaseType t] +typeArgsFor (Reflect _) (t : _) = [getBaseType t] +typeArgsFor (Rot _) (t : _) = [getBaseType t] +typeArgsFor op (_ : t : _) + | op `elem` [If, Mask, Overlay] = [getBaseType t] +typeArgsFor _ _ = [] + +-- | Typecheck the application of an operator to some terms, returning +-- a typed, elaborated version of the application. +applyOp :: + ( Has (Throw CheckErr) sig m + , Has (Reader EntityMap) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + Op -> + [WExp] -> + m (Some (TTerm g)) +applyOp ctx op ts = do + tts <- mapM (infer ctx) ts + foldl (\r -> (r >>=) . applyTo) (inferOp (typeArgsFor op tts) op) tts + +-- | Infer the type of a term, and elaborate along the way. +infer :: + forall sig m g. + ( Has (Throw CheckErr) sig m + , Has (Reader EntityMap) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + WExp -> + m (Some (TTerm g)) +infer _ (WInt i) = return $ Some (TTyBase BInt) (embed (CLit i)) +infer _ (WFloat f) = return $ Some (TTyBase BFloat) (embed (CLit f)) +infer _ (WBool b) = return $ Some (TTyBase BBool) (embed (CLit b)) +infer _ (WCell c) = do + c' <- resolveCell c + return $ Some TTyCell (embed (CCell c')) +infer ctx (WVar x) = mapSome TVar <$> lookup x ctx +infer ctx (WOp op ts) = applyOp ctx op ts +infer _ WSeed = return $ Some TTyInt (embed CSeed) +infer _ (WCoord ax) = return $ Some (TTyWorld TTyInt) (embed (CCoord ax)) +infer _ WHash = return $ Some (TTyWorld TTyInt) (embed CHash) +infer ctx (WLet defs body) = inferLet ctx defs body +infer ctx (WOverlay ts) = inferOverlay ctx ts +infer _ctx (WImport key) = do + worldMap <- ask @WorldMap + case M.lookup key worldMap of + Just (Some ty t) -> return (Some ty (weaken @g t)) + Nothing -> throwError $ UnknownImport key + +-- | Try to resolve a 'RawCellVal'---containing only 'Text' names for +-- terrain, entities, and robots---into a real 'CellVal' with +-- references to actual terrain, entities, and robots. +resolveCell :: + (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) => + RawCellVal -> + m CellVal +resolveCell items = do + cellVals <- mapM resolveCellItem items + return $ foldl' () empty cellVals + +-- | Try to resolve one cell item name into an actual item (terrain, +-- entity, robot, etc.). +resolveCellItem :: + forall sig m. + (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) => + (Maybe CellTag, Text) -> + m CellVal +resolveCellItem (mCellTag, item) = case mCellTag of + Just cellTag -> do + -- The item was tagged specifically, like {terrain: dirt} or {entity: water} + mCell <- resolverByTag cellTag item + maybe (throwError $ NotAThing item cellTag) return mCell + Nothing -> do + -- The item was not tagged; try resolving in all possible ways and choose + -- the first that works + maybeCells <- mapM (`resolverByTag` item) [minBound .. maxBound :: CellTag] + case F.asum maybeCells of + Nothing -> throwError $ NotAnything item + Just cell -> return cell + where + mkTerrain t = CellVal t mempty mempty + mkEntity e = CellVal mempty (EJust (Last e)) mempty + resolverByTag :: CellTag -> Text -> m (Maybe CellVal) + resolverByTag = \case + CellTerrain -> return . fmap mkTerrain . readTerrain + CellEntity -> \eName -> + case eName of + "erase" -> return $ Just (CellVal mempty EErase mempty) + _ -> do + em <- ask @EntityMap + return . fmap mkEntity $ lookupEntityName eName em + CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots + +-- | Infer the type of a let expression, and elaborate into a series +-- of lambda applications. +inferLet :: + ( Has (Throw CheckErr) sig m + , Has (Reader EntityMap) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + [(Var, WExp)] -> + WExp -> + m (Some (TTerm g)) +inferLet ctx [] body = infer ctx body +inferLet ctx ((x, e) : xs) body = do + e'@(Some ty1 _) <- infer ctx e + Some ty2 let' <- inferLet (CCons x ty1 ctx) xs body + apply (Some (ty1 :->: ty2) (TLam let')) e' + +-- | Infer the type of an @overlay@ expression, and elaborate into a +-- chain of @<>@ (over) operations. +inferOverlay :: + ( Has (Throw CheckErr) sig m + , Has (Reader EntityMap) sig m + , Has (Reader WorldMap) sig m + ) => + Ctx g -> + NE.NonEmpty WExp -> + m (Some (TTerm g)) +inferOverlay ctx es = case NE.uncons es of + -- @overlay [e] = e@ + (e, Nothing) -> infer ctx e + -- @overlay (e : es') = e <> overlay es'@ + (e, Just es') -> do + e' <- infer ctx e + o' <- inferOverlay ctx es' + case getBaseType e' of + SomeTy ty -> do + let wty = TTyWorld ty + c <- checkOver ty (return $ embed COver) + apply (Some (wty :->: wty :->: wty) (Φ .$$ c)) e' >>= applyTo o' diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs deleted file mode 100644 index 84fbe6904..000000000 --- a/src/Swarm/Game/WorldGen.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Procedural world generation via coherent noise. -module Swarm.Game.WorldGen where - -import Control.Lens (view) -import Data.Array.IArray -import Data.Bifunctor (second) -import Data.Bool -import Data.ByteString (ByteString) -import Data.Enumeration -import Data.Hash.Murmur -import Data.Int (Int32) -import Data.List (find) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set qualified as S -import Data.Tagged -import Data.Text (Text) -import Data.Text qualified as T -import Numeric.Noise.Perlin -import Swarm.Game.Entity -import Swarm.Game.Terrain -import Swarm.Game.World -import Witch -import Witch.Encoding qualified as Encoding - --- | A simple test world used for a while during early development. -testWorld1 :: Coords -> (TerrainType, Maybe Text) -testWorld1 (Coords (-5, 3)) = (StoneT, Just "flerb") -testWorld1 (Coords (2, -1)) = (GrassT, Just "elephant") -testWorld1 (Coords (i, j)) - | noiseValue pn1 (fromIntegral i, fromIntegral j, 0) > 0 = (DirtT, Just "tree") - | noiseValue pn2 (fromIntegral i, fromIntegral j, 0) > 0 = (StoneT, Just "rock") - | otherwise = (GrassT, Nothing) - where - pn1, pn2 :: Perlin - pn1 = perlin 0 5 0.05 0.5 - pn2 = perlin 0 5 0.05 0.75 - -data Size = Small | Big deriving (Eq, Ord, Show, Read) -data Hardness = Soft | Hard deriving (Eq, Ord, Show, Read) -data Origin = Natural | Artificial deriving (Eq, Ord, Show, Read) -type Seed = Int - --- | A list of entities available in the initial world. -testWorld2Entites :: S.Set Text -testWorld2Entites = - S.fromList - [ "mountain" - , "boulder" - , "LaTeX" - , "tree" - , "rock" - , "lodestone" - , "sand" - , "wavy water" - , "water" - , "flower" - , "bit (0)" - , "bit (1)" - , "Linux" - , "lambda" - , "pixel (R)" - , "pixel (G)" - , "pixel (B)" - , "copper ore" - ] - --- | Look up an entity name in an entity map, when we know the entity --- must exist. This is only used for entities which are named in --- 'testWorld2'. -readEntity :: EntityMap -> Text -> Entity -readEntity em name = - fromMaybe - (error $ "Unknown entity name in WorldGen: " <> show name) - (lookupEntityName name em) - --- | The main world of the classic game, for historical reasons named --- 'testWorld2'. If new entities are added, you SHOULD ALSO UPDATE --- 'testWorld2Entities'. -testWorld2 :: EntityMap -> Seed -> WorldFun TerrainType Entity -testWorld2 em baseSeed = second (readEntity em) (WF tw2) - where - tw2 :: Coords -> (TerrainType, Maybe Text) - tw2 (Coords ix@(r, c)) = - genBiome - (bool Small Big (sample ix pn0 > 0)) - (bool Soft Hard (sample ix pn1 > 0)) - (bool Natural Artificial (sample ix pn2 > 0)) - where - h = murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix - - genBiome Big Hard Natural - | sample ix cl0 > 0.5 = (StoneT, Just "mountain") - | h `mod` 30 == 0 = (StoneT, Just "boulder") - | sample ix cl0 > 0 = - case h `mod` 30 of - 1 -> (DirtT, Just "LaTeX") - _ -> (DirtT, Just "tree") - | otherwise = (GrassT, Nothing) - genBiome Small Hard Natural - | h `mod` 100 == 0 = (StoneT, Just "lodestone") - | h `mod` 10 == 0 = (StoneT, Just "rock") - | otherwise = (StoneT, Nothing) - genBiome Big Soft Natural - | abs (sample ix pn1) < 0.1 = (DirtT, Just "sand") - | even (r + c) = (DirtT, Just "wavy water") - | otherwise = (DirtT, Just "water") - genBiome Small Soft Natural - | h `mod` 20 == 0 = (GrassT, Just "flower") - | h `mod` 20 == 10 = (GrassT, Just "cotton") - | otherwise = (GrassT, Nothing) - genBiome Small Soft Artificial - | h `mod` 10 == 0 = (GrassT, Just (T.concat ["bit (", from (show ((r + c) `mod` 2)), ")"])) - | otherwise = (GrassT, Nothing) - genBiome Big Soft Artificial - | h `mod` 5000 == 0 = (DirtT, Just "Linux") - | sample ix cl0 > 0.5 = (GrassT, Nothing) - | otherwise = (DirtT, Nothing) - genBiome Small Hard Artificial - | h `mod` 120 == 1 = (StoneT, Just "lambda") - | h `mod` 50 == 0 = (StoneT, Just (T.concat ["pixel (", from ["RGB" !! fromIntegral ((r + c) `mod` 3)], ")"])) - | otherwise = (StoneT, Nothing) - genBiome Big Hard Artificial - | sample ix cl0 > 0.85 = (StoneT, Just "copper ore") - | otherwise = (StoneT, Nothing) - - sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0) - - pn :: Int -> Perlin - pn seed = perlin (seed + baseSeed) 6 0.05 0.6 - - pn0 = pn 0 - pn1 = pn 1 - pn2 = pn 2 - - -- alternative noise function - -- rg :: Int -> Ridged - -- rg seed = ridged seed 6 0.05 1 2 - - clumps :: Int -> Perlin - clumps seed = perlin (seed + baseSeed) 4 0.08 0.5 - - cl0 = clumps 0 - --- | Create a world function from a finite array of specified cells --- plus a seed to randomly generate the rest. -testWorld2FromArray :: EntityMap -> Array (Int32, Int32) (TerrainType, Maybe Entity) -> Seed -> WorldFun TerrainType Entity -testWorld2FromArray em arr seed = WF $ \co@(Coords (r, c)) -> - if inRange bnds (r, c) - then arr ! (r, c) - else runWF tw2 co - where - tw2 = testWorld2 em seed - bnds = bounds arr - --- | Offset a world by a multiple of the @skip@ in such a way that it --- satisfies the given predicate. -findOffset :: Integer -> ((Coords -> (t, Maybe e)) -> Bool) -> WorldFun t e -> WorldFun t e -findOffset skip isGood (WF f) = WF f' - where - offset :: Enumeration Int32 - offset = fromIntegral . (skip *) <$> int - - f' = - fromMaybe (error "the impossible happened, no offsets were found!") - . find isGood - . map shift - . enumerate - $ offset >< offset - - shift (dr, dc) (Coords (r, c)) = f (Coords (r - dr, c - dc)) - --- | Offset the world so the base starts in a 32x32 patch containing at least one --- of each of a list of required entities. -findPatchWith :: [Text] -> WorldFun t Entity -> WorldFun t Entity -findPatchWith reqs = findOffset 32 isGoodPatch - where - patchCoords = [(r, c) | r <- [-16 .. 16], c <- [-16 .. 16]] - isGoodPatch f = all (`S.member` es) reqs - where - es = S.fromList . map (view entityName) . mapMaybe (snd . f . Coords) $ patchCoords - --- | Offset the world so the base starts on empty spot next to tree and grass. -findTreeOffset :: WorldFun t Entity -> WorldFun t Entity -findTreeOffset = findOffset 1 isGoodPlace - where - isGoodPlace f = - hasEntity Nothing (0, 0) - && any (hasEntity (Just "tree")) neighbors - && all (\c -> hasEntity (Just "tree") c || hasEntity Nothing c) neighbors - where - hasEntity mayE = (== mayE) . fmap (view entityName) . snd . f . Coords - - neighbors = [(r, c) | r <- [-1 .. 1], c <- [-1 .. 1]] - --- | Offset the world so the base starts in a good patch (near --- necessary items), next to a tree. -findGoodOrigin :: WorldFun t Entity -> WorldFun t Entity -findGoodOrigin = findTreeOffset . findPatchWith ["tree", "copper ore", "bit (0)", "bit (1)", "rock", "lambda", "water", "sand"] diff --git a/src/Swarm/Language/Parse.hs b/src/Swarm/Language/Parse.hs index 527657833..e72dc10bd 100644 --- a/src/Swarm/Language/Parse.hs +++ b/src/Swarm/Language/Parse.hs @@ -55,6 +55,7 @@ import Data.Void import Swarm.Language.Syntax import Swarm.Language.Types import Swarm.Util (failT, findDup, squote) +import Swarm.Util.Parse (fully, fullyMaybe) import Text.Megaparsec hiding (runParser) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L @@ -481,7 +482,7 @@ runParser p t = first (from . errorBundlePretty) (parse (runReaderT p DisallowAn -- "Swarm.Language.Parse.QQ"), with a specified source position. runParserTH :: (Monad m, MonadFail m) => (String, Int, Int) -> Parser a -> String -> m a runParserTH (file, line, col) p s = - case snd (runParser' (runReaderT (fully p) AllowAntiquoting) initState) of + case snd (runParser' (runReaderT (fully sc p) AllowAntiquoting) initState) of Left err -> fail $ errorBundlePretty err Right e -> return e where @@ -505,29 +506,18 @@ runParserTH (file, line, col) p s = , stateParseErrors = [] } --- | Run a parser "fully", consuming leading whitespace and ensuring --- that the parser extends all the way to eof. -fully :: Parser a -> Parser a -fully p = sc *> p <* eof - --- | Run a parser "fully", consuming leading whitespace (including the --- possibility that the input is nothing but whitespace) and --- ensuring that the parser extends all the way to eof. -fullyMaybe :: Parser a -> Parser (Maybe a) -fullyMaybe = fully . optional - -- | Parse some input 'Text' completely as a 'Term', consuming leading -- whitespace and ensuring the parsing extends all the way to the -- end of the input 'Text'. Returns either the resulting 'Term' (or -- @Nothing@ if the input was only whitespace) or a pretty-printed -- parse error message. readTerm :: Text -> Either Text (Maybe Syntax) -readTerm = runParser (fullyMaybe parseTerm) +readTerm = runParser (fullyMaybe sc parseTerm) -- | A lower-level `readTerm` which returns the megaparsec bundle error -- for precise error reporting. readTerm' :: Text -> Either ParserError (Maybe Syntax) -readTerm' = parse (runReaderT (fullyMaybe parseTerm) DisallowAntiquoting) "" +readTerm' = parse (runReaderT (fullyMaybe sc parseTerm) DisallowAntiquoting) "" -- | A utility for converting a ParserError into a one line message: -- : diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index 712497962..7a00bb666 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -25,6 +25,7 @@ import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Model import Swarm.TUI.Model.Name import Swarm.TUI.Model.UI +import Swarm.Util.Erasable (maybeToErasable) import System.Clock ------------------------------------------------------------ @@ -57,7 +58,7 @@ handleCtrlLeftClick mouseLoc = do -- TODO (#1151): Use hoistMaybe when available terrain <- MaybeT . pure $ maybeTerrainType mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiWorldEditor . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeEntityPaint) + uiState . uiWorldEditor . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeToErasable maybeEntityPaint) uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing immediatelyRedrawWorld return () @@ -121,7 +122,10 @@ updateAreaBounds = \case -- TODO (#1152): Validate that the lower-right click is below and to the right of -- the top-left coord and that they are within the same subworld LowerRightPending upperLeftMouseCoords -> do - uiState . uiWorldEditor . editingBounds . boundsRect + uiState + . uiWorldEditor + . editingBounds + . boundsRect .= Just (fmap (,view planar mouseCoords) upperLeftMouseCoords) uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs index 122fe0bbc..9eddaeac7 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ b/src/Swarm/TUI/Editor/Palette.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -26,11 +27,12 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Terrain (TerrainType (BlankT), getTerrainDefaultPaletteChar) +import Swarm.Game.Terrain (TerrainType, getTerrainDefaultPaletteChar) import Swarm.Game.Universe import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) import Swarm.Util (binTuples, histogram) import Swarm.Util qualified as U +import Swarm.Util.Erasable makeSuggestedPalette :: Maybe Scenario -> [[CellPaintDisplay]] -> KM.KeyMap (AugmentedCell EntityFacade) makeSuggestedPalette maybeOriginalScenario cellGrid = @@ -41,11 +43,13 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = -- NOTE: the left-most maps take precedence! $ paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette where - getMaybeEntityDisplay (Cell _terrain maybeEntity _) = do + getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display) + getMaybeEntityDisplay (Cell _terrain (erasableToMaybe -> maybeEntity) _) = do EntityFacade eName d <- maybeEntity return (eName, d) - getMaybeEntityNameTerrainPair (Cell terrain maybeEntity _) = do + getMaybeEntityNameTerrainPair :: PCell EntityFacade -> Maybe (EntityName, TerrainType) + getMaybeEntityNameTerrainPair (Cell terrain (erasableToMaybe -> maybeEntity) _) = do EntityFacade eName _ <- maybeEntity return (eName, terrain) @@ -96,15 +100,15 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = eDisplay <- M.lookup eName usedEntityDisplays let displayChar = eDisplay ^. defaultChar guard $ Set.notMember displayChar excludedPaletteChars - let cell = Cell terrain (Just $ EntityFacade eName eDisplay) [] - return ((terrain, Just eName), (T.singleton displayChar, cell)) + let cell = Cell terrain (EJust $ EntityFacade eName eDisplay) [] + return ((terrain, EJust eName), (T.singleton displayChar, cell)) -- TODO (#1153): Filter out terrain-only palette entries that aren't actually -- used in the map. terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) terrainOnlyPalette = M.fromList $ map f U.listEnums where - f x = ((x, Nothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x Nothing [])) + f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) -- | Generate a \"skeleton\" scenario with placeholders for certain required fields constructScenario :: Maybe Scenario -> [[CellPaintDisplay]] -> SkeletonScenario @@ -122,14 +126,14 @@ constructScenario maybeOriginalScenario cellGrid = customEntities = maybe mempty (^. scenarioEntities) maybeOriginalScenario wd = WorldDescription - { defaultTerrain = Just $ Cell BlankT Nothing [] - , offsetOrigin = False + { offsetOrigin = False , scrollable = True , palette = WorldPalette suggestedPalette , ul = upperLeftCoord , area = cellGrid , navigation = Navigation mempty mempty , worldName = DefaultRootSubworld + , worldProg = Nothing } suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs index 1fcbd2235..f422ea78d 100644 --- a/src/Swarm/TUI/Editor/Util.hs +++ b/src/Swarm/TUI/Editor/Util.hs @@ -18,6 +18,7 @@ import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Editor.Model import Swarm.TUI.Model +import Swarm.Util.Erasable getEntitiesForList :: EntityMap -> V.Vector EntityFacade getEntitiesForList em = @@ -46,9 +47,10 @@ getContentAt editor w coords = (terrainOverride, _) <- maybePaintedCell return terrainOverride + maybeEntityOverride :: Maybe EntityPaint maybeEntityOverride = do (_, e) <- maybePaintedCell - Facade <$> e + Facade <$> erasableToMaybe e maybePaintedCell = do guard $ editor ^. isWorldEditorEnabled @@ -112,9 +114,9 @@ getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w = drawCell rowIndex colIndex = Cell terrain - (toFacade <$> maybeEntity) + (toFacade <$> maybeToErasable erasableEntity) [] where - (terrain, maybeEntity) = getContent $ W.Coords (rowIndex, colIndex) + (terrain, erasableEntity) = getContent $ W.Coords (rowIndex, colIndex) renderRow rowIndex = map (drawCell rowIndex) [xLeft .. xRight] diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs index 389cde82b..e2d430350 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -84,6 +84,7 @@ module Swarm.TUI.Model ( webPort, upstreamRelease, eventLog, + worlds, scenarios, stdEntityMap, stdRecipes, @@ -147,6 +148,8 @@ import Swarm.Game.Robot import Swarm.Game.Scenario.Status import Swarm.Game.ScenarioInfo (ScenarioCollection, loadScenarios, _SISingle) import Swarm.Game.State +import Swarm.Game.World.Load (loadWorlds) +import Swarm.Game.World.Typecheck (WorldMap) import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name @@ -191,6 +194,7 @@ data RuntimeState = RuntimeState { _webPort :: Maybe Port , _upstreamRelease :: Either NewReleaseFailure String , _eventLog :: Notifications LogEntry + , _worlds :: WorldMap , _scenarios :: ScenarioCollection , _stdEntityMap :: EntityMap , _stdRecipes :: [Recipe Entity] @@ -208,7 +212,8 @@ initRuntimeState :: initRuntimeState = do entities <- loadEntities recipes <- loadRecipes entities - scenarios <- loadScenarios entities + worlds <- loadWorlds entities + scenarios <- loadScenarios entities worlds appDataMap <- readAppData let getDataLines f = case M.lookup f appDataMap of @@ -224,6 +229,7 @@ initRuntimeState = do { _webPort = Nothing , _upstreamRelease = Left (NoMainUpstreamRelease []) , _eventLog = mempty + , _worlds = worlds , _scenarios = scenarios , _stdEntityMap = entities , _stdRecipes = recipes @@ -247,6 +253,10 @@ upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String) -- place to log it. eventLog :: Lens' RuntimeState (Notifications LogEntry) +-- | A collection of typechecked world DSL terms that are available to +-- be used in scenario definitions. +worlds :: Lens' RuntimeState WorldMap + -- | The collection of scenarios that comes with the game. scenarios :: Lens' RuntimeState ScenarioCollection @@ -290,6 +300,7 @@ mkGameStateConfig rs = , initNameList = rs ^. stdNameList , initEntities = rs ^. stdEntityMap , initRecipes = rs ^. stdRecipes + , initWorldMap = rs ^. worlds } -- ---------------------------------------------------------------------------- diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index 95e304de0..6caa9eedb 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -123,7 +123,7 @@ constructAppState rs ui opts@(AppOpts {..}) = do case skipMenu opts of False -> return $ AppState gs (ui & lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs True -> do - (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap) + (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap) (rs ^. worlds) maybeRunScript <- traverse parseCodeFile scriptToRun let maybeAutoplay = do diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index 61e6f69c5..4cea40cfb 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -23,10 +23,12 @@ module Swarm.Util ( both, allEqual, surfaceEmpty, + applyWhen, -- * Directory utilities readFileMay, readFileMayT, + acquireAllWithExt, -- * Text utilities isIdentChar, @@ -74,8 +76,8 @@ module Swarm.Util ( import Control.Applicative (Alternative) import Control.Carrier.Throw.Either import Control.Effect.State (State, modify, state) -import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<>~)) -import Control.Monad (guard, unless) +import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<&>), (<>~)) +import Control.Monad (filterM, guard, unless) import Data.Bifunctor (Bifunctor (bimap), first) import Data.Char (isAlphaNum, toLower) import Data.Either.Validation @@ -98,6 +100,8 @@ import Language.Haskell.TH.Syntax (lift) import NLP.Minimorph.English qualified as MM import NLP.Minimorph.Util ((<+>)) import System.Clock (TimeSpec) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (takeExtension, ()) import System.IO.Error (catchIOError) import Witch (from) @@ -196,6 +200,12 @@ allEqual (x : xs) = all (== x) xs surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a surfaceEmpty isEmpty t = t <$ guard (not (isEmpty t)) +-- Note, once we upgrade to an LTS version that includes +-- base-compat-0.13, we should switch to using 'applyWhen' from there. +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f x = f x +applyWhen False _ x = x + ------------------------------------------------------------ -- Directory stuff @@ -207,6 +217,20 @@ readFileMay = catchIO . readFile readFileMayT :: FilePath -> IO (Maybe Text) readFileMayT = catchIO . T.readFile +-- | Recursively acquire all files in the given directory with the +-- given extension, and their contents. +acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)] +acquireAllWithExt dir ext = do + paths <- listDirectory dir <&> map (dir ) + filePaths <- filterM (\path -> doesFileExist path <&> (&&) (hasExt path)) paths + children <- mapM (\path -> (,) path <$> readFile path) filePaths + -- recurse + sub <- filterM doesDirectoryExist paths + transChildren <- concat <$> mapM (`acquireAllWithExt` ext) sub + return $ children <> transChildren + where + hasExt path = takeExtension path == ("." ++ ext) + -- | Turns any IO error into Nothing. catchIO :: IO a -> IO (Maybe a) catchIO act = (Just <$> act) `catchIOError` (\_ -> return Nothing) diff --git a/src/Swarm/Util/Effect.hs b/src/Swarm/Util/Effect.hs index 6d7ef7339..5ba51ceb2 100644 --- a/src/Swarm/Util/Effect.hs +++ b/src/Swarm/Util/Effect.hs @@ -4,9 +4,9 @@ -- fused-effect utilities for Swarm. module Swarm.Util.Effect where +import Control.Carrier.Accum.FixedStrict import Control.Carrier.Error.Either (ErrorC (..)) import Control.Carrier.Throw.Either (ThrowC (..), runThrow) -import Control.Effect.Accum import Control.Effect.Throw import Control.Monad ((<=<), (>=>)) import Control.Monad.Trans.Except (ExceptT) @@ -27,6 +27,20 @@ withThrow f = runThrow >=> either (throwError . f) return throwToMaybe :: forall e m a. Functor m => ThrowC e m a -> m (Maybe a) throwToMaybe = fmap eitherToMaybe . runThrow +-- | Transform a @Throw e@ constrint into a concrete @Maybe@, +-- logging any error as a warning. +throwToWarning :: (Has (Accum (Seq e)) sig m) => ThrowC e m a -> m (Maybe a) +throwToWarning m = do + res <- runThrow m + case res of + Left err -> warn err >> return Nothing + Right a -> return (Just a) + +-- | Run a computation with an @Accum@ effect (typically accumulating +-- a list of warnings), ignoring the accumulated value. +ignoreWarnings :: forall e m a. (Monoid e, Functor m) => AccumC e m a -> m a +ignoreWarnings = evalAccum mempty + -- | Convert a fused-effects style computation using a @Throw e@ -- constraint into an @ExceptT@ computation. This is mostly a stub -- to convert from one style to the other while we are in the middle diff --git a/src/Swarm/Util/Erasable.hs b/src/Swarm/Util/Erasable.hs new file mode 100644 index 000000000..f9781b2c6 --- /dev/null +++ b/src/Swarm/Util/Erasable.hs @@ -0,0 +1,46 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Custom extension of 'Semigroup' to 'Monoid' that adds identity + +-- annihilator elements. +module Swarm.Util.Erasable where + +-- | Extend a semigroup to a monoid by adding an identity ('ENothing') /and/ an +-- annihilator ('EErase'). That is, +-- +-- * @ENothing <> e = e <> ENothing = e@ +-- * @EErase <> e = e <> EErase = EErase@ +-- +-- This allows us to "erase" previous values by combining with +-- 'EErase'. The 'erasableToMaybe' function turns an 'Erasable' +-- into a 'Maybe' by collapsing 'ENothing' and 'EErase' both back +-- into 'Nothing'. +data Erasable e = ENothing | EErase | EJust e + deriving (Show, Eq, Ord, Functor) + +instance Semigroup e => Semigroup (Erasable e) where + ENothing <> e = e + e <> ENothing = e + EErase <> _ = EErase + _ <> EErase = EErase + EJust e1 <> EJust e2 = EJust (e1 <> e2) + +instance Semigroup e => Monoid (Erasable e) where + mempty = ENothing + +-- | Generic eliminator for 'Erasable' values. +erasable :: a -> a -> (e -> a) -> Erasable e -> a +erasable x y z = \case + ENothing -> x + EErase -> y + EJust e -> z e + +-- | Convert an 'Erasable' value to 'Maybe', turning both 'ENothing' +-- and 'EErase' into 'Nothing'. +erasableToMaybe :: Erasable e -> Maybe e +erasableToMaybe = erasable Nothing Nothing Just + +-- | Inject a 'Maybe' value into 'Erasable' using 'ENothing' and +-- 'EJust'. +maybeToErasable :: Maybe e -> Erasable e +maybeToErasable = maybe ENothing EJust diff --git a/src/Swarm/Util/Parse.hs b/src/Swarm/Util/Parse.hs new file mode 100644 index 000000000..6c573e6b6 --- /dev/null +++ b/src/Swarm/Util/Parse.hs @@ -0,0 +1,19 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parsing utilities for Swarm. +module Swarm.Util.Parse where + +import Control.Applicative (optional) +import Text.Megaparsec (MonadParsec, eof) + +-- | Run a parser "fully", consuming leading whitespace and ensuring +-- that the parser extends all the way to eof. +fully :: (MonadParsec e s f) => f () -> f a -> f a +fully sc p = sc *> p <* eof + +-- | Run a parser "fully", consuming leading whitespace (including the +-- possibility that the input is nothing but whitespace) and +-- ensuring that the parser extends all the way to eof. +fullyMaybe :: (MonadParsec e s f) => f () -> f a -> f (Maybe a) +fullyMaybe sc = fully sc . optional diff --git a/swarm.cabal b/swarm.cabal index ee4090c89..be11963b9 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -24,7 +24,7 @@ extra-source-files: CHANGELOG.md editors/emacs/*.el editors/vscode/syntaxes/*.json data-dir: data/ -data-files: *.yaml, scenarios/**/*.yaml, scenarios/**/*.txt, scenarios/**/*.sw, *.txt, test/language-snippets/**/*.sw +data-files: *.yaml, worlds/*.world, scenarios/**/*.yaml, scenarios/**/*.txt, scenarios/**/*.sw, *.txt, test/language-snippets/**/*.sw source-repository head type: git @@ -133,7 +133,16 @@ library Swarm.Game.Terrain Swarm.Game.Value Swarm.Game.World - Swarm.Game.WorldGen + Swarm.Game.World.Abstract + Swarm.Game.World.Compile + Swarm.Game.World.Coords + Swarm.Game.World.Eval + Swarm.Game.World.Gen + Swarm.Game.World.Interpret + Swarm.Game.World.Load + Swarm.Game.World.Parse + Swarm.Game.World.Syntax + Swarm.Game.World.Typecheck Swarm.Language.Capability Swarm.Language.Context Swarm.Language.Direction @@ -187,7 +196,9 @@ library Swarm.TUI.View.Util Swarm.Util Swarm.Util.Effect + Swarm.Util.Erasable Swarm.Util.Lens + Swarm.Util.Parse Swarm.Util.Yaml Swarm.Version Swarm.Web diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 93fd44f85..b27053d55 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -11,8 +11,8 @@ module Main where import Control.Carrier.Lift (runM) import Control.Carrier.Throw.Either (runThrow) -import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (<>~), (^.), (^..), (^?!)) -import Control.Monad (filterM, forM_, unless, when) +import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<>~), (^.), (^..), (^?!)) +import Control.Monad (forM_, unless, when) import Control.Monad.State (StateT (runStateT), gets) import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) @@ -47,17 +47,16 @@ import Swarm.Game.State ( winSolution, ) import Swarm.Game.Step (gameTick) +import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) import Swarm.Language.Pretty (prettyString) -import Swarm.TUI.Model (RuntimeState, defaultAppOpts, gameState, stdEntityMap, userScenario) +import Swarm.TUI.Model (RuntimeState, defaultAppOpts, gameState, stdEntityMap, userScenario, worlds) import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState) import Swarm.TUI.Model.UI (UIState) +import Swarm.Util (acquireAllWithExt) import Swarm.Util.Yaml (decodeFileEitherE) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.Environment (getEnvironment) -import System.FilePath (splitDirectories) -import System.FilePath.Posix (takeExtension, ()) +import System.FilePath.Posix (splitDirectories) import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase) @@ -68,11 +67,10 @@ isUnparseableTest (fp, _) = "_Validation" `elem` splitDirectories fp main :: IO () main = do - examplePaths <- acquire "example" "sw" - scenarioPaths <- acquire "data/scenarios" "yaml" + examplePaths <- acquireAllWithExt "example" "sw" + scenarioPaths <- acquireAllWithExt "data/scenarios" "yaml" let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths - scenarioPrograms <- acquire "data/scenarios" "sw" - ci <- any (("CI" ==) . fst) <$> getEnvironment + scenarioPrograms <- acquireAllWithExt "data/scenarios" "sw" (rs, ui) <- do out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts either (assertFailure . prettyString) return out @@ -82,9 +80,9 @@ main = do "Tests" [ exampleTests examplePaths , exampleTests scenarioPrograms - , scenarioParseTests em parseableScenarios - , scenarioParseInvalidTests em unparseableScenarios - , testScenarioSolution rs ui ci em + , scenarioParseTests em (rs ^. worlds) parseableScenarios + , scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios + , testScenarioSolutions rs ui , testEditorFiles ] @@ -98,27 +96,27 @@ exampleTest (path, fileContent) = where value = processTerm $ into @Text fileContent -scenarioParseTests :: EntityMap -> [(FilePath, String)] -> TestTree -scenarioParseTests em inputs = +scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree +scenarioParseTests em worldMap inputs = testGroup "Test scenarios parse" - (map (scenarioTest Parsed em) inputs) + (map (scenarioTest Parsed em worldMap) inputs) -scenarioParseInvalidTests :: EntityMap -> [(FilePath, String)] -> TestTree -scenarioParseInvalidTests em inputs = +scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree +scenarioParseInvalidTests em worldMap inputs = testGroup "Test invalid scenarios fail to parse" - (map (scenarioTest Failed em) inputs) + (map (scenarioTest Failed em worldMap) inputs) data ParseResult = Parsed | Failed -scenarioTest :: ParseResult -> EntityMap -> (FilePath, String) -> TestTree -scenarioTest expRes em (path, _) = - testCase ("parse scenario " ++ show path) (getScenario expRes em path) +scenarioTest :: ParseResult -> EntityMap -> WorldMap -> (FilePath, String) -> TestTree +scenarioTest expRes em worldMap (path, _) = + testCase ("parse scenario " ++ show path) (getScenario expRes em worldMap path) -getScenario :: ParseResult -> EntityMap -> FilePath -> IO () -getScenario expRes em p = do - res <- decodeFileEitherE em p :: IO (Either ParseException Scenario) +getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO () +getScenario expRes em worldMap p = do + res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of Left err -> assertFailure (prettyPrintParseException err) @@ -127,18 +125,6 @@ getScenario expRes em p = do Left _err -> return () Right _s -> assertFailure "Unexpectedly parsed invalid scenario!" -acquire :: FilePath -> String -> IO [(FilePath, String)] -acquire dir ext = do - paths <- listDirectory dir <&> map (dir ) - filePaths <- filterM (\path -> doesFileExist path <&> (&&) (hasExt path)) paths - children <- mapM (\path -> (,) path <$> readFile path) filePaths - -- recurse - sub <- filterM doesDirectoryExist paths - transChildren <- concat <$> mapM (`acquire` ext) sub - return $ children <> transChildren - where - hasExt path = takeExtension path == ("." ++ ext) - data Time = -- | One second should be enough to run most programs. Default @@ -158,8 +144,8 @@ time = \case data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) -testScenarioSolution :: RuntimeState -> UIState -> Bool -> EntityMap -> TestTree -testScenarioSolution rs ui _ci _em = +testScenarioSolutions :: RuntimeState -> UIState -> TestTree +testScenarioSolutions rs ui = testGroup "Test scenario solutions" [ testGroup @@ -306,6 +292,17 @@ testScenarioSolution rs ui _ci _em = , testSolution Default "Testing/144-subworlds/subworld-located-robots" , testSolution Default "Testing/1379-single-world-portal-reorientation" , testSolution Default "Testing/1399-backup-command" + , testGroup + -- Note that the description of the classic world in + -- data/worlds/classic.yaml (automatically tested to some + -- extent by the solution to Tutorial/world101 and + -- Tutorial/farming) also constitutes a fairly + -- comprehensive test of world DSL features. + "World DSL (#1320)" + [ testSolution Default "Testing/1320-world-DSL/constant" + , testSolution Default "Testing/1320-world-DSL/erase" + , testSolution Default "Testing/1320-world-DSL/override" + ] ] ] where