From af5e6f642e9454047b16c2a9ac13e615e265bce9 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 8 Oct 2023 17:09:04 -0700 Subject: [PATCH] Structure browser --- data/scenarios/Testing/00-ORDER.txt | 1 + .../1575-structure-recognizer/00-ORDER.txt | 10 + .../1575-browse-structures.yaml | 131 ++++++++++++ .../1575-construction-count.yaml | 69 +++++++ .../1575-ensure-disjoint.yaml | 84 ++++++++ .../1575-ensure-single-recognition.yaml | 80 ++++++++ .../1575-handle-overlapping.yaml | 76 +++++++ ...575-overlapping-tiebreaker-by-largest.yaml | 71 +++++++ ...75-overlapping-tiebreaker-by-location.yaml | 76 +++++++ .../1575-placement-occlusion.yaml | 89 +++++++++ .../1575-remove-structure.yaml | 65 ++++++ .../1575-swap-structure.yaml | 117 +++++++++++ .../1138-nonexistent-nested-structure.yaml | 55 +++++ ...zed-placements-disallow-reorientation.yaml | 40 ++++ data/schema/named-structure.json | 8 + data/schema/structure.json | 4 +- data/schema/world.json | 2 +- editors/emacs/swarm-mode.el | 1 + editors/vim/swarm.vim | 2 +- editors/vscode/syntaxes/swarm.tmLanguage.json | 2 +- src/Swarm/Game/Location.hs | 11 + src/Swarm/Game/Scenario.hs | 30 +++ src/Swarm/Game/Scenario/Objective/WinCheck.hs | 2 +- src/Swarm/Game/Scenario/Topography/Area.hs | 3 + .../Scenario/Topography/Navigation/Portal.hs | 2 +- .../Topography/Navigation/Waypoint.hs | 25 +-- .../Game/Scenario/Topography/Placement.hs | 11 +- .../Game/Scenario/Topography/Structure.hs | 128 +++++++++--- .../Topography/Structure/Recognition/Log.hs | 72 +++++++ .../Structure/Recognition/Precompute.hs | 166 +++++++++++++++ .../Structure/Recognition/Registry.hs | 97 +++++++++ .../Structure/Recognition/Tracking.hs | 189 ++++++++++++++++++ .../Topography/Structure/Recognition/Type.hs | 163 +++++++++++++++ .../Structure/Recognition/Type/Toplevel.hs | 23 +++ .../Scenario/Topography/WorldDescription.hs | 20 +- src/Swarm/Game/State.hs | 128 +++++++++--- src/Swarm/Game/Step.hs | 14 ++ src/Swarm/Game/Step/Combustion.hs | 1 + src/Swarm/Game/Step/Pathfinding.hs | 1 + src/Swarm/Game/Step/Util.hs | 41 +--- src/Swarm/Game/Step/Util/Inspect.hs | 29 +++ src/Swarm/Language/Capability.hs | 3 + src/Swarm/Language/Syntax.hs | 9 + src/Swarm/Language/Typecheck.hs | 1 + src/Swarm/TUI/Controller.hs | 14 ++ src/Swarm/TUI/Editor/Palette.hs | 1 + src/Swarm/TUI/Model/Goal.hs | 4 +- src/Swarm/TUI/Model/Menu.hs | 1 + src/Swarm/TUI/Model/Name.hs | 7 + src/Swarm/TUI/Model/StateUpdate.hs | 11 + src/Swarm/TUI/Model/Structure.hs | 30 +++ src/Swarm/TUI/Model/UI.hs | 7 + src/Swarm/TUI/View.hs | 22 +- src/Swarm/TUI/View/Structure.hs | 130 ++++++++++++ src/Swarm/TUI/View/Util.hs | 10 + src/Swarm/Util.hs | 6 + src/Swarm/Web.hs | 26 +++ stack.yaml | 1 + swarm.cabal | 12 ++ test/integration/Main.hs | 13 ++ test/unit/Main.hs | 2 + test/unit/TestOrdering.hs | 30 +++ 62 files changed, 2344 insertions(+), 135 deletions(-) create mode 100644 data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml create mode 100644 data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml create mode 100644 data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml create mode 100644 data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml create mode 100644 src/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs create mode 100644 src/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs create mode 100644 src/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs create mode 100644 src/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs create mode 100644 src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs create mode 100644 src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type/Toplevel.hs create mode 100644 src/Swarm/Game/Step/Util/Inspect.hs create mode 100644 src/Swarm/TUI/Model/Structure.hs create mode 100644 src/Swarm/TUI/View/Structure.hs create mode 100644 test/unit/TestOrdering.hs diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 91789eed9d..581eff1216 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -49,3 +49,4 @@ Achievements 1430-built-robot-ownership.yaml 1536-custom-unwalkable-entities.yaml 1535-ping +1575-structure-recognizer diff --git a/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt new file mode 100644 index 0000000000..378687d255 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt @@ -0,0 +1,10 @@ +1575-browse-structures.yaml +1575-construction-count.yaml +1575-handle-overlapping.yaml +1575-ensure-single-recognition.yaml +1575-ensure-disjoint.yaml +1575-overlapping-tiebreaker-by-largest.yaml +1575-overlapping-tiebreaker-by-location.yaml +1575-remove-structure.yaml +1575-swap-structure.yaml +1575-placement-occlusion.yaml diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml new file mode 100644 index 0000000000..04912ded39 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml @@ -0,0 +1,131 @@ +version: 1 +name: Structure browser +description: | + Hit F6 to view the recognizable structures. + + Only the subset of the structures marked with + "recognize: true" are browseable. + In particular, the "donut" structure is placed + in the map but not displayed in the F6 dialog. +creative: false +objectives: + - teaser: Build structure + goal: + - | + Build a "precious" structure + condition: | + foundStructure <- structure "precious" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: [1, 0] + devices: + - grabber + - treads + inventory: + - [50, flower] + - [50, log] + - [50, rock] + - [50, copper pipe] + - [50, iron gear] + - [50, quartz] + - [50, gold] + - [50, silver] + - [50, mithril] + - [50, cotton] +solution: | + move; + place "quartz"; + move; + place "quartz"; + move; + place "mithril"; +structures: + - name: donut + structure: + palette: + '@': [dirt, rock] + mask: '.' + map: | + .@@@. + @@@@@ + @@.@@ + @@@@@ + .@@@. + - name: diamond + recognize: true + description: "A diamond pattern of flowers" + structure: + mask: '.' + palette: + 'x': [stone, flower] + map: | + ...x... + ..xxx.. + .xxxxx. + xxxxxxx + .xxxxx. + ..xxx.. + ...x... + - name: contraption + recognize: true + description: "A device for assembling useful widgets" + structure: + mask: '.' + palette: + 'r': [stone, log] + 'I': [stone, rock] + 'l': [stone, copper pipe] + 'g': [stone, iron gear] + map: | + rllllr + lIIIIl + lIIIgg + rlllgg + - name: precious + recognize: true + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'g': [stone, gold] + 's': [stone, silver] + 'm': [stone, mithril] + map: | + qgs + gsq + qqm + - name: smallish + recognize: true + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'm': [stone, mithril] + 'c': [stone, cotton] + map: | + qqm + cqq +known: [flower, log, rock, copper pipe, iron plate] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'q': [grass, quartz] + 'g': [grass, gold] + 's': [grass, silver] + 'm': [grass, mithril] + 'c': [grass, cotton] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: donut + offset: [6, 0] + map: | + .qgs......... + .gsq......... + B............ + .cqq......... + ............. diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml new file mode 100644 index 0000000000..71a8a863d9 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml @@ -0,0 +1,69 @@ +version: 1 +name: Structure recognizer - counting +description: | + Count the construction of several adjacent copies +creative: false +objectives: + - teaser: Build 12 structures + goal: + - | + Build 12 copies of the "green_jewel" structure + condition: | + foundGreen <- structure "green_jewel" 0; + return $ case foundGreen (\_. false) (\x. fst x >= 12); +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - dictionary + - grabber + - lambda + - logger + - strange loop + - treads + inventory: + - [108, pixel (G)] +solution: | + def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; + + doN 6 ( + doN 9 (place "pixel (G)"; move;); + doN 2 (turn right; move;); + doN 9 (place "pixel (G)"; move;); + doN 2 (turn left; move;); + ); +structures: + - name: green_jewel + recognize: true + structure: + palette: + 'g': [stone, pixel (G)] + map: | + ggg + ggg + ggg +known: [pixel (G)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + B........ + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... + ......... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml new file mode 100644 index 0000000000..f8a079cafb --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml @@ -0,0 +1,84 @@ +version: 1 +name: Structure recognizer - Disjoint recognitions +description: | + Ensure that the completion of a second structure + template is not recognized if it overlaps + with a previously completed structure. + + Player starts with 3 `silver`{=entity}. A win + should not be counted until all three are placed. +creative: false +objectives: + - teaser: Build 2 chessboards + prerequisite: + not: premature_win + goal: + - | + Build 2 of the same structure + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2; + ); + - id: premature_win + teaser: Don't count win early + optional: true + goal: + - | + Two structures shouldn't be recognized + while the bases still possesses `silver`{=entity} + condition: | + robotHasSilver <- as base {has "silver"}; + + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2 && robotHasSilver; + ); +robots: + - name: base + dir: [0, -1] + devices: + - grabber + - treads + inventory: + - [3, silver] +solution: | + move; + turn left; + place "silver"; + move; move; + place "silver"; + move; move; + place "silver"; +structures: + - name: chessboard + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gsgs + sgsg + gsgs + sgsg +world: + name: root + dsl: | + {water} + palette: + '.': [grass, water] + 'x': [grass, erase] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, water, base] + upperleft: [0, 0] + map: | + ...B.... + gsgxgxgx + sgsgsgsg + gsgsgsgs + sgsgsgsg diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml new file mode 100644 index 0000000000..7d8e21106a --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml @@ -0,0 +1,80 @@ +version: 1 +name: Structure recognizer - single recognition +description: | + Ensure that only a single structure is recognized + when placing an entity would complete more than one + structure template. +creative: false +objectives: + - teaser: Build 2 chessboards + prerequisite: + not: premature_win + goal: + - | + Build 2 of the same structure + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2; + ); + - id: premature_win + teaser: Don't count win early + optional: true + goal: + - | + Two structures shouldn't be recognized + while the bases still possesses `gold`{=entity} + condition: | + robotHasGold <- as base {has "gold"}; + + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\fs. + let boardCount = fst fs in + boardCount >= 2 && robotHasGold; + ); +robots: + - name: base + dir: [0, -1] + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; + place "silver"; + move; move; move; + turn left; + move; move; move; move; + place "gold"; +structures: + - name: chessboard + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gsgs + sgsg + gsgs + sgsg +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + ...B.... + gsg.gsgs + sgsgsgsg + gsgsgsgs + sgsgsgs. diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml new file mode 100644 index 0000000000..5462e2942b --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml @@ -0,0 +1,76 @@ +version: 1 +name: Structure recognizer - Overlaps +description: | + Completing a row that lies between two partially-complete structures + may complete both of them, but only one will be registered. +creative: false +objectives: + - teaser: Build structure + goal: + - | + Build a "precious" structure + condition: | + foundStructure <- structure "precious" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: [1, 0] + devices: + - grabber + - treads + inventory: + - [50, quartz] + - [50, gold] + - [50, silver] + - [50, mithril] + - [50, cotton] +solution: | + move; + place "quartz"; + move; + place "quartz"; + move; + place "mithril"; +structures: + - name: precious + recognize: true + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'g': [stone, gold] + 's': [stone, silver] + 'm': [stone, mithril] + map: | + qgs + gsq + qqm + - name: smallish + recognize: true + structure: + mask: '.' + palette: + 'q': [stone, quartz] + 'm': [stone, mithril] + 'c': [stone, cotton] + map: | + qqm + cqq +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'q': [grass, quartz] + 'g': [grass, gold] + 's': [grass, silver] + 'm': [grass, mithril] + 'c': [grass, cotton] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + .qgs. + .gsq. + B.... + .cqq. diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml new file mode 100644 index 0000000000..399c5cd23b --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml @@ -0,0 +1,71 @@ +version: 1 +name: Structure recognizer - Tiebreaking overlaps by size +description: | + A larger overlapping structure should always win the tiebreaker +creative: false +objectives: + - teaser: Build structure + prerequisite: + not: wrong_structure + goal: + - | + Build a 3x3 structure + condition: | + foundStructure <- structure "large" 0; + return $ case foundStructure (\_. false) (\_. true); + - id: wrong_structure + teaser: Don't recognize small structure + optional: true + goal: + - | + The small structure shouldn't be recognized. + condition: | + foundStructure <- structure "small" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: [1, 0] + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; + place "gold"; +structures: + - name: large + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + sss + ggs + ggs + - name: small + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + map: | + gg + gg +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + .sss + .ggs + B.gs diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml new file mode 100644 index 0000000000..358cb88d7f --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml @@ -0,0 +1,76 @@ +version: 1 +name: Structure recognizer - Tiebreaking overlaps by position +description: | + A more lower-left overlapping structure of + identical size should win the tiebreaker +creative: false +objectives: + - teaser: Build structure + prerequisite: + not: wrong_structure + goal: + - | + Build a structure + condition: | + foundStructure <- structure "topleft" 0; + return $ case foundStructure (\_. false) (\_. true); + - id: wrong_structure + teaser: Don't recognize small structure + optional: true + goal: + - | + The "bottomright" structure shouldn't be recognized. + condition: | + foundStructure <- structure "bottomright" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: [1, 0] + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; move; move; + place "gold"; +structures: + - name: topleft + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + ss + gg + gg + - name: bottomright + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gg + gg + ss +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + ..ss. + ..gg. + B.g.g + ...gg + ...ss diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml new file mode 100644 index 0000000000..89267a18d2 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml @@ -0,0 +1,89 @@ +version: 1 +name: Structure recognizer - placement occlusion +description: | + Pre-placed structures should be recognized, unless some other + structure or content has overwritten them. +creative: false +objectives: + - id: complete_green_structure + teaser: Complete green structure + prerequisite: + not: complete_red_structure + goal: + - | + Build a "green_jewel" structure + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundGreen <- structure "green_jewel" 0; + return $ isRight foundGreen; + - id: complete_red_structure + optional: true + teaser: Complete red structure + goal: + - | + A "red_jewel" structure should not be recognized + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundRed <- structure "red_jewel" 0; + return $ isRight foundRed; +robots: + - name: base + dir: [1, 0] + devices: + - fast grabber + - treads + inventory: + - [1, pixel (R)] +solution: | + noop; +structures: + - name: red_jewel + recognize: true + structure: + palette: + 'r': [stone, pixel (R)] + map: | + rrr + rrr + rrr + - name: green_jewel + recognize: true + structure: + palette: + 'g': [stone, pixel (G)] + map: | + ggg + ggg + ggg +known: [pixel (R), pixel (G)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [-97, 17] + placements: + - src: green_jewel + offset: [3, -3] + - src: red_jewel + offset: [1, -1] + - src: red_jewel + offset: [1, -5] + - src: red_jewel + offset: [5, -1] + - src: red_jewel + offset: [5, -5] + map: | + ......... + ......... + ......... + B........ + ......... + ......... + ......... + ......... + ......... diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml new file mode 100644 index 0000000000..9e0b37c3ab --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml @@ -0,0 +1,65 @@ +version: 1 +name: Structure recognizer - removal +description: | + Remove a structure from the registry + when one of its cells are removed. +creative: false +objectives: + - teaser: Destroy structure + prerequisite: complete_structure + goal: + - | + Remove a piece of the structure to destroy it + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. true) (\_. false); + - id: complete_structure + teaser: Complete structure + goal: + - | + Build a structure + condition: | + foundStructure <- structure "chessboard" 0; + return $ case foundStructure (\_. false) (\_. true); +robots: + - name: base + dir: [0, -1] + devices: + - grabber + - treads + inventory: + - [1, gold] + - [1, silver] +solution: | + move; + place "silver"; + grab; +structures: + - name: chessboard + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + map: | + gsgs + sgsg + gsgs + sgsg +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + ...B. + gsg.g + sgsgs + gsgsg + sgsgs diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml new file mode 100644 index 0000000000..2574df9112 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml @@ -0,0 +1,117 @@ +version: 1 +name: Structure recognizer - swap +description: | + Change one structure into another. + Also tests pre-registration of structures. +creative: false +objectives: + - teaser: Complete blue structure + prerequisite: complete_green_structure + goal: + - | + Build a "blue_jewel" structure + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundBlue <- structure "blue_jewel" 0; + foundGreen <- structure "green_jewel" 0; + foundRed <- structure "red_jewel" 0; + return $ isRight foundBlue && not (isRight foundRed) && not (isRight foundRed); + - id: complete_green_structure + teaser: Complete green structure + prerequisite: complete_red_structure + goal: + - | + Build a "green_jewel" structure + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundGreen <- structure "green_jewel" 0; + foundRed <- structure "red_jewel" 0; + return $ isRight foundGreen && not (isRight foundRed); + - id: complete_red_structure + teaser: Complete red structure + goal: + - | + Build a "red_jewel" structure + condition: | + def isRight = \x. case x (\_. false) (\_. true); end; + + foundRed <- structure "red_jewel" 0; + return $ isRight foundRed; +robots: + - name: base + dir: [1, 0] + devices: + - fast grabber + - treads + inventory: + - [1, pixel (G)] + - [1, pixel (B)] +solution: | + move; move; move; + swap "pixel (G)"; + swap "pixel (B)"; +structures: + - name: red_jewel + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + 'j': [stone, pixel (R)] + map: | + ggggg + gsssg + gsjsg + gsssg + ggggg + - name: green_jewel + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + 'j': [stone, pixel (G)] + map: | + ggggg + gsssg + gsjsg + gsssg + ggggg + - name: blue_jewel + recognize: true + structure: + mask: '.' + palette: + 'g': [stone, gold] + 's': [stone, silver] + 'j': [stone, pixel (B)] + map: | + ggggg + gsssg + gsjsg + gsssg + ggggg +known: [gold, silver, pixel (R), pixel (G), pixel (B)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'g': [grass, gold] + 's': [grass, silver] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: red_jewel + offset: [1, 0] + map: | + ...... + ...... + B..... + ...... + ...... diff --git a/data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml b/data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml new file mode 100644 index 0000000000..5525e38284 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml @@ -0,0 +1,55 @@ +version: 1 +name: Structure placement (nested) +description: | + Try to place a structure named "bitpair_bogus" + which does not exist. +robots: + - name: base + loc: [11, 0] + dir: [1, 0] +world: + palette: + '.': [grass] + upperleft: [-1, 1] + structures: + - name: bitpair + structure: + palette: + '0': [stone, bit (0)] + '1': [stone, bit (1)] + map: | + 1 + 0 + - name: bigbox + structure: + palette: + '.': [stone] + 'T': [stone, tree] + structures: + - name: minibox + structure: + palette: + '.': [stone] + 'x': [stone, tree] + placements: + - src: bitpair_bogus + offset: [1, 0] + map: | + x. + .x + placements: + - src: minibox + offset: [0, -1] + map: | + T.T. + .T.T + placements: + - src: bigbox + offset: [1, -1] + - src: bitpair + offset: [1, -7] + map: | + ........ + ........ + ........ + ........ diff --git a/data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml b/data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml new file mode 100644 index 0000000000..e1b7551a4c --- /dev/null +++ b/data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml @@ -0,0 +1,40 @@ +version: 1 +name: Structure recognizer - placement occlusion +description: | + Disallow recognized structures from being placed with non-default orientation. +creative: false +robots: + - name: base + dir: [1, 0] + devices: + - treads +structures: + - name: red_jewel + recognize: true + structure: + mask: '.' + palette: + 'r': [stone, pixel (R)] + map: | + rrrr + rrrr +known: [pixel (R), pixel (G)] +world: + name: root + dsl: | + {blank} + palette: + '.': [grass] + 'B': [grass, null, base] + upperleft: [0, 0] + placements: + - src: red_jewel + offset: [2, -2] + orient: + up: west + map: | + ....... + ....... + B...... + ....... + ....... diff --git a/data/schema/named-structure.json b/data/schema/named-structure.json index 2fbdafa665..39bc281876 100644 --- a/data/schema/named-structure.json +++ b/data/schema/named-structure.json @@ -10,6 +10,14 @@ "type": "string", "description": "Name of this substructure" }, + "description": { + "type": "string", + "description": "Description of this substructure" + }, + "recognize": { + "type": "boolean", + "description": "Whether this structure participates in automatic recognition when constructed" + }, "structure": { "$ref": "structure.json" } diff --git a/data/schema/structure.json b/data/schema/structure.json index a2fdbcf815..577718e285 100644 --- a/data/schema/structure.json +++ b/data/schema/structure.json @@ -2,7 +2,7 @@ "$schema": "http://json-schema.org/draft-07/schema#", "$id": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/structure.json", "title": "Structure", - "description": "Structure properties", + "description": "Structure properties. Structures may opt into \"automatic recognition\" for when they are constructed by a robot. There are certain limitations on the shape and placement of such \"recognizable\" structures.", "type": "object", "additionalProperties": false, "properties": { @@ -26,7 +26,7 @@ } }, "placements": { - "description": "Structure placements", + "description": "Structure placements. Earlier members may occlude later members of the list.", "type": "array", "items": { "$ref": "placement.json" diff --git a/data/schema/world.json b/data/schema/world.json index 3144d5ce9d..df6ab82ac4 100644 --- a/data/schema/world.json +++ b/data/schema/world.json @@ -28,7 +28,7 @@ } }, "placements": { - "description": "Structure placements", + "description": "Structure placements. Earlier members may occlude later members of the list.", "type": "array", "items": { "$ref": "placement.json" diff --git a/editors/emacs/swarm-mode.el b/editors/emacs/swarm-mode.el index b0ca6bd78a..723147a1e9 100644 --- a/editors/emacs/swarm-mode.el +++ b/editors/emacs/swarm-mode.el @@ -87,6 +87,7 @@ "scout" "whereami" "waypoint" + "structure" "detect" "resonate" "density" diff --git a/editors/vim/swarm.vim b/editors/vim/swarm.vim index fac896fbd2..b6102fa3d8 100644 --- a/editors/vim/swarm.vim +++ b/editors/vim/swarm.vim @@ -1,6 +1,6 @@ syn keyword Keyword def end let in require syn keyword Builtins self parent base if inl inr case fst snd force undefined fail not format chars split charat tochar key -syn keyword Command noop wait selfdestruct move backup path push stride turn grab harvest ignite place ping give equip unequip make has equipped count drill use build salvage reprogram say listen log view appear create halt time scout whereami waypoint detect resonate density sniff chirp watch surveil heading blocked scan upload ishere isempty meet meetall whoami setname random run return try swap atomic instant installkeyhandler teleport as robotnamed robotnumbered knows +syn keyword Command noop wait selfdestruct move backup path push stride turn grab harvest ignite place ping give equip unequip make has equipped count drill use build salvage reprogram say listen log view appear create halt time scout whereami waypoint structure detect resonate density sniff chirp watch surveil heading blocked scan upload ishere isempty meet meetall whoami setname random run return try swap atomic instant installkeyhandler teleport as robotnamed robotnumbered knows syn keyword Direction east north west south down forward left back right syn keyword Type int text dir bool cmd void unit actor diff --git a/editors/vscode/syntaxes/swarm.tmLanguage.json b/editors/vscode/syntaxes/swarm.tmLanguage.json index 8a5686ed29..9dbea57123 100644 --- a/editors/vscode/syntaxes/swarm.tmLanguage.json +++ b/editors/vscode/syntaxes/swarm.tmLanguage.json @@ -58,7 +58,7 @@ }, { "name": "keyword.other", - "match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|path|push|stride|turn|grab|harvest|ignite|place|ping|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b" + "match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|path|push|stride|turn|grab|harvest|ignite|place|ping|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|structure|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b" } ] }, diff --git a/src/Swarm/Game/Location.hs b/src/Swarm/Game/Location.hs index b3f3e8a6c7..33dae49f71 100644 --- a/src/Swarm/Game/Location.hs +++ b/src/Swarm/Game/Location.hs @@ -10,6 +10,7 @@ module Swarm.Game.Location ( Location, pattern Location, + HasLocation (..), -- ** Heading and Direction functions Heading, @@ -234,3 +235,13 @@ getElemsInArea o@(Location x y) d m = M.elems sm' & M.split (Location (x + d) (y + 1)) -- B & fst -- B> sm' = M.filterWithKey (const . (<= d) . manhattan o) sm + +-- * Locatable things + +class HasLocation a where + -- | Basically 'fmap' for the 'Location' field of a record + modifyLoc :: (Location -> Location) -> a -> a + + -- | Translation by a vector + offsetLoc :: V2 Int32 -> a -> a + offsetLoc locOffset = modifyLoc (.+^ locOffset) diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 09b5418ab2..9205c067ef 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -21,6 +21,9 @@ module Swarm.Game.Scenario ( -- * Scenario Scenario (..), + StaticStructureInfo (..), + staticPlacements, + structureDefs, -- ** Fields scenarioVersion, @@ -35,6 +38,7 @@ module Swarm.Game.Scenario ( scenarioKnown, scenarioWorlds, scenarioNavigation, + scenarioStructures, scenarioRobots, scenarioObjectives, scenarioSolution, @@ -89,6 +93,22 @@ import Swarm.Util.Yaml import System.Directory (doesFileExist) import System.FilePath ((<.>), ()) +data StaticStructureInfo = StaticStructureInfo + { _structureDefs :: Structure.InheritedStructureDefs + , _staticPlacements :: M.Map SubworldName [Structure.LocatedStructure (Maybe Cell)] + } + deriving (Show) + +makeLensesNoSigs ''StaticStructureInfo + +-- | Structure templates that may be auto-recognized when constructed +-- by a robot +structureDefs :: Lens' StaticStructureInfo Structure.InheritedStructureDefs + +-- | A record of the static placements of structures, so that they can be +-- added to the "recognized" list upon scenario initialization +staticPlacements :: Lens' StaticStructureInfo (M.Map SubworldName [Structure.LocatedStructure (Maybe Cell)]) + ------------------------------------------------------------ -- Scenario ------------------------------------------------------------ @@ -108,6 +128,7 @@ data Scenario = Scenario , _scenarioKnown :: [Text] , _scenarioWorlds :: NonEmpty WorldDescription , _scenarioNavigation :: Navigation (M.Map SubworldName) Location + , _scenarioStructures :: StaticStructureInfo , _scenarioRobots :: [TRobot] , _scenarioObjectives :: [Objective] , _scenarioSolution :: Maybe ProcessedTerm @@ -172,6 +193,11 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where $ NE.toList allWorlds let mergedNavigation = Navigation mergedWaypoints mergedPortals + structureInfo = + StaticStructureInfo (filter Structure.recognize rootLevelSharedStructures) + . M.fromList + . NE.toList + $ NE.map (worldName &&& placedStructures) allWorlds Scenario <$> liftE (v .: "version") @@ -186,6 +212,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where <*> pure known <*> pure allWorlds <*> pure mergedNavigation + <*> pure structureInfo <*> pure rs <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives) <*> liftE (v .:? "solution") @@ -234,6 +261,9 @@ scenarioKnown :: Lens' Scenario [Text] -- The "root" subworld shall always be at the head of the list, by construction. scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription) +-- | Information required for structure recognition +scenarioStructures :: Lens' Scenario StaticStructureInfo + -- | Waypoints and inter-world portals scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location) diff --git a/src/Swarm/Game/Scenario/Objective/WinCheck.hs b/src/Swarm/Game/Scenario/Objective/WinCheck.hs index 34ace9d90e..2f71693844 100644 --- a/src/Swarm/Game/Scenario/Objective/WinCheck.hs +++ b/src/Swarm/Game/Scenario/Objective/WinCheck.hs @@ -6,7 +6,7 @@ -- Utilities to check whether conditions are met for a game win/loss. module Swarm.Game.Scenario.Objective.WinCheck where -import Data.Aeson +import Data.Aeson (ToJSON) import Data.BoolExpr qualified as BE import Data.BoolExpr.Simplify qualified as Simplify import Data.List (partition) diff --git a/src/Swarm/Game/Scenario/Topography/Area.hs b/src/Swarm/Game/Scenario/Topography/Area.hs index 678617184b..f6d1edf9fb 100644 --- a/src/Swarm/Game/Scenario/Topography/Area.hs +++ b/src/Swarm/Game/Scenario/Topography/Area.hs @@ -53,3 +53,6 @@ getAreaDimensions cellGrid = where w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid -- column count h = fromIntegral $ length cellGrid -- row count + +computeArea :: AreaDimensions -> Int32 +computeArea (AreaDimensions w h) = w * h diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs index 9bcae2a1e7..5426582c0b 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -180,7 +180,7 @@ validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portal correctedWaypoints = binTuples $ map - (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint $ upperLeft .-. origin) x)) + (\x -> (wpName $ wpConfig $ value x, fmap (offsetLoc $ upperLeft .-. origin) x)) unmergedWaypoints bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs index c983b2ad90..f27736cc6f 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs +++ b/src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs @@ -20,18 +20,22 @@ -- precise control of ordering. module Swarm.Game.Scenario.Topography.Navigation.Waypoint where -import Data.Int (Int32) import Data.Text qualified as T import Data.Yaml as Y import GHC.Generics (Generic) -import Linear (V2 (..)) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Placement +-- | This type is isomorphic to 'Maybe'. +data Parentage a + = WithParent a + | Root + deriving (Show, Eq) + -- | Indicates which structure something came from -- for debugging purposes. data Originated a = Originated - { parent :: Maybe Placement + { parent :: Parentage Placement , value :: a } deriving (Show, Eq, Functor) @@ -75,16 +79,5 @@ instance FromJSON Waypoint where <$> parseWaypointConfig v <*> v .: "loc" --- | Basically "fmap" for the "Location" field -modifyLocation :: - (Location -> Location) -> - Waypoint -> - Waypoint -modifyLocation f (Waypoint cfg originalLoc) = Waypoint cfg $ f originalLoc - --- | Translation by a vector -offsetWaypoint :: - V2 Int32 -> - Waypoint -> - Waypoint -offsetWaypoint locOffset = modifyLocation (.+^ locOffset) +instance HasLocation Waypoint where + modifyLoc f (Waypoint cfg originalLoc) = Waypoint cfg $ f originalLoc diff --git a/src/Swarm/Game/Scenario/Topography/Placement.hs b/src/Swarm/Game/Scenario/Topography/Placement.hs index 49dc57709c..bbcef9aca0 100644 --- a/src/Swarm/Game/Scenario/Topography/Placement.hs +++ b/src/Swarm/Game/Scenario/Topography/Placement.hs @@ -13,10 +13,13 @@ import Data.Yaml as Y import GHC.Generics (Generic) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area -import Swarm.Language.Syntax (AbsoluteDir (..)) +import Swarm.Language.Direction (AbsoluteDir (..)) newtype StructureName = StructureName Text - deriving (Eq, Ord, Show, Generic, FromJSON) + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +getStructureName :: StructureName -> Text +getStructureName (StructureName sn) = sn -- | Orientation transformations are applied before translation. data Orientation = Orientation @@ -37,8 +40,8 @@ defaultOrientation :: Orientation defaultOrientation = Orientation DNorth False -- | This is the point-wise equivalent of "applyOrientationTransform" -reorientWaypoint :: Orientation -> AreaDimensions -> Location -> Location -reorientWaypoint (Orientation upDir shouldFlip) (AreaDimensions width height) = +reorientLandmark :: Orientation -> AreaDimensions -> Location -> Location +reorientLandmark (Orientation upDir shouldFlip) (AreaDimensions width height) = rotational . flipping where transposeLoc (Location x y) = Location (-y) (-x) diff --git a/src/Swarm/Game/Scenario/Topography/Structure.hs b/src/Swarm/Game/Scenario/Topography/Structure.hs index 226d766645..36845737a4 100644 --- a/src/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/Swarm/Game/Scenario/Topography/Structure.hs @@ -3,17 +3,20 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- Definitions of "structures" for use within a map, +-- Definitions of "structures" for use within a map -- as well as logic for combining them. module Swarm.Game.Scenario.Topography.Structure where import Control.Applicative ((<|>)) -import Control.Arrow ((&&&)) +import Control.Arrow (left, (&&&)) +import Control.Monad (when) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Coerce +import Data.Either.Extra (maybeToEither) +import Data.Foldable (foldrM) import Data.Map qualified as M -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes) import Data.Text (Text) import Data.Text qualified as T import Data.Yaml as Y @@ -25,22 +28,28 @@ 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 (failT, quote, showT) import Swarm.Util.Yaml import Witch (into) data NamedStructure c = NamedStructure { name :: StructureName + , recognize :: Bool + -- ^ whether this structure should be registered for automatic recognition + , description :: Maybe Text + -- ^ will be UI-facing only if this is a recognizable structure , structure :: PStructure c } deriving (Eq, Show) -type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))] +type InheritedStructureDefs = [NamedStructure (Maybe Cell)] -instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where +instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe Cell)) where parseJSONE = withObjectE "named structure" $ \v -> do NamedStructure <$> liftE (v .: "name") + <*> liftE (v .:? "recognize" .!= False) + <*> liftE (v .:? "description") <*> v ..: "structure" @@ -54,40 +63,57 @@ data PStructure c = Structure } deriving (Eq, Show) -data MergedStructure c = MergedStructure [[c]] [Originated Waypoint] +data Placed c = Placed Placement (NamedStructure c) + deriving (Show) + +-- | For use in registering recognizable pre-placed structures +data LocatedStructure c = LocatedStructure + { originalPlacement :: Placed c + , cornerLoc :: Location + } + deriving (Show) + +instance HasLocation (LocatedStructure c) where + modifyLoc f (LocatedStructure x originalLoc) = + LocatedStructure x $ f originalLoc + +data MergedStructure c = MergedStructure [[c]] [LocatedStructure c] [Originated Waypoint] -- | Destructively overlays one direct child structure -- upon the input structure. -- However, the child structure is assembled recursively. overlaySingleStructure :: - M.Map StructureName (PStructure (Maybe a)) -> - (Placement, PStructure (Maybe a)) -> + M.Map StructureName (NamedStructure (Maybe a)) -> + Placed (Maybe a) -> MergedStructure (Maybe a) -> - MergedStructure (Maybe a) + Either Text (MergedStructure (Maybe a)) overlaySingleStructure inheritedStrucDefs - (p@(Placement _ loc@(Location colOffset rowOffset) orientation), struc) - (MergedStructure inputArea inputWaypoints) = - MergedStructure mergedArea mergedWaypoints - where - mergedArea = zipWithPad mergeSingleRow inputArea paddedOverlayRows + (Placed p@(Placement _ loc@(Location colOffset rowOffset) orientation) ns) + (MergedStructure inputArea inputPlacements inputWaypoints) = do + MergedStructure overlayArea overlayPlacements overlayWaypoints <- + mergeStructures inheritedStrucDefs (WithParent p) $ structure ns - placeWaypoint = - offsetWaypoint (coerce loc) - . modifyLocation (reorientWaypoint orientation $ getAreaDimensions overlayArea) - mergedWaypoints = inputWaypoints <> map (fmap placeWaypoint) overlayWaypoints + let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints + mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements + mergedArea = zipWithPad mergeSingleRow inputArea $ paddedOverlayRows overlayArea + + return $ MergedStructure mergedArea mergedPlacements mergedWaypoints + where + placeOnArea overArea = + offsetLoc (coerce loc) + . modifyLoc (reorientLandmark orientation $ getAreaDimensions overArea) zipWithPad f a b = zipWith f a $ b <> repeat Nothing - MergedStructure overlayArea overlayWaypoints = mergeStructures inheritedStrucDefs (Just p) struc - affineTransformedOverlay = applyOrientationTransform orientation overlayArea + affineTransformedOverlay = applyOrientationTransform orientation mergeSingleRow inputRow maybeOverlayRow = zipWithPad (flip (<|>)) inputRow paddedSingleOverlayRow where paddedSingleOverlayRow = maybe [] (applyOffset colOffset) maybeOverlayRow - paddedOverlayRows = applyOffset (negate rowOffset) . map Just $ affineTransformedOverlay + paddedOverlayRows = applyOffset (negate rowOffset) . map Just . affineTransformedOverlay applyOffset offsetNum = modifyFront where integralOffset = fromIntegral offsetNum @@ -96,25 +122,61 @@ overlaySingleStructure then (replicate integralOffset Nothing <>) else drop $ abs integralOffset +elaboratePlacement :: Parentage Placement -> Either Text a -> Either Text a +elaboratePlacement p = left (elaboration <>) + where + pTxt = case p of + Root -> "root placement" + WithParent (Placement (StructureName sn) loc _) -> + T.unwords + [ "placement of" + , quote sn + , "at" + , showT loc + ] + elaboration = + T.unwords + [ "Within" + , pTxt <> ":" + , "" + ] + -- | Overlays all of the "child placements", such that the children encountered earlier -- in the YAML file supersede the later ones (due to use of 'foldr' instead of 'foldl'). mergeStructures :: - M.Map StructureName (PStructure (Maybe a)) -> - Maybe Placement -> + M.Map StructureName (NamedStructure (Maybe a)) -> + Parentage Placement -> PStructure (Maybe a) -> - MergedStructure (Maybe a) -mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = - foldr (overlaySingleStructure structureMap) (MergedStructure origArea originatedWaypoints) overlays + Either Text (MergedStructure (Maybe a)) +mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do + overlays <- elaboratePlacement parentPlacement $ mapM g subPlacements + let wrapPlacement p@(Placed z _) = LocatedStructure p $ offset z + wrappedOverlays = map wrapPlacement $ filter (\(Placed _ ns) -> recognize ns) overlays + foldrM + (overlaySingleStructure structureMap) + (MergedStructure origArea wrappedOverlays originatedWaypoints) + overlays where originatedWaypoints = map (Originated parentPlacement) subWaypoints -- deeper definitions override the outer (toplevel) ones - structureMap = M.union (M.fromList $ map (name &&& structure) subStructures) inheritedStrucDefs - overlays = mapMaybe g subPlacements - g placement@(Placement sName _ _) = - sequenceA (placement, M.lookup sName structureMap) - -instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where + structureMap = M.union (M.fromList $ map (name &&& id) subStructures) inheritedStrucDefs + + g placement@(Placement sName@(StructureName n) _ orientation) = do + t@(_, ns) <- + maybeToEither + (T.unwords ["Could not look up structure", quote n]) + $ sequenceA (placement, M.lookup sName structureMap) + when (recognize ns && orientation /= defaultOrientation) $ + Left $ + T.unwords + [ "Recognizable structure" + , quote n + , "must use default orientation." + ] + return $ uncurry Placed t + +instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe Cell)) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= WorldPalette mempty localStructureDefs <- v ..:? "structures" ..!= [] diff --git a/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs new file mode 100644 index 0000000000..0965ccf24b --- /dev/null +++ b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs @@ -0,0 +1,72 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Types strictly for debugging structure recognition via the web interface +module Swarm.Game.Scenario.Topography.Structure.Recognition.Log where + +import Data.Aeson +import Data.Int (Int32) +import GHC.Generics (Generic) +import Servant.Docs (ToSample) +import Servant.Docs qualified as SD +import Swarm.Game.Entity (EntityName) +import Swarm.Game.Location (Location) +import Swarm.Game.Scenario.Topography.Placement (StructureName) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Universe (Cosmic) + +type StructureRowContent = [Maybe EntityName] +type WorldRowContent = [Maybe EntityName] + +data MatchingRowFrom = MatchingRowFrom + { rowIdx :: Int32 + , structure :: StructureName + } + deriving (Generic, ToJSON) + +newtype HaystackPosition = HaystackPosition Int + deriving (Generic, ToJSON) + +data HaystackContext = HaystackContext + { worldRow :: WorldRowContent + , haystackPosition :: HaystackPosition + } + deriving (Generic, ToJSON) + +data FoundRowCandidate = FoundRowCandidate + { haystackContext :: HaystackContext + , structureContent :: StructureRowContent + , rowCandidates :: [MatchingRowFrom] + } + deriving (Generic, ToJSON) + +data ParticipatingEntity = ParticipatingEntity + { entity :: EntityName + , searchOffsets :: InspectionOffsets + } + deriving (Generic, ToJSON) + +data SearchLog + = FoundParticipatingEntity ParticipatingEntity + | StructureRemoved StructureName + | FoundRowCandidates [FoundRowCandidate] + | FoundCompleteStructureCandidates [StructureName] + deriving (Generic) + +instance ToJSON SearchLog where + toJSON = genericToJSON searchLogOptions + +searchLogOptions :: Options +searchLogOptions = + defaultOptions + { sumEncoding = ObjectWithSingleField + } + +instance ToSample SearchLog where + toSamples _ = SD.noSamples + +data StructureLocation = StructureLocation StructureName (Cosmic Location) + deriving (Generic, ToJSON) + +instance ToSample StructureLocation where + toSamples _ = SD.noSamples diff --git a/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs new file mode 100644 index 0000000000..a75df11148 --- /dev/null +++ b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs @@ -0,0 +1,166 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Precomputation for structure recognizer. +-- +-- = Search process overview +-- +-- 2D structures may be defined at the +-- . +-- Upon scenario load, all of the predefined structures that are marked +-- as @"recognize"@ are compiled into searcher state machines. +-- +-- When an entity is placed on any cell in the world, the +-- 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified' +-- function is called, which looks up a customized searcher based +-- on the type of placed entity. +-- +-- The first searching stage looks for any member row of all participating +-- structure definitions that contains the placed entity. +-- The value returned by the searcher is a second-stage searcher state machine, +-- which this time searches for complete structures of which the found row may +-- be a member. +-- +-- Both the first stage and second stage searcher know to start the search +-- at a certain offset horizontally or vertically from the placed entity, +-- based on where within a structure that entity (or row) may occur. +-- +-- Upon locating a complete structure, it is added to a registry, which +-- supports lookups by either name or by location (using two different +-- maps maintained in parallel). The map by location is used to remove +-- a structure from the registry if a member entity is changed. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute ( + -- * Main external interface + mkAutomatons, + + -- * Helper functions + populateStaticFoundStructures, + placedToFound, + getEntityGrid, +) where + +import Control.Arrow ((&&&)) +import Data.Int (Int32) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (catMaybes) +import Data.Semigroup (sconcat) +import Data.Tuple (swap) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Structure +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Universe (Cosmic (..), SubworldName) +import Swarm.Util (binTuples, histogram) +import Swarm.Util.Erasable (erasableToMaybe) +import Text.AhoCorasick + +getEntityGrid :: NamedStructure (Maybe Cell) -> [SymbolSequence] +getEntityGrid = map (map ((erasableToMaybe . cellEntity) =<<)) . area . structure + +allStructureRows :: [StructureWithGrid] -> [StructureRow] +allStructureRows = + concatMap getRows + where + getRows :: StructureWithGrid -> [StructureRow] + getRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g + +mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets +mkOffsets pos xs = + InspectionOffsets (pure (negate pos)) $ + pure $ + fromIntegral (length xs) - 1 - pos + +-- | Given a row of entities observed in the world, +-- yield a searcher that can determine of adjacent +-- rows constitute a complete structure. +mkRowLookup :: + NE.NonEmpty StructureRow -> + AutomatonInfo SymbolSequence StructureRow +mkRowLookup neList = + AutomatonInfo bounds sm + where + mkSmTuple = entityGrid . wholeStructure &&& id + + deriveRowOffsets :: StructureRow -> InspectionOffsets + deriveRowOffsets (StructureRow (StructureWithGrid _ g) rwIdx _) = + mkOffsets rwIdx g + + bounds = sconcat $ NE.map deriveRowOffsets neList + sm = makeStateMachine $ NE.toList $ NE.map mkSmTuple neList + +-- | Make the first-phase lookup map, keyed by 'Entity', +-- along with automatons whose key symbols are "Maybe Entity". +-- +-- Each automaton in this first layer will attempt to match the +-- underlying world row against all rows within all structures +-- (so long as they contain the keyed entity). +mkEntityLookup :: + [StructureWithGrid] -> + M.Map Entity (AutomatonInfo AtomicKeySymbol StructureSearcher) +mkEntityLookup grids = + M.map mkValues rowsByEntityParticipation + where + rowsAcrossAllStructures = allStructureRows grids + + -- The input here are all rows across all structures + -- that share the same entity sequence. + mkSmValue :: SymbolSequence -> NE.NonEmpty SingleRowEntityRecurrences -> StructureSearcher + mkSmValue ksms singleRows = + StructureSearcher sm2D ksms singleRows + where + structureRowsNE = NE.map myRow singleRows + sm2D = mkRowLookup structureRowsNE + + mkValues :: NE.NonEmpty SingleRowEntityRecurrences -> AutomatonInfo AtomicKeySymbol StructureSearcher + mkValues neList = AutomatonInfo bounds sm + where + groupedByUniqueRow = binTuples $ NE.toList $ NE.map (rowContent . myRow &&& id) neList + bounds = sconcat $ NE.map expandedOffsets neList + sm = makeStateMachine $ M.toList $ M.mapWithKey mkSmValue groupedByUniqueRow + + -- The values of this map are guaranteed to contain only one + -- entry per row of a given structure. + rowsByEntityParticipation :: M.Map Entity (NE.NonEmpty SingleRowEntityRecurrences) + rowsByEntityParticipation = + binTuples $ + map (myEntity &&& id) $ + concatMap explodeRowEntities rowsAcrossAllStructures + + deriveEntityOffsets :: PositionWithinRow -> InspectionOffsets + deriveEntityOffsets (PositionWithinRow pos r) = + mkOffsets pos $ rowContent r + + -- The members of "rowMembers" are of 'Maybe' type; the 'Nothing's + -- are dropped but accounted for when indexing the columns. + explodeRowEntities :: StructureRow -> [SingleRowEntityRecurrences] + explodeRowEntities r@(StructureRow _ _ rowMembers) = + map f $ M.toList $ binTuples unconsolidated + where + f (e, occurrences) = + SingleRowEntityRecurrences r e occurrences $ + sconcat $ + NE.map deriveEntityOffsets occurrences + unconsolidated = + map swap $ + catMaybes $ + zipWith (\idx -> fmap (PositionWithinRow idx r,)) [0 ..] rowMembers + +mkAutomatons :: InheritedStructureDefs -> RecognizerAutomatons +mkAutomatons xs = + RecognizerAutomatons + infos + (mkEntityLookup grids) + where + grids = map extractGrid xs + + process g = StructureInfo g . histogram . concatMap catMaybes $ entityGrid g + infos = map process grids + +extractGrid :: NamedStructure (Maybe Cell) -> StructureWithGrid +extractGrid x = StructureWithGrid x $ getEntityGrid x + +placedToFound :: SubworldName -> LocatedStructure (Maybe Cell) -> FoundStructure +placedToFound swName (LocatedStructure (Placed _ ns) loc) = + FoundStructure (extractGrid ns) $ Cosmic swName loc diff --git a/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs new file mode 100644 index 0000000000..d1f12cb1e5 --- /dev/null +++ b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs @@ -0,0 +1,97 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Registry of found structures. +-- This datatype contains two maps that must be kept in sync. +-- Uses smart constructors to maintain this invariant. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Registry ( + FoundRegistry, + + -- * Instantiation + emptyFoundStructures, + populateStaticFoundStructures, + + -- * Read-only accessors + foundByName, + foundByLocation, + + -- * Mutation + addFound, + removeStructure, +) +where + +import Control.Arrow ((&&&)) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Map.NonEmpty (NEMap) +import Data.Map.NonEmpty qualified as NEM +import Swarm.Game.Location (Location) +import Swarm.Game.Scenario.Topography.Placement (StructureName) +import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Universe (Cosmic) +import Swarm.Util (binTuples, deleteKeys) + +-- | The authoritative source of which built structures currently exist. +data FoundRegistry = FoundRegistry + { _foundByName :: Map StructureName (NEMap (Cosmic Location) StructureWithGrid) + , _foundByLocation :: Map (Cosmic Location) FoundStructure + } + +emptyFoundStructures :: FoundRegistry +emptyFoundStructures = FoundRegistry mempty mempty + +-- | We use a 'NEMap' here so that we can use the +-- safe-indexing function 'indexWrapNonEmpty' in the implementation +-- of the @structure@ command. +foundByName :: FoundRegistry -> Map StructureName (NEMap (Cosmic Location) StructureWithGrid) +foundByName = _foundByName + +-- | This is a worldwide "mask" that prevents members of placed +-- structures from participating in new structures and facilitates +-- deletion of structures when their elements are removed from the world. +-- +-- Each recognized structure instance will have @MxN@ entries in this map. +foundByLocation :: FoundRegistry -> Map (Cosmic Location) FoundStructure +foundByLocation = _foundByLocation + +removeStructure :: FoundStructure -> FoundRegistry -> FoundRegistry +removeStructure fs (FoundRegistry byName byLoc) = + FoundRegistry + (M.update tidyDelete structureName byName) + (deleteKeys allOccupiedCoords byLoc) + where + allOccupiedCoords = genOccupiedCoords fs + structureName = Structure.name $ originalDefinition $ structureWithGrid fs + upperLeft = upperLeftCorner fs + + -- NOTE: Observe similarities to + -- Swarm.Game.State.removeRobotFromLocationMap + tidyDelete = NEM.nonEmptyMap . NEM.delete upperLeft + +addFound :: FoundStructure -> FoundRegistry -> FoundRegistry +addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = + FoundRegistry + (M.insertWith (<>) k (NEM.singleton loc swg) byName) + (M.union occupationMap byLoc) + where + k = Structure.name $ originalDefinition swg + occupationMap = M.fromList $ map (,fs) $ genOccupiedCoords fs + +-- | Bulk insertion of found structures. +-- +-- Each of these shall have been re-checked in case +-- a subsequent placement occludes them. +populateStaticFoundStructures :: [FoundStructure] -> FoundRegistry +populateStaticFoundStructures allFound = + FoundRegistry byName byLocation + where + mkOccupationMap fs = M.fromList $ map (,fs) $ genOccupiedCoords fs + byLocation = M.unions $ map mkOccupationMap allFound + + byName = + M.map (NEM.fromList . NE.map (upperLeftCorner &&& structureWithGrid)) $ + binTuples $ + map (Structure.name . originalDefinition . structureWithGrid &&& id) allFound diff --git a/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs new file mode 100644 index 0000000000..fc9c525823 --- /dev/null +++ b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs @@ -0,0 +1,189 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Online operations for structure recognizer. +-- +-- See "Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute" for +-- details of the structure recognition process. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking ( + entityModified, +) where + +import Control.Carrier.State.Lazy +import Control.Effect.Lens +import Control.Lens ((^.)) +import Control.Monad (forM, forM_) +import Data.Hashable (Hashable) +import Data.Int (Int32) +import Data.List (sortOn) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (listToMaybe) +import Data.Ord (Down (..)) +import Data.Semigroup (Max (..), Min (..)) +import Linear (V2 (..)) +import Swarm.Game.Entity +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Structure.Recognition.Log +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel +import Swarm.Game.State +import Swarm.Game.Universe +import Swarm.Game.World.Modify +import Text.AhoCorasick + +-- | A hook called from the centralized entity update function, +-- 'Swarm.Game.Step.Util.updateEntityAt'. +-- +-- This handles structure detection upon addition of an entity, +-- and structure de-registration upon removal of an entity. +-- Also handles atomic entity swaps. +entityModified :: + (Has (State GameState) sig m) => + CellModification Entity -> + Cosmic Location -> + m () +entityModified modification cLoc = do + case modification of + Add newEntity -> doAddition newEntity + Remove _ -> doRemoval + Swap _ newEntity -> doRemoval >> doAddition newEntity + where + doAddition newEntity = do + entLookup <- use $ discovery . structureRecognition . automatons . automatonsByEntity + forM_ (M.lookup newEntity entLookup) $ \finder -> do + let msg = FoundParticipatingEntity $ ParticipatingEntity (view entityName newEntity) (finder ^. inspectionOffsets) + discovery . structureRecognition . recognitionLog %= (msg :) + registerRowMatches cLoc finder + + doRemoval = do + -- Entity was removed; may need to remove registered structure. + structureRegistry <- use $ discovery . structureRecognition . foundStructures + forM_ (M.lookup cLoc $ foundByLocation structureRegistry) $ \fs -> do + let structureName = Structure.name $ originalDefinition $ structureWithGrid fs + in do + discovery . structureRecognition . recognitionLog %= (StructureRemoved structureName :) + discovery . structureRecognition . foundStructures %= removeStructure fs + +-- | Ensures that the entity in this cell is not already +-- participating in a registered structure +availableEntityAt :: + (Has (State GameState) sig m) => + Cosmic Location -> + m (Maybe Entity) +availableEntityAt cLoc = do + registry <- use $ discovery . structureRecognition . foundStructures + if M.member cLoc $ foundByLocation registry + then return Nothing + else entityAt cLoc + +-- | Excludes entities that are already part of a +-- registered found structure. +getWorldRow :: + (Has (State GameState) sig m) => + Cosmic Location -> + InspectionOffsets -> + Int32 -> + m [Maybe Entity] +getWorldRow cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) yOffset = + mapM availableEntityAt horizontalOffsets + where + horizontalOffsets = map mkLoc [offsetLeft .. offsetRight] + + -- NOTE: We negate the yOffset because structure rows are numbered increasing from top + -- to bottom, but swarm world coordinates increase from bottom to top. + mkLoc x = cLoc `offsetBy` V2 x (negate yOffset) + +registerRowMatches :: + (Has (State GameState) sig m) => + Cosmic Location -> + AutomatonInfo AtomicKeySymbol StructureSearcher -> + m () +registerRowMatches cLoc (AutomatonInfo horizontalOffsets sm) = do + entitiesRow <- getWorldRow cLoc horizontalOffsets 0 + let candidates = findAll sm entitiesRow + mkCandidateLogEntry c = + FoundRowCandidate + (HaystackContext (map (fmap $ view entityName) entitiesRow) (HaystackPosition $ pIndex c)) + (map (fmap $ view entityName) . needleContent $ pVal c) + rowMatchInfo + where + rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c + where + f x = MatchingRowFrom (rowIndex x) $ Structure.name . originalDefinition . wholeStructure $ x + + logEntry = FoundRowCandidates $ map mkCandidateLogEntry candidates + + discovery . structureRecognition . recognitionLog %= (logEntry :) + candidates2D <- forM candidates $ checkVerticalMatch cLoc horizontalOffsets + registerStructureMatches $ concat candidates2D + +checkVerticalMatch :: + (Has (State GameState) sig m) => + Cosmic Location -> + -- | Horizontal search offsets + InspectionOffsets -> + Position StructureSearcher -> + m [FoundStructure] +checkVerticalMatch cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = + getMatches2D cLoc horizontalFoundOffsets $ automaton2D $ pVal foundRow + where + foundLeftOffset = searchOffsetLeft + fromIntegral (pIndex foundRow) + foundRightInclusiveIndex = foundLeftOffset + fromIntegral (pLength foundRow) - 1 + horizontalFoundOffsets = InspectionOffsets (pure foundLeftOffset) (pure foundRightInclusiveIndex) + +getFoundStructures :: + Hashable keySymb => + (Int32, Int32) -> + Cosmic Location -> + StateMachine keySymb StructureRow -> + [keySymb] -> + [FoundStructure] +getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows = + map mkFound candidates + where + candidates = findAll sm entityRows + mkFound candidate = FoundStructure (wholeStructure $ pVal candidate) $ cLoc `offsetBy` loc + where + -- NOTE: We negate the yOffset because structure rows are numbered increasing from top + -- to bottom, but swarm world coordinates increase from bottom to top. + loc = V2 offsetLeft $ negate $ offsetTop + fromIntegral (pIndex candidate) + +getMatches2D :: + (Has (State GameState) sig m) => + Cosmic Location -> + -- | Horizontal found offsets (inclusive indices) + InspectionOffsets -> + AutomatonInfo SymbolSequence StructureRow -> + m [FoundStructure] +getMatches2D + cLoc + horizontalFoundOffsets@(InspectionOffsets (Min offsetLeft) _) + (AutomatonInfo (InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm) = do + entityRows <- mapM getRow verticalOffsets + return $ getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows + where + getRow = getWorldRow cLoc horizontalFoundOffsets + verticalOffsets = [offsetTop .. offsetBottom] + +-- | +-- We only allow an entity to participate in one structure at a time, +-- so multiple matches require a tie-breaker. +-- The largest structure (by area) shall win. +registerStructureMatches :: + (Has (State GameState) sig m) => + [FoundStructure] -> + m () +registerStructureMatches unrankedCandidates = do + discovery . structureRecognition . recognitionLog %= (newMsg :) + + forM_ (listToMaybe rankedCandidates) $ \fs -> + discovery . structureRecognition . foundStructures %= addFound fs + where + -- Sorted by decreasing order of preference. + rankedCandidates = sortOn Down unrankedCandidates + + getStructureName (FoundStructure swg _) = Structure.name $ originalDefinition swg + newMsg = FoundCompleteStructureCandidates $ map getStructureName rankedCandidates diff --git a/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs new file mode 100644 index 0000000000..78d78318bc --- /dev/null +++ b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Structure recognizer types. +-- +-- See overview of the structure recognizer feature in +-- "Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute". +module Swarm.Game.Scenario.Topography.Structure.Recognition.Type where + +import Control.Arrow ((&&&)) +import Control.Lens (makeLenses) +import Data.Aeson (ToJSON) +import Data.Function (on) +import Data.Int (Int32) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Ord (Down (Down)) +import Data.Semigroup (Max, Min) +import GHC.Generics (Generic) +import Linear (V2 (..)) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Location (Location) +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Structure (NamedStructure) +import Swarm.Game.Universe (Cosmic, offsetBy) +import Text.AhoCorasick (StateMachine) + +-- | A "needle" consisting of a single cell within +-- the haystack (a row of cells) to be searched +type AtomicKeySymbol = Maybe Entity + +-- | A "needle" consisting row of cells within the haystack +-- (a sequence of rows) to be searched +type SymbolSequence = [AtomicKeySymbol] + +-- | This is returned as a value of the 1-D searcher. +-- It contains search automatons customized to the 2-D structures +-- that may possibly contain the row found by the 1-D searcher. +data StructureSearcher = StructureSearcher + { automaton2D :: AutomatonInfo SymbolSequence StructureRow + , needleContent :: SymbolSequence + , singleRowItems :: NE.NonEmpty SingleRowEntityRecurrences + } + +data PositionWithinRow = PositionWithinRow + { _position :: Int32 + -- ^ horizontal index of the entity within the row + , structureRow :: StructureRow + } + +-- Represents all of the locations that particular entity +-- occurs within a specific row of a particular structure. +data SingleRowEntityRecurrences = SingleRowEntityRecurrences + { myRow :: StructureRow + , myEntity :: Entity + , entityOccurrences :: NE.NonEmpty PositionWithinRow + , expandedOffsets :: InspectionOffsets + } + +-- | A a specific row within a particular structure. +data StructureRow = StructureRow + { wholeStructure :: StructureWithGrid + , rowIndex :: Int32 + -- ^ vertical index of the row within the structure + , rowContent :: SymbolSequence + } + +-- | The original definition of a structure, bundled +-- with its grid of cells having been extracted for convenience. +data StructureWithGrid = StructureWithGrid + { originalDefinition :: NamedStructure (Maybe Cell) + , entityGrid :: [SymbolSequence] + } + deriving (Eq) + +-- | Structure definitions with metadata for consumption by the UI +data StructureInfo = StructureInfo + { withGrid :: StructureWithGrid + , entityCounts :: Map Entity Int + } + +-- | For all of the rows that contain a given entity +-- (and are recognized by a single automaton), +-- compute the left-most and right-most position +-- within the row that the given entity may occur. +-- +-- This determines how far to the left and to the right +-- our search of the world cells needs to begin and +-- end, respectively. +-- +-- The 'Semigroup' instance always grows in extent, taking the minimum +-- of the leftward offsets and the maximum of the rightward offsets. +data InspectionOffsets = InspectionOffsets + { startOffset :: Min Int32 + -- ^ Always non-positive (i.e. either zero or negative). + -- For the first-level search, this extends to the left. + -- For the second-level search, this extends upward. + , endOffset :: Max Int32 + -- ^ Always non-negative. + -- For the first-level search, this extends to the right. + -- For the second-level search, this extends downward. + } + deriving (Show, Generic, ToJSON) + +instance Semigroup InspectionOffsets where + InspectionOffsets l1 r1 <> InspectionOffsets l2 r2 = + InspectionOffsets (l1 <> l2) (r1 <> r2) + +-- | Each automaton shall be initialized to recognize +-- a certain subset of structure rows, that may either +-- all be within one structure, or span multiple structures. +data AutomatonInfo k v = AutomatonInfo + { _inspectionOffsets :: InspectionOffsets + , _automaton :: StateMachine k v + } + deriving (Generic) + +makeLenses ''AutomatonInfo + +-- | The complete set of data needed to identify applicable +-- structures, based on a just-placed entity. +data RecognizerAutomatons = RecognizerAutomatons + { _definitions :: [StructureInfo] + -- ^ all of the structures that shall participate in automatic recognition. + -- This list is used only by the UI. + , _automatonsByEntity :: Map Entity (AutomatonInfo AtomicKeySymbol StructureSearcher) + } + deriving (Generic) + +makeLenses ''RecognizerAutomatons + +-- | Finals output of the search process. +-- These are the elements that are stored in the 'FoundRegistry'. +data FoundStructure = FoundStructure + { structureWithGrid :: StructureWithGrid + , upperLeftCorner :: Cosmic Location + } + deriving (Eq) + +-- | Ordering is by increasing preference between simultaneously +-- completed structures. +-- The preference heuristic is for: +-- +-- 1. Primarily, larger area. +-- 2. Secondarily, lower X-Y coords (X is compared first) +-- +-- Since the natural order of coordinates increases as described, +-- we need to invert it with 'Down' so that this ordering is by +-- increasing preference. +instance Ord FoundStructure where + compare = compare `on` (f1 &&& f2) + where + f1 = computeArea . getAreaDimensions . entityGrid . structureWithGrid + f2 = Down . upperLeftCorner + +genOccupiedCoords :: FoundStructure -> [Cosmic Location] +genOccupiedCoords (FoundStructure swg loc) = + [loc `offsetBy` V2 x (negate y) | x <- [0 .. w - 1], y <- [0 .. h - 1]] + where + AreaDimensions w h = getAreaDimensions $ entityGrid swg diff --git a/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type/Toplevel.hs b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type/Toplevel.hs new file mode 100644 index 0000000000..1b9e84cf32 --- /dev/null +++ b/src/Swarm/Game/Scenario/Topography/Structure/Recognition/Type/Toplevel.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Public interface for structure recognizer. +module Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel where + +import Control.Lens hiding (from, (<.>)) +import GHC.Generics (Generic) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Log +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type + +data StructureRecognizer = StructureRecognizer + { _automatons :: RecognizerAutomatons + , _foundStructures :: FoundRegistry + -- ^ Records the top-left corner of the found structure + , _recognitionLog :: [SearchLog] + } + deriving (Generic) + +makeLenses ''StructureRecognizer diff --git a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs index 21a2100091..69a4c8b0c4 100644 --- a/src/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -9,8 +9,10 @@ module Swarm.Game.Scenario.Topography.WorldDescription where import Control.Carrier.Reader (runReader) import Control.Carrier.Throw.Either import Control.Monad (forM) +import Data.Coerce import Data.Functor.Identity import Data.Maybe (catMaybes) +import Data.Text qualified as T import Data.Yaml as Y import Swarm.Game.Entity import Swarm.Game.Location @@ -19,9 +21,15 @@ 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 ( + Parentage (Root), WaypointName, ) -import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure)) +import Swarm.Game.Scenario.Topography.Structure ( + InheritedStructureDefs, + LocatedStructure, + MergedStructure (MergedStructure), + PStructure (Structure), + ) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Universe @@ -45,6 +53,7 @@ data PWorldDescription e = WorldDescription , ul :: Location , area :: [[PCell e]] , navigation :: Navigation Identity WaypointName + , placedStructures :: [LocatedStructure (Maybe (PCell e))] , worldName :: SubworldName , worldProg :: Maybe (TTerm '[] (World CellVal)) } @@ -70,7 +79,13 @@ instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) World let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs struc = Structure initialArea initialStructureDefs placementDefs $ waypointDefs <> mapWaypoints - MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc + + MergedStructure mergedArea staticStructurePlacements unmergedWaypoints <- + either (fail . T.unpack) return $ + Structure.mergeStructures mempty Root struc + + let absoluteStructurePlacements = + map (offsetLoc $ coerce upperLeft) staticStructurePlacements validatedNavigation <- validatePartialNavigation @@ -92,6 +107,7 @@ instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) World <*> pure upperLeft <*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells. <*> pure validatedNavigation + <*> pure absoluteStructurePlacements <*> pure subWorldName <*> pure dslTerm diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 505346c585..6d99d42625 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -100,6 +100,7 @@ module Swarm.Game.State ( availableCommands, knownEntities, gameAchievements, + structureRecognition, -- *** Landscape Landscape, @@ -155,21 +156,25 @@ module Swarm.Game.State ( buildWorldTuples, genMultiWorld, genRobotTemplates, + entityAt, + zoomWorld, ) where import Control.Applicative ((<|>)) import Control.Arrow (Arrow ((&&&))) +import Control.Carrier.State.Lazy qualified as Fused import Control.Effect.Lens import Control.Effect.Lift import Control.Effect.State (State) import Control.Effect.Throw import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) -import Control.Monad (forM_) +import Control.Monad (filterM, forM, forM_, join) import Data.Aeson (FromJSON, ToJSON) import Data.Array (Array, listArray) import Data.Bifunctor (first) import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Foldable (toList) +import Data.Foldable.Extra (allM) import Data.Int (Int32) import Data.IntMap (IntMap) import Data.IntMap qualified as IM @@ -192,6 +197,7 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import Data.Tuple (swap) import GHC.Generics (Generic) +import Linear (V2 (..)) import Servant.Docs (ToSample) import Servant.Docs qualified as SD import Swarm.Game.Achievement.Attainment @@ -211,6 +217,10 @@ import Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Status import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel import Swarm.Game.ScenarioInfo import Swarm.Game.Terrain (TerrainType (..)) import Swarm.Game.Universe as U @@ -513,6 +523,7 @@ data Discovery = Discovery , _availableCommands :: Notifications Const , _knownEntities :: [Text] , _gameAchievements :: Map GameplayAchievement Attainment + , _structureRecognition :: StructureRecognizer } makeLensesNoSigs ''Discovery @@ -533,6 +544,9 @@ knownEntities :: Lens' Discovery [Text] -- | Map of in-game achievements that were obtained gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment) +-- | Recognizer for robot-constructed structures +structureRecognition :: Lens' Discovery StructureRecognizer + data Landscape = Landscape { _worldNavigation :: Navigation (M.Map SubworldName) Location , _multiWorld :: W.MultiWorld Int Entity @@ -1166,6 +1180,7 @@ initGameState gsc = , -- This does not need to be initialized with anything, -- since the master list of achievements is stored in UIState _gameAchievements = mempty + , _structureRecognition = StructureRecognizer (RecognizerAutomatons [] mempty) emptyFoundStructures [] } , _activeRobots = IS.empty , _waitingRobots = M.empty @@ -1274,31 +1289,70 @@ genRobotTemplates scenario worldTuples = genRobots :: [(Int, TRobot)] genRobots = concat $ NE.toList $ NE.map (fst . snd) worldTuples --- | Create an initial game state corresponding to the given scenario. -scenarioToGameState :: - Scenario -> - ValidatedLaunchParams -> - GameStateConfig -> - IO GameState -scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do - -- Decide on a seed. In order of preference, we will use: - -- 1. seed value provided by the user - -- 2. seed value specified in the scenario description - -- 3. randomly chosen seed value - theSeed <- case userSeed <|> scenario ^. scenarioSeed of - Just s -> return s - Nothing -> randomRIO (0, maxBound :: Int) +-- | Get the entity (if any) at a given location. +entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity) +entityAt (Cosmic subworldName loc) = + join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc)) - now <- Clock.getTime Clock.Monotonic - let robotList' = (robotCreatedAt .~ now) <$> robotList +-- | Perform an action requiring a 'W.World' state component in a +-- larger context with a 'GameState'. +zoomWorld :: + (Has (State GameState) sig m) => + SubworldName -> + Fused.StateC (W.World Int Entity) Identity b -> + m (Maybe b) +zoomWorld swName n = do + mw <- use $ landscape . multiWorld + forM (M.lookup swName mw) $ \w -> do + let (w', a) = run (Fused.runState w n) + landscape . multiWorld %= M.insert swName w' + return a + +-- | Matches definitions against the placements. +-- Fails fast (short-circuits) if a non-matching +-- cell is encountered. +ensureStructureIntact :: + (Has (State GameState) sig m) => + FoundStructure -> + m Bool +ensureStructureIntact (FoundStructure (StructureWithGrid _ grid) upperLeft) = + allM outer $ zip [0 ..] grid + where + outer (i, row) = allM (inner i) $ zip [0 ..] row + inner i (j, cell) = + fmap (== cell) $ + entityAt $ + upperLeft `offsetBy` V2 i (negate j) - let modifyRecipesInfo oldRecipesInfo = - oldRecipesInfo - & recipesOut %~ addRecipesWith outRecipeMap - & recipesIn %~ addRecipesWith inRecipeMap - & recipesCat %~ addRecipesWith catRecipeMap +mkRecognizer :: + (Has (State GameState) sig m) => + StaticStructureInfo -> + m StructureRecognizer +mkRecognizer (StaticStructureInfo xs thePlacements) = do + filteredFound <- filterM ensureStructureIntact allFound + let fs = populateStaticFoundStructures filteredFound + return $ StructureRecognizer (mkAutomatons xs) fs [] + where + f (swn, locatedList) = map (placedToFound swn) locatedList + allFound = concatMap f $ M.toList thePlacements - return $ +pureScenarioToGameState :: + Scenario -> + Seed -> + Clock.TimeSpec -> + Maybe CodeToRun -> + GameStateConfig -> + GameState +pureScenarioToGameState scenario theSeed now toRun gsc = + preliminaryGameState + & discovery . structureRecognition .~ recognizer + where + recognizer = + runIdentity $ + Fused.evalState preliminaryGameState $ + mkRecognizer (scenario ^. scenarioStructures) + + preliminaryGameState = (initGameState gsc) { _focusedRobotID = baseID } @@ -1328,7 +1382,15 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) False -> REPLDone Nothing True -> REPLWorking (Typed Nothing PolyUnit mempty) & temporal . robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick) - where + + robotList' = (robotCreatedAt .~ now) <$> robotList + + modifyRecipesInfo oldRecipesInfo = + oldRecipesInfo + & recipesOut %~ addRecipesWith outRecipeMap + & recipesIn %~ addRecipesWith inRecipeMap + & recipesCat %~ addRecipesWith catRecipeMap + groupRobotsBySubworld = binTuples . map (view (robotLocation . subworld) &&& id) @@ -1398,6 +1460,24 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) initGensym = length robotList - 1 addRecipesWith f = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) +-- | Create an initial game state corresponding to the given scenario. +scenarioToGameState :: + Scenario -> + ValidatedLaunchParams -> + GameStateConfig -> + IO GameState +scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do + -- Decide on a seed. In order of preference, we will use: + -- 1. seed value provided by the user + -- 2. seed value specified in the scenario description + -- 3. randomly chosen seed value + theSeed <- case userSeed <|> scenario ^. scenarioSeed of + Just s -> return s + Nothing -> randomRIO (0, maxBound :: Int) + + now <- Clock.getTime Clock.Monotonic + return $ pureScenarioToGameState scenario theSeed now toRun gsc + -- | Take a world description, parsed from a scenario file, and turn -- it into a list of located robots and a world function. buildWorld :: WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index a694edff34..ab7fd750a3 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -46,6 +46,7 @@ import Data.List (find, sortOn) import Data.List qualified as L import Data.List.NonEmpty qualified as NE import Data.Map qualified as M +import Data.Map.NonEmpty qualified as NEM import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) import Data.Ord (Down (Down)) import Data.Sequence ((><)) @@ -75,10 +76,14 @@ import Swarm.Game.Scenario.Objective.WinCheck qualified as WC import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation) import Swarm.Game.Scenario.Topography.Navigation.Util import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) +import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel (foundStructures) import Swarm.Game.State import Swarm.Game.Step.Combustion qualified as Combustion import Swarm.Game.Step.Pathfinding import Swarm.Game.Step.Util +import Swarm.Game.Step.Util.Inspect import Swarm.Game.Universe import Swarm.Game.Value import Swarm.Game.World qualified as W @@ -1398,6 +1403,15 @@ execConst c vs s k = do 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 + Structure -> case vs of + [VText name, VInt idx] -> do + registry <- use $ discovery . structureRecognition . foundStructures + let maybeFoundStructures = M.lookup (StructureName name) $ foundByName registry + mkOutput mapNE = (NE.length xs, indexWrapNonEmpty xs idx ^. planar) + where + xs = NEM.keys mapNE + return $ Out (asValue $ mkOutput <$> maybeFoundStructures) s k + _ -> badConst Detect -> case vs of [VText name, VRect x1 y1 x2 y2] -> do loc <- use robotLocation diff --git a/src/Swarm/Game/Step/Combustion.hs b/src/Swarm/Game/Step/Combustion.hs index b66617cde0..446eb43dde 100644 --- a/src/Swarm/Game/Step/Combustion.hs +++ b/src/Swarm/Game/Step/Combustion.hs @@ -32,6 +32,7 @@ import Swarm.Game.Location import Swarm.Game.Robot import Swarm.Game.State import Swarm.Game.Step.Util +import Swarm.Game.Step.Util.Inspect import Swarm.Game.Universe import Swarm.Language.Context (empty) import Swarm.Language.Pipeline (ProcessedTerm) diff --git a/src/Swarm/Game/Step/Pathfinding.hs b/src/Swarm/Game/Step/Pathfinding.hs index 15f02f0ce3..650e4efb60 100644 --- a/src/Swarm/Game/Step/Pathfinding.hs +++ b/src/Swarm/Game/Step/Pathfinding.hs @@ -35,6 +35,7 @@ import Swarm.Game.Entity import Swarm.Game.Location import Swarm.Game.State import Swarm.Game.Step.Util +import Swarm.Game.Step.Util.Inspect import Swarm.Game.Universe import Swarm.Language.Syntax import Swarm.Util (hoistMaybe) diff --git a/src/Swarm/Game/Step/Util.hs b/src/Swarm/Game/Step/Util.hs index 4d2e7232b5..c4872d2dc6 100644 --- a/src/Swarm/Game/Step/Util.hs +++ b/src/Swarm/Game/Step/Util.hs @@ -13,13 +13,10 @@ 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 (forM, forM_, guard, join, when) +import Control.Monad (forM_, guard, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Array (bounds, (!)) -import Data.IntMap qualified as IM -import Data.List (find) -import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T @@ -29,6 +26,7 @@ import Swarm.Game.Exception import Swarm.Game.Location import Swarm.Game.ResourceLoading (NameGenerator (..)) import Swarm.Game.Robot +import Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking qualified as SRT import Swarm.Game.State import Swarm.Game.Universe import Swarm.Game.World qualified as W @@ -72,8 +70,9 @@ updateEntityAt cLoc@(Cosmic subworldName loc) upd = do zoomWorld subworldName $ W.updateM @Int (W.locToCoords loc) upd - forM_ (WM.getModification =<< someChange) $ \_modType -> do + forM_ (WM.getModification =<< someChange) $ \modType -> do wakeWatchingRobots cLoc + SRT.entityModified modType cLoc -- * Capabilities @@ -120,38 +119,6 @@ getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic flagRedraw :: (Has (State GameState) sig m) => m () flagRedraw = needsRedraw .= True --- * World queries - -getNeighborLocs :: Cosmic Location -> [Cosmic Location] -getNeighborLocs loc = map (offsetBy loc . flip applyTurn north . DRelative . DPlanar) listEnums - --- | Perform an action requiring a 'W.World' state component in a --- larger context with a 'GameState'. -zoomWorld :: - (Has (State GameState) sig m) => - SubworldName -> - StateC (W.World Int Entity) Identity b -> - m (Maybe b) -zoomWorld swName n = do - mw <- use $ landscape . multiWorld - forM (M.lookup swName mw) $ \w -> do - let (w', a) = run (runState w n) - landscape . multiWorld %= M.insert swName w' - return a - --- | Get the entity (if any) at a given location. -entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity) -entityAt (Cosmic subworldName loc) = - join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc)) - --- | Get the robot with a given ID. -robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot) -robotWithID rid = use (robotMap . at rid) - --- | Get the robot with a given name. -robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot) -robotWithName rname = use (robotMap . to IM.elems . to (find $ \r -> r ^. robotName == rname)) - -- * Randomness -- | Generate a uniformly random number using the random generator in diff --git a/src/Swarm/Game/Step/Util/Inspect.hs b/src/Swarm/Game/Step/Util/Inspect.hs new file mode 100644 index 0000000000..975d7a5edb --- /dev/null +++ b/src/Swarm/Game/Step/Util/Inspect.hs @@ -0,0 +1,29 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Step.Util.Inspect where + +import Control.Carrier.State.Lazy +import Control.Effect.Lens +import Control.Lens hiding (from, use, (%=), (<.>)) +import Data.IntMap qualified as IM +import Data.List (find) +import Data.Text (Text) +import Swarm.Game.Location +import Swarm.Game.Robot +import Swarm.Game.State +import Swarm.Game.Universe +import Swarm.Language.Direction +import Swarm.Util (listEnums) + +-- * World queries + +getNeighborLocs :: Cosmic Location -> [Cosmic Location] +getNeighborLocs loc = map (offsetBy loc . flip applyTurn north . DRelative . DPlanar) listEnums + +-- | Get the robot with a given ID. +robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot) +robotWithID rid = use (robotMap . at rid) + +-- | Get the robot with a given name. +robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot) +robotWithName rname = use (robotMap . to IM.elems . to (find $ \r -> r ^. robotName == rname)) diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index e2e7ce9724..4f8c18a14f 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -80,6 +80,8 @@ data Capability CDrill | -- | Execute the 'Waypoint' command CWaypoint + | -- | Execute the 'Structure' command + CStructure | -- | Execute the 'Whereami' command CSenseloc | -- | Execute the 'Blocked' command @@ -261,6 +263,7 @@ constCaps = \case Scout -> Just CRecondir Whereami -> Just CSenseloc Waypoint -> Just CWaypoint + Structure -> Just CStructure Detect -> Just CDetectloc Resonate -> Just CDetectcount Density -> Just CDetectcount diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index 75448c0ebb..b69b1cd799 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -224,6 +224,8 @@ data Const Whereami | -- | Get the x, y coordinates of a named waypoint, by index Waypoint + | -- | Get the x, y coordinates of a constructed structure, by index + Structure | -- | Locate the closest instance of a given entity within the rectangle -- specified by opposite corners, relative to the current location. Detect @@ -643,6 +645,13 @@ constInfo c = case c of , "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." ] + Structure -> + command 2 Intangible . doc "Get the x, y coordinates of a constructed structure, by name and index" $ + [ "The outermost type of the return value indicates whether any structure of such name exists." + , "Since structures can have multiple occurrences, returns a tuple of (count, (x, y))." + , "The supplied index will be wrapped automatically, modulo the structure count." + , "A robot can use the count to know whether they have iterated over the full structure list." + ] Detect -> command 2 Intangible . doc "Detect an entity within a rectangle." $ ["Locate the closest instance of a given entity within the rectangle specified by opposite corners, relative to the current location."] diff --git a/src/Swarm/Language/Typecheck.hs b/src/Swarm/Language/Typecheck.hs index b8a2f4d2c1..d9df8b5b71 100644 --- a/src/Swarm/Language/Typecheck.hs +++ b/src/Swarm/Language/Typecheck.hs @@ -774,6 +774,7 @@ inferConst c = case c of Scout -> [tyQ| dir -> cmd bool |] Whereami -> [tyQ| cmd (int * int) |] Waypoint -> [tyQ| text -> int -> cmd (int * (int * int)) |] + Structure -> [tyQ| text -> int -> cmd (unit + (int * (int * int))) |] Detect -> [tyQ| text -> ((int * int) * (int * int)) -> cmd (unit + (int * int)) |] Resonate -> [tyQ| text -> ((int * int) * (int * int)) -> cmd int |] Density -> [tyQ| ((int * int) * (int * int)) -> cmd int |] diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index bddb2b1ab1..6b7d2c7e61 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -76,6 +76,8 @@ import Swarm.Game.Entity hiding (empty) import Swarm.Game.Location import Swarm.Game.ResourceLoading (getSwarmHistoryPath) import Swarm.Game.Robot +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (definitions) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel (automatons) import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.Step (finishGameTick, gameTick) @@ -106,6 +108,7 @@ import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl import Swarm.TUI.Model.StateUpdate +import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI import Swarm.TUI.View.Objective qualified as GR import Swarm.TUI.View.Util (generateModal) @@ -331,6 +334,7 @@ handleMainEvent ev = do FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do toggleModal MessagesModal gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks + FKey 6 | not (null $ s ^. gameState . discovery . structureRecognition . automatons . definitions) -> toggleModal StructuresModal -- show goal ControlChar 'g' -> if hasAnythingToShow $ s ^. uiState . uiGoal . goalsContent @@ -504,6 +508,16 @@ handleModalEvent = \case uiState . uiGoal . listWidget .= newList GoalSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) + Just StructuresModal -> case ev of + V.EvKey (V.KChar '\t') [] -> uiState . uiStructure . structurePanelFocus %= focusNext + _ -> do + focused <- use $ uiState . uiStructure . structurePanelFocus + case focusGetCurrent focused of + Just (StructureWidgets w) -> case w of + StructuresList -> + refreshList $ uiState . uiStructure . structurePanelListWidget + StructureSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev) + _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) where refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs index 2fa9552054..a3d11b36d3 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ b/src/Swarm/TUI/Editor/Palette.hs @@ -133,6 +133,7 @@ constructScenario maybeOriginalScenario cellGrid = , ul = upperLeftCoord , area = cellGrid , navigation = Navigation mempty mempty + , placedStructures = mempty , worldName = DefaultRootSubworld , worldProg = Nothing } diff --git a/src/Swarm/TUI/Model/Goal.hs b/src/Swarm/TUI/Model/Goal.hs index e099b98614..5da871c539 100644 --- a/src/Swarm/TUI/Model/Goal.hs +++ b/src/Swarm/TUI/Model/Goal.hs @@ -29,11 +29,11 @@ import Swarm.Util (listEnums) data GoalStatus = -- | Goals in this category have other goals as prerequisites. -- However, they are only displayed if the "previewable" attribute - -- is `true`. + -- is @true@. Upcoming | -- | Goals in this category may be pursued in parallel. -- However, they are only displayed if the "hidden" attribute - -- is `false`. + -- is @false@. Active | -- | A goal's programmatic condition, as well as all its prerequisites, were completed. -- This is a "latch" mechanism; at some point the conditions required to meet the goal may diff --git a/src/Swarm/TUI/Model/Menu.hs b/src/Swarm/TUI/Model/Menu.hs index 254a6a6a46..ba70aae812 100644 --- a/src/Swarm/TUI/Model/Menu.hs +++ b/src/Swarm/TUI/Model/Menu.hs @@ -47,6 +47,7 @@ data ModalType | RecipesModal | CommandsModal | MessagesModal + | StructuresModal | EntityPaletteModal | TerrainPaletteModal | RobotsModal diff --git a/src/Swarm/TUI/Model/Name.hs b/src/Swarm/TUI/Model/Name.hs index 9d6be71ff3..61f056743a 100644 --- a/src/Swarm/TUI/Model/Name.hs +++ b/src/Swarm/TUI/Model/Name.hs @@ -47,6 +47,11 @@ data GoalWidget | GoalSummary deriving (Eq, Ord, Show, Read, Bounded, Enum) +data StructureWidget + = StructuresList + | StructureSummary + deriving (Eq, Ord, Show, Read, Bounded, Enum) + -- | Clickable buttons in modal dialogs. data Button = CancelButton @@ -93,6 +98,8 @@ data Name ScenarioConfigControl ScenarioConfigPanel | -- | The list of goals/objectives. GoalWidgets GoalWidget + | -- | The list of goals/objectives. + StructureWidgets StructureWidget | -- | The list of scenario choices. ScenarioList | -- | The scrollable viewport for the info panel. diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index 1a7be56686..c2fef9ba7e 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -18,6 +18,7 @@ module Swarm.TUI.Model.StateUpdate ( ) where import Brick.AttrMap (applyAttrMappings) +import Brick.Focus import Brick.Widgets.List qualified as BL import Control.Applicative ((<|>)) import Control.Carrier.Accum.FixedStrict (runAccum) @@ -48,6 +49,8 @@ import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics import Swarm.Game.Scenario.Status +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (definitions) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel (automatons) import Swarm.Game.ScenarioInfo ( loadScenarioInfo, normalizeScenarioPath, @@ -64,10 +67,14 @@ import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (toSerializableParams) import Swarm.TUI.Model import Swarm.TUI.Model.Goal (emptyGoalDisplay) +import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI import Swarm.TUI.View.Attribute.Attr (swarmAttrMap) import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) +import Swarm.TUI.View.Structure qualified as SR +import Swarm.Util (listEnums) import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock @@ -257,6 +264,10 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do & lastFrameTime .~ curTime & uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing & uiWorldEditor . EM.editingBounds . EM.boundsRect %~ setNewBounds + & uiStructure + .~ StructureDisplay + (SR.makeListWidget $ gs ^. discovery . structureRecognition . automatons . definitions) + (focusSetCurrent (StructureWidgets StructuresList) $ focusRing $ map StructureWidgets listEnums) where entityList = EU.getEntitiesForList $ gs ^. landscape . entityMap diff --git a/src/Swarm/TUI/Model/Structure.hs b/src/Swarm/TUI/Model/Structure.hs new file mode 100644 index 0000000000..a588465ce7 --- /dev/null +++ b/src/Swarm/TUI/Model/Structure.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A UI-centric model for Structure presentation. +module Swarm.TUI.Model.Structure where + +import Brick.Focus +import Brick.Widgets.List qualified as BL +import Control.Lens (makeLenses) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.TUI.Model.Name +import Swarm.Util (listEnums) + +data StructureDisplay = StructureDisplay + { _structurePanelListWidget :: BL.List Name StructureInfo + -- ^ required for maintaining the selection/navigation + -- state among list items + , _structurePanelFocus :: FocusRing Name + } + +makeLenses ''StructureDisplay + +emptyStructureDisplay :: StructureDisplay +emptyStructureDisplay = + StructureDisplay + (BL.list (StructureWidgets StructuresList) mempty 1) + (focusRing $ map StructureWidgets listEnums) diff --git a/src/Swarm/TUI/Model/UI.hs b/src/Swarm/TUI/Model/UI.hs index 3000df69cd..96dea4a7f5 100644 --- a/src/Swarm/TUI/Model/UI.hs +++ b/src/Swarm/TUI/Model/UI.hs @@ -23,6 +23,7 @@ module Swarm.TUI.Model.UI ( uiScrollToEnd, uiModal, uiGoal, + uiStructure, uiHideGoals, uiAchievements, lgTicksPerSecond, @@ -81,6 +82,7 @@ import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.Structure import Swarm.TUI.View.Attribute.Attr (swarmAttrMap) import Swarm.Util import Swarm.Util.Lens (makeLensesExcluding) @@ -107,6 +109,7 @@ data UIState = UIState , _uiScrollToEnd :: Bool , _uiModal :: Maybe Modal , _uiGoal :: GoalDisplay + , _uiStructure :: StructureDisplay , _uiHideGoals :: Bool , _uiAchievements :: Map CategorizedAchievement Attainment , _uiShowFPS :: Bool @@ -186,6 +189,9 @@ uiModal :: Lens' UIState (Maybe Modal) -- has been displayed to the user initially. uiGoal :: Lens' UIState GoalDisplay +-- | Definition and status of a recognizable structure +uiStructure :: Lens' UIState StructureDisplay + -- | When running with @--autoplay@, suppress the goal dialogs. -- -- For development, the @--cheat@ flag shows goals again. @@ -319,6 +325,7 @@ initUIState speedFactor showMainMenu cheatMode = do , _uiScrollToEnd = False , _uiModal = Nothing , _uiGoal = emptyGoalDisplay + , _uiStructure = emptyStructureDisplay , _uiHideGoals = False , _uiAchievements = M.fromList $ map (view achievement &&& id) achievements , _uiShowFPS = False diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 30d6266e70..db5a0aea1a 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -23,7 +23,6 @@ module Swarm.TUI.View ( -- * Robot panel drawRobotPanel, drawItem, - drawLabelledEntityName, renderDutyCycle, -- * Info panel @@ -93,6 +92,8 @@ import Swarm.Game.Scenario.Scoring.CodeSize import Swarm.Game.Scenario.Scoring.ConcreteMetrics import Swarm.Game.Scenario.Scoring.GenericMetrics import Swarm.Game.Scenario.Status +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel (automatons) import Swarm.Game.ScenarioInfo ( ScenarioItem (..), scenarioItemName, @@ -121,6 +122,7 @@ import Swarm.TUI.View.Achievement import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay import Swarm.TUI.View.Objective qualified as GR +import Swarm.TUI.View.Structure qualified as SR import Swarm.TUI.View.Util as VU import Swarm.Util import Swarm.Util.UnitInterval @@ -617,6 +619,7 @@ drawModal s = \case RecipesModal -> availableListWidget (s ^. gameState) RecipeList CommandsModal -> commandsListWidget (s ^. gameState) MessagesModal -> availableListWidget (s ^. gameState) MessageList + StructuresModal -> SR.renderStructuresDisplay (s ^. gameState) (s ^. uiState . uiStructure) ScenarioEndModal outcome -> padBottom (Pad 1) $ vBox $ @@ -807,6 +810,7 @@ helpWidget theSeed mport = , ("F3", "Available recipes") , ("F4", "Available commands") , ("F5", "Messages") + , ("F6", "Structures") , ("Ctrl-g", "show goal") , ("Ctrl-p", "pause") , ("Ctrl-o", "single step") @@ -945,6 +949,12 @@ drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyC | otherwise = NoHighlight in Just (highlight, key, name) + -- Hides this key if the recognizable structure list is empty + structuresKey = + if null $ s ^. gameState . discovery . structureRecognition . automatons . definitions + then Nothing + else Just (NoHighlight, "F6", "Structures") + globalKeyCmds = catMaybes [ Just (NoHighlight, "F1", "Help") @@ -952,6 +962,7 @@ drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyC , notificationKey (discovery . availableRecipes) "F3" "Recipes" , notificationKey (discovery . availableCommands) "F4" "Commands" , notificationKey messageNotifications "F5" "Messages" + , structuresKey ] -- | Draw a menu explaining what key commands are available for the @@ -1160,15 +1171,6 @@ drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n showCount = padLeft Max . str . show drawItem _ _ _ (EquippedEntry e) = drawLabelledEntityName e <+> padLeft Max (str " ") --- | Draw the name of an entity, labelled with its visual --- representation as a cell in the world. -drawLabelledEntityName :: Entity -> Widget Name -drawLabelledEntityName e = - hBox - [ padRight (Pad 2) (renderDisplay (e ^. entityDisplay)) - , txt (e ^. entityName) - ] - ------------------------------------------------------------ -- Info panel ------------------------------------------------------------ diff --git a/src/Swarm/TUI/View/Structure.hs b/src/Swarm/TUI/View/Structure.hs new file mode 100644 index 0000000000..e4060deb88 --- /dev/null +++ b/src/Swarm/TUI/View/Structure.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Display logic for Objectives. +module Swarm.TUI.View.Structure ( + renderStructuresDisplay, + makeListWidget, +) where + +import Brick hiding (Direction, Location) +import Brick.Focus +import Brick.Widgets.Center +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.Map.NonEmpty qualified as NEM +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Data.Vector qualified as V +import Swarm.Game.Entity (entityDisplay) +import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (getEntityGrid) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel (foundStructures) +import Swarm.Game.State +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Structure +import Swarm.TUI.View.Attribute.Attr +import Swarm.TUI.View.CellDisplay +import Swarm.TUI.View.Util +import Swarm.Util (parens) + +structureWidget :: GameState -> StructureInfo -> Widget n +structureWidget gs s = + hLimit 30 $ + vBox + [ hBox + [ padRight (Pad 1) $ txt "Name:" + , withAttr boldAttr $ txt theName + , txt occurrenceCountSuffix + ] + , maybeDescriptionWidget + , padTop (Pad 1) $ + hBox + [ structureIllustration + , padLeft (Pad 4) ingredientsBox + ] + ] + where + maybeDescriptionWidget = maybe emptyWidget txtWrap $ Structure.description . originalDefinition . withGrid $ s + + registry = gs ^. discovery . structureRecognition . foundStructures + occurrenceCountSuffix = case M.lookup sName $ foundByName registry of + Nothing -> "" + Just inner -> " " <> parens (T.unwords [T.pack $ show $ NEM.size inner, "found"]) + + structureIllustration = vBox $ map (hBox . map renderOneCell) cells + d = originalDefinition $ withGrid s + + ingredientsBox = + vBox + [ padBottom (Pad 1) $ withAttr boldAttr $ txt "Ingredients:" + , ingredientLines + ] + ingredientLines = vBox . map showCount . M.toList $ entityCounts s + + showCount (e, c) = + hBox + [ drawLabelledEntityName e + , txt $ + T.unwords + [ ":" + , T.pack $ show c + ] + ] + + sName = Structure.name d + StructureName theName = sName + cells = getEntityGrid d + renderOneCell = maybe (txt " ") (renderDisplay . view entityDisplay) + +makeListWidget :: [StructureInfo] -> BL.List Name StructureInfo +makeListWidget structureDefs = + BL.listMoveTo 0 $ BL.list (StructureWidgets StructuresList) (V.fromList structureDefs) 1 + +renderStructuresDisplay :: GameState -> StructureDisplay -> Widget Name +renderStructuresDisplay gs structureDisplay = + vBox + [ hBox + [ leftSide + , padLeft (Pad 2) structureElaboration + ] + , footer + ] + where + footer = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes" + lw = _structurePanelListWidget structureDisplay + fr = _structurePanelFocus structureDisplay + leftSide = + hLimitPercent 25 $ + padAll 1 $ + vBox + [ hCenter $ withAttr boldAttr $ txt "Candidates" + , padAll 1 $ + vLimit 10 $ + withFocusRing fr (BL.renderList drawSidebarListItem) lw + ] + + -- Adds very subtle coloring to indicate focus switch + highlightIfFocused = case focusGetCurrent fr of + Just (StructureWidgets StructureSummary) -> withAttr lightCyanAttr + _ -> id + + -- Note: An extra "padRight" is inserted to account for the vertical scrollbar, + -- whether or not it appears. + structureElaboration = + clickable (StructureWidgets StructureSummary) + . maybeScroll ModalViewport + . maybe emptyWidget (padAll 1 . padRight (Pad 1) . highlightIfFocused . structureWidget gs . snd) + $ BL.listSelectedElement lw + +drawSidebarListItem :: + Bool -> + StructureInfo -> + Widget Name +drawSidebarListItem _isSelected (StructureInfo swg _) = + txt . getStructureName . Structure.name $ originalDefinition swg diff --git a/src/Swarm/TUI/View/Util.hs b/src/Swarm/TUI/View/Util.hs index 3bf207f137..2a45fbe916 100644 --- a/src/Swarm/TUI/View/Util.hs +++ b/src/Swarm/TUI/View/Util.hs @@ -50,6 +50,7 @@ generateModal s mt = Modal mt (dialog (Just $ str title) buttons (maxModalWindow RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) CommandsModal -> ("Available Commands", Nothing, descriptionWidth) MessagesModal -> ("Messages", Nothing, descriptionWidth) + StructuresModal -> ("Buildable Structures", Nothing, descriptionWidth) ScenarioEndModal WinModal -> let nextMsg = "Next challenge!" stopMsg = fromMaybe "Return to the menu" haltingMessage @@ -214,3 +215,12 @@ maybeScroll vpName contents = . viewport vpName Vertical . Widget Fixed Fixed $ return result + +-- | Draw the name of an entity, labelled with its visual +-- representation as a cell in the world. +drawLabelledEntityName :: Entity -> Widget n +drawLabelledEntityName e = + hBox + [ padRight (Pad 2) (renderDisplay (e ^. entityDisplay)) + , txt (e ^. entityName) + ] diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index a2935bbb92..726899766e 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -25,6 +25,7 @@ module Swarm.Util ( both, allEqual, surfaceEmpty, + deleteKeys, applyWhen, hoistMaybe, unsnocNE, @@ -225,6 +226,11 @@ allEqual (x : xs) = all (== x) xs surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a surfaceEmpty isEmpty t = t <$ guard (not (isEmpty t)) +-- | Taken from here: +-- https://hackage.haskell.org/package/ghc-9.8.1/docs/GHC-Data-FiniteMap.html#v:deleteList +deleteKeys :: Ord key => [key] -> Map key elt -> Map key elt +deleteKeys ks m = foldl' (flip M.delete) m ks + ------------------------------------------------------------ -- Forward-compatibility functions diff --git a/src/Swarm/Web.hs b/src/Swarm/Web.hs index c694dc659b..20d3884745 100644 --- a/src/Swarm/Web.hs +++ b/src/Swarm/Web.hs @@ -46,6 +46,9 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (ByteString) import Data.Foldable (toList) import Data.IntMap qualified as IM +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Map.NonEmpty qualified as NEM import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -63,6 +66,9 @@ import Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph import Swarm.Game.Scenario.Objective.WinCheck +import Swarm.Game.Scenario.Topography.Structure.Recognition.Log +import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel import Swarm.Game.State import Swarm.Language.Module import Swarm.Language.Pipeline @@ -90,6 +96,8 @@ type SwarmAPI = :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking :<|> "goals" :> Get '[JSON] WinCondition + :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog] + :<|> "recognize" :> "found" :> Get '[JSON] [StructureLocation] :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem] @@ -138,6 +146,8 @@ mkApp state events = :<|> goalsGraphHandler state :<|> uiGoalHandler state :<|> goalsHandler state + :<|> recogLogHandler state + :<|> recogFoundHandler state :<|> codeRenderHandler :<|> codeRunHandler events :<|> replHandler state @@ -183,6 +193,22 @@ goalsHandler appStateRef = do appState <- liftIO (readIORef appStateRef) return $ appState ^. gameState . winCondition +recogLogHandler :: ReadableIORef AppState -> Handler [SearchLog] +recogLogHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + return $ appState ^. gameState . discovery . structureRecognition . recognitionLog + +recogFoundHandler :: ReadableIORef AppState -> Handler [StructureLocation] +recogFoundHandler appStateRef = do + appState <- liftIO (readIORef appStateRef) + let registry = appState ^. gameState . discovery . structureRecognition . foundStructures + return + . map (uncurry StructureLocation) + . concatMap (\(x, ys) -> map (x,) $ NE.toList ys) + . M.toList + . M.map NEM.keys + $ foundByName registry + codeRenderHandler :: Text -> Handler Text codeRenderHandler contents = do return $ case processTermEither contents of diff --git a/stack.yaml b/stack.yaml index 14245bdc91..4d7e157a98 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,5 +10,6 @@ extra-deps: # breaking changes; see https://github.com/swarm-game/swarm/issues/1350 - lsp-1.6.0.0 - lsp-types-1.6.0.0 +- AhoCorasick-0.0.4 resolver: lts-21.0 diff --git a/swarm.cabal b/swarm.cabal index 6bb40d5009..e94c5f9a41 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -148,6 +148,12 @@ library Swarm.Game.Scenario.Topography.Navigation.Waypoint Swarm.Game.Scenario.Topography.Placement Swarm.Game.Scenario.Topography.Structure + Swarm.Game.Scenario.Topography.Structure.Recognition.Log + Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute + Swarm.Game.Scenario.Topography.Structure.Recognition.Registry + Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking + Swarm.Game.Scenario.Topography.Structure.Recognition.Type + Swarm.Game.Scenario.Topography.Structure.Recognition.Type.Toplevel Swarm.Game.Scenario.Topography.WorldDescription Swarm.Game.Scenario.Topography.WorldPalette Swarm.Game.ScenarioInfo @@ -156,6 +162,7 @@ library Swarm.Game.Step.Combustion Swarm.Game.Step.Pathfinding Swarm.Game.Step.Util + Swarm.Game.Step.Util.Inspect Swarm.Game.Terrain Swarm.Game.Value Swarm.Game.World @@ -216,12 +223,14 @@ library Swarm.TUI.Model.Name Swarm.TUI.Model.Repl Swarm.TUI.Model.StateUpdate + Swarm.TUI.Model.Structure Swarm.TUI.Model.UI Swarm.TUI.Panel Swarm.TUI.View Swarm.TUI.View.Achievement Swarm.TUI.View.CellDisplay Swarm.TUI.View.Objective + Swarm.TUI.View.Structure Swarm.TUI.View.Util Swarm.Util Swarm.Util.Effect @@ -238,6 +247,7 @@ library build-depends: base >= 4.14 && < 4.19, brick-list-skip >= 0.1.1.2 && < 0.2, + AhoCorasick >= 0.0.4 && < 0.0.5, aeson >= 2 && < 2.2, array >= 0.5.4 && < 0.6, astar >= 0.3 && < 0.3.1, @@ -275,6 +285,7 @@ library pandoc-types >= 1.23 && < 1.24, murmur3 >= 1.0.4 && < 1.1, natural-sort >= 0.1.2 && < 0.2, + nonempty-containers >= 0.3.4 && < 0.3.5, palette >= 0.3 && < 0.4, parser-combinators >= 1.2 && < 1.4, prettyprinter >= 1.7.0 && < 1.8, @@ -338,6 +349,7 @@ test-suite swarm-unit TestPedagogy TestNotification TestLanguagePipeline + TestOrdering TestPretty TestBoolExpr TestCommand diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 416cf0294a..f4484fc055 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -363,6 +363,19 @@ testScenarioSolutions rs ui = [ testSolution Default "Testing/1535-ping/1535-in-range" , testSolution Default "Testing/1535-ping/1535-out-of-range" ] + , testGroup + "Structure recognition (#1575)" + [ testSolution Default "Testing/1575-structure-recognizer/1575-browse-structures" + , testSolution Default "Testing/1575-structure-recognizer/1575-construction-count" + , testSolution Default "Testing/1575-structure-recognizer/1575-handle-overlapping" + , testSolution Default "Testing/1575-structure-recognizer/1575-ensure-single-recognition" + , testSolution Default "Testing/1575-structure-recognizer/1575-ensure-disjoint" + , testSolution Default "Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest" + , testSolution Default "Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location" + , testSolution Default "Testing/1575-structure-recognizer/1575-remove-structure" + , testSolution Default "Testing/1575-structure-recognizer/1575-swap-structure" + , testSolution Default "Testing/1575-structure-recognizer/1575-placement-occlusion" + ] ] , testSolution' Default "Testing/1430-built-robot-ownership" CheckForBadErrors $ \g -> do let r2 = g ^. robotMap . at 2 diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 15c4c04c1d..3792558b22 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -34,6 +34,7 @@ import TestLSP (testLSP) import TestLanguagePipeline (testLanguagePipeline) import TestModel (testModel) import TestNotification (testNotification) +import TestOrdering (testOrdering) import TestPedagogy (testPedagogy) import TestPretty (testPrettyConst) import TestScoring (testHighScores) @@ -60,6 +61,7 @@ tests s = , testPedagogy (s ^. runtimeState) , testInventory , testNotification (s ^. gameState) + , testOrdering , testMisc , testLSP ] diff --git a/test/unit/TestOrdering.hs b/test/unit/TestOrdering.hs new file mode 100644 index 0000000000..fa7a79a582 --- /dev/null +++ b/test/unit/TestOrdering.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Swarm unit tests +module TestOrdering where + +import Data.List (sort) +import Swarm.Game.Location +import Test.Tasty +import Test.Tasty.HUnit + +testOrdering :: TestTree +testOrdering = + testGroup + "Ordering" + [ testCase "Sorted locations" $ do + assertEqual "Locations should be ascending" expectedOrder (sort unsortedLocs) + ] + where + unsortedLocs = + [ Location 4 6 + , Location 3 7 + ] + + expectedOrder = + [ Location 3 7 + , Location 4 6 + ]