From f9c22635b5160c0610683d55b387f7157f6ee8f5 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 22 Jul 2023 13:29:22 -0700 Subject: [PATCH] subworlds (#1353) Closes #144. This builds upon portals support (#1356) # Demo scripts/play.sh --scenario data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml --autoplay --speed 2 [![asciicast](https://asciinema.org/a/vC13dW8M1S8t2b1J4XkW80U1q.svg)](https://asciinema.org/a/vC13dW8M1S8t2b1J4XkW80U1q) # Future work * Augment portal definitions with an optional "relative orientation" attribute, that can turn the player around when passing through the portal (#1379) * Specify whether portal performs instant transportation or whether `move down` is required (#1368) --- bench/Benchmark.hs | 8 +- data/scenarios/Testing/00-ORDER.txt | 1 + .../Testing/144-subworlds/00-ORDER.txt | 5 + .../144-subworlds/_basic-subworld/solution.sw | 7 + .../_subworld-located-robots/solution.sw | 10 + .../_subworld-mapped-robots/judges.sw | 52 ++++ .../_subworld-mapped-robots/solution.sw | 8 + .../Testing/144-subworlds/basic-subworld.yaml | 108 +++++++ .../spatial-consistency-enforcement.yaml | 93 ++++++ .../subworld-located-robots.yaml | 116 ++++++++ .../144-subworlds/subworld-mapped-robots.yaml | 116 ++++++++ .../subworld-shared-structures.yaml | 193 ++++++++++++ .../144-spatial-consistency-enforcement.yaml | 93 ++++++ ...bworld-uniqueness-enforcement-default.yaml | 87 ++++++ ...subworld-uniqueness-enforcement-named.yaml | 89 ++++++ scripts/enforce-todo-issues.sh | 2 +- src/Swarm/Doc/Gen.hs | 9 +- src/Swarm/Game/Log.hs | 7 +- src/Swarm/Game/Robot.hs | 13 +- src/Swarm/Game/Scenario.hs | 58 +++- src/Swarm/Game/Scenario/RobotLookup.hs | 16 +- src/Swarm/Game/Scenario/Topography/Cell.hs | 2 +- .../Scenario/Topography/Navigation/Portal.hs | 278 ++++++++++++++---- .../Game/Scenario/Topography/Structure.hs | 15 +- .../Scenario/Topography/WorldDescription.hs | 42 ++- src/Swarm/Game/State.hs | 197 +++++++++---- src/Swarm/Game/Step.hs | 182 +++++++----- src/Swarm/Game/Universe.hs | 63 ++++ src/Swarm/Game/World.hs | 49 ++- src/Swarm/Language/Syntax.hs | 3 +- src/Swarm/TUI/Controller.hs | 3 +- src/Swarm/TUI/Controller/Util.hs | 11 +- src/Swarm/TUI/Editor/Controller.hs | 18 +- src/Swarm/TUI/Editor/Masking.hs | 5 +- src/Swarm/TUI/Editor/Model.hs | 7 +- src/Swarm/TUI/Editor/Palette.hs | 4 +- src/Swarm/TUI/Editor/Util.hs | 30 +- src/Swarm/TUI/Editor/View.hs | 3 +- src/Swarm/TUI/Model.hs | 6 +- src/Swarm/TUI/Model/Name.hs | 2 + src/Swarm/TUI/Model/StateUpdate.hs | 6 +- src/Swarm/TUI/Model/UI.hs | 5 +- src/Swarm/TUI/View.hs | 53 ++-- src/Swarm/TUI/View/CellDisplay.hs | 41 ++- src/Swarm/Util.hs | 12 +- src/Swarm/Version.hs | 4 +- swarm.cabal | 4 +- test/integration/Main.hs | 3 + 48 files changed, 1824 insertions(+), 315 deletions(-) create mode 100644 data/scenarios/Testing/144-subworlds/00-ORDER.txt create mode 100644 data/scenarios/Testing/144-subworlds/_basic-subworld/solution.sw create mode 100644 data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw create mode 100644 data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw create mode 100644 data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw create mode 100644 data/scenarios/Testing/144-subworlds/basic-subworld.yaml create mode 100644 data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml create mode 100644 data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml create mode 100644 data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml create mode 100644 data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml create mode 100644 data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml create mode 100644 data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml create mode 100644 data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml create mode 100644 src/Swarm/Game/Universe.hs diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index 4a7b20f17..1228d3166 100644 --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -11,13 +11,15 @@ import Control.Monad.Except (runExceptT) import Control.Monad.State (evalStateT, execStateT) import Criterion.Main (Benchmark, bench, bgroup, defaultConfig, defaultMainWith, whnfAppIO) import Criterion.Types (Config (timeLimit)) +import Data.Map qualified as M import Swarm.Game.CESK (emptyStore, initMachine) import Swarm.Game.Display (defaultRobotDisplay) import Swarm.Game.Location import Swarm.Game.Robot (TRobot, mkRobot) -import Swarm.Game.State (GameState, addTRobot, creativeMode, world) +import Swarm.Game.State (GameState, addTRobot, creativeMode, multiWorld) import Swarm.Game.Step (gameTick) import Swarm.Game.Terrain (TerrainType (DirtT)) +import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld)) import Swarm.Game.World (WorldFun (..), newWorld) import Swarm.Language.Context qualified as Context import Swarm.Language.Pipeline (ProcessedTerm) @@ -73,7 +75,7 @@ circlerProgram = -- | Initializes a robot with program prog at location loc facing north. initRobot :: ProcessedTerm -> Location -> TRobot -initRobot prog loc = mkRobot () Nothing "" [] (Just loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False 0 +initRobot prog loc = mkRobot () Nothing "" [] (Just $ Cosmic DefaultRootSubworld loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False 0 -- | Creates a GameState with numRobot copies of robot on a blank map, aligned -- in a row starting at (0,0) and spreading east. @@ -85,7 +87,7 @@ mkGameState robotMaker numRobots = do (mapM addTRobot robots) ( (initAppState ^. gameState) & creativeMode .~ True - & world .~ newWorld (WF $ const (fromEnum DirtT, Nothing)) + & multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, Nothing))) ) -- | Runs numGameTicks ticks of the game. diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 479496793..4f33ad100 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -38,3 +38,4 @@ 1295-density-command.yaml 1138-structures 1356-portals +144-subworlds diff --git a/data/scenarios/Testing/144-subworlds/00-ORDER.txt b/data/scenarios/Testing/144-subworlds/00-ORDER.txt new file mode 100644 index 000000000..59d8c8657 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/00-ORDER.txt @@ -0,0 +1,5 @@ +basic-subworld.yaml +subworld-shared-structures.yaml +subworld-mapped-robots.yaml +subworld-located-robots.yaml +spatial-consistency-enforcement.yaml diff --git a/data/scenarios/Testing/144-subworlds/_basic-subworld/solution.sw b/data/scenarios/Testing/144-subworlds/_basic-subworld/solution.sw new file mode 100644 index 000000000..978deb101 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/_basic-subworld/solution.sw @@ -0,0 +1,7 @@ + +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +doN 8 move; +f <- grab; +doN 7 move; +place f; diff --git a/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw b/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw new file mode 100644 index 000000000..8b012b9fb --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw @@ -0,0 +1,10 @@ + +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +doN 3 move; +f <- grab; + +doN 5 move; +r <- meet; +case r return $ \j. give j f; + diff --git a/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw new file mode 100644 index 000000000..8ca85ea5f --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw @@ -0,0 +1,52 @@ + +def getRobotNumber = \n. + r <- robotnumbered n; + if (r == self) { + return n; + } {getRobotNumber $ n + 1}; + end; + +def amLowestRecursive = \targetName. \idx. + r <- robotnumbered idx; + thisName <- as r {whoami}; + if (thisName == targetName) { + return $ r == self; + } {amLowestRecursive targetName $ idx + 1}; + end; + +/** +Iterates through robots by increasing index. +If we encounter a robot, fetched by index, +with the same name as me, but I am not that robot, +then we return false. +*/ +def amFirstOfMyName = + myName <- whoami; + amLowestRecursive myName 0; + end; + +def waitToGiveThing = \thing. + r <- meet; + case r (\_. wait 1; waitToGiveThing thing) $ \b. give b thing; + end; + +def waitToGive = + let thing = "bitcoin" in + create thing; + waitToGiveThing thing; + end; + +def waitToReceive = + noop; + end; + +def go = + myNumber <- getRobotNumber 0; + log $ "My number: " ++ format myNumber; + amFirst <- amFirstOfMyName; + log $ "Am first with this name? " ++ format amFirst; + + if amFirst {waitToReceive} {waitToGive}; + end; + +go; \ No newline at end of file diff --git a/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw new file mode 100644 index 000000000..b43d0fd76 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw @@ -0,0 +1,8 @@ + +def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + +doN 16 move; + +r <- meet; +case r return $ \j. give j "bitcoin"; + diff --git a/data/scenarios/Testing/144-subworlds/basic-subworld.yaml b/data/scenarios/Testing/144-subworlds/basic-subworld.yaml new file mode 100644 index 000000000..aa6c9c4e0 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/basic-subworld.yaml @@ -0,0 +1,108 @@ +version: 1 +name: Subworlds demo +description: | + Surface and underground with portals. +objectives: + - goal: + - | + `place` the "flower" on the white cell. + condition: | + j <- robotnamed "judge"; + as j {ishere "flower"} +solution: | + run "scenarios/Testing/144-subworlds/_basic-subworld/solution.sw" +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: [1, 0] + system: true + display: + char: 'J' + invisible: true +known: [flower, boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + upperleft: [-1, 1] + map: | + b..b..b..b + .p..f...P. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 't': [ice, null, judge] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + map: | + .......... + .p.Bt...P. + .......... diff --git a/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml b/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml new file mode 100644 index 000000000..e1ad3e3fa --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml @@ -0,0 +1,93 @@ +version: 1 +name: Subworld spatial consistency enforcement +description: | + Portals annotated to enforce spatial consistency between subworlds +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads +known: [boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + consistent: true + upperleft: [-1, 1] + map: | + b..b..b..b + .P......p. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + consistent: true + map: | + .......... + .p.B....P. + .......... diff --git a/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml b/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml new file mode 100644 index 000000000..2d1b83146 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml @@ -0,0 +1,116 @@ +version: 1 +name: Subworld robots (explicit location) +description: | + Demonstrate that system robots can be placed in any subworld. +objectives: + - goal: + - | + `give` the "flower" to the robot underground. + condition: | + j <- robotnamed "judge"; + as j {has "flower"} +solution: | + run "scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw" +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + loc: + subworld: root + loc: [2, 0] + devices: + - ADT calculator + - antenna + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: [1, 0] + loc: + subworld: underground + loc: [4, 0] + system: true + display: + char: 'J' + invisible: false +known: [flower, boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'b': [dirt, boulder] + 't': [grass, null, judge] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + upperleft: [-1, 1] + map: | + b..b..b..b + .p......P. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'f': [grass, flower] + 'B': [grass, null, base] + 't': [grass, null, judge] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + map: | + .......... + .p....f.P. + .......... diff --git a/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml b/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml new file mode 100644 index 000000000..5d2615806 --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml @@ -0,0 +1,116 @@ +version: 1 +name: Subworld robots (map placement) +description: | + Demonstrate that system robots can be placed in any subworld. + + Also demonstrates tiebreaking logic for robot numbering based + on subworld. +objectives: + - goal: + - | + `give` the "bitcoin" to the robot in the "root" world. + - | + First obtain it from the robot living underground. + condition: | + j <- robotnumbered 1; + as j {has "bitcoin"} +solution: | + run "scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw" +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - antenna + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: [1, 0] + system: true + display: + char: 'J' + invisible: false + program: | + run "scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw"; +known: [boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'b': [dirt, boulder] + 't': [grass, null, judge] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + upperleft: [-1, 1] + map: | + b..b..b..b + .p.t....P. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 't': [grass, null, judge] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + map: | + .......... + .p.B..t.P. + .......... diff --git a/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml b/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml new file mode 100644 index 000000000..5e6759b7b --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml @@ -0,0 +1,193 @@ +version: 1 +name: Subworld shared structures +description: | + Traverse floors of the tower +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + loc: [0, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads +known: [flower] +structures: + - name: minibox + structure: + palette: + '.': [stone] + 'd': [dirt] + 'f': [stone, flower] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in + map: | + p.... + .ddd. + .d.d. + .ddd. + ....P + - name: flowers + structure: + mask: '.' + palette: + 'f': [stone, flower] + map: | + f.f + .f. + f.f +subworlds: + - name: floor1 + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in + placements: + - src: flowers + offset: [1, 1] + - src: minibox + offset: [0, 0] + orient: + up: west + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: floor2 + upperleft: [0, 0] + map: | + ..... + ..... + ..... + ..... + ..... + - name: floor2 + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in + placements: + - src: flowers + offset: [1, 0] + - src: minibox + offset: [0, 0] + orient: + up: south + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: floor3 + upperleft: [0, 0] + map: | + ..... + ..... + ..... + ..... + ..... + - name: floor3 + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in + placements: + - src: flowers + offset: [1, -2] + - src: minibox + offset: [0, 0] + orient: + up: east + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: root + upperleft: [0, 0] + map: | + ..... + ..... + ..... + ..... + ..... +world: + name: root + default: [blank] + palette: + '.': [grass] + upperleft: [0, 0] + placements: + - src: flowers + offset: [0, -2] + - src: minibox + offset: [0, 0] + portals: + - entrance: portal_in + exitInfo: + exit: portal_out + subworldName: floor1 + map: | + ..... + ..... + ..... + ..... + ..... diff --git a/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml b/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml new file mode 100644 index 000000000..ab5a85b90 --- /dev/null +++ b/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml @@ -0,0 +1,93 @@ +version: 1 +name: Subworld spatial consistency enforcement +description: | + Portals annotated to enforce spatial consistency between subworlds +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads +known: [boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + consistent: true + upperleft: [-1, 1] + map: | + b..b..b..b + .P.....p.. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + consistent: true + map: | + .......... + .p.B....P. + .......... diff --git a/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml new file mode 100644 index 000000000..ec3269649 --- /dev/null +++ b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml @@ -0,0 +1,87 @@ +version: 1 +name: Subworld uniqueness (default name) +description: | + Has two unnamed subworlds, which fail uniqueness +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: [1, 0] + system: true + display: + char: 'J' + invisible: true +known: [flower, boulder] +subworlds: + - default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + upperleft: [-1, 1] + map: | + b..b..b..b + .p..f...P. + b..b..b..b +world: + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 't': [ice, null, judge] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + map: | + .......... + .p.Bt...P. + .......... diff --git a/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml new file mode 100644 index 000000000..b608da8ec --- /dev/null +++ b/data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml @@ -0,0 +1,89 @@ +version: 1 +name: Subworld uniqueness (explicit name) +description: | + Has two identically-named subworlds +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads + - name: judge + dir: [1, 0] + system: true + display: + char: 'J' + invisible: true +known: [flower, boulder] +subworlds: + - name: foo + default: [blank] + palette: + '.': [dirt] + 'f': [dirt, flower] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + upperleft: [-1, 1] + map: | + b..b..b..b + .p..f...P. + b..b..b..b +world: + name: foo + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 't': [ice, null, judge] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + map: | + .......... + .p.Bt...P. + .......... diff --git a/scripts/enforce-todo-issues.sh b/scripts/enforce-todo-issues.sh index 73c40f396..1d0fdfcad 100755 --- a/scripts/enforce-todo-issues.sh +++ b/scripts/enforce-todo-issues.sh @@ -4,7 +4,7 @@ SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) cd $SCRIPT_DIR/.. -if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX):?\s' src 2>&1 | grep -vP '#\d+'; then +if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\b' src 2>&1 | grep -vP '#\d+'; then echo "Please add a link to Issue, for example: TODO: #123" exit 1 else diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs index f8ca2986c..ebc2f1fba 100644 --- a/src/Swarm/Doc/Gen.hs +++ b/src/Swarm/Doc/Gen.hs @@ -52,7 +52,7 @@ import Swarm.Game.Failure qualified as F import Swarm.Game.Failure.Render qualified as F import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight) import Swarm.Game.ResourceLoading (getDataFileNameSafe) -import Swarm.Game.Robot (equippedDevices, instantiateRobot, robotInventory) +import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory) import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots) import Swarm.Game.WorldGen (testWorld2Entites) import Swarm.Language.Capability (Capability) @@ -551,11 +551,14 @@ classicScenario = do entities <- loadEntities >>= guardRight "load entities" fst <$> loadScenario "data/scenarios/classic.yaml" entities +startingHelper :: Scenario -> Robot +startingHelper = instantiateRobot 0 . head . view scenarioRobots + startingDevices :: Scenario -> Set Entity -startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . instantiateRobot 0 . head . view scenarioRobots +startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . startingHelper startingInventory :: Scenario -> Map Entity Int -startingInventory = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot 0 . head . view scenarioRobots +startingInventory = Map.fromList . map swap . E.elems . view robotInventory . startingHelper -- | Ignore utility entities that are just used for tutorials and challenges. ignoredEntities :: Set Text diff --git a/src/Swarm/Game/Log.hs b/src/Swarm/Game/Log.hs index ec2dd56ee..731310bf9 100644 --- a/src/Swarm/Game/Log.hs +++ b/src/Swarm/Game/Log.hs @@ -20,6 +20,7 @@ module Swarm.Game.Log ( -- * Robot log entries LogEntry (..), + LogLocation (..), leText, leSource, leRobotName, @@ -34,6 +35,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Swarm.Game.CESK (TickNumber) import Swarm.Game.Location (Location) +import Swarm.Game.Universe (Cosmic) -- | Severity of the error - critical errors are bugs -- and should be reported as Issues. @@ -50,6 +52,9 @@ data LogSource ErrorTrace ErrorLevel deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) +data LogLocation a = Omnipresent | Located a + deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) + -- | An entry in a robot's log. data LogEntry = LogEntry { _leTime :: TickNumber @@ -61,7 +66,7 @@ data LogEntry = LogEntry -- ^ The name of the robot that generated the entry. , _leRobotID :: Int -- ^ The ID of the robot that generated the entry. - , _leLocation :: Location + , _leLocation :: LogLocation (Cosmic Location) -- ^ Location of the robot at log entry creation. , _leText :: Text -- ^ The text of the log entry. diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index 01c0664de..233ab5a8c 100644 --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -95,6 +95,7 @@ import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisib import Swarm.Game.Entity hiding (empty) import Swarm.Game.Location (Heading, Location, toDirection) import Swarm.Game.Log +import Swarm.Game.Universe import Swarm.Language.Capability (Capability) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Requirement (ReqCtx) @@ -167,8 +168,8 @@ data RobotPhase -- | With a robot template, we may or may not have a location. With a -- concrete robot we must have a location. type family RobotLocation (phase :: RobotPhase) :: Data.Kind.Type where - RobotLocation 'TemplateRobot = Maybe Location - RobotLocation 'ConcreteRobot = Location + RobotLocation 'TemplateRobot = Maybe (Cosmic Location) + RobotLocation 'ConcreteRobot = Cosmic Location -- | Robot templates have no ID; concrete robots definitely do. type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where @@ -270,19 +271,19 @@ robotDisplay = lens getDisplay setDisplay -- a getter, since when changing a robot's location we must remember -- to update the 'robotsByLocation' map as well. You can use the -- 'updateRobotLocation' function for this purpose. -robotLocation :: Getter Robot Location +robotLocation :: Getter Robot (Cosmic Location) -- | Set a robot's location. This is unsafe and should never be -- called directly except by the 'updateRobotLocation' function. -- The reason is that we need to make sure the 'robotsByLocation' -- map stays in sync. -unsafeSetRobotLocation :: Location -> Robot -> Robot +unsafeSetRobotLocation :: Cosmic Location -> Robot -> Robot unsafeSetRobotLocation loc r = r {_robotLocation = loc} -- | A template robot's location. Unlike 'robotLocation', this is a -- lens, since when dealing with robot templates there is as yet no -- 'robotsByLocation' map to keep up-to-date. -trobotLocation :: Lens' TRobot (Maybe Location) +trobotLocation :: Lens' TRobot (Maybe (Cosmic Location)) trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l}) -- | Which way the robot is currently facing. @@ -313,7 +314,7 @@ instantiateRobot :: RID -> TRobot -> Robot instantiateRobot i r = r { _robotID = i - , _robotLocation = fromMaybe zero (_robotLocation r) + , _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r } -- | The ID number of the robot's parent, that is, the robot that diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 67e442f7e..823afa9da 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -33,7 +33,8 @@ module Swarm.Game.Scenario ( scenarioEntities, scenarioRecipes, scenarioKnown, - scenarioWorld, + scenarioWorlds, + scenarioNavigation, scenarioRobots, scenarioObjectives, scenarioSolution, @@ -45,19 +46,24 @@ module Swarm.Game.Scenario ( getScenarioPath, ) where +import Control.Arrow ((&&&)) import Control.Lens hiding (from, (.=), (<.>)) -import Control.Monad (filterM) +import Control.Monad (filterM, unless) import Control.Monad.Except (ExceptT (..), runExceptT, withExceptT) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (except) import Data.Aeson import Data.Either.Extra (eitherToMaybe, maybeToEither) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M import Data.Maybe (catMaybes, isNothing, listToMaybe) import Data.Text (Text) import Data.Text qualified as T import Swarm.Game.Entity import Swarm.Game.Failure import Swarm.Game.Failure.Render +import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Robot (TRobot) @@ -66,9 +72,12 @@ import Swarm.Game.Scenario.Objective.Validation import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Style import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Navigation.Portal +import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldDescription +import Swarm.Game.Universe import Swarm.Language.Pipeline (ProcessedTerm) -import Swarm.Util (failT) +import Swarm.Util (binTuples, failT) import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Util.Yaml import System.Directory (doesFileExist) @@ -92,7 +101,8 @@ data Scenario = Scenario , _scenarioEntities :: EntityMap , _scenarioRecipes :: [Recipe Entity] , _scenarioKnown :: [Text] - , _scenarioWorld :: WorldDescription + , _scenarioWorlds :: NonEmpty WorldDescription + , _scenarioNavigation :: Navigation (M.Map SubworldName) Location , _scenarioRobots :: [TRobot] , _scenarioObjectives :: [Objective] , _scenarioSolution :: Maybe ProcessedTerm @@ -123,6 +133,35 @@ instance FromJSONE EntityMap Scenario where rs <- v ..: "robots" let rsMap = buildRobotMap rs + rootLevelSharedStructures <- localE (,rsMap) $ v ..:? "structures" ..!= [] + + allWorlds <- localE (\x -> (rootLevelSharedStructures :: Structure.InheritedStructureDefs, (x, rsMap))) $ do + rootWorld <- v ..: "world" + subworlds <- v ..:? "subworlds" ..!= [] + return $ rootWorld :| subworlds + + let worldsByName = binTuples $ NE.toList $ NE.map (worldName &&& id) allWorlds + dupedNames = M.keys $ M.filter ((> 1) . length) worldsByName + unless (null dupedNames) $ + failT + [ "Subworld names are not unique:" + , T.intercalate ", " $ map renderWorldName dupedNames + ] + + let mergedWaypoints = + M.fromList $ + map (worldName &&& runIdentity . waypoints . navigation) $ + NE.toList allWorlds + + mergedPortals <- + validatePortals + . Navigation mergedWaypoints + . M.unions + . map (portals . navigation) + $ NE.toList allWorlds + + let mergedNavigation = Navigation mergedWaypoints mergedPortals + Scenario <$> liftE (v .: "version") <*> liftE (v .: "name") @@ -134,7 +173,8 @@ instance FromJSONE EntityMap Scenario where <*> pure em <*> v ..:? "recipes" ..!= [] <*> pure known - <*> localE (,rsMap) (v ..: "world") + <*> pure allWorlds + <*> pure mergedNavigation <*> pure rs <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives) <*> liftE (v .:? "solution") @@ -179,8 +219,12 @@ scenarioRecipes :: Lens' Scenario [Recipe Entity] -- not have to scan them. scenarioKnown :: Lens' Scenario [Text] --- | The starting world for the scenario. -scenarioWorld :: Lens' Scenario WorldDescription +-- | The subworlds of the scenario. +-- The "root" subworld shall always be at the head of the list, by construction. +scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription) + +-- | Waypoints and inter-world portals +scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location) -- | The starting robots for the scenario. Note this should -- include the base. diff --git a/src/Swarm/Game/Scenario/RobotLookup.hs b/src/Swarm/Game/Scenario/RobotLookup.hs index 1ff371a1b..c5926d003 100644 --- a/src/Swarm/Game/Scenario/RobotLookup.hs +++ b/src/Swarm/Game/Scenario/RobotLookup.hs @@ -6,9 +6,12 @@ module Swarm.Game.Scenario.RobotLookup where import Control.Lens hiding (from, (<.>)) +import Data.Aeson (FromJSON) import Data.Map (Map) import Data.Map qualified as M import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) import Swarm.Game.Entity import Swarm.Game.Robot (TRobot, trobotName) import Swarm.Util (failT, quote) @@ -18,17 +21,20 @@ import Swarm.Util.Yaml -- Robot map ------------------------------------------------------------ +newtype RobotName = RobotName Text + deriving (Show, Eq, Ord, Generic, FromJSON) + -- | A robot template paired with its definition's index within -- the Scenario file type IndexedTRobot = (Int, TRobot) -- | A map from names to robots, used to look up robots in scenario -- descriptions. -type RobotMap = Map Text IndexedTRobot +type RobotMap = Map RobotName IndexedTRobot -- | Create a 'RobotMap' from a list of robot templates. buildRobotMap :: [TRobot] -> RobotMap -buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 ..] rs +buildRobotMap rs = M.fromList $ zipWith (\x y -> (RobotName $ view trobotName y, (x, y))) [0 ..] rs ------------------------------------------------------------ -- Lookup utilities @@ -36,11 +42,11 @@ buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 -- | Look up a thing by name, throwing a parse error if it is not -- found. -getThing :: Text -> (Text -> m -> Maybe a) -> Text -> ParserE m a +getThing :: Show k => Text -> (k -> m -> Maybe a) -> k -> ParserE m a getThing thing lkup name = do m <- getE case lkup name m of - Nothing -> failT ["Unknown", thing, "name:", quote name] + Nothing -> failT ["Unknown", thing, "name:", quote $ T.pack $ show name] Just a -> return a -- | Look up an entity by name in an 'EntityMap', throwing a parse @@ -50,5 +56,5 @@ getEntity = getThing "entity" lookupEntityName -- | Look up a robot by name in a 'RobotMap', throwing a parse error -- if it is not found. -getRobot :: Text -> ParserE RobotMap IndexedTRobot +getRobot :: RobotName -> ParserE RobotMap IndexedTRobot getRobot = getThing "robot" M.lookup diff --git a/src/Swarm/Game/Scenario/Topography/Cell.hs b/src/Swarm/Game/Scenario/Topography/Cell.hs index 7de1cc25a..3dae3043f 100644 --- a/src/Swarm/Game/Scenario/Topography/Cell.hs +++ b/src/Swarm/Game/Scenario/Topography/Cell.hs @@ -77,7 +77,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where traverse (localE fst . getEntity) meName let name2rob r = do - mrName <- liftE $ parseJSON @(Maybe Text) r + mrName <- liftE $ parseJSON @(Maybe RobotName) r traverse (localE snd . getRobot) mrName robs <- mapMaybeM name2rob (drop 2 tup) diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs index 5a012e2c1..016ff8a4f 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -1,38 +1,65 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.Navigation.Portal where +import Control.Arrow ((&&&)) +import Control.Lens (view) import Control.Monad (forM, forM_, unless) -import Data.Aeson (FromJSON) +import Data.Aeson +import Data.Bifunctor (first) +import Data.BoolExpr (Signed (..)) +import Data.Function (on) +import Data.Functor.Identity import Data.Int (Int32) -import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE +import Data.Map (Map) import Data.Map qualified as M -import Data.Maybe (listToMaybe) -import Data.Text (Text) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Text qualified as T +import Data.Tuple (swap) import GHC.Generics (Generic) -import Linear (V2) +import Linear (V2, negated) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Navigation.Waypoint -import Swarm.Util (binTuples, quote) +import Swarm.Game.Universe +import Swarm.Util (allEqual, binTuples, both, failT, quote, showT) --- | Note: The primary overworld shall use --- the reserved name \"root\". -newtype SubworldName = SubworldName Text - deriving (Show, Eq, Ord, Generic, FromJSON) +type WaypointMap = M.Map WaypointName (NonEmpty Location) -data Navigation = Navigation - { waypoints :: M.Map WaypointName (NonEmpty Location) +data AnnotatedDestination a = AnnotatedDestination + { enforceConsistency :: Bool + , cosmoLocation :: Cosmic a + } + deriving (Show, Eq) + +-- | Parameterized on waypoint dimensionality ('additionalDimension') and +-- on the portal location specification method ('portalExitLoc'). +-- == @additionalDimension@ +-- As a member of the 'WorldDescription', waypoints are only known within a +-- a single subworld, so 'additionalDimension' is 'Identity' for the map +-- of waypoint names to planar locations. +-- At the Scenario level, in contrast, we have access to all subworlds, so +-- we nest this map to planar locations in additional mapping layer by subworld. +-- == @portalExitLoc@ +-- At the subworld parsing level, we only can obtain the planar location +-- for portal /entrances/, but the /exits/ remain as waypoint names. +-- At the Scenario-parsing level, we finally have +-- access to the waypoints across all subworlds, and can therefore translate +-- the portal exits to concrete planar locations. +data Navigation additionalDimension portalExitLoc = Navigation + { waypoints :: additionalDimension WaypointMap -- ^ Note that waypoints defined at the "root" level are still relative to -- the top-left corner of the map rectangle; they are not in absolute world -- coordinates (as with applying the "ul" offset). - , portals :: M.Map Location Location + , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc) } - deriving (Eq, Show) + +deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) +deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b) data PortalExit = PortalExit { exit :: WaypointName @@ -44,51 +71,81 @@ data PortalExit = PortalExit data Portal = Portal { entrance :: WaypointName , exitInfo :: PortalExit + , consistent :: Bool } - deriving (Show, Eq, Generic, FromJSON) + deriving (Show, Eq) + +instance FromJSON Portal where + parseJSON = withObject "Portal" $ \v -> + Portal + <$> v + .: "entrance" + <*> v + .: "exitInfo" + <*> v .:? "consistent" .!= False failUponDuplication :: (MonadFail m, Show a, Show b) => - String -> + T.Text -> M.Map a (NonEmpty b) -> m () failUponDuplication message binnedMap = forM_ (listToMaybe $ M.toList duplicated) $ \(pIn, pOuts) -> - fail $ - unwords - [ "Waypoint" - , show pIn - , message - , intercalate ", " $ map show $ NE.toList pOuts - ] + failT + [ "Waypoint" + , showT pIn + , message + , T.intercalate ", " $ map showT $ NE.toList pOuts + ] where duplicated = M.filter ((> 1) . NE.length) binnedMap --- | Enforces the following constraints: --- * portals can have multiple entrances but only a single exit +failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a +failWaypointLookup (WaypointName rawName) = + maybe (failT ["No waypoint named", quote rawName]) return + +-- | +-- The following constraints must be enforced: +-- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit -- * no two portals share the same entrance location --- * global waypoint uniqueness when the "unique" flag is specified -validateNavigation :: +-- * waypoint uniqueness within a subworld when the 'unique' flag is specified +-- +-- == Data flow: +-- +-- Waypoints are defined within a subworld and are namespaced by it. +-- Optional intra-subworld uniqueness of Waypoints is enforced at WorldDescription +-- parse time. +-- Portals are declared within a subworld. The portal entrance must be a waypoint +-- within this subworld. +-- They can reference waypoints in other subworlds as exits, but these references +-- are not validated until the Scenario parse level. +-- +-- * Since portal /entrances/ are specified at the subworld level, validation that +-- no entrances overlap can also be performed at that level. +-- * However, enforcement of single-multiplicity on portal /exits/ must be performed +-- at scenario-parse level, because for a portal exit that references a waypoint in +-- another subworld, we can't know at the single-WorldDescription level whether +-- that waypoint has plural multiplicity. +validatePartialNavigation :: (MonadFail m, Traversable t) => - V2 Int32 -> + SubworldName -> + Location -> [Originated Waypoint] -> t Portal -> - m Navigation -validateNavigation upperLeft unmergedWaypoints portalDefs = do + m (Navigation Identity WaypointName) +validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag - -- TODO(#144) Currently ignores subworld references - nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName@(WaypointName rawExitName) _)) -> do + nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent) -> do -- Portals can have multiple entrances but only a single exit. -- That is, the pairings of entries to exits must form a proper mathematical "function". - -- Multiple occurrences of entrance waypoints of a given name will replicate portal entrances. + -- Multiple occurrences of entrance waypoints of a given name will result in + -- multiple portal entrances. entranceLocs <- getLocs entranceName - firstExitLoc :| otherExits <- getLocs exitName - unless (null otherExits) - . fail - . T.unpack - $ T.unwords ["Ambiguous exit waypoints named", quote rawExitName, "for portal"] - return $ map ((,extractLoc firstExitLoc) . extractLoc) $ NE.toList entranceLocs + + let sw = fromMaybe currentSubworldName maybeExitSubworldName + f = (,AnnotatedDestination isConsistent $ Cosmic sw exitName) . extractLoc + return $ map f $ NE.toList entranceLocs let reconciledPortalPairs = concat nestedPortalPairs @@ -97,24 +154,143 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do failUponDuplication "has overlapping portal entrances exiting to" $ binTuples reconciledPortalPairs - return $ Navigation bareWaypoints $ M.fromList reconciledPortalPairs + return . Navigation (pure bareWaypoints) . M.fromList $ + map (first $ Cosmic currentSubworldName) reconciledPortalPairs where - getLocs wpWrapper@(WaypointName rawName) = case M.lookup wpWrapper correctedWaypoints of - Nothing -> - fail $ - T.unpack $ - T.unwords - [ "No waypoint named" - , quote rawName - ] - Just xs -> return xs + getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints extractLoc (Originated _ (Waypoint _ loc)) = loc correctedWaypoints = binTuples $ map - (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint upperLeft) x)) + (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint $ upperLeft .-. origin) x)) unmergedWaypoints bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints - waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints + +validatePortals :: + MonadFail m => + Navigation (M.Map SubworldName) WaypointName -> + m (M.Map (Cosmic Location) (AnnotatedDestination Location)) +validatePortals (Navigation wpUniverse partialPortals) = do + portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent portalExit@(Cosmic swName (WaypointName rawExitName))) -> do + firstExitLoc :| otherExits <- getLocs portalExit + unless (null otherExits) $ + failT + [ "Ambiguous exit waypoints named" + , quote rawExitName + , "for portal" + ] + return (portalEntrance, AnnotatedDestination isConsistent $ Cosmic swName firstExitLoc) + + ensureSpatialConsistency portalPairs + + return $ M.fromList portalPairs + where + getLocs (Cosmic swName wpWrapper@(WaypointName exitName)) = do + subworldWaypoints <- case M.lookup swName wpUniverse of + Just x -> return x + Nothing -> + failT + [ "Could not lookup waypoint" + , quote exitName + , "for portal exit because subworld" + , quote $ renderWorldName swName + , "does not exist" + ] + + failWaypointLookup wpWrapper $ + M.lookup wpWrapper subworldWaypoints + +-- | A portal can be marked as \"consistent\", meaning that it represents +-- a conventional physical passage rather than a \"magical\" teleportation. +-- +-- If there exists more than one \"consistent\" portal between the same +-- two subworlds, then the portal locations must be spatially consistent +-- between the two worlds. I.e. the space comprising the two subworlds +-- forms a "conservative vector field". +-- +-- Verifying this is simple: +-- For all of the portals between Subworlds A and B: +-- * The coordinates of all \"consistent\" portal locations in Subworld A +-- are subtracted from the corresponding coordinates in Subworld B. It +-- does not matter which are exits vs. entrances. +-- * The resulting \"vector\" from every pair must be equal. +ensureSpatialConsistency :: + MonadFail m => + [(Cosmic Location, AnnotatedDestination Location)] -> + m () +ensureSpatialConsistency xs = + unless (null nonUniform) $ + failT + [ "Non-uniform portal distances:" + , showT nonUniform + ] + where + consistentPairs :: [(Cosmic Location, Cosmic Location)] + consistentPairs = map (fmap cosmoLocation) $ filter (enforceConsistency . snd) xs + + interWorldPairs :: [(Cosmic Location, Cosmic Location)] + interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs + + normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)] + normalizedOrdering = map normalizePairOrder interWorldPairs + + normalizePairOrder :: (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a) + normalizePairOrder pair = + if uncurry ((>) `on` view subworld) pair + then Negative $ swap pair + else Positive pair + + tuplify :: (Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a)) + tuplify = both (view subworld) &&& both (view planar) + + getSigned :: Signed (V2 Int32) -> V2 Int32 + getSigned = \case + Positive x -> x + Negative x -> negated x + + groupedBySubworldPair :: + Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location))) + groupedBySubworldPair = binTuples $ map (sequenceSigned . fmap tuplify) normalizedOrdering + + vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32)) + vectorized = M.map (NE.map (getSigned . fmap (uncurry (.-.)))) groupedBySubworldPair + + nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32)) + nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized + +-- | +-- An implementation of 'sequenceA' for 'Signed' that does not +-- require an 'Applicative' instance for the inner 'Functor'. +-- +-- == Discussion +-- Compare to the 'Traversable' instance of 'Signed': +-- @ +-- instance Traversable Signed where +-- traverse f (Positive x) = Positive <$> f x +-- traverse f (Negative x) = Negative <$> f x +-- @ +-- +-- if we were to substitute 'id' for f: +-- @ +-- traverse id (Positive x) = Positive <$> id x +-- traverse id (Negative x) = Negative <$> id x +-- @ +-- our implementation essentially becomes @traverse id@. +-- +-- However, we cannot simply write our implementation as @traverse id@, because +-- the 'traverse' function has an 'Applicative' constraint, which is superfluous +-- for our purpose. +-- +-- Perhaps there is an opportunity to invent a typeclass for datatypes which +-- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors, +-- for which a less-constrained 'sequence' function could be automatically derived. +-- Compare to the 'Comonad' class and its 'extract' function. +sequenceSigned :: + Functor f => + Signed (f a) -> + f (Signed a) +sequenceSigned = \case + Positive x -> Positive <$> x + Negative x -> Negative <$> x diff --git a/src/Swarm/Game/Scenario/Topography/Structure.hs b/src/Swarm/Game/Scenario/Topography/Structure.hs index c1b8c3e47..49675f53d 100644 --- a/src/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/Swarm/Game/Scenario/Topography/Structure.hs @@ -22,6 +22,7 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.WorldPalette +import Swarm.Util (failT, showT) import Swarm.Util.Yaml import Witch (into) @@ -31,11 +32,13 @@ data NamedStructure c = NamedStructure } deriving (Eq, Show) +type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))] + instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where parseJSONE = withObjectE "named structure" $ \v -> do - sName <- liftE $ v .: "name" - NamedStructure sName - <$> v + NamedStructure + <$> liftE (v .: "name") + <*> v ..: "structure" data PStructure c = Structure @@ -111,12 +114,12 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= WorldPalette mempty - structureDefs <- v ..:? "structures" ..!= [] + localStructureDefs <- v ..:? "structures" ..!= [] placementDefs <- liftE $ v .:? "placements" .!= [] waypointDefs <- liftE $ v .:? "waypoints" .!= [] maybeMaskChar <- liftE $ v .:? "mask" (maskedArea, mapWaypoints) <- liftE $ (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal - return $ Structure maskedArea structureDefs placementDefs $ waypointDefs <> mapWaypoints + return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints -- | "Paint" a world map using a 'WorldPalette', turning it from a raw -- string into a nested list of 'Cell' values by looking up each @@ -142,7 +145,7 @@ paintMap maskChar pal a = do if Just c == maskChar then return Nothing else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of - Nothing -> fail $ "Char not in world palette: " ++ show c + Nothing -> failT ["Char not in world palette:", showT c] Just cell -> return $ Just cell readMap :: Applicative f => (Char -> f b) -> Text -> f [[b]] diff --git a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs index a2a24efdc..f87b7b046 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -5,7 +5,7 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.WorldDescription where -import Data.Coerce +import Data.Functor.Identity import Data.Maybe (catMaybes) import Data.Yaml as Y import Swarm.Game.Entity @@ -14,8 +14,13 @@ import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Portal +import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( + WaypointName, + ) +import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure)) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldPalette +import Swarm.Game.Universe import Swarm.Util.Yaml ------------------------------------------------------------ @@ -32,36 +37,49 @@ data PWorldDescription e = WorldDescription , palette :: WorldPalette e , ul :: Location , area :: [[PCell e]] - , navigation :: Navigation + , navigation :: Navigation Identity WaypointName + , worldName :: SubworldName } deriving (Eq, Show) type WorldDescription = PWorldDescription Entity -instance FromJSONE (EntityMap, RobotMap) WorldDescription where +instance FromJSONE (InheritedStructureDefs, (EntityMap, RobotMap)) WorldDescription where parseJSONE = withObjectE "world description" $ \v -> do - pal <- v ..:? "palette" ..!= WorldPalette mempty - structureDefs <- v ..:? "structures" ..!= [] + (scenarioLevelStructureDefs, (em, rm)) <- getE + (pal, terr, rootWorldStructureDefs) <- localE (const (em, rm)) $ do + pal <- v ..:? "palette" ..!= WorldPalette mempty + terr <- v ..:? "default" + rootWorldStructs <- v ..:? "structures" ..!= [] + return (pal, terr, rootWorldStructs) + waypointDefs <- liftE $ v .:? "waypoints" .!= [] portalDefs <- liftE $ v .:? "portals" .!= [] placementDefs <- liftE $ v .:? "placements" .!= [] (initialArea, mapWaypoints) <- liftE ((v .:? "map" .!= "") >>= Structure.paintMap Nothing pal) upperLeft <- liftE (v .:? "upperleft" .!= origin) + subWorldName <- liftE (v .:? "name" .!= DefaultRootSubworld) - let struc = Structure.Structure initialArea structureDefs placementDefs $ waypointDefs <> mapWaypoints - Structure.MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc + let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs + struc = Structure initialArea initialStructureDefs placementDefs $ waypointDefs <> mapWaypoints + MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc - validatedLandmarks <- validateNavigation (coerce upperLeft) unmergedWaypoints portalDefs + validatedNavigation <- + validatePartialNavigation + subWorldName + upperLeft + unmergedWaypoints + portalDefs - WorldDescription - <$> v ..:? "default" - <*> liftE (v .:? "offset" .!= False) + WorldDescription terr + <$> liftE (v .:? "offset" .!= False) <*> liftE (v .:? "scrollable" .!= True) <*> pure pal <*> pure upperLeft <*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells. - <*> pure validatedLandmarks + <*> pure validatedNavigation + <*> pure subWorldName ------------------------------------------------------------ -- World editor diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 63650e030..40a25bfc2 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -61,7 +61,7 @@ module Swarm.Game.State ( currentScenarioPath, knownEntities, worldNavigation, - world, + multiWorld, worldScrollable, viewCenterRule, viewCenter, @@ -107,6 +107,7 @@ module Swarm.Game.State ( focusedRange, clearFocusedRobotLogUpdated, addRobot, + addRobotToLocation, addTRobot, emitMessage, wakeWatchingRobots, @@ -114,6 +115,7 @@ module Swarm.Game.State ( sleepForever, wakeUpRobotsDoneSleeping, deleteRobot, + removeRobotFromLocationMap, activateRobot, toggleRunStatus, messageIsRecent, @@ -174,6 +176,7 @@ import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.ScenarioInfo import Swarm.Game.Terrain (TerrainType (..)) +import Swarm.Game.Universe as U import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray) import Swarm.Game.World qualified as W import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray) @@ -185,7 +188,7 @@ 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 (uniq, (<+=), (<<.=), (?)) +import Swarm.Util (binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?)) import Swarm.Util.Lens (makeLensesExcluding) import System.Clock qualified as Clock import System.Random (StdGen, mkStdGen, randomRIO) @@ -198,7 +201,7 @@ import System.Random (StdGen, mkStdGen, randomRIO) -- world viewport. data ViewCenterRule = -- | The view should be centered on an absolute position. - VCLocation Location + VCLocation (Cosmic Location) | -- | The view should be centered on a certain robot. VCRobot RID deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) @@ -381,11 +384,11 @@ data GameState = GameState -- Waiting robots for a given time are a list because it is cheaper to -- prepend to a list than insert into a Set. _waitingRobots :: Map TickNumber [RID] - , _robotsByLocation :: Map Location IntSet + , _robotsByLocation :: Map SubworldName (Map Location IntSet) , -- This member exists as an optimization so -- that we do not have to iterate over all "waiting" robots, -- since there may be many. - _robotsWatching :: Map Location (S.Set RID) + _robotsWatching :: Map (Cosmic Location) (S.Set RID) , _allDiscoveredEntities :: Inventory , _availableRecipes :: Notifications (Recipe Entity) , _availableCommands :: Notifications Const @@ -401,11 +404,11 @@ data GameState = GameState , _recipesReq :: IntMap [Recipe Entity] , _currentScenarioPath :: Maybe FilePath , _knownEntities :: [Text] - , _worldNavigation :: Navigation - , _world :: W.World Int Entity + , _worldNavigation :: Navigation (M.Map SubworldName) Location + , _multiWorld :: W.MultiWorld Int Entity , _worldScrollable :: Bool , _viewCenterRule :: ViewCenterRule - , _viewCenter :: Location + , _viewCenter :: Cosmic Location , _needsRedraw :: Bool , _replStatus :: REPLStatus , _replNextValueIndex :: Integer @@ -473,28 +476,32 @@ robotMap :: Lens' GameState (IntMap Robot) -- location of a robot changes, or a robot is created or destroyed. -- Fortunately, there are relatively few ways for these things to -- happen. -robotsByLocation :: Lens' GameState (Map Location IntSet) +robotsByLocation :: Lens' GameState (Map SubworldName (Map Location IntSet)) -- | Get a list of all the robots at a particular location. -robotsAtLocation :: Location -> GameState -> [Robot] +robotsAtLocation :: Cosmic Location -> GameState -> [Robot] robotsAtLocation loc gs = mapMaybe (`IM.lookup` (gs ^. robotMap)) . maybe [] IS.toList - . M.lookup loc + . M.lookup (loc ^. planar) + . M.findWithDefault mempty (loc ^. subworld) . view robotsByLocation $ gs --- | Get a list of all the robots that are "watching" by location. -robotsWatching :: Lens' GameState (Map Location (S.Set RID)) +-- | Get a list of all the robots that are \"watching\" by location. +robotsWatching :: Lens' GameState (Map (Cosmic Location) (S.Set RID)) -- | Get all the robots within a given Manhattan distance from a -- location. -robotsInArea :: Location -> Int32 -> GameState -> [Robot] -robotsInArea o d gs = map (rm IM.!) rids +robotsInArea :: Cosmic Location -> Int32 -> GameState -> [Robot] +robotsInArea (Cosmic subworldName o) d gs = map (rm IM.!) rids where rm = gs ^. robotMap rl = gs ^. robotsByLocation - rids = concatMap IS.elems $ getElemsInArea o d rl + rids = + concatMap IS.elems $ + getElemsInArea o d $ + M.findWithDefault mempty subworldName rl -- | The base robot, if it exists. baseRobot :: Traversal' GameState Robot @@ -559,19 +566,19 @@ recipesReq :: Lens' GameState (IntMap [Recipe Entity]) -- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'. currentScenarioPath :: Lens' GameState (Maybe FilePath) --- | The names of entities that should be considered "known", that is, +-- | The names of entities that should be considered \"known\", that is, -- robots know what they are without having to scan them. knownEntities :: Lens' GameState [Text] --- | Includes a Map of named locations and an +-- | Includes a 'Map' of named locations and an -- "Edge list" (graph) that maps portal entrances to exits -worldNavigation :: Lens' GameState Navigation +worldNavigation :: Lens' GameState (Navigation (M.Map SubworldName) Location) -- | The current state of the world (terrain and entities only; robots --- are stored in the 'robotMap'). Int is used instead of --- TerrainType because we need to be able to store terrain values in +-- are stored in the 'robotMap'). 'Int' is used instead of +-- 'TerrainType' because we need to be able to store terrain values in -- unboxed tile arrays. -world :: Lens' GameState (W.World Int Entity) +multiWorld :: Lens' GameState (W.MultiWorld Int Entity) -- | Whether the world map is supposed to be scrollable or not. worldScrollable :: Lens' GameState Bool @@ -580,7 +587,7 @@ worldScrollable :: Lens' GameState Bool -- modified directly, since it is calculated automatically from the -- 'viewCenterRule'. To modify the view center, either set the -- 'viewCenterRule', or use 'modifyViewCenter'. -viewCenter :: Getter GameState Location +viewCenter :: Getter GameState (Cosmic Location) viewCenter = to _viewCenter -- | Whether the world view needs to be redrawn. @@ -638,14 +645,14 @@ viewCenterRule = lens getter setter setter :: GameState -> ViewCenterRule -> GameState setter g rule = case rule of - VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2} + VCLocation loc -> g {_viewCenterRule = rule, _viewCenter = loc} VCRobot rid -> let robotcenter = g ^? robotMap . ix rid . robotLocation in -- retrieve the loc of the robot if it exists, Nothing otherwise. -- sometimes, lenses are amazing... case robotcenter of Nothing -> g - Just v2 -> g {_viewCenterRule = rule, _viewCenter = v2, _focusedRobotID = rid} + Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid} -- | Whether the repl is currently working. replWorking :: Getter GameState Bool @@ -686,14 +693,22 @@ messageNotifications = to getNotif messageIsRecent :: GameState -> LogEntry -> Bool messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. ticks -messageIsFromNearby :: Location -> LogEntry -> Bool -messageIsFromNearby l e = manhattan l (e ^. leLocation) <= hearingDistance +-- | Reconciles the possibilities of log messages being +-- omnipresent and robots being in different worlds +messageIsFromNearby :: Cosmic Location -> LogEntry -> Bool +messageIsFromNearby l e = case e ^. leLocation of + Omnipresent -> True + Located x -> f x + where + f logLoc = case cosmoMeasure manhattan l logLoc of + InfinitelyFar -> False + Measurable x -> x <= hearingDistance -- | Given a current mapping from robot names to robots, apply a -- 'ViewCenterRule' to derive the location it refers to. The result --- is @Maybe@ because the rule may refer to a robot which does not +-- is 'Maybe' because the rule may refer to a robot which does not -- exist. -applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe Location +applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location) applyViewCenterRule (VCLocation l) _ = Just l applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation @@ -710,13 +725,15 @@ recalcViewCenter g = & (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id) where oldViewCenter = g ^. viewCenter - newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap)) + newViewCenter = + fromMaybe oldViewCenter $ + applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap) -- | Modify the 'viewCenter' by applying an arbitrary function to the -- current value. Note that this also modifies the 'viewCenterRule' -- to match. After calling this function the 'viewCenterRule' will -- specify a particular location, not a robot. -modifyViewCenter :: (Location -> Location) -> GameState -> GameState +modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> GameState -> GameState modifyViewCenter update g = g & case g ^. viewCenterRule of @@ -732,10 +749,10 @@ unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id -- | Given a width and height, compute the region, centered on the -- 'viewCenter', that should currently be in view. -viewingRegion :: GameState -> (Int32, Int32) -> W.BoundsRectangle -viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) +viewingRegion :: GameState -> (Int32, Int32) -> Cosmic W.BoundsRectangle +viewingRegion g (w, h) = Cosmic sw (W.Coords (rmin, cmin), W.Coords (rmax, cmax)) where - Location cx cy = g ^. viewCenter + Cosmic sw (Location cx cy) = g ^. viewCenter (rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1) (cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1) @@ -775,17 +792,22 @@ data RobotRange -- both radii. -- * If the base has an @antenna@ installed, it also doubles both radii. focusedRange :: GameState -> Maybe RobotRange -focusedRange g = computedRange <$ focusedRobot g +focusedRange g = checkRange <$ focusedRobot g where - computedRange - | g ^. creativeMode || g ^. worldScrollable || r <= minRadius = Close - | r > maxRadius = Far - | otherwise = MidRange $ (r - minRadius) / (maxRadius - minRadius) + checkRange = case r of + InfinitelyFar -> Far + Measurable r' -> computedRange r' + + computedRange r' + | g ^. creativeMode || g ^. worldScrollable || r' <= minRadius = Close + | r' > maxRadius = Far + | otherwise = MidRange $ (r' - minRadius) / (maxRadius - minRadius) -- Euclidean distance from the base to the view center. r = case g ^. robotMap . at 0 of - Just br -> euclidean (g ^. viewCenter) (br ^. robotLocation) - _ -> 1000000000 -- if the base doesn't exist, we have bigger problems + -- if the base doesn't exist, we have bigger problems + Nothing -> InfinitelyFar + Just br -> cosmoMeasure euclidean (g ^. viewCenter) (br ^. robotLocation) -- See whether the base or focused robot have antennas installed. baseInv, focInv :: Maybe Inventory @@ -827,10 +849,18 @@ addRobot r = do let rid = r ^. robotID robotMap %= IM.insert rid r - robotsByLocation - %= M.insertWith IS.union (r ^. robotLocation) (IS.singleton rid) + addRobotToLocation rid $ r ^. robotLocation internalActiveRobots %= IS.insert rid +-- | Helper function for updating the "robotsByLocation" bookkeeping +addRobotToLocation :: (Has (State GameState) sig m) => RID -> Cosmic Location -> m () +addRobotToLocation rid rLoc = + robotsByLocation + %= M.insertWith + (M.unionWith IS.union) + (rLoc ^. subworld) + (M.singleton (rLoc ^. planar) (IS.singleton rid)) + maxMessageQueueSize :: Int maxMessageQueueSize = 1000 @@ -889,7 +919,7 @@ clearWatchingRobots rids = do -- -- NOTE: Clearing "TickNumber" map entries from "internalWaitingRobots" -- upon wakeup is handled by "wakeUpRobotsDoneSleeping" in State.hs -wakeWatchingRobots :: (Has (State GameState) sig m) => Location -> m () +wakeWatchingRobots :: (Has (State GameState) sig m) => Cosmic Location -> m () wakeWatchingRobots loc = do currentTick <- use ticks waitingMap <- use waitingRobots @@ -948,7 +978,24 @@ deleteRobot rn = do mrobot <- robotMap . at rn <<.= Nothing mrobot `forM_` \robot -> do -- Delete the robot from the index of robots by location. - robotsByLocation . ix (robot ^. robotLocation) %= IS.delete rn + removeRobotFromLocationMap (robot ^. robotLocation) rn + +-- | Makes sure empty sets don't hang around in the +-- 'robotsByLocation' map. We don't want a key with an +-- empty set at every location any robot has ever +-- visited! +removeRobotFromLocationMap :: + (Has (State GameState) sig m) => + Cosmic Location -> + RID -> + m () +removeRobotFromLocationMap (Cosmic oldSubworld oldPlanar) rid = + robotsByLocation %= M.update (tidyDelete rid) oldSubworld + where + deleteOne x = surfaceEmpty IS.null . IS.delete x + + tidyDelete robID = + surfaceEmpty M.null . M.update (deleteOne robID) oldPlanar ------------------------------------------------------------ -- Initialization @@ -1004,10 +1051,10 @@ initGameState gsc = , _currentScenarioPath = Nothing , _knownEntities = [] , _worldNavigation = Navigation mempty mempty - , _world = W.emptyWorld (fromEnum StoneT) + , _multiWorld = mempty , _worldScrollable = True , _viewCenterRule = VCRobot 0 - , _viewCenter = origin + , _viewCenter = defaultCosmicLocation , _needsRedraw = False , _replStatus = REPLDone Nothing , _replNextValueIndex = 0 @@ -1045,10 +1092,7 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) & winCondition .~ theWinCondition & winSolution .~ scenario ^. scenarioSolution & robotMap .~ IM.fromList (map (view robotID &&& id) robotList') - & robotsByLocation - .~ M.fromListWith - IS.union - (map (view robotLocation &&& (IS.singleton . view robotID)) robotList') + & robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld robotList') & internalActiveRobots .~ setOf (traverse . robotID) robotList' & availableCommands .~ Notifications 0 initialCommands & gensym .~ initGensym @@ -1060,9 +1104,12 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) & recipesIn %~ addRecipesWith inRecipeMap & recipesReq %~ addRecipesWith reqRecipeMap & knownEntities .~ scenario ^. scenarioKnown - & worldNavigation .~ navigation (scenario ^. scenarioWorld) - & world .~ theWorld theSeed - & worldScrollable .~ scenario ^. scenarioWorld . to scrollable + & worldNavigation .~ scenario ^. scenarioNavigation + & multiWorld .~ allSubworldsMap theSeed + -- TODO (#1370): Should we allow subworlds to have their own scrollability? + -- Leaning toward no , but for now just adopt the root world scrollability + -- as being universal. + & worldScrollable .~ NE.head (scenario ^. scenarioWorlds) ^. to scrollable & viewCenterRule .~ VCRobot baseID & replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working, -- otherwise the store of definition cells is not saved (see #333, #838) @@ -1070,6 +1117,14 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) True -> REPLWorking (Typed Nothing PolyUnit mempty) & robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick) where + groupRobotsBySubworld = + binTuples . map (view (robotLocation . subworld) &&& id) + + groupRobotsByPlanarLocation rs = + M.fromListWith + IS.union + (map (view (robotLocation . planar) &&& (IS.singleton . view robotID)) rs) + em = initEntities gsc <> scenario ^. scenarioEntities baseID = 0 (things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em)) @@ -1100,7 +1155,12 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) -- 2.a. If multiple robots are specified in the map, prefer the one that -- is defined first within the Scenario file. -- 2.b. If multiple robots are instantiated from the same template, then - -- prefer the one closest to the upper-left of the screen, with higher rows given precedence over columns. + -- prefer the one with a lower-indexed subworld. Note that the root + -- subworld is always first. + -- 2.c. If multiple robots instantiated from the same template are in the + -- same subworld, then + -- prefer the one closest to the upper-left of the screen, with higher + -- rows given precedence over columns (i.e. first in row-major order). robotsByBasePrecedence = locatedRobots ++ map snd (sortOn fst genRobots) initialCodeToRun = getCodeToRun <$> toRun @@ -1145,8 +1205,23 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) (maybe True (`S.member` initialCaps) . constCaps) allConst - (genRobots, wf) = buildWorld em (scenario ^. scenarioWorld) - theWorld = W.newWorld . wf + -- Subworld order as encountered in the scenario YAML file is preserved for + -- the purpose of numbering robots, other than the "root" subworld + -- guaranteed to be first. + genRobots = concat $ NE.toList $ NE.map (fst . snd) builtWorldTuples + + builtWorldTuples = + NE.map (worldName &&& buildWorld em) $ + scenario ^. scenarioWorlds + + allSubworldsMap s = + M.map genWorld + . M.fromList + . NE.toList + $ builtWorldTuples + where + genWorld x = W.newWorld $ snd x s + theWinCondition = maybe NoWinCondition @@ -1159,7 +1234,7 @@ 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, first fromEnum . wf) +buildWorld em WorldDescription {..} = (robots worldName, first fromEnum . wf) where rs = fromIntegral $ length area cs = fromIntegral $ length (head area) @@ -1177,13 +1252,13 @@ buildWorld em WorldDescription {..} = (robots, first fromEnum . wf) Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e)) -- Get all the robots described in cells and set their locations appropriately - robots :: [IndexedTRobot] - robots = + robots :: SubworldName -> [IndexedTRobot] + robots swName = area & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices & concat & concatMap ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) -> - let robotWithLoc = trobotLocation ?~ W.coordsToLoc (Coords (ulr + r, ulc + c)) + let robotWithLoc = trobotLocation ?~ Cosmic swName (W.coordsToLoc (Coords (ulr + r, ulc + c))) in map (fmap robotWithLoc) robotList ) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 666a7f925..80cbe3ed3 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -30,7 +30,7 @@ import Control.Effect.Error import Control.Effect.Lens import Control.Effect.Lift import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (foldM, forM, forM_, guard, msum, unless, when, zipWithM) +import Control.Monad (foldM, forM, forM_, guard, join, msum, unless, when, zipWithM) import Control.Monad.Except (runExceptT) import Data.Array (bounds, (!)) import Data.Bifunctor (second) @@ -75,9 +75,10 @@ import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective qualified as OB import Swarm.Game.Scenario.Objective.WinCheck qualified as WC -import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) +import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), cosmoLocation) import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.Value import Swarm.Game.World qualified as W import Swarm.Language.Capability @@ -378,7 +379,20 @@ getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic -- -- Use ID (-1) so it won't conflict with any robots currently in the robot map. hypotheticalRobot :: CESK -> TimeSpec -> Robot -hypotheticalRobot c = mkRobot (-1) Nothing "hypothesis" [] zero zero defaultRobotDisplay c [] [] True False +hypotheticalRobot c = + mkRobot + (-1) + Nothing + "hypothesis" + [] + defaultCosmicLocation + zero + defaultRobotDisplay + c + [] + [] + True + False evaluateCESK :: (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => @@ -413,24 +427,36 @@ flagRedraw = needsRedraw .= True -- | Perform an action requiring a 'W.World' state component in a -- larger context with a 'GameState'. -zoomWorld :: (Has (State GameState) sig m) => StateC (W.World Int Entity) Identity b -> m b -zoomWorld n = do - w <- use world - let (w', a) = run (runState w n) - world .= w' - return a +zoomWorld :: + (Has (State GameState) sig m) => + SubworldName -> + StateC (W.World Int Entity) Identity b -> + m (Maybe b) +zoomWorld swName n = do + mw <- use multiWorld + forM (M.lookup swName mw) $ \w -> do + let (w', a) = run (runState w n) + multiWorld %= M.insert swName w' + return a -- | Get the entity (if any) at a given location. -entityAt :: (Has (State GameState) sig m) => Location -> m (Maybe Entity) -entityAt loc = zoomWorld (W.lookupEntityM @Int (W.locToCoords loc)) +entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity) +entityAt (Cosmic subworldName loc) = + join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc)) -- | Modify the entity (if any) at a given location. updateEntityAt :: - (Has (State GameState) sig m) => Location -> (Maybe Entity -> Maybe Entity) -> m () -updateEntityAt loc upd = do - didChange <- zoomWorld $ W.updateM @Int (W.locToCoords loc) upd + (Has (State GameState) sig m) => + Cosmic Location -> + (Maybe Entity -> Maybe Entity) -> + m () +updateEntityAt cLoc@(Cosmic subworldName loc) upd = do + didChange <- + fmap (fromMaybe False) $ + zoomWorld subworldName $ + W.updateM @Int (W.locToCoords loc) upd when didChange $ - wakeWatchingRobots loc + wakeWatchingRobots cLoc -- | Get the robot with a given ID. robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot) @@ -483,13 +509,17 @@ randomName = do -- | Create a log entry given current robot and game time in ticks noting whether it has been said. -- -- This is the more generic version used both for (recorded) said messages and normal logs. -createLogEntry :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry +createLogEntry :: + (Has (State GameState) sig m, Has (State Robot) sig m) => + LogSource -> + Text -> + m LogEntry createLogEntry source msg = do rid <- use robotID rn <- use robotName time <- use ticks loc <- use robotLocation - pure $ LogEntry time source rn rid loc msg + pure $ LogEntry time source rn rid (Located loc) msg -- | Print some text via the robot's log. traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry @@ -608,8 +638,8 @@ updateWorld :: WorldUpdate Entity -> m () updateWorld c (ReplaceEntity loc eThen down) = do - w <- use world - let eNow = W.lookupEntity (W.locToCoords loc) w + w <- use multiWorld + let eNow = W.lookupCosmicEntity (fmap W.locToCoords loc) w -- Can fail if a robot started a multi-tick "drill" operation on some entity -- and meanwhile another entity swaps it out from under them. if Just eThen /= eNow @@ -1034,7 +1064,13 @@ seedProgram minTime randTime thing = -- | Construct a "seed robot" from entity, time range and position, -- and add it to the world. It has low priority and will be covered -- by placed entities. -addSeedBot :: Has (State GameState) sig m => Entity -> (Integer, Integer) -> Location -> TimeSpec -> m () +addSeedBot :: + Has (State GameState) sig m => + Entity -> + (Integer, Integer) -> + Cosmic Location -> + TimeSpec -> + m () addSeedBot e (minT, maxT) loc ts = void $ addTRobot $ @@ -1095,7 +1131,7 @@ execConst c vs s k = do -- Figure out where we're going loc <- use robotLocation orient <- use robotOrientation - let nextLoc = loc .+^ (orient ? zero) + let nextLoc = loc `offsetBy` (orient ? zero) checkMoveAhead nextLoc $ MoveFailure { failIfBlocked = ThrowExn @@ -1107,9 +1143,9 @@ execConst c vs s k = do -- Figure out where we're going loc <- use robotLocation orient <- use robotOrientation - let heading = orient ? zero - nextLoc = loc .+^ heading - placementLoc = nextLoc .+^ heading + let applyHeading = (`offsetBy` (orient ? zero)) + nextLoc = applyHeading loc + placementLoc = applyHeading nextLoc -- If unobstructed, the robot will move even if -- there is nothing to push. @@ -1153,11 +1189,11 @@ execConst c vs s k = do let heading = orient ? zero -- Excludes the base location. - let locsInDirection :: [Location] + let locsInDirection :: [Cosmic Location] locsInDirection = take (min (fromIntegral d) maxStrideRange) $ drop 1 $ - iterate (.+^ heading) loc + iterate (`offsetBy` heading) loc failureMaybes <- mapM checkMoveFailure locsInDirection let maybeFirstFailure = asum failureMaybes @@ -1182,7 +1218,7 @@ execConst c vs s k = do target <- getRobotWithinTouch rid -- either change current robot or one in robot map let oldLoc = target ^. robotLocation - nextLoc = Location (fromIntegral x) (fromIntegral y) + nextLoc = fmap (const $ Location (fromIntegral x) (fromIntegral y)) oldLoc onTarget rid $ do checkMoveAhead nextLoc $ @@ -1364,24 +1400,26 @@ execConst c vs s k = do selfRid <- use robotID -- Includes the base location, so we exclude the base robot later. - let locsInDirection :: [Location] - locsInDirection = take maxScoutRange $ iterate (.+^ heading) myLoc + let locsInDirection :: [Cosmic Location] + locsInDirection = take maxScoutRange $ iterate (`offsetBy` heading) myLoc let hasOpaqueEntity = fmap (maybe False (`hasProperty` E.Opaque)) . entityAt - let hasVisibleBot :: Location -> Bool + let hasVisibleBot :: Cosmic Location -> Bool hasVisibleBot = any botIsVisible . IS.toList . excludeSelf . botsHere where excludeSelf = (`IS.difference` IS.singleton selfRid) - botsHere loc = M.findWithDefault mempty loc botsByLocs + botsHere (Cosmic swName loc) = + M.findWithDefault mempty loc $ + M.findWithDefault mempty swName botsByLocs botIsVisible = maybe False canSee . (`IM.lookup` rMap) canSee = not . (^. robotDisplay . invisible) -- A robot on the same cell as an opaque entity is considered hidden. -- Returns (Just Bool) if the result is conclusively visible or opaque, -- or Nothing if we don't have a conclusive answer yet. - let isConclusivelyVisible :: Bool -> Location -> Maybe Bool + let isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool isConclusivelyVisible isOpaque loc | isOpaque = Just False | hasVisibleBot loc = Just True @@ -1400,11 +1438,12 @@ execConst c vs s k = do _ -> badConst Whereami -> do loc <- use robotLocation - return $ Out (asValue loc) s k + return $ Out (asValue $ loc ^. planar) s k Waypoint -> case vs of [VText name, VInt idx] -> do lm <- use worldNavigation - case M.lookup (WaypointName name) (waypoints lm) of + Cosmic swName _ <- use robotLocation + case M.lookup (WaypointName name) $ M.findWithDefault mempty swName $ waypoints lm of Nothing -> throwError $ CmdFailed Waypoint (T.unwords ["No waypoint named", name]) Nothing Just wps -> return $ Out (asValue (NE.length wps, indexWrapNonEmpty wps idx)) s k _ -> badConst @@ -1413,8 +1452,9 @@ execConst c vs s k = do loc <- use robotLocation let locs = rectCells x1 y1 x2 y2 -- sort offsets by (Manhattan) distance so that we return the closest occurrence - let sortedLocs = sortOn (\(V2 x y) -> abs x + abs y) locs - firstOne <- findM (fmap (maybe False $ isEntityNamed name) . entityAt . (loc .+^)) sortedLocs + let sortedOffsets = sortOn (\(V2 x y) -> abs x + abs y) locs + let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc + firstOne <- findM f sortedOffsets return $ Out (asValue firstOne) s k _ -> badConst Resonate -> case vs of @@ -1436,7 +1476,8 @@ execConst c vs s k = do _ -> badConst Surveil -> case vs of [VPair (VInt x) (VInt y)] -> do - let loc = Location (fromIntegral x) (fromIntegral y) + Cosmic swName _ <- use robotLocation + let loc = Cosmic swName $ Location (fromIntegral x) (fromIntegral y) addWatchedLocation loc return $ Out VUnit s k _ -> badConst @@ -1485,7 +1526,7 @@ execConst c vs s k = do Blocked -> do loc <- use robotLocation orient <- use robotOrientation - let nextLoc = loc .+^ (orient ? zero) + let nextLoc = loc `offsetBy` (orient ? zero) me <- entityAt nextLoc return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) s k Scan -> case vs of @@ -1576,12 +1617,18 @@ execConst c vs s k = do loc <- use robotLocation m <- traceLog Said msg -- current robot will inserted to robot set, so it needs the log emitMessage m - let addLatestClosest rl = \case + let measureToLog robLoc rawLogLoc = case rawLogLoc of + Located logLoc -> cosmoMeasure manhattan robLoc logLoc + Omnipresent -> Measurable 0 + addLatestClosest rl = \case Seq.Empty -> Seq.singleton m es Seq.:|> e - | e ^. leTime < m ^. leTime -> es |> e |> m - | manhattan rl (e ^. leLocation) > manhattan rl (m ^. leLocation) -> es |> m + | e `isEarlierThan` m -> es |> e |> m + | e `isFartherThan` m -> es |> m | otherwise -> es |> e + where + isEarlierThan = (<) `on` (^. leTime) + isFartherThan = (>) `on` (measureToLog rl . view leLocation) let addToRobotLog :: Has (State GameState) sgn m => Robot -> m () addToRobotLog r = do maybeRidLoc <- evalState r $ do @@ -1729,7 +1776,7 @@ execConst c vs s k = do g <- get @GameState let neighbor = find ((/= rid) . (^. robotID)) -- pick one other than ourself - . sortOn (manhattan loc . (^. robotLocation)) -- prefer closer + . sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer $ robotsInArea loc 1 g -- all robots within Manhattan distance 1 return $ Out (asValue neighbor) s k MeetAll -> case vs of @@ -1840,7 +1887,8 @@ execConst c vs s k = do -- a robot can program adjacent robots -- privileged bots ignore distance checks loc <- use robotLocation - (isPrivileged || (childRobot ^. robotLocation) `manhattan` loc <= 1) + + isNearbyOrExempt isPrivileged loc (childRobot ^. robotLocation) `holdsOrFail` ["You can only reprogram an adjacent robot."] -- Figure out if we can supply what the target robot requires, @@ -2177,8 +2225,8 @@ execConst c vs s k = do m CESK doResonate p x1 y1 x2 y2 = do loc <- use robotLocation - let locs = rectCells x1 y1 x2 y2 - hits <- mapM (fmap (fromEnum . p) . entityAt . (loc .+^)) locs + let offsets = rectCells x1 y1 x2 y2 + hits <- mapM (fmap (fromEnum . p) . entityAt . offsetBy loc) offsets return $ Out (VInt $ fromIntegral $ sum hits) s k rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32] @@ -2201,10 +2249,11 @@ execConst c vs s k = do m (Maybe (Int32, V2 Int32)) findNearest name = do loc <- use robotLocation - findM (fmap (maybe False $ isEntityNamed name) . entityAt . (loc .+^) . snd) sortedLocs + let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc . snd + findM f sortedOffsets where - sortedLocs :: [(Int32, V2 Int32)] - sortedLocs = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange] + sortedOffsets :: [(Int32, V2 Int32)] + sortedOffsets = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange] -- Grow a list of locations in a diamond shape outward, such that the nearest cells -- are searched first by construction, rather than having to sort. @@ -2239,11 +2288,11 @@ execConst c vs s k = do when (isCardinal d) $ hasCapabilityFor COrient $ TDir d return $ applyTurn d $ orient ? zero - lookInDirection :: HasRobotStepState sig m => Direction -> m (Location, Maybe Entity) + lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity) lookInDirection d = do newHeading <- deriveHeading d loc <- use robotLocation - let nextLoc = loc .+^ newHeading + let nextLoc = loc `offsetBy` newHeading (nextLoc,) <$> entityAt nextLoc ensureEquipped :: HasRobotStepState sig m => Text -> m Entity @@ -2421,7 +2470,7 @@ execConst c vs s k = do -- Make sure nothing is in the way. Note that system robots implicitly ignore -- and base throws on failure. - checkMoveFailure :: HasRobotStepState sig m => Location -> m (Maybe MoveFailureDetails) + checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureDetails) checkMoveFailure nextLoc = do me <- entityAt nextLoc systemRob <- use systemRobot @@ -2463,7 +2512,7 @@ execConst c vs s k = do IgnoreFail -> return () -- Determine the move failure mode and apply the corresponding effect. - checkMoveAhead :: HasRobotStepState sig m => Location -> MoveFailure -> m () + checkMoveAhead :: HasRobotStepState sig m => Cosmic Location -> MoveFailure -> m () checkMoveAhead nextLoc failureHandlers = do maybeFailure <- checkMoveFailure nextLoc applyMoveFailureEffect maybeFailure failureHandlers @@ -2571,7 +2620,7 @@ execConst c vs s k = do addWatchedLocation :: HasRobotStepState sig m => - Location -> + Cosmic Location -> m () addWatchedLocation loc = do rid <- use robotID @@ -2604,9 +2653,11 @@ isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode -- | Requires that the target location is within one cell. -- Requirement is waived if the bot is privileged. -isNearbyOrExempt :: Bool -> Location -> Location -> Bool +isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool isNearbyOrExempt privileged myLoc otherLoc = - privileged || otherLoc `manhattan` myLoc <= 1 + privileged || case cosmoMeasure manhattan myLoc otherLoc of + InfinitelyFar -> False + Measurable x -> x <= 1 grantAchievement :: (Has (State GameState) sig m, Has (Lift IO) sig m) => @@ -2687,33 +2738,22 @@ provisionChild childID toEquip toGive = do -- Also implements teleportation by portals. updateRobotLocation :: (HasRobotStepState sig m) => - Location -> - Location -> + Cosmic Location -> + Cosmic Location -> m () updateRobotLocation oldLoc newLoc | oldLoc == newLoc = return () | otherwise = do newlocWithPortal <- applyPortal newLoc rid <- use robotID - robotsByLocation . at oldLoc %= deleteOne rid - robotsByLocation . at newlocWithPortal . non Empty %= IS.insert rid + removeRobotFromLocationMap oldLoc rid + addRobotToLocation rid newlocWithPortal modify (unsafeSetRobotLocation newlocWithPortal) flagRedraw where applyPortal loc = do lms <- use worldNavigation - return $ M.findWithDefault loc loc $ portals lms - - -- Make sure empty sets don't hang around in the - -- robotsByLocation map. We don't want a key with an - -- empty set at every location any robot has ever - -- visited! - deleteOne _ Nothing = Nothing - deleteOne x (Just s) - | IS.null s' = Nothing - | otherwise = Just s' - where - s' = IS.delete x s + return . M.findWithDefault loc loc . M.map cosmoLocation $ portals lms -- | Execute a stateful action on a target robot --- whether the -- current one or another. diff --git a/src/Swarm/Game/Universe.hs b/src/Swarm/Game/Universe.hs new file mode 100644 index 000000000..acb660866 --- /dev/null +++ b/src/Swarm/Game/Universe.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Universe where + +import Control.Lens (makeLenses, view) +import Data.Function (on) +import Data.Int (Int32) +import Data.Text (Text) +import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:)) +import GHC.Generics (Generic) +import Linear (V2 (..)) +import Swarm.Game.Location + +data SubworldName = DefaultRootSubworld | SubworldName Text + deriving (Show, Eq, Ord, Generic, ToJSON) + +instance FromJSON SubworldName where + parseJSON = withText "subworld name" $ return . SubworldName + +renderWorldName :: SubworldName -> Text +renderWorldName = \case + SubworldName s -> s + DefaultRootSubworld -> "" + +-- | The swarm universe consists of locations +-- indexed by subworld. +-- Not only is this datatype useful for planar (2D) +-- coordinates, but is also used for named waypoints. +data Cosmic a = Cosmic + { _subworld :: SubworldName + , _planar :: a + } + deriving (Show, Eq, Ord, Functor, Generic, ToJSON) + +makeLenses ''Cosmic + +instance (FromJSON a) => FromJSON (Cosmic a) where + parseJSON x = case x of + Object v -> objParse v + _ -> Cosmic DefaultRootSubworld <$> parseJSON x + where + objParse v = + Cosmic + <$> v .: "subworld" + <*> v .: "loc" + +defaultCosmicLocation :: Cosmic Location +defaultCosmicLocation = Cosmic DefaultRootSubworld origin + +data DistanceMeasure b = Measurable b | InfinitelyFar + deriving (Eq, Ord) + +-- | Returns 'InfinitelyFar' if not within the same subworld. +cosmoMeasure :: (a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b +cosmoMeasure f a b + | ((/=) `on` view subworld) a b = InfinitelyFar + | otherwise = Measurable $ (f `on` view planar) a b + +offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location +offsetBy loc v = fmap (.+^ v) loc diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index c32e919b1..4d0ff3f51 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -23,6 +23,7 @@ module Swarm.Game.World ( WorldFun (..), worldFunFromArray, World, + MultiWorld, -- ** Tile management loadCell, @@ -31,7 +32,9 @@ module Swarm.Game.World ( -- ** World functions newWorld, emptyWorld, + lookupCosmicTerrain, lookupTerrain, + lookupCosmicEntity, lookupEntity, update, @@ -55,11 +58,14 @@ 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.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.Util ((?)) import Prelude hiding (lookup) @@ -187,6 +193,8 @@ type TerrainTile t = U.UArray TileOffset t -- which have to be boxed. type EntityTile e = A.Array TileOffset (Maybe e) +type MultiWorld t e = Map SubworldName (World t e) + -- | A 'World' consists of a 'WorldFun' that specifies the initial -- world, a cache of loaded square tiles to make lookups faster, and -- a map storing locations whose entities have changed from their @@ -214,6 +222,14 @@ newWorld f = World f M.empty M.empty emptyWorld :: t -> World t e emptyWorld t = newWorld (WF $ const (t, Nothing)) +lookupCosmicTerrain :: + IArray U.UArray Int => + Cosmic Coords -> + MultiWorld Int e -> + TerrainType +lookupCosmicTerrain (Cosmic subworldName i) multiWorld = + maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName multiWorld + -- | Look up the terrain value at certain coordinates: try looking it -- up in the tile cache first, and fall back to running the 'WorldFun' -- otherwise. @@ -228,11 +244,19 @@ lookupTerrain i (World f t _) = -- | A stateful variant of 'lookupTerrain', which first loads the tile -- containing the given coordinates if it is not already loaded, -- then looks up the terrain value. -lookupTerrainM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m t +lookupTerrainM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m t lookupTerrainM c = do modify @(World t e) $ loadCell c lookupTerrain c <$> get @(World t e) +lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e +lookupCosmicEntity (Cosmic subworldName i) multiWorld = + lookupEntity i =<< M.lookup subworldName multiWorld + -- | Look up the entity at certain coordinates: first, see if it is in -- the map of locations with changed entities; then try looking it -- up in the tile cache first; and finally fall back to running the @@ -246,10 +270,14 @@ lookupEntity i (World f t m) = ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t) ? snd (runWF f i) --- | A stateful variant of 'lookupTerrain', which first loads the tile +-- | A stateful variant of 'lookupEntity', which first loads the tile -- containing the given coordinates if it is not already loaded, -- then looks up the terrain value. -lookupEntityM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m (Maybe e) +lookupEntityM :: + forall t e sig m. + (Has (State (World t e)) sig m, IArray U.UArray t) => + Coords -> + m (Maybe e) lookupEntityM c = do modify @(World t e) $ loadCell c lookupEntity c <$> get @(World t e) @@ -258,7 +286,11 @@ lookupEntityM c = do -- returning an updated 'World' and a Boolean indicating whether -- the update changed the entity here. -- See also 'updateM'. -update :: Coords -> (Maybe Entity -> Maybe Entity) -> World t Entity -> (World t Entity, Bool) +update :: + Coords -> + (Maybe Entity -> Maybe Entity) -> + World t Entity -> + (World t Entity, Bool) update i g w@(World f t m) = (wNew, ((/=) `on` fmap (view entityHash)) entityAfter entityBefore) where @@ -283,7 +315,12 @@ loadCell c = loadRegion (c, c) -- | Load all the tiles which overlap the given rectangular region -- (specified as an upper-left and lower-right corner, inclusive). -loadRegion :: forall t e. (IArray U.UArray t) => (Coords, Coords) -> World t e -> World t e +loadRegion :: + forall t e. + (IArray U.UArray t) => + (Coords, Coords) -> + World t e -> + World t e loadRegion reg (World f t m) = World f t' m where tiles = range (over both tileCoords reg) @@ -308,7 +345,7 @@ loadRegion reg (World f t m) = World f t' m -- This type is used for changes by e.g. the drill command at later -- tick. Using ADT allows us to serialize and inspect the updates. data WorldUpdate e = ReplaceEntity - { updatedLoc :: Location + { updatedLoc :: Cosmic Location , originalEntity :: e , newEntity :: Maybe e } diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index a7f066d88..808277c04 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -697,7 +697,8 @@ constInfo c = case c of Whereami -> command 0 Intangible "Get the current x and y coordinates." Waypoint -> command 2 Intangible . doc "Get the x, y coordinates of a named waypoint, by index" $ - [ "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))." + [ "Return only the waypoints in the same subworld as the calling robot." + , "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))." , "The supplied index will be wrapped automatically, modulo the waypoint count." , "A robot can use the count to know whether they have iterated over the full waypoint circuit." ] diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 0b4f05844..eb60a2a31 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -378,6 +378,7 @@ handleMainEvent ev = do | s ^. uiState . uiCheatMode -> do uiState . uiWorldEditor . isWorldEditorEnabled %= not setFocus WorldEditorPanel + MouseDown WorldPositionIndicator _ _ _ -> uiState . uiWorldCursor .= Nothing MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> -- Eye Dropper tool EC.handleMiddleClick mouseLoc @@ -1341,7 +1342,7 @@ scrollView update = do -- always work, but there seems to be some sort of race condition -- where 'needsRedraw' gets reset before the UI drawing code runs. invalidateCacheEntry WorldCache - gameState %= modifyViewCenter update + gameState %= modifyViewCenter (fmap update) -- | Convert a directional key into a direction. keyToDir :: V.Key -> Heading diff --git a/src/Swarm/TUI/Controller/Util.hs b/src/Swarm/TUI/Controller/Util.hs index ec69c8d42..4b1386de9 100644 --- a/src/Swarm/TUI/Controller/Util.hs +++ b/src/Swarm/TUI/Controller/Util.hs @@ -9,8 +9,10 @@ import Brick.Focus import Control.Lens import Control.Monad (forM_, unless) import Control.Monad.IO.Class (liftIO) +import Data.Map qualified as M import Graphics.Vty qualified as V import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Model import Swarm.TUI.Model.UI @@ -77,17 +79,18 @@ loadVisibleRegion = do mext <- lookupExtent WorldExtent forM_ mext $ \(Extent _ _ size) -> do gs <- use gameState - gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size)) + let vr = viewingRegion gs (over both fromIntegral size) + gameState . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld) -mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe W.Coords) +mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmic W.Coords)) mouseLocToWorldCoords (Brick.Location mouseLoc) = do mext <- lookupExtent WorldExtent case mext of Nothing -> pure Nothing Just ext -> do region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) - let regionStart = W.unCoords (fst region) + let regionStart = W.unCoords (fst $ region ^. planar) mouseLoc' = bimap fromIntegral fromIntegral mouseLoc mx = snd mouseLoc' + fst regionStart my = fst mouseLoc' + snd regionStart - in pure . Just $ W.Coords (mx, my) + in pure . Just $ Cosmic (region ^. subworld) $ W.Coords (mx, my) diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index f31440f68..712497962 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -16,6 +16,7 @@ import Data.Yaml qualified as Y import Graphics.Vty qualified as V import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Model @@ -39,7 +40,7 @@ activateWorldEditorFunction AreaSelector = do SelectionComplete -> uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= UpperLeftPending _ -> return () activateWorldEditorFunction OutputPathSelector = - -- TODO + -- TODO: #1371 liftIO $ putStrLn "File selection" activateWorldEditorFunction MapSaveButton = saveMapFile activateWorldEditorFunction ClearEntityButton = @@ -56,7 +57,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 (terrain, maybeEntityPaint) + uiState . uiWorldEditor . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeEntityPaint) uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing immediatelyRedrawWorld return () @@ -67,7 +68,7 @@ handleRightClick mouseLoc = do _ <- runMaybeT $ do guard $ worldEditor ^. isWorldEditorEnabled mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc - uiState . uiWorldEditor . paintedTerrain %= M.delete mouseCoords + uiState . uiWorldEditor . paintedTerrain %= M.delete (mouseCoords ^. planar) immediatelyRedrawWorld return () @@ -76,7 +77,7 @@ handleMiddleClick :: B.Location -> EventM Name AppState () handleMiddleClick mouseLoc = do worldEditor <- use $ uiState . uiWorldEditor when (worldEditor ^. isWorldEditorEnabled) $ do - w <- use $ gameState . world + w <- use $ gameState . multiWorld let setTerrainPaint coords = do let (terrain, maybeElementPaint) = EU.getContentAt @@ -108,7 +109,7 @@ handleWorldEditorPanelEvent = \case _ -> return () -- | Return value: whether the cursor position should be updated -updateAreaBounds :: Maybe W.Coords -> EventM Name AppState Bool +updateAreaBounds :: Maybe (Cosmic W.Coords) -> EventM Name AppState Bool updateAreaBounds = \case Nothing -> return True Just mouseCoords -> do @@ -117,10 +118,11 @@ updateAreaBounds = \case UpperLeftPending -> do uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= LowerRightPending mouseCoords return False - -- TODO (#1152): Validate that the lower-right click is below and to the right of the top-left coord + -- TODO (#1152): Validate that the lower-right click is below and to the right of + -- the top-left coord and that they are within the same subworld LowerRightPending upperLeftMouseCoords -> do uiState . uiWorldEditor . editingBounds . boundsRect - .= Just (upperLeftMouseCoords, mouseCoords) + .= Just (fmap (,view planar mouseCoords) upperLeftMouseCoords) uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete t <- liftIO $ getTime Monotonic @@ -133,7 +135,7 @@ saveMapFile :: EventM Name AppState () saveMapFile = do worldEditor <- use $ uiState . uiWorldEditor maybeBounds <- use $ uiState . uiWorldEditor . editingBounds . boundsRect - w <- use $ gameState . world + w <- use $ gameState . multiWorld let mapCellGrid = EU.getEditedMapRectangle worldEditor maybeBounds w let fp = worldEditor ^. outputFilePath diff --git a/src/Swarm/TUI/Editor/Masking.hs b/src/Swarm/TUI/Editor/Masking.hs index 93274e5e5..2cd94f0a6 100644 --- a/src/Swarm/TUI/Editor/Masking.hs +++ b/src/Swarm/TUI/Editor/Masking.hs @@ -2,6 +2,7 @@ module Swarm.TUI.Editor.Masking where import Control.Lens hiding (Const, from) import Data.Maybe (fromMaybe) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.Util qualified as EU @@ -20,11 +21,11 @@ shouldHideWorldCell ui coords = False ( do bounds <- we ^. editingBounds . boundsRect - pure $ EU.isOutsideRegion bounds coords + pure $ EU.isOutsideRegion (bounds ^. planar) coords ) isOutsideSingleSelectedCorner = fromMaybe False $ do - cornerCoords <- case we ^. editingBounds . boundsSelectionStep of + Cosmic _ cornerCoords <- case we ^. editingBounds . boundsSelectionStep of LowerRightPending cornerCoords -> Just cornerCoords _ -> Nothing pure $ EU.isOutsideTopLeftCorner cornerCoords coords diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs index 7b50f13fd..02de5d9ae 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ b/src/Swarm/TUI/Editor/Model.hs @@ -13,6 +13,7 @@ import Swarm.Game.Entity qualified as E import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Model.Name import Swarm.Util @@ -21,7 +22,7 @@ import System.Clock data BoundsSelectionStep = UpperLeftPending | -- | Stores the *world coords* of the upper-left click - LowerRightPending W.Coords + LowerRightPending (Cosmic W.Coords) | SelectionComplete data EntityPaint @@ -42,7 +43,7 @@ getEntityName :: EntityFacade -> EntityName getEntityName (EntityFacade name _) = name data MapEditingBounds = MapEditingBounds - { _boundsRect :: Maybe W.BoundsRectangle + { _boundsRect :: Maybe (Cosmic W.BoundsRectangle) -- ^ Upper-left and lower-right coordinates -- of the map to be saved. , _boundsPersistDisplayUntil :: TimeSpec @@ -82,6 +83,6 @@ initialWorldEditor ts = MapEditingBounds -- Note that these are in "world coordinates", -- not in player-facing "Location" coordinates - (Just (W.Coords (-10, -20), W.Coords (10, 20))) + (Just $ Cosmic DefaultRootSubworld (W.Coords (-10, -20), W.Coords (10, 20))) (ts - 1) SelectionComplete diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs index 4f2f42152..122fe0bbc 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ b/src/Swarm/TUI/Editor/Palette.hs @@ -27,6 +27,7 @@ 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.Universe import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) import Swarm.Util (binTuples, histogram) import Swarm.Util qualified as U @@ -86,7 +87,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid = originalPalette :: KM.KeyMap CellPaintDisplay originalPalette = KM.map (toCellPaintDisplay . standardCell) $ - maybe mempty (unPalette . palette . (^. scenarioWorld)) maybeOriginalScenario + maybe mempty (unPalette . palette . NE.head . (^. scenarioWorlds)) maybeOriginalScenario pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain @@ -128,6 +129,7 @@ constructScenario maybeOriginalScenario cellGrid = , ul = upperLeftCoord , area = cellGrid , navigation = Navigation mempty mempty + , worldName = DefaultRootSubworld } suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs index 86a3d8861..1fcbd2235 100644 --- a/src/Swarm/TUI/Editor/Util.hs +++ b/src/Swarm/TUI/Editor/Util.hs @@ -14,6 +14,7 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Editor.Model import Swarm.TUI.Model @@ -24,19 +25,19 @@ getEntitiesForList em = where entities = M.elems $ entitiesByName em -getEditingBounds :: WorldDescription -> (Bool, W.BoundsRectangle) +getEditingBounds :: WorldDescription -> (Bool, Cosmic W.BoundsRectangle) getEditingBounds myWorld = (EA.isEmpty a, newBounds) where - newBounds = (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) + newBounds = Cosmic DefaultRootSubworld (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) upperLeftLoc = ul myWorld a = EA.getAreaDimensions $ area myWorld lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc getContentAt :: WorldEditor Name -> - W.World Int Entity -> - W.Coords -> + W.MultiWorld Int Entity -> + Cosmic W.Coords -> (TerrainType, Maybe EntityPaint) getContentAt editor w coords = (terrainWithOverride, entityWithOverride) @@ -51,20 +52,21 @@ getContentAt editor w coords = maybePaintedCell = do guard $ editor ^. isWorldEditorEnabled - Map.lookup coords pm + Map.lookup (coords ^. planar) pm pm = editor ^. paintedTerrain entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride - underlyingCellEntity = W.lookupEntity coords w - underlyingCellTerrain = toEnum $ W.lookupTerrain coords w + underlyingCellEntity = W.lookupCosmicEntity coords w + underlyingCellTerrain = W.lookupCosmicTerrain coords w getTerrainAt :: WorldEditor Name -> - W.World Int Entity -> - W.Coords -> + W.MultiWorld Int Entity -> + Cosmic W.Coords -> TerrainType -getTerrainAt editor w coords = fst $ getContentAt editor w coords +getTerrainAt editor w coords = + fst $ getContentAt editor w coords isOutsideTopLeftCorner :: -- | top left corner coords @@ -95,16 +97,16 @@ isOutsideRegion (tl, br) coord = getEditedMapRectangle :: WorldEditor Name -> - Maybe W.BoundsRectangle -> - W.World Int Entity -> + Maybe (Cosmic W.BoundsRectangle) -> + W.MultiWorld Int Entity -> [[CellPaintDisplay]] getEditedMapRectangle _ Nothing _ = [] -getEditedMapRectangle worldEditor (Just coords) w = +getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w = map renderRow [yTop .. yBottom] where (W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords - getContent = getContentAt worldEditor w + getContent = getContentAt worldEditor w . Cosmic subworldName drawCell :: Int32 -> Int32 -> CellPaintDisplay drawCell rowIndex colIndex = diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs index cee307b69..51fba78f0 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ b/src/Swarm/TUI/Editor/View.hs @@ -9,6 +9,7 @@ import Data.List qualified as L import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Attr import Swarm.TUI.Border @@ -92,7 +93,7 @@ drawWorldEditor toplevelFocusRing uis = areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of UpperLeftPending -> str "Click top-left" LowerRightPending _wcoords -> str "Click bottom-right" - SelectionComplete -> maybe emptyWidget renderBounds maybeAreaBounds + SelectionComplete -> maybe emptyWidget (renderBounds . view planar) maybeAreaBounds areaWidget = mkFormControl (WorldEditorPanelControl AreaSelector) $ diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs index 65cd7fbd7..706f619d0 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -133,7 +133,6 @@ import Data.Text.IO qualified as T (readFile) import Data.Vector qualified as V import GitHash (GitInfo) import Graphics.Vty (ColorMode (..)) -import Linear (zero) import Network.Wai.Handler.Warp (Port) import Swarm.Game.CESK (TickNumber (..)) import Swarm.Game.Entity as E @@ -154,6 +153,7 @@ import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI +import Swarm.Util (failT, showT) import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease)) import Text.Fuzzy qualified as Fuzzy @@ -209,7 +209,7 @@ initRuntimeState = do namesFile <- getDataFileNameSafe NameGeneration "names.txt" return (adjsFile, namesFile) - let markEx what a = catchError a (\e -> fail $ "Failed to " <> what <> ": " <> show e) + let markEx what a = catchError a (\e -> failT ["Failed to", what <> ":", showT e]) (adjs, names) <- liftIO . markEx "load name generation data" $ do as <- tail . T.lines <$> T.readFile adjsFile ns <- tail . T.lines <$> T.readFile namesFile @@ -273,7 +273,7 @@ logEvent src (who, rid) msg el = & notificationsCount %~ succ & notificationsContent %~ (l :) where - l = LogEntry (TickNumber 0) src who rid zero msg + l = LogEntry (TickNumber 0) src who rid Omnipresent msg -- | Create a 'GameStateConfig' record from the 'RuntimeState'. mkGameStateConfig :: RuntimeState -> GameStateConfig diff --git a/src/Swarm/TUI/Model/Name.hs b/src/Swarm/TUI/Model/Name.hs index ca5310680..f58c0bf73 100644 --- a/src/Swarm/TUI/Model/Name.hs +++ b/src/Swarm/TUI/Model/Name.hs @@ -62,6 +62,8 @@ data Name WorldCache | -- | The cached extent for the world view. WorldExtent + | -- | The cursor/viewCenter display in the bottom left of the World view + WorldPositionIndicator | -- | The list of possible entities to paint a map with. EntityPaintList | -- | The entity paint item position in the EntityPaintList. diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index 7afbed9a0..be91b7310 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -26,6 +26,7 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execStateT) import Data.List qualified as List +import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) @@ -36,7 +37,7 @@ import Swarm.Game.Achievement.Persistence import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Failure.Render (prettyFailure) import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace)) -import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorld) +import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorlds) import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics @@ -235,8 +236,7 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do where entityList = EU.getEntitiesForList $ gs ^. entityMap - myWorld = scenario ^. scenarioWorld - (isEmptyArea, newBounds) = EU.getEditingBounds myWorld + (isEmptyArea, newBounds) = EU.getEditingBounds $ NE.head $ scenario ^. scenarioWorlds setNewBounds maybeOldBounds = if isEmptyArea then maybeOldBounds diff --git a/src/Swarm/TUI/Model/UI.hs b/src/Swarm/TUI/Model/UI.hs index 5aedef169..2d16ec951 100644 --- a/src/Swarm/TUI/Model/UI.hs +++ b/src/Swarm/TUI/Model/UI.hs @@ -75,6 +75,7 @@ import Swarm.Game.ResourceLoading (getSwarmHistoryPath, readAppData) import Swarm.Game.ScenarioInfo ( ScenarioInfoPair, ) +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Attr (swarmAttrMap) import Swarm.TUI.Editor.Model @@ -101,7 +102,7 @@ data UIState = UIState , _uiCheatMode :: Bool , _uiFocusRing :: FocusRing Name , _uiLaunchConfig :: LaunchOptions - , _uiWorldCursor :: Maybe W.Coords + , _uiWorldCursor :: Maybe (Cosmic W.Coords) , _uiWorldEditor :: WorldEditor Name , _uiREPL :: REPLState , _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry) @@ -159,7 +160,7 @@ uiLaunchConfig :: Lens' UIState LaunchOptions uiFocusRing :: Lens' UIState (FocusRing Name) -- | The last clicked position on the world view. -uiWorldCursor :: Lens' UIState (Maybe W.Coords) +uiWorldCursor :: Lens' UIState (Maybe (Cosmic W.Coords)) -- | State of all World Editor widgets uiWorldEditor :: Lens' UIState (WorldEditor Name) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 9afb74741..6a6133d20 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -87,6 +87,7 @@ import Swarm.Game.ScenarioInfo ( scenarioItemName, ) import Swarm.Game.State +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Language.Capability (Capability (..), constCaps) import Swarm.Language.Pretty (prettyText) @@ -416,11 +417,11 @@ drawGameUI s = ] ] where - addCursorPos = case s ^. uiState . uiWorldCursor of - Nothing -> id - Just coord -> - let worldCursorInfo = drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord - in bottomLabels . leftLabel ?~ padLeftRight 1 worldCursorInfo + addCursorPos = bottomLabels . leftLabel ?~ padLeftRight 1 widg + where + widg = case s ^. uiState . uiWorldCursor of + Nothing -> str $ renderCoordsString $ s ^. gameState . viewCenter + Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord -- Add clock display in top right of the world view if focused robot -- has a clock equipped addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (s ^. uiState . lgTicksPerSecond) $ s ^. gameState) @@ -462,14 +463,22 @@ drawGameUI s = ) ] -drawWorldCursorInfo :: WorldEditor Name -> GameState -> W.Coords -> Widget Name -drawWorldCursorInfo worldEditor g coords = +renderCoordsString :: Cosmic Location -> String +renderCoordsString (Cosmic sw coords) = + unwords $ VU.locationToString coords : suffix + where + suffix = case sw of + DefaultRootSubworld -> [] + SubworldName swName -> ["in", T.unpack swName] + +drawWorldCursorInfo :: WorldEditor Name -> GameState -> Cosmic W.Coords -> Widget Name +drawWorldCursorInfo worldEditor g cCoords = case getStatic g coords of Just s -> renderDisplay $ displayStatic s Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget] where - coordsWidget = - str $ VU.locationToString $ W.coordsToLoc coords + Cosmic _ coords = cCoords + coordsWidget = str $ renderCoordsString $ fmap W.coordsToLoc cCoords tileMembers = terrain : mapMaybe merge [entity, robot] tileMemberWidgets = @@ -481,9 +490,9 @@ drawWorldCursorInfo worldEditor g coords = where f cell preposition = [renderDisplay cell, txt preposition] - terrain = displayTerrainCell worldEditor g coords - entity = displayEntityCell worldEditor g coords - robot = displayRobotCell g coords + terrain = displayTerrainCell worldEditor g cCoords + entity = displayEntityCell worldEditor g cCoords + robot = displayRobotCell g cCoords merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible)) @@ -649,15 +658,16 @@ robotsListWidget s = hCenter table | robot ^. robotLogUpdated = "x" | otherwise = " " - locWidget = hBox [worldCell, txt $ " " <> locStr] + locWidget = hBox [worldCell, str $ " " <> locStr] where - rloc@(Location x y) = robot ^. robotLocation + rCoords = fmap W.locToCoords rLoc + rLoc = robot ^. robotLocation worldCell = drawLoc (s ^. uiState) g - (W.locToCoords rloc) - locStr = from (show x) <> " " <> from (show y) + rCoords + locStr = renderCoordsString rLoc statusWidget = case robot ^. machine of Waiting {} -> txt "waiting" @@ -666,11 +676,11 @@ robotsListWidget s = hCenter table | otherwise -> withAttr greenAttr $ txt "idle" basePos :: Point V2 Double - basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation) + basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation . planar) -- Keep the base and non system robot (e.g. no seed) isRelevant robot = robot ^. robotID == 0 || not (robot ^. systemRobot) -- Keep the robot that are less than 32 unit away from the base - isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation) basePos < 32 + isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation . planar) basePos < 32 robots :: [Robot] robots = filter (\robot -> debugging || (isRelevant robot && isNear robot)) @@ -1000,8 +1010,9 @@ drawWorld ui g = ctx <- getContext let w = ctx ^. availWidthL h = ctx ^. availHeightL - ixs = range (viewingRegion g (fromIntegral w, fromIntegral h)) - render . vBox . map hBox . chunksOf w . map (drawLoc ui g) $ ixs + vr = viewingRegion g (fromIntegral w, fromIntegral h) + ixs = range $ vr ^. planar + render . vBox . map hBox . chunksOf w . map (drawLoc ui g . Cosmic (vr ^. subworld)) $ ixs ------------------------------------------------------------ -- Robot inventory panel @@ -1017,7 +1028,7 @@ drawRobotPanel s -- away and a robot that does not exist. | Just r <- s ^. gameState . to focusedRobot , Just (_, lst) <- s ^. uiState . uiInventory = - let Location x y = r ^. robotLocation + let Cosmic _subworldName (Location x y) = r ^. robotLocation drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb in padBottom Max $ vBox diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs index ff770c745..5eb4f80dd 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ b/src/Swarm/TUI/View/CellDisplay.hs @@ -24,6 +24,7 @@ import Swarm.Game.Robot import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State import Swarm.Game.Terrain +import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Attr import Swarm.TUI.Editor.Masking @@ -39,30 +40,37 @@ renderDisplay :: Display -> Widget n renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] -- | Render the 'Display' for a specific location. -drawLoc :: UIState -> GameState -> W.Coords -> Widget Name -drawLoc ui g coords = +drawLoc :: UIState -> GameState -> Cosmic W.Coords -> Widget Name +drawLoc ui g cCoords@(Cosmic _ coords) = if shouldHideWorldCell ui coords then str " " else drawCell where showRobots = ui ^. uiShowRobots we = ui ^. uiWorldEditor - drawCell = renderDisplay $ displayLoc showRobots we g coords + drawCell = renderDisplay $ displayLoc showRobots we g cCoords -displayTerrainCell :: WorldEditor Name -> GameState -> W.Coords -> Display +displayTerrainCell :: + WorldEditor Name -> + GameState -> + Cosmic W.Coords -> + Display displayTerrainCell worldEditor g coords = - terrainMap M.! EU.getTerrainAt worldEditor (g ^. world) coords + terrainMap M.! EU.getTerrainAt worldEditor (g ^. multiWorld) coords -displayRobotCell :: GameState -> W.Coords -> [Display] +displayRobotCell :: + GameState -> + Cosmic W.Coords -> + [Display] displayRobotCell g coords = map (view robotDisplay) $ - robotsAtLocation (W.coordsToLoc coords) g + robotsAtLocation (fmap W.coordsToLoc coords) g -displayEntityCell :: WorldEditor Name -> GameState -> W.Coords -> [Display] +displayEntityCell :: WorldEditor Name -> GameState -> Cosmic W.Coords -> [Display] displayEntityCell worldEditor g coords = maybeToList $ displayForEntity <$> maybeEntity where - (_, maybeEntity) = EU.getContentAt worldEditor (g ^. world) coords + (_, maybeEntity) = EU.getContentAt worldEditor (g ^. multiWorld) coords displayForEntity :: EntityPaint -> Display displayForEntity e = (if known e then id else hidden) $ getDisplay e @@ -89,14 +97,19 @@ hidingMode g -- 'Display's for the terrain, entity, and robots at the location, and -- taking into account "static" based on the distance to the robot -- being @view@ed. -displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display -displayLoc showRobots we g coords = +displayLoc :: Bool -> WorldEditor Name -> GameState -> Cosmic W.Coords -> Display +displayLoc showRobots we g cCoords@(Cosmic _ coords) = staticDisplay g coords - <> displayLocRaw showRobots we g coords + <> displayLocRaw showRobots we g cCoords -- | Get the 'Display' for a specific location, by combining the -- 'Display's for the terrain, entity, and robots at the location. -displayLocRaw :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display +displayLocRaw :: + Bool -> + WorldEditor Name -> + GameState -> + Cosmic W.Coords -> + Display displayLocRaw showRobots worldEditor g coords = sconcat $ terrain NE.:| entity <> robots where terrain = displayTerrainCell worldEditor g coords @@ -152,7 +165,7 @@ getStatic g coords where -- Offset from the location of the view center to the location under -- consideration for display. - offset = W.coordsToLoc coords .-. (g ^. viewCenter) + offset = W.coordsToLoc coords .-. (g ^. viewCenter . planar) -- Hash. h = diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index 12883cff8..84146700e 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -21,6 +21,8 @@ module Swarm.Util ( histogram, findDup, both, + allEqual, + surfaceEmpty, -- * Directory utilities readFileMay, @@ -71,10 +73,11 @@ module Swarm.Util ( ) where import Control.Algebra (Has) +import Control.Applicative (Alternative) import Control.Effect.State (State, modify, state) import Control.Effect.Throw (Throw, throwError) import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<>~)) -import Control.Monad (unless, (<=<)) +import Control.Monad (guard, unless, (<=<)) import Control.Monad.Except (ExceptT (..), runExceptT) import Data.Bifunctor (Bifunctor (bimap), first) import Data.Char (isAlphaNum) @@ -189,6 +192,13 @@ findDup = go S.empty both :: Bifunctor p => (a -> d) -> p a a -> p d d both f = bimap f f +allEqual :: (Ord a) => [a] -> Bool +allEqual [] = True +allEqual (x : xs) = all (== x) xs + +surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a +surfaceEmpty isEmpty t = t <$ guard (not (isEmpty t)) + ------------------------------------------------------------ -- Directory stuff diff --git a/src/Swarm/Version.hs b/src/Swarm/Version.hs index 6a4ef8aaa..118c41d5b 100644 --- a/src/Swarm/Version.hs +++ b/src/Swarm/Version.hs @@ -24,6 +24,7 @@ import Data.Char (isDigit) import Data.Either (lefts, rights) import Data.Foldable (toList) import Data.Maybe (listToMaybe) +import Data.Text qualified as T import Data.Version (Version (..), parseVersion, showVersion) import Data.Yaml (ParseException, Parser, decodeEither', parseEither) import GitHash (GitInfo, giBranch) @@ -38,6 +39,7 @@ import Network.HTTP.Client ( import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (hUserAgent) import Paths_swarm qualified +import Swarm.Util (failT, quote) import Text.ParserCombinators.ReadP (readP_to_S) -- $setup @@ -104,7 +106,7 @@ parseRelease = \case t <- o .: "tag_name" if isSwarmReleaseTag t then return t - else fail $ "The release '" <> t <> "' is not main Swarm release!" + else failT ["The release", quote $ T.pack t, "is not main Swarm release!"] _otherValue -> fail "The JSON release is not an Object!" data NewReleaseFailure where diff --git a/swarm.cabal b/swarm.cabal index 067a41d00..2a30ad856 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -103,6 +103,7 @@ library Swarm.Game.Robot Swarm.Game.Scenario Swarm.Game.Scenario.Topography.Cell + Swarm.Game.Universe Swarm.TUI.Launch.Controller Swarm.TUI.Launch.Model Swarm.TUI.Launch.Prep @@ -351,6 +352,7 @@ benchmark benchmark mtl, random, swarm, - text + text, + containers default-language: Haskell2010 ghc-options: -threaded diff --git a/test/integration/Main.hs b/test/integration/Main.hs index d07607a59..2ef7e0ea0 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -303,6 +303,9 @@ testScenarioSolution rs ui _ci _em = , testSolution Default "Testing/1256-halt-command" , testSolution Default "Testing/1295-density-command" , testSolution Default "Testing/1356-portals/portals-flip-and-rotate.yaml" + , testSolution Default "Testing/144-subworlds/basic-subworld.yaml" + , testSolution Default "Testing/144-subworlds/subworld-mapped-robots.yaml" + , testSolution Default "Testing/144-subworlds/subworld-located-robots.yaml" ] ] where