swarm 0.5.0.0 → 0.6.0.0
raw patch · 693 files changed
+55198/−35327 lines, 693 filesdep +AhoCorasickdep +JuicyPixelsdep +MissingHdep −blaze-htmldep −servantdep −stmdep ~QuickCheckdep ~SHAdep ~aesonnew-component:exe:swarm-docsnew-component:exe:swarm-host-tournamentnew-component:exe:swarm-scenebinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: AhoCorasick, JuicyPixels, MissingH, cookie, data-fix, deriving-compat, exceptions, free, nonempty-containers, servant-multipart, sqlite-simple, unicode-show, utf8-string, vty-crossplatform, wai-app-static, wai-extra
Dependencies removed: blaze-html, servant, stm, unification-fd
Dependency ranges changed: QuickCheck, SHA, aeson, array, base, brick, bytestring, colour, commonmark, containers, directory, extra, filepath, fused-effects, githash, hashable, http-client, http-client-tls, http-types, lens, linear, lsp, megaparsec, mtl, palette, parser-combinators, random, servant-docs, split, tasty, tasty-hunit, template-haskell, text, time, transformers, unordered-containers, vector, vty, warp, witch, yaml
API changes (from Hackage documentation)
This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.
Files
- CHANGELOG.md +97/−0
- LICENSE +2/−2
- app/Main.hs +59/−97
- app/Swarm/App.hs +153/−0
- app/doc/Main.hs +74/−0
- app/scene/Main.hs +47/−0
- app/tournament/Main.hs +100/−0
- data/about.txt +1/−1
- data/entities.yaml +1289/−1454
- data/recipes.yaml +447/−495
- data/scenarios/00-ORDER.txt +1/−0
- data/scenarios/Challenges/00-ORDER.txt +3/−0
- data/scenarios/Challenges/2048.yaml +50/−57
- data/scenarios/Challenges/Mazes/easy_cave_maze.yaml +14/−14
- data/scenarios/Challenges/Mazes/easy_spiral_maze.yaml +14/−15
- data/scenarios/Challenges/Mazes/invisible_maze.yaml +15/−20
- data/scenarios/Challenges/Mazes/loopy_maze.yaml +15/−20
- data/scenarios/Challenges/Ranching/00-ORDER.txt +2/−0
- data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw +298/−0
- data/scenarios/Challenges/Ranching/_beekeeping/solution.sw +362/−0
- data/scenarios/Challenges/Ranching/_capture/opponent.sw +1/−4
- data/scenarios/Challenges/Ranching/_fishing/hauler.sw +90/−0
- data/scenarios/Challenges/Ranching/_fishing/shark.sw +24/−0
- data/scenarios/Challenges/Ranching/_fishing/solution.sw +195/−0
- data/scenarios/Challenges/Ranching/_gated-paddock/fence-construction.sw +1/−1
- data/scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw +3/−3
- data/scenarios/Challenges/Ranching/_powerset/setup.sw +3/−7
- data/scenarios/Challenges/Ranching/beekeeping.yaml +452/−0
- data/scenarios/Challenges/Ranching/capture.yaml +6/−7
- data/scenarios/Challenges/Ranching/fishing.yaml +544/−0
- data/scenarios/Challenges/Ranching/gated-paddock.yaml +17/−16
- data/scenarios/Challenges/Ranching/powerset.yaml +14/−15
- data/scenarios/Challenges/Sliding Puzzles/3x3.yaml +31/−31
- data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw +4/−8
- data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw +3/−3
- data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw +3/−3
- data/scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw +3/−3
- data/scenarios/Challenges/Sokoban/Gadgets/no-reverse.yaml +3/−3
- data/scenarios/Challenges/Sokoban/Gadgets/one-way.yaml +3/−3
- data/scenarios/Challenges/Sokoban/Simple/trapdoor.yaml +3/−3
- data/scenarios/Challenges/Sokoban/_foresight/solution.sw +1/−1
- data/scenarios/Challenges/Sokoban/foresight.yaml +7/−8
- data/scenarios/Challenges/_blender/apprehension-checker.sw +1/−1
- data/scenarios/Challenges/_combo-lock/solution.sw +0/−1
- data/scenarios/Challenges/_dimsum/cook.sw +24/−0
- data/scenarios/Challenges/_dimsum/patron.sw +24/−0
- data/scenarios/Challenges/_dimsum/solution.sw +27/−0
- data/scenarios/Challenges/_friend/cat.sw +5/−5
- data/scenarios/Challenges/_gallery/setup.sw +161/−0
- data/scenarios/Challenges/_gallery/solution.sw +117/−0
- data/scenarios/Challenges/_gopher/gopher.sw +2/−2
- data/scenarios/Challenges/_hackman/ghost.sw +1/−15
- data/scenarios/Challenges/_hackman/solution.sw +1/−1
- data/scenarios/Challenges/_hackman/teleport_monitor.sw +22/−0
- data/scenarios/Challenges/_hackman/teleporter.sw +0/−41
- data/scenarios/Challenges/_hanoi/hanoi-solution.sw +6/−6
- data/scenarios/Challenges/_lights-out/assistant.sw +4/−9
- data/scenarios/Challenges/_maypole/monitor.sw +4/−4
- data/scenarios/Challenges/_pack-tetrominoes/solution.sw +67/−0
- data/scenarios/Challenges/_word-search/create-puzzle.sw +1/−1
- data/scenarios/Challenges/_word-search/verify-solution.sw +0/−183
- data/scenarios/Challenges/arbitrage.yaml +17/−17
- data/scenarios/Challenges/blender.yaml +9/−9
- data/scenarios/Challenges/bridge-building.yaml +31/−45
- data/scenarios/Challenges/bucket-brigade.yaml +11/−15
- data/scenarios/Challenges/chess_horse.yaml +6/−7
- data/scenarios/Challenges/combo-lock.yaml +12/−12
- data/scenarios/Challenges/dimsum.yaml +157/−0
- data/scenarios/Challenges/friend.yaml +4/−7
- data/scenarios/Challenges/gallery.yaml +263/−0
- data/scenarios/Challenges/gopher.yaml +5/−5
- data/scenarios/Challenges/hackman.yaml +70/−47
- data/scenarios/Challenges/hanoi.yaml +28/−31
- data/scenarios/Challenges/ice-cream.yaml +13/−15
- data/scenarios/Challenges/lights-out.yaml +3/−5
- data/scenarios/Challenges/maypole.yaml +4/−5
- data/scenarios/Challenges/pack-tetrominoes.yaml +147/−0
- data/scenarios/Challenges/teleport.yaml +6/−6
- data/scenarios/Challenges/wave.yaml +4/−5
- data/scenarios/Challenges/wolf-goat-cabbage.yaml +8/−8
- data/scenarios/Challenges/word-search.yaml +17/−191
- data/scenarios/Fun/00-ORDER.txt +2/−0
- data/scenarios/Fun/GoL.yaml +5/−5
- data/scenarios/Fun/_logo-burst/coordinator.sw +1/−1
- data/scenarios/Fun/_logo-burst/drone.sw +2/−2
- data/scenarios/Fun/_snake/snake.sw +160/−0
- data/scenarios/Fun/_snake/spawn.sw +35/−0
- data/scenarios/Fun/horton.yaml +96/−0
- data/scenarios/Fun/logo-burst.yaml +10/−11
- data/scenarios/Fun/snake.yaml +122/−0
- data/scenarios/Mechanics/active-trapdoor.yaml +2/−2
- data/scenarios/Speedruns/curry.yaml +5/−4
- data/scenarios/Speedruns/forester.yaml +5/−4
- data/scenarios/Speedruns/mithril.yaml +5/−4
- data/scenarios/Testing/00-ORDER.txt +18/−0
- data/scenarios/Testing/1007-use-command.yaml +34/−34
- data/scenarios/Testing/1024-sand.yaml +2/−2
- data/scenarios/Testing/1034-custom-attributes.yaml +116/−8
- data/scenarios/Testing/1138-structures/flip-and-rotate.yaml +1/−1
- data/scenarios/Testing/1138-structures/nested-structure.yaml +1/−1
- data/scenarios/Testing/1138-structures/sibling-precedence.yaml +5/−5
- data/scenarios/Testing/1140-detect-command.yaml +10/−10
- data/scenarios/Testing/1157-drill-return-value.yaml +12/−12
- data/scenarios/Testing/1171-chirp-command.yaml +7/−7
- data/scenarios/Testing/1171-resonate-command.yaml +5/−5
- data/scenarios/Testing/1171-sniff-command.yaml +7/−7
- data/scenarios/Testing/1207-scout-command.yaml +11/−11
- data/scenarios/Testing/1218-stride-command.yaml +27/−27
- data/scenarios/Testing/1234-push-command.yaml +14/−14
- data/scenarios/Testing/1256-halt-command.yaml +10/−11
- data/scenarios/Testing/1262-display-device-commands.yaml +54/−0
- data/scenarios/Testing/1295-density-command.yaml +6/−6
- data/scenarios/Testing/1320-world-DSL/00-ORDER.txt +2/−0
- data/scenarios/Testing/1320-world-DSL/constant.yaml +3/−3
- data/scenarios/Testing/1320-world-DSL/coords.yaml +22/−0
- data/scenarios/Testing/1320-world-DSL/erase.yaml +3/−3
- data/scenarios/Testing/1320-world-DSL/override.yaml +3/−3
- data/scenarios/Testing/1320-world-DSL/reflect.yaml +46/−0
- data/scenarios/Testing/1322-wait-with-instant.yaml +72/−0
- data/scenarios/Testing/1341-command-count.yaml +17/−17
- data/scenarios/Testing/1355-combustion.yaml +63/−63
- data/scenarios/Testing/1356-portals/automatic-waypoint-patrol.yaml +3/−3
- data/scenarios/Testing/1356-portals/portals-and-waypoints.yaml +4/−4
- data/scenarios/Testing/1356-portals/portals-flip-and-rotate.yaml +5/−5
- data/scenarios/Testing/1379-single-world-portal-reorientation.yaml +10/−10
- data/scenarios/Testing/1399-backup-command.yaml +4/−4
- data/scenarios/Testing/1430-built-robot-ownership.yaml +10/−10
- data/scenarios/Testing/144-subworlds/basic-subworld.yaml +6/−6
- data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml +3/−3
- data/scenarios/Testing/144-subworlds/subworld-located-robots.yaml +6/−9
- data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml +8/−8
- data/scenarios/Testing/144-subworlds/subworld-shared-structures.yaml +39/−42
- data/scenarios/Testing/1533-sow-command.yaml +195/−0
- data/scenarios/Testing/1533-sow-seed-maturation.yaml +101/−0
- data/scenarios/Testing/1535-ping/1535-in-range.yaml +6/−6
- data/scenarios/Testing/1535-ping/1535-out-of-range.yaml +6/−6
- data/scenarios/Testing/1536-custom-unwalkable-entities.yaml +5/−9
- data/scenarios/Testing/1569-pathfinding-cache/00-ORDER.txt +3/−0
- data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-distance-limit.yaml +127/−0
- data/scenarios/Testing/1569-pathfinding-cache/1569-cache-invalidation-modes.yaml +176/−0
- data/scenarios/Testing/1569-pathfinding-cache/1569-harvest-batch.yaml +60/−0
- data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt +16/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-bounding-box-overlap.yaml +83/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml +130/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-construction-count.yaml +69/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-ensure-disjoint.yaml +85/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-ensure-single-recognition.yaml +80/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-floorplan-command.yaml +75/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-handle-overlapping.yaml +75/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml +109/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-nested-structure-definition.yaml +100/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-largest.yaml +71/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-overlapping-tiebreaker-by-location.yaml +76/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-placement-occlusion.yaml +89/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-remove-structure.yaml +65/−0
- data/scenarios/Testing/1575-structure-recognizer/1575-swap-structure.yaml +115/−0
- data/scenarios/Testing/1575-structure-recognizer/1644-rotated-preplacement-recognition.yaml +47/−0
- data/scenarios/Testing/1575-structure-recognizer/1644-rotated-recognition.yaml +51/−0
- data/scenarios/Testing/1598-detect-entity-change.yaml +109/−0
- data/scenarios/Testing/1631-tags.yaml +130/−0
- data/scenarios/Testing/1634-message-colors.yaml +40/−0
- data/scenarios/Testing/1642-biomes.yaml +102/−0
- data/scenarios/Testing/1681-pushable-entity.yaml +56/−0
- data/scenarios/Testing/1721-custom-walkable-entities.yaml +86/−0
- data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml +101/−0
- data/scenarios/Testing/1747-volume-command.yaml +56/−0
- data/scenarios/Testing/1775-custom-terrain.yaml +58/−0
- data/scenarios/Testing/1777-capability-cost.yaml +94/−0
- data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt +3/−0
- data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml +59/−0
- data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml +30/−0
- data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml +99/−0
- data/scenarios/Testing/201-require/00-ORDER.txt +1/−0
- data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml +51/−0
- data/scenarios/Testing/201-require/201-require-device-creative.yaml +2/−2
- data/scenarios/Testing/201-require/201-require-device-creative1.yaml +5/−5
- data/scenarios/Testing/201-require/201-require-device.yaml +2/−2
- data/scenarios/Testing/201-require/201-require-entities-def.yaml +2/−2
- data/scenarios/Testing/201-require/201-require-entities.yaml +2/−2
- data/scenarios/Testing/201-require/533-reprogram-simple.yaml +2/−2
- data/scenarios/Testing/201-require/533-reprogram.yaml +2/−2
- data/scenarios/Testing/231-requirements/00-ORDER.txt +1/−0
- data/scenarios/Testing/231-requirements/231-command-transformer-reqs.yaml +36/−0
- data/scenarios/Testing/373-drill.yaml +19/−28
- data/scenarios/Testing/378-objectives.yaml +1/−1
- data/scenarios/Testing/394-build-drill.yaml +2/−2
- data/scenarios/Testing/397-wrong-missing.yaml +8/−8
- data/scenarios/Testing/428-drowning-destroy.yaml +4/−5
- data/scenarios/Testing/475-wait-one.yaml +4/−4
- data/scenarios/Testing/479-atomic-race.yaml +9/−9
- data/scenarios/Testing/479-atomic.yaml +8/−8
- data/scenarios/Testing/490-harvest.yaml +2/−2
- data/scenarios/Testing/504-teleport-self.yaml +3/−3
- data/scenarios/Testing/508-capability-subset.yaml +6/−6
- data/scenarios/Testing/555-teleport-location.yaml +4/−4
- data/scenarios/Testing/562-lodestone.yaml +13/−18
- data/scenarios/Testing/684-swap.yaml +4/−4
- data/scenarios/Testing/687-watch-command.yaml +8/−9
- data/scenarios/Testing/699-movement-fail/699-move-blocked.yaml +3/−3
- data/scenarios/Testing/699-movement-fail/699-move-liquid.yaml +4/−4
- data/scenarios/Testing/699-movement-fail/699-teleport-blocked.yaml +5/−5
- data/scenarios/Testing/710-multi-robot.yaml +28/−29
- data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml +1/−1
- data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml +1/−1
- data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml +6/−7
- data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml +1/−1
- data/scenarios/Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml +6/−6
- data/scenarios/Testing/836-pathfinding/836-no-path-exists1.yaml +2/−3
- data/scenarios/Testing/836-pathfinding/836-no-path-exists2.yaml +2/−2
- data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-reachable.yaml +1/−1
- data/scenarios/Testing/836-pathfinding/836-path-exists-distance-limit-unreachable.yaml +1/−2
- data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity-unwalkable.yaml +2/−2
- data/scenarios/Testing/836-pathfinding/836-path-exists-find-entity.yaml +2/−2
- data/scenarios/Testing/836-pathfinding/836-path-exists-find-location.yaml +2/−2
- data/scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/patrol.sw +2/−1
- data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-solution.sw +2/−1
- data/scenarios/Testing/836-pathfinding/_836-path-exists/find-entity-unwalkable-solution.sw +2/−1
- data/scenarios/Testing/836-pathfinding/_836-path-exists/find-location-solution.sw +2/−1
- data/scenarios/Testing/858-inventory/858-counting-objective.yaml +1/−1
- data/scenarios/Testing/858-inventory/858-nonpossession-objective.yaml +1/−1
- data/scenarios/Testing/858-inventory/858-possession-objective.yaml +1/−1
- data/scenarios/Testing/920-meet.yaml +20/−8
- data/scenarios/Testing/955-heading.yaml +1/−1
- data/scenarios/Testing/956-GPS.yaml +4/−5
- data/scenarios/Testing/958-isempty.yaml +3/−3
- data/scenarios/Testing/961-custom-capabilities.yaml +6/−6
- data/scenarios/Testing/Achievements/RobotIntoWater.yaml +2/−2
- data/scenarios/Testing/_Validation/1138-nonexistent-nested-structure.yaml +55/−0
- data/scenarios/Testing/_Validation/1356-ambiguous-portal-entrance.yaml +3/−3
- data/scenarios/Testing/_Validation/1356-ambiguous-portal-exit.yaml +3/−3
- data/scenarios/Testing/_Validation/1356-waypoint-uniqueness-enforcement.yaml +2/−2
- data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml +3/−3
- data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-default.yaml +4/−4
- data/scenarios/Testing/_Validation/144-subworld-uniqueness-enforcement-named.yaml +4/−4
- data/scenarios/Testing/_Validation/1575-recognized-placements-disallow-reorientation.yaml +40/−0
- data/scenarios/Testing/_Validation/1632-entity-attributes.yaml +19/−0
- data/scenarios/Testing/_Validation/1655-display-characters.yaml +18/−0
- data/scenarios/Testing/_Validation/1678-redundant-structure-recognition-symmetries.yaml +29/−0
- data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml +27/−0
- data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml +27/−0
- data/scenarios/Testing/_Validation/1777-capability-cost-bad-entity-reference.yaml +39/−0
- data/scenarios/Testing/_Validation/1875-robot-subworld-location.yaml +16/−0
- data/scenarios/Testing/_Validation/1935-rectangular-area.yaml +12/−0
- data/scenarios/Testing/_Validation/1938-palette-usage.yaml +13/−0
- data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml +1/−1
- data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml +1/−1
- data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml +1/−1
- data/scenarios/Tutorials/backstory.yaml +8/−28
- data/scenarios/Tutorials/bind2.yaml +6/−6
- data/scenarios/Tutorials/build.yaml +3/−7
- data/scenarios/Tutorials/conditionals.yaml +10/−10
- data/scenarios/Tutorials/craft.yaml +4/−8
- data/scenarios/Tutorials/crash-secret.sw +18/−9
- data/scenarios/Tutorials/crash.yaml +3/−4
- data/scenarios/Tutorials/def.yaml +4/−9
- data/scenarios/Tutorials/equip.yaml +3/−9
- data/scenarios/Tutorials/farming.sw +5/−5
- data/scenarios/Tutorials/farming.yaml +4/−12
- data/scenarios/Tutorials/give.yaml +2/−4
- data/scenarios/Tutorials/grab.yaml +4/−8
- data/scenarios/Tutorials/lambda.yaml +5/−10
- data/scenarios/Tutorials/move.yaml +23/−43
- data/scenarios/Tutorials/place.yaml +12/−18
- data/scenarios/Tutorials/require.yaml +7/−20
- data/scenarios/Tutorials/requireinv.yaml +4/−11
- data/scenarios/Tutorials/scan.yaml +4/−9
- data/scenarios/Tutorials/type-errors.yaml +5/−10
- data/scenarios/Tutorials/types.yaml +7/−18
- data/scenarios/Tutorials/world101.sw +4/−4
- data/scenarios/Tutorials/world101.yaml +11/−37
- data/scenarios/Vignettes/_roadway/coordinator.sw +1/−1
- data/scenarios/Vignettes/_roadway/drone.sw +21/−21
- data/scenarios/Vignettes/roadway.yaml +53/−58
- data/scenarios/World Examples/00-ORDER.txt +4/−0
- data/scenarios/World Examples/clearing.yaml +22/−0
- data/scenarios/World Examples/rorschach.yaml +21/−0
- data/scenarios/World Examples/stretch.yaml +16/−0
- data/scenarios/World Examples/translate.yaml +24/−0
- data/scenarios/blank.yaml +2/−2
- data/scenarios/classic.yaml +2/−2
- data/scenarios/creative.yaml +3/−4
- data/terrains.yaml +16/−0
- data/test/standalone-topography/checkerboard.png binary
- data/test/standalone-topography/checkerboard.yaml +43/−0
- data/test/standalone-topography/circle-and-crosses.png binary
- data/test/standalone-topography/circle-and-crosses.yaml +59/−0
- data/worlds/classic.world +1/−0
- docs/image/sublibrary-graph.svg +127/−0
- editors/emacs/swarm-mode.el +170/−125
- editors/vim/swarm.vim +6/−6
- editors/vscode/syntaxes/swarm.tmLanguage.json +0/−111
- editors/vscode/syntaxes/swarm.tmLanguage.yaml +201/−0
- example/BFS-clear.sw +10/−10
- example/cat.sw +3/−3
- example/dfs.sw +2/−2
- example/fact.sw +2/−2
- example/list.sw +31/−31
- example/maybe.sw +9/−0
- example/multi-key-handler.sw +3/−3
- example/omega.sw +5/−0
- example/pilotmode.sw +2/−2
- example/rectypes.sw +107/−0
- example/wander.sw +2/−2
- src/Control/Carrier/Accum/FixedStrict.hs +0/−139
- src/Data/BoolExpr/Simplify.hs +0/−60
- src/Swarm/App.hs +0/−140
- src/Swarm/Constant.hs +0/−27
- src/Swarm/Doc/Gen.hs +0/−597
- src/Swarm/Doc/Pedagogy.hs +0/−248
- src/Swarm/Doc/Schema/Arrangement.hs +0/−42
- src/Swarm/Doc/Schema/Parse.hs +0/−52
- src/Swarm/Doc/Schema/Refined.hs +0/−145
- src/Swarm/Doc/Schema/Render.hs +0/−194
- src/Swarm/Doc/Schema/SchemaType.hs +0/−38
- src/Swarm/Doc/Util.hs +0/−22
- src/Swarm/Game/Achievement/Attainment.hs +0/−61
- src/Swarm/Game/Achievement/Definitions.hs +0/−120
- src/Swarm/Game/Achievement/Description.hs +0/−97
- src/Swarm/Game/Achievement/Persistence.hs +0/−64
- src/Swarm/Game/CESK.hs +0/−429
- src/Swarm/Game/Display.hs +0/−203
- src/Swarm/Game/Entity.hs +0/−713
- src/Swarm/Game/Exception.hs +0/−187
- src/Swarm/Game/Failure.hs +0/−141
- src/Swarm/Game/Location.hs +0/−236
- src/Swarm/Game/Recipe.hs +0/−267
- src/Swarm/Game/ResourceLoading.hs +0/−152
- src/Swarm/Game/Robot.hs +0/−656
- src/Swarm/Game/Scenario.hs +0/−305
- src/Swarm/Game/Scenario/Objective.hs +0/−209
- src/Swarm/Game/Scenario/Objective/Graph.hs +0/−152
- src/Swarm/Game/Scenario/Objective/Logic.hs +0/−49
- src/Swarm/Game/Scenario/Objective/Validation.hs +0/−51
- src/Swarm/Game/Scenario/Objective/WinCheck.hs +0/−96
- src/Swarm/Game/Scenario/RobotLookup.hs +0/−60
- src/Swarm/Game/Scenario/Scoring/Best.hs +0/−164
- src/Swarm/Game/Scenario/Scoring/CodeSize.hs +0/−35
- src/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs +0/−60
- src/Swarm/Game/Scenario/Scoring/GenericMetrics.hs +0/−64
- src/Swarm/Game/Scenario/Status.hs +0/−135
- src/Swarm/Game/Scenario/Style.hs +0/−53
- src/Swarm/Game/Scenario/Topography/Area.hs +0/−55
- src/Swarm/Game/Scenario/Topography/Cell.hs +0/−125
- src/Swarm/Game/Scenario/Topography/EntityFacade.hs +0/−35
- src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +0/−316
- src/Swarm/Game/Scenario/Topography/Navigation/Util.hs +0/−44
- src/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs +0/−90
- src/Swarm/Game/Scenario/Topography/Placement.hs +0/−79
- src/Swarm/Game/Scenario/Topography/Structure.hs +0/−155
- src/Swarm/Game/Scenario/Topography/WorldDescription.hs +0/−117
- src/Swarm/Game/Scenario/Topography/WorldPalette.hs +0/−128
- src/Swarm/Game/ScenarioInfo.hs +0/−286
- src/Swarm/Game/State.hs +0/−1432
- src/Swarm/Game/Step.hs +0/−2870
- src/Swarm/Game/Step/Combustion.hs +0/−227
- src/Swarm/Game/Step/Pathfinding.hs +0/−137
- src/Swarm/Game/Step/Util.hs +0/−224
- src/Swarm/Game/Terrain.hs +0/−67
- src/Swarm/Game/Universe.hs +0/−79
- src/Swarm/Game/Value.hs +0/−66
- src/Swarm/Game/World.hs +0/−328
- src/Swarm/Game/World/Abstract.hs +0/−102
- src/Swarm/Game/World/Compile.hs +0/−126
- src/Swarm/Game/World/Coords.hs +0/−48
- src/Swarm/Game/World/Eval.hs +0/−39
- src/Swarm/Game/World/Gen.hs +0/−79
- src/Swarm/Game/World/Interpret.hs +0/−87
- src/Swarm/Game/World/Load.hs +0/−65
- src/Swarm/Game/World/Modify.hs +0/−40
- src/Swarm/Game/World/Parse.hs +0/−263
- src/Swarm/Game/World/Render.hs +0/−65
- src/Swarm/Game/World/Syntax.hs +0/−119
- src/Swarm/Game/World/Typecheck.hs +0/−687
- src/Swarm/Language/Capability.hs +0/−325
- src/Swarm/Language/Context.hs +0/−79
- src/Swarm/Language/Direction.hs +0/−116
- src/Swarm/Language/Elaborate.hs +0/−56
- src/Swarm/Language/Key.hs +0/−137
- src/Swarm/Language/LSP.hs +0/−170
- src/Swarm/Language/LSP/Hover.hs +0/−276
- src/Swarm/Language/LSP/VarUsage.hs +0/−110
- src/Swarm/Language/Module.hs +0/−47
- src/Swarm/Language/Parse.hs +0/−585
- src/Swarm/Language/Parse/QQ.hs +0/−39
- src/Swarm/Language/Pipeline.hs +0/−94
- src/Swarm/Language/Pipeline/QQ.hs +0/−57
- src/Swarm/Language/Pretty.hs +0/−447
- src/Swarm/Language/Requirement.hs +0/−250
- src/Swarm/Language/Syntax.hs +0/−1177
- src/Swarm/Language/Text/Markdown.hs +0/−342
- src/Swarm/Language/Typecheck.hs +0/−1122
- src/Swarm/Language/Typecheck/Unify.hs +0/−90
- src/Swarm/Language/Typed.hs +0/−22
- src/Swarm/Language/Types.hs +0/−389
- src/Swarm/Language/Value.hs +0/−128
- src/Swarm/Log.hs +0/−70
- src/Swarm/ReadableIORef.hs +0/−17
- src/Swarm/TUI/Border.hs +0/−129
- src/Swarm/TUI/Controller.hs +0/−1477
- src/Swarm/TUI/Controller/Util.hs +0/−96
- src/Swarm/TUI/Editor/Controller.hs too large to diff
- src/Swarm/TUI/Editor/Json.hs too large to diff
- src/Swarm/TUI/Editor/Masking.hs too large to diff
- src/Swarm/TUI/Editor/Model.hs too large to diff
- src/Swarm/TUI/Editor/Palette.hs too large to diff
- src/Swarm/TUI/Editor/Util.hs too large to diff
- src/Swarm/TUI/Editor/View.hs too large to diff
- src/Swarm/TUI/Inventory/Sorting.hs too large to diff
- src/Swarm/TUI/Launch/Controller.hs too large to diff
- src/Swarm/TUI/Launch/Model.hs too large to diff
- src/Swarm/TUI/Launch/Prep.hs too large to diff
- src/Swarm/TUI/Launch/View.hs too large to diff
- src/Swarm/TUI/List.hs too large to diff
- src/Swarm/TUI/Model.hs too large to diff
- src/Swarm/TUI/Model/Goal.hs too large to diff
- src/Swarm/TUI/Model/Menu.hs too large to diff
- src/Swarm/TUI/Model/Name.hs too large to diff
- src/Swarm/TUI/Model/Repl.hs too large to diff
- src/Swarm/TUI/Model/StateUpdate.hs too large to diff
- src/Swarm/TUI/Model/UI.hs too large to diff
- src/Swarm/TUI/Panel.hs too large to diff
- src/Swarm/TUI/View.hs too large to diff
- src/Swarm/TUI/View/Achievement.hs too large to diff
- src/Swarm/TUI/View/Attribute/Attr.hs too large to diff
- src/Swarm/TUI/View/Attribute/CustomStyling.hs too large to diff
- src/Swarm/TUI/View/Attribute/Util.hs too large to diff
- src/Swarm/TUI/View/CellDisplay.hs too large to diff
- src/Swarm/TUI/View/Objective.hs too large to diff
- src/Swarm/TUI/View/Util.hs too large to diff
- src/Swarm/Util.hs too large to diff
- src/Swarm/Util/Effect.hs too large to diff
- src/Swarm/Util/Erasable.hs too large to diff
- src/Swarm/Util/Lens.hs too large to diff
- src/Swarm/Util/Parse.hs too large to diff
- src/Swarm/Util/UnitInterval.hs too large to diff
- src/Swarm/Util/WindowedCounter.hs too large to diff
- src/Swarm/Util/Yaml.hs too large to diff
- src/Swarm/Version.hs too large to diff
- src/Swarm/Web.hs too large to diff
- src/swarm-doc/Swarm/Doc/Command.hs too large to diff
- src/swarm-doc/Swarm/Doc/Gen.hs too large to diff
- src/swarm-doc/Swarm/Doc/Keyword.hs too large to diff
- src/swarm-doc/Swarm/Doc/Pedagogy.hs too large to diff
- src/swarm-doc/Swarm/Doc/Schema/Arrangement.hs too large to diff
- src/swarm-doc/Swarm/Doc/Schema/Parse.hs too large to diff
- src/swarm-doc/Swarm/Doc/Schema/Refined.hs too large to diff
- src/swarm-doc/Swarm/Doc/Schema/Render.hs too large to diff
- src/swarm-doc/Swarm/Doc/Schema/SchemaType.hs too large to diff
- src/swarm-doc/Swarm/Doc/Util.hs too large to diff
- src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs too large to diff
- src/swarm-doc/Swarm/Doc/Wiki/Matrix.hs too large to diff
- src/swarm-doc/Swarm/Doc/Wiki/Util.hs too large to diff
- src/swarm-engine/Swarm/Effect.hs too large to diff
- src/swarm-engine/Swarm/Effect/Time.hs too large to diff
- src/swarm-engine/Swarm/Game/Achievement/Attainment.hs too large to diff
- src/swarm-engine/Swarm/Game/Achievement/Description.hs too large to diff
- src/swarm-engine/Swarm/Game/Achievement/Persistence.hs too large to diff
- src/swarm-engine/Swarm/Game/CESK.hs too large to diff
- src/swarm-engine/Swarm/Game/Exception.hs too large to diff
- src/swarm-engine/Swarm/Game/Robot/Activity.hs too large to diff
- src/swarm-engine/Swarm/Game/Robot/Concrete.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Objective/WinCheck.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Scoring/ConcreteMetrics.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Status.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Topography/Navigation/Util.hs too large to diff
- src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs too large to diff
- src/swarm-engine/Swarm/Game/ScenarioInfo.hs too large to diff
- src/swarm-engine/Swarm/Game/State.hs too large to diff
- src/swarm-engine/Swarm/Game/State/Initialize.hs too large to diff
- src/swarm-engine/Swarm/Game/State/Robot.hs too large to diff
- src/swarm-engine/Swarm/Game/State/Runtime.hs too large to diff
- src/swarm-engine/Swarm/Game/State/Substate.hs too large to diff
- src/swarm-engine/Swarm/Game/Step.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Arithmetic.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Combustion.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Const.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Flood.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Path/Cache.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Path/Cache/DistanceLimit.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Path/Finding.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Path/Type.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/RobotStepState.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Util.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Util/Command.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Util/Inspect.hs too large to diff
- src/swarm-engine/Swarm/Game/Step/Validate.hs too large to diff
- src/swarm-engine/Swarm/Game/Tick.hs too large to diff
- src/swarm-engine/Swarm/Game/Value.hs too large to diff
- src/swarm-engine/Swarm/Log.hs too large to diff
- src/swarm-engine/Swarm/Version.hs too large to diff
- src/swarm-lang/Swarm/Effect/Unify.hs too large to diff
- src/swarm-lang/Swarm/Effect/Unify/Common.hs too large to diff
- src/swarm-lang/Swarm/Effect/Unify/Fast.hs too large to diff
- src/swarm-lang/Swarm/Effect/Unify/Naive.hs too large to diff
- src/swarm-lang/Swarm/Language/Capability.hs too large to diff
- src/swarm-lang/Swarm/Language/Context.hs too large to diff
- src/swarm-lang/Swarm/Language/Elaborate.hs too large to diff
- src/swarm-lang/Swarm/Language/Format.hs too large to diff
- src/swarm-lang/Swarm/Language/JSON.hs too large to diff
- src/swarm-lang/Swarm/Language/Key.hs too large to diff
- src/swarm-lang/Swarm/Language/Kindcheck.hs too large to diff
- src/swarm-lang/Swarm/Language/LSP.hs too large to diff
- src/swarm-lang/Swarm/Language/LSP/Hover.hs too large to diff
- src/swarm-lang/Swarm/Language/LSP/VarUsage.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Comment.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Core.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Lex.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/QQ.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Record.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Term.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Type.hs too large to diff
- src/swarm-lang/Swarm/Language/Parser/Util.hs too large to diff
- src/swarm-lang/Swarm/Language/Pipeline.hs too large to diff
- src/swarm-lang/Swarm/Language/Pipeline/QQ.hs too large to diff
- src/swarm-lang/Swarm/Language/Pretty.hs too large to diff
- src/swarm-lang/Swarm/Language/Requirements.hs too large to diff
- src/swarm-lang/Swarm/Language/Requirements/Analysis.hs too large to diff
- src/swarm-lang/Swarm/Language/Requirements/Type.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/AST.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/CommandMetadata.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/Comments.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/Constants.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/Loc.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/Pattern.hs too large to diff
- src/swarm-lang/Swarm/Language/Syntax/Util.hs too large to diff
- src/swarm-lang/Swarm/Language/Text/Markdown.hs too large to diff
- src/swarm-lang/Swarm/Language/Typecheck.hs too large to diff
- src/swarm-lang/Swarm/Language/Typed.hs too large to diff
- src/swarm-lang/Swarm/Language/Types.hs too large to diff
- src/swarm-lang/Swarm/Language/Value.hs too large to diff
- src/swarm-scenario/Swarm/Constant.hs too large to diff
- src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs too large to diff
- src/swarm-scenario/Swarm/Game/Device.hs too large to diff
- src/swarm-scenario/Swarm/Game/Display.hs too large to diff
- src/swarm-scenario/Swarm/Game/Entity.hs too large to diff
- src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs too large to diff
- src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs too large to diff
- src/swarm-scenario/Swarm/Game/Failure.hs too large to diff
- src/swarm-scenario/Swarm/Game/Ingredients.hs too large to diff
- src/swarm-scenario/Swarm/Game/Land.hs too large to diff
- src/swarm-scenario/Swarm/Game/Recipe.hs too large to diff
- src/swarm-scenario/Swarm/Game/ResourceLoading.hs too large to diff
- src/swarm-scenario/Swarm/Game/Robot.hs too large to diff
- src/swarm-scenario/Swarm/Game/Robot/Walk.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Objective.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Objective/Logic.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/RobotLookup.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Style.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/Center.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/EntityFacade.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs too large to diff
- src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs too large to diff
- src/swarm-scenario/Swarm/Game/State/Config.hs too large to diff
- src/swarm-scenario/Swarm/Game/State/Landscape.hs too large to diff
- src/swarm-scenario/Swarm/Game/Terrain.hs too large to diff
- src/swarm-scenario/Swarm/Game/World.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Abstract.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Compile.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Eval.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Gen.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Interpret.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Load.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Modify.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Parse.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Render.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Syntax.hs too large to diff
- src/swarm-scenario/Swarm/Game/World/Typecheck.hs too large to diff
- src/swarm-scenario/Swarm/Util/Content.hs too large to diff
- src/swarm-topography/Swarm/Game/Location.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs too large to diff
- src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs too large to diff
- src/swarm-topography/Swarm/Game/Universe.hs too large to diff
- src/swarm-topography/Swarm/Game/World/Coords.hs too large to diff
- src/swarm-tournament/Swarm/Web/Auth.hs too large to diff
- src/swarm-tournament/Swarm/Web/Tournament.hs too large to diff
- src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs too large to diff
- src/swarm-tournament/Swarm/Web/Tournament/Type.hs too large to diff
- src/swarm-tournament/Swarm/Web/Tournament/Validate.hs too large to diff
- src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs too large to diff
- src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs too large to diff
- src/swarm-tui/Swarm/TUI/Border.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs too large to diff
- src/swarm-tui/Swarm/TUI/Controller/Util.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/Controller.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/Json.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/Masking.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/Model.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/Palette.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/Util.hs too large to diff
- src/swarm-tui/Swarm/TUI/Editor/View.hs too large to diff
- src/swarm-tui/Swarm/TUI/Inventory/Sorting.hs too large to diff
- src/swarm-tui/Swarm/TUI/Launch/Controller.hs too large to diff
- src/swarm-tui/Swarm/TUI/Launch/Model.hs too large to diff
- src/swarm-tui/Swarm/TUI/Launch/Prep.hs too large to diff
- src/swarm-tui/Swarm/TUI/Launch/View.hs too large to diff
- src/swarm-tui/Swarm/TUI/List.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Achievements.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Event.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Goal.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Menu.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Name.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Popup.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Repl.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/Structure.hs too large to diff
- src/swarm-tui/Swarm/TUI/Model/UI.hs too large to diff
- src/swarm-tui/Swarm/TUI/Panel.hs too large to diff
- src/swarm-tui/Swarm/TUI/View.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Achievement.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Attribute/Attr.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Attribute/Util.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/CellDisplay.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Logo.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Objective.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Popup.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Structure.hs too large to diff
- src/swarm-tui/Swarm/TUI/View/Util.hs too large to diff
- src/swarm-util/Control/Carrier/Accum/FixedStrict.hs too large to diff
- src/swarm-util/Data/BoolExpr/Simplify.hs too large to diff
- src/swarm-util/Swarm/Language/Syntax/Direction.hs too large to diff
- src/swarm-util/Swarm/Util.hs too large to diff
- src/swarm-util/Swarm/Util/Effect.hs too large to diff
- src/swarm-util/Swarm/Util/Erasable.hs too large to diff
- src/swarm-util/Swarm/Util/JSON.hs too large to diff
- src/swarm-util/Swarm/Util/Lens.hs too large to diff
- src/swarm-util/Swarm/Util/OccurrenceEncoder.hs too large to diff
- src/swarm-util/Swarm/Util/ReadableIORef.hs too large to diff
- src/swarm-util/Swarm/Util/RingBuffer.hs too large to diff
- src/swarm-util/Swarm/Util/UnitInterval.hs too large to diff
- src/swarm-util/Swarm/Util/WindowedCounter.hs too large to diff
- src/swarm-util/Swarm/Util/Yaml.hs too large to diff
- src/swarm-web/Swarm/Web.hs too large to diff
- src/swarm-web/Swarm/Web/Worldview.hs too large to diff
- swarm.cabal too large to diff
- test/bench/Benchmark.hs too large to diff
- test/integration/Main.hs too large to diff
- test/integration/TestRecipeCoverage.hs too large to diff
- test/standalone-topography/src/Lib.hs too large to diff
- test/standalone-topography/src/Main.hs too large to diff
- test/tournament-host/Main.hs too large to diff
- test/unit/Main.hs too large to diff
- test/unit/TestCommand.hs too large to diff
- test/unit/TestEval.hs too large to diff
- test/unit/TestInventory.hs too large to diff
- test/unit/TestLSP.hs too large to diff
- test/unit/TestLanguagePipeline.hs too large to diff
- test/unit/TestModel.hs too large to diff
- test/unit/TestNotification.hs too large to diff
- test/unit/TestOrdering.hs too large to diff
- test/unit/TestOverlay.hs too large to diff
- test/unit/TestParse.hs too large to diff
- test/unit/TestPedagogy.hs too large to diff
- test/unit/TestPretty.hs too large to diff
- test/unit/TestRepl.hs too large to diff
- test/unit/TestRequirements.hs too large to diff
- test/unit/TestScoring.hs too large to diff
- test/unit/TestUtil.hs too large to diff
@@ -1,5 +1,102 @@ # Revision history for swarm +## **0.6.0.0** - 2024-07-15++Some of the highlights of this release include native Windows support,+customizable keybindings, type synonyms and equirecursive types, and a+prototype tournament server+([#1798](https://github.com/swarm-game/swarm/pull/1798)) where players+can upload their solutions to challenge scenarios. See below for a+more detailed list (or see the [complete list of git+commits](https://github.com/swarm-game/swarm/commits/main/?since=2023-11-01)).++Aside from the more visible changes listed below, this release cycle saw a *lot* of internal refactoring.+For example, we finished splitting the codebase into a number of+independent sublibraries and split several large modules into smaller+modules.++### Community++* New [Discord server](https://discord.gg/kp8MuSgkPw)!++### Breaking changes++* Types are now required to start with an uppercase letter ([#1583](https://github.com/swarm-game/swarm/pull/1583))+ * Use `swarm format --v0.5` to convert old code.++### Bugfixes++* Variables in a local monadic binder escape to outer scopes+ ([#681](https://github.com/swarm-game/swarm/issues/681); fixed by [#1928](https://github.com/swarm-game/swarm/pull/1928))++### New Features++#### Language++* `volume` command measuring the enclosed area around a given location+ ([#1747](https://github.com/swarm-game/swarm/pull/1747))+* `sow` command for planting growing entities that spread ([#1817](https://github.com/swarm-game/swarm/pull/1817))+* Type synonyms ([#1865](https://github.com/swarm-game/swarm/pull/1865))+* Recursive types ([#1894](https://github.com/swarm-game/swarm/pull/1894))+* Entity tags and related commands ([#1635](https://github.com/swarm-game/swarm/pull/1635))+* `meetAll` command now returns a list ([#1999](https://github.com/swarm-game/swarm/pull/1999))++#### Entities + recipes++* New `lens` entity and recipe for `detonator` ([#1876](https://github.com/swarm-game/swarm/pull/1876))+* `infinite improbability drive` device enabling `teleport` command+ ([#1724](https://github.com/swarm-game/swarm/pull/1724))+* Recipes for `rolex`, `olfactometer`, `dozer blade`, and `hourglass` entities+ ([#2028](https://github.com/swarm-game/swarm/pull/2028), [#2025](https://github.com/swarm-game/swarm/pull/2025))++#### New scenarios++* Beekeeping scenario ([#1599](https://github.com/swarm-game/swarm/pull/1599))+* Fishing scenario ([#1628](https://github.com/swarm-game/swarm/pull/1628))+* Dim sum restaurant ([#1686](https://github.com/swarm-game/swarm/pull/1686))+* Gallery scenario ([#1760](https://github.com/swarm-game/swarm/pull/1760))+* Snake automata ([#1699](https://github.com/swarm-game/swarm/pull/1699))++#### Scenario mechanics and authoring improvements++* Path caching, for more efficient repeated use of the `path` command ([#1595](https://github.com/swarm-game/swarm/pull/1595))+* Render any map to PNG ([#1632](https://github.com/swarm-game/swarm/pull/1632))+* Extensible terrain ([#1775](https://github.com/swarm-game/swarm/pull/1775))+* Spreadable plant growth ([#1817](https://github.com/swarm-game/swarm/pull/1817))+* Exercising commands can consume entities ([#1777](https://github.com/swarm-game/swarm/pull/1777))+* Recognize built structures ([#1579](https://github.com/swarm-game/swarm/pull/1579))+* Test for point-to-point connectivity ([#1721](https://github.com/swarm-game/swarm/pull/1721))+* Validate palettes ([#1938](https://github.com/swarm-game/swarm/pull/1938)), map shape ([#1935](https://github.com/swarm-game/swarm/pull/1935)), subworld references ([#1875](https://github.com/swarm-game/swarm/pull/1875))++#### UI enhancements++* Fix REPL type display ([#1610](https://github.com/swarm-game/swarm/pull/1610))+* Handle backword kill word event in REPL ([#1861](https://github.com/swarm-game/swarm/pull/1861))+* Make log error messages ephemeral ([#1877](https://github.com/swarm-game/swarm/pull/1877))+* Pretty print code blocks according to widget size ([#1897](https://github.com/swarm-game/swarm/pull/1897))+* Automatically insert matching close brackets at REPL ([#1953](https://github.com/swarm-game/swarm/pull/1953))+* Highlight only the part of the REPL input indicated as the location+ of an error ([#1957](https://github.com/swarm-game/swarm/pull/1957))+* Popups for new achievements, recipes, and commands+ ([#2027](https://github.com/swarm-game/swarm/pull/2027))+* Save current REPL input with down arrow+ ([#2000](https://github.com/swarm-game/swarm/pull/2000))+* Customizable keybindings ([#1979](https://github.com/swarm-game/swarm/pull/1979))++#### Command line options++* `format` subcommand now tries to preserve comments ([#1845](https://github.com/swarm-game/swarm/pull/1845))+* Add `format --v0.5` option to port code from older syntax ([#1851](https://github.com/swarm-game/swarm/pull/1851))+* `keybindings` subcommand for displaying and initializing keybinding+ configuration ([#1979](https://github.com/swarm-game/swarm/pull/1979))+* `docs recipes` subcommand now takes `--forward` and `--next` flags+ for filtering the output edges ([#2033](https://github.com/swarm-game/swarm/pull/2033))++### Building/packaging++* Add Windows build to CI ([#1974](https://github.com/swarm-game/swarm/pull/1974))+* Native Windows support ([#1617](https://github.com/swarm-game/swarm/pull/1617))+ ## **0.5.0.0** - 2023-11-01 ### Bugfixes
@@ -1,4 +1,4 @@-Copyright Brent Yorgey 2021-2022+Copyright Brent Yorgey and other contributors 2021-2024 SPDX-License-Identifier: BSD-3-Clause All rights reserved.@@ -14,7 +14,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Swarm team nor the names of other+ * Neither the name of Brent Yorgey nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
@@ -6,46 +6,37 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where +import Control.Monad (when) import Data.Foldable qualified-import Data.Maybe (fromMaybe)-import Data.Text (Text, pack)-import Data.Text qualified as T-import Data.Text.IO qualified as Text+import Data.Text.IO qualified as T import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) import Options.Applicative-import Prettyprinter-import Prettyprinter.Render.Text qualified as RT import Swarm.App (appMain)-import Swarm.Doc.Gen (EditorType (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs)-import Swarm.Game.World.Render (printScenarioMap, renderScenarioMap)+import Swarm.Game.ResourceLoading (getSwarmConfigIniFile)+import Swarm.Language.Format import Swarm.Language.LSP (lspMain)-import Swarm.Language.Parse (readTerm)-import Swarm.Language.Pretty (ppr)+import Swarm.Language.Parser.Core (LanguageVersion (..)) import Swarm.TUI.Model (AppOpts (..), ColorMode (..))+import Swarm.TUI.Model.KeyBindings (KeybindingPrint (..), showKeybindings) import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond)-import Swarm.Util ((?)) import Swarm.Version import Swarm.Web (defaultPort)-import System.Console.Terminal.Size qualified as Term-import System.Exit (exitFailure) import System.IO (hPrint, stderr) import Text.Read (readMaybe) gitInfo :: Maybe GitInfo-gitInfo = either (const Nothing) Just ($$tGitInfoCwdTry)+gitInfo = either (const Nothing) Just $$tGitInfoCwdTry commitInfo :: String commitInfo = case gitInfo of Nothing -> "" Just git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")" -type Width = Int- data CLI = Run AppOpts- | Format Input (Maybe Width)- | DocGen GenerateDocs- | RenderMap FilePath+ | -- | Print list of bindings, optionally initializing the INI configuration file.+ ListKeybinding Bool KeybindingPrint+ | Format FormatConfig | LSP | Version @@ -53,11 +44,10 @@ cliParser = subparser ( mconcat- [ command "format" (info (Format <$> format <*> optional widthOpt <**> helper) (progDesc "Format a file"))- , command "generate" (info (DocGen <$> docgen <**> helper) (progDesc "Generate docs"))- , command "map" (info (RenderMap <$> strArgument (metavar "FILE")) (progDesc "Render a scenario world map."))+ [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) , command "version" (info (pure Version) (progDesc "Get current and upstream version."))+ , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings")) ] ) <|> Run@@ -73,54 +63,38 @@ <*> pure gitInfo ) where- format :: Parser Input- format =- (Stdin <$ switch (long "stdin" <> help "Read code from stdin"))- <|> (File <$> strArgument (metavar "FILE"))- widthOpt :: Parser Width+ input :: Parser FormatInput+ input =+ flag' Stdin (long "stdin" <> help "Read code from stdin")+ <|> (InputFile <$> strArgument (metavar "FILE"))++ output :: Parser FormatOutput+ output =+ flag Stdout Stdout (long "stdout" <> help "Write formatted code to stdout (default)")+ <|> (OutputFile <$> strOption (long "output" <> short 'o' <> metavar "FILE" <> help "Write formatted code to an output file"))+ <|> flag' Inplace (long "inplace" <> short 'i' <> help "Format file in place")++ widthOpt :: Parser FormatWidth widthOpt = option auto (long "width" <> metavar "COLUMNS" <> help "Use layout with maximum width")- docgen :: Parser GenerateDocs- docgen =- subparser . mconcat $- [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")- , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords")- , command "keys" (info (pure SpecialKeyNames) $ progDesc "Output list of recognized special key names")- , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables")- , command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage")- , command "endpoints" (info (pure WebAPIEndpoints) $ progDesc "Generate markdown Web API documentation.")- ] - editor :: Parser (Maybe EditorType)- editor =- Data.Foldable.asum- [ pure Nothing- , Just VSCode <$ switch (long "code" <> help "Generate for the VS Code editor")- , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor")- ]- address :: Parser PageAddress- address =- let replace a b = T.unpack . T.replace a b . T.pack- opt n =- fmap (fromMaybe "") . optional $- option- str- ( long n- <> metavar "ADDRESS"- <> help ("Set the address of " <> replace "-" " " n <> ". Default no link.")- )- in PageAddress <$> opt "entities-page" <*> opt "commands-page" <*> opt "capabilities-page" <*> opt "recipes-page"- cheatsheet :: Parser (Maybe SheetType)- cheatsheet =- Data.Foldable.asum- [ pure Nothing- , Just Entities <$ switch (long "entities" <> help "Generate entities page (uses data from entities.yaml)")- , Just Recipes <$ switch (long "recipes" <> help "Generate recipes page (uses data from recipes.yaml)")- , Just Capabilities <$ switch (long "capabilities" <> help "Generate capabilities page (uses entity map)")- , Just Commands <$ switch (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)")- , Just Scenario <$ switch (long "scenario" <> help "Generate scenario schema page")- ]+ langVer :: Parser LanguageVersion+ langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5")++ printKeyMode :: Parser KeybindingPrint+ printKeyMode =+ flag' IniPrint (long "ini" <> help "Print in INI format")+ <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format")+ <|> pure TextPrint++ initKeybindingConfig :: Parser Bool+ initKeybindingConfig = switch (short 'i' <> long "init" <> help "Initialise the keybindings configuration file")++ parseFormat :: Parser FormatConfig+ parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper+ seed :: Parser (Maybe Int) seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation")+ webPort :: Parser (Maybe Int) webPort = optional $@@ -161,47 +135,35 @@ <> fullDesc ) -data Input = Stdin | File FilePath--getInput :: Input -> IO Text-getInput Stdin = Text.getContents-getInput (File fp) = Text.readFile fp--showInput :: Input -> Text-showInput Stdin = "(input)"-showInput (File fp) = pack fp---- | Utility function to validate and format swarm-lang code-formatFile :: Input -> Maybe Width -> IO ()-formatFile input mWidth = do- content <- getInput input- case readTerm content of- Right Nothing -> Text.putStrLn ""- Right (Just ast) -> do- mWindow <- Term.size- let mkOpt w = LayoutOptions (AvailablePerLine w 1.0)- let opt =- fmap mkOpt mWidth- ? fmap (\(Term.Window _h w) -> mkOpt w) mWindow- ? defaultLayoutOptions- Text.putStrLn . RT.renderStrict . layoutPretty opt $ ppr ast- Left e -> do- Text.hPutStrLn stderr $ showInput input <> ":" <> e- exitFailure- showVersion :: IO () showVersion = do putStrLn $ "Swarm game - " <> version <> commitInfo up <- getNewerReleaseVersion gitInfo either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up +printKeybindings :: Bool -> KeybindingPrint -> IO ()+printKeybindings initialize p = do+ kb <- showKeybindings p+ T.putStrLn kb+ (iniExists, ini) <- getSwarmConfigIniFile initialize+ when initialize $ do+ kbi <- showKeybindings IniPrint+ T.writeFile ini kbi+ let iniState+ | iniExists && initialize = "has been updated"+ | iniExists = "is"+ | initialize = "has been created"+ | otherwise = "can be created (--init)"+ putStrLn $ replicate 80 '-'+ putStrLn $ "The configuration file " <> iniState <> " at:"+ putStrLn ini+ main :: IO () main = do cli <- execParser cliInfo case cli of Run opts -> appMain opts- DocGen g -> generateDocs g- Format fo w -> formatFile fo w- RenderMap mapPath -> printScenarioMap =<< renderScenarioMap mapPath+ ListKeybinding initialize p -> printKeybindings initialize p+ Format cfg -> formatSwarmIO cfg LSP -> lspMain Version -> showVersion
@@ -0,0 +1,153 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- HLINT ignore "Use underscore" -}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+-- Description: Application entry point+--+-- Main entry point for the Swarm application.+module Swarm.App where++import Brick+import Brick.BChan+import Control.Carrier.Lift (runM)+import Control.Carrier.Throw.Either (runThrow)+import Control.Concurrent (forkIO, threadDelay)+import Control.Lens (view, (%~), (&), (?~))+import Control.Monad (forever, void, when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (newIORef, writeIORef)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Graphics.Vty qualified as V+import Graphics.Vty.CrossPlatform qualified as V+import Swarm.Game.Failure (SystemFailure)+import Swarm.Game.State.Runtime+import Swarm.Language.Pretty (prettyText)+import Swarm.Log (LogSource (SystemLog), Severity (..))+import Swarm.TUI.Controller+import Swarm.TUI.Model+import Swarm.TUI.Model.StateUpdate+import Swarm.TUI.Model.UI (uiAttrMap)+import Swarm.TUI.View+import Swarm.Util.ReadableIORef (mkReadonly)+import Swarm.Version (getNewerReleaseVersion)+import Swarm.Web+import System.IO (stderr)++type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState ()++-- | The configuration of the Swarm app which we pass to the @brick@+-- library.+app :: EventHandler -> App AppState AppEvent Name+app eventHandler =+ App+ { appDraw = drawUI+ , appChooseCursor = chooseCursor+ , appHandleEvent = eventHandler+ , appStartEvent = enablePasteMode+ , appAttrMap = view $ uiState . uiAttrMap+ }++-- | The main @IO@ computation which initializes the state, sets up+-- some communication channels, and runs the UI.+appMain :: AppOpts -> IO ()+appMain opts = do+ res <- runM . runThrow $ initAppState opts+ case res of+ Left err -> T.hPutStrLn stderr (prettyText @SystemFailure err)+ Right s -> do+ -- Send Frame events as at a reasonable rate for 30 fps. The+ -- game is responsible for figuring out how many steps to take+ -- each frame to achieve the desired speed, regardless of the+ -- frame rate. Note that if the game cannot keep up with 30+ -- fps, it's not a problem: the channel will fill up and this+ -- thread will block. So the force of the threadDelay is just+ -- to set a *maximum* possible frame rate.+ --+ -- 5 is the size of the bounded channel; when it gets that big,+ -- any writes to it will block. Probably 1 would work fine,+ -- though it seems like it could be good to have a bit of buffer+ -- just so the app never has to wait for the thread to wake up+ -- and do another write.++ chan <- newBChan 5+ _ <- forkIO $+ forever $ do+ threadDelay 33_333 -- cap maximum framerate at 30 FPS+ writeBChan chan Frame++ _ <- forkIO $ do+ upRel <- getNewerReleaseVersion (repoGitInfo opts)+ writeBChan chan (UpstreamVersion upRel)++ -- Start the web service with a reference to the game state.+ -- NOTE: This reference should be considered read-only by+ -- the web service; the game alone shall host the canonical state.+ appStateRef <- newIORef s+ eport <-+ Swarm.Web.startWebThread+ (userWebPort opts)+ (mkReadonly appStateRef)+ chan++ let logP p = logEvent SystemLog Info "Web API" ("started on :" <> T.pack (show p))+ let logE e = logEvent SystemLog Error "Web API" (T.pack e)+ let s1 =+ s+ & runtimeState+ %~ case eport of+ Right p -> (webPort ?~ p) . (eventLog %~ logP p)+ Left e -> eventLog %~ logE e++ -- Update the reference for every event+ let eventHandler e = do+ curSt <- get+ liftIO $ writeIORef appStateRef curSt+ handleEvent e++ -- Setup virtual terminal+ let buildVty = V.mkVty V.defaultConfig {V.configPreferredColorMode = colorMode opts}+ vty <- buildVty++ V.setMode (V.outputIface vty) V.Mouse True++ let cm = V.outputColorMode $ V.outputIface vty+ let s2 =+ s1+ & runtimeState . eventLog %~ logEvent SystemLog Info "Graphics" ("Color mode: " <> T.pack (show cm))++ -- Run the app.+ void $ customMain vty buildVty (Just chan) (app eventHandler) s2++-- | A demo program to run the web service directly, without the terminal application.+-- This is useful to live update the code using @ghcid -W --test "Swarm.App.demoWeb"@.+demoWeb :: IO ()+demoWeb = do+ let demoPort = 8080+ res <-+ runM . runThrow $ initAppState (defaultAppOpts {userScenario = demoScenario})+ case res of+ Left err -> T.putStrLn (prettyText @SystemFailure err)+ Right s -> do+ appStateRef <- newIORef s+ chan <- newBChan 5+ webMain+ Nothing+ demoPort+ (mkReadonly appStateRef)+ chan+ where+ demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml"++-- | If available for the terminal emulator, enable bracketed paste mode.+enablePasteMode :: EventM n s ()+enablePasteMode = do+ vty <- getVtyHandle+ let output = V.outputIface vty+ when (V.supportsMode output V.BracketedPaste) $+ liftIO $+ V.setMode output V.BracketedPaste True
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+module Main where++import Data.Foldable qualified+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Options.Applicative+import Swarm.Doc.Gen (EdgeFilter (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs)+import Swarm.Doc.Keyword (EditorType (..))++cliParser :: Parser GenerateDocs+cliParser =+ subparser $+ mconcat+ [ command "recipes" (info (RecipeGraph <$> edgeFilter <**> helper) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")+ , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords")+ , command "keys" (info (pure SpecialKeyNames) $ progDesc "Output list of recognized special key names")+ , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables")+ , command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage")+ ]+ where+ editor :: Parser (Maybe EditorType)+ editor =+ Data.Foldable.asum+ [ pure Nothing+ , Just VSCode <$ switch (long "code" <> help "Generate for the VS Code editor")+ , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor")+ , Just Vim <$ switch (long "vim" <> help "Generate for the Vim editor")+ ]+ edgeFilter :: Parser EdgeFilter+ edgeFilter =+ Data.Foldable.asum+ [ pure NoFilter+ , FilterForward <$ switch (long "forward" <> help "Show only forward edges")+ , FilterNext <$ switch (long "next" <> help "Show only edges to next group")+ ]+ address :: Parser PageAddress+ address =+ let replace a b = T.unpack . T.replace a b . T.pack+ opt n =+ fmap (fromMaybe "") . optional $+ option+ str+ ( long n+ <> metavar "ADDRESS"+ <> help ("Set the address of " <> replace "-" " " n <> ". Default no link.")+ )+ in PageAddress <$> opt "entities-page" <*> opt "commands-page" <*> opt "capabilities-page" <*> opt "recipes-page"+ cheatsheet :: Parser SheetType+ cheatsheet =+ Data.Foldable.asum+ [ flag' Entities (long "entities" <> help "Generate entities page (uses data from entities.yaml)")+ , flag' Terrain (long "terrain" <> help "Generate terrain page (uses data from terrains.yaml)")+ , flag' Recipes (long "recipes" <> help "Generate recipes page (uses data from recipes.yaml)")+ , flag' Capabilities (long "capabilities" <> help "Generate capabilities page (uses entity map)")+ , flag' Commands (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)")+ , flag' CommandMatrix (long "matrix" <> help "Generate commands matrix page")+ , flag' Scenario (long "scenario" <> help "Generate scenario schema page")+ ]++cliInfo :: ParserInfo GenerateDocs+cliInfo =+ info+ (cliParser <**> helper)+ ( header "Swarm docs"+ <> progDesc "Generate swarm documentation."+ <> fullDesc+ )++main :: IO ()+main = generateDocs =<< execParser cliInfo
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+module Main where++import Options.Applicative+import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))+import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderOpts (..), doRenderCmd)++data CLI+ = RenderMap FilePath RenderOpts++cliParser :: Parser CLI+cliParser =+ RenderMap <$> strArgument (metavar "SCENARIO") <*> subOpts+ where+ sizeOpts =+ AreaDimensions+ <$> option auto (metavar "WIDTH" <> short 'w' <> long "width" <> help "width of source grid")+ <*> option auto (metavar "HEIGHT" <> short 'h' <> long "height" <> help "height of source grid")++ subOpts =+ RenderOpts+ <$> seed+ <*> flag ConsoleText PngImage (long "png" <> help "Render to PNG")+ <*> option str (long "dest" <> short 'd' <> value "output.png" <> help "Output filepath")+ <*> optional sizeOpts+ <*> flag Terminate RenderBlankImage (long "fail-blank" <> short 'b' <> help "Render blank image upon failure")++ seed :: Parser (Maybe Int)+ seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation")++cliInfo :: ParserInfo CLI+cliInfo =+ info+ (cliParser <**> helper)+ ( header "Swarm scene"+ <> progDesc "Render a scenario world map."+ <> fullDesc+ )++main :: IO ()+main = do+ cli <- execParser cliInfo+ case cli of+ RenderMap mapPath opts -> doRenderCmd opts mapPath
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- SPDX-License-Identifier: BSD-3-Clause+module Main where++import Control.Monad.Trans.Reader (runReaderT)+import Data.Maybe (fromMaybe)+import Data.Yaml (decodeFileThrow)+import Database.SQLite.Simple (execute_, withConnection)+import Network.Wai.Handler.Warp (Port)+import Options.Applicative+import Swarm.Game.State (Sha1 (..))+import Swarm.Web.Tournament+import Swarm.Web.Tournament.Database.Query+import Swarm.Web.Tournament.Type (UserAlias (..))++data AppOpts = AppOpts+ { userWebPort :: Maybe Port+ -- ^ Explicit port on which to run the web API+ , gameGitVersion :: Sha1+ , deploymentEnv :: DeploymentEnvironment+ }++webPort :: Parser (Maybe Int)+webPort =+ optional $+ option+ auto+ ( long "port"+ <> metavar "PORT"+ <> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".")+ )++gameVersion :: Parser Sha1+gameVersion =+ Sha1+ <$> option+ str+ ( long "version"+ <> metavar "VERSION"+ <> help "Set the git version of the game"+ )++parseRunningLocally :: Parser DeploymentEnvironment+parseRunningLocally =+ flag+ ProdDeployment+ (LocalDevelopment $ UserAlias "local-user")+ (long "local" <> help "Running locally for development")++cliParser :: Parser AppOpts+cliParser = AppOpts <$> webPort <*> gameVersion <*> parseRunningLocally++cliInfo :: ParserInfo AppOpts+cliInfo =+ info+ (cliParser <**> helper)+ ( header "Swarm tournament"+ <> progDesc "Hosts a tournament server."+ <> fullDesc+ )++main :: IO ()+main = do+ opts <- execParser cliInfo++ creds <- case deploymentEnv opts of+ LocalDevelopment _ -> return $ GitHubCredentials "" ""+ ProdDeployment -> decodeFileThrow "swarm-github-app-credentials.yaml"++ webMain+ (AppData (gameGitVersion opts) creds persistenceFunctions (deploymentEnv opts))+ (fromMaybe defaultPort $ userWebPort opts)+ where+ persistenceFunctions =+ PersistenceLayer+ { scenarioStorage =+ ScenarioPersistence+ { lookupCache = withConn lookupScenarioSolution+ , storeCache = withConn insertScenario+ , getContent = withConn lookupScenarioContent+ }+ , solutionStorage =+ ScenarioPersistence+ { lookupCache = withConn lookupSolutionSubmission+ , storeCache = withConn insertSolutionSubmission+ , getContent = withConn lookupSolutionContent+ }+ , authenticationStorage =+ AuthenticationStorage+ { usernameFromCookie = withConn getUsernameFromCookie+ , cookieFromUsername = withConn insertCookie+ }+ }+ where+ withConn f x =+ withConnection databaseFilename $ \conn -> do+ execute_ conn "PRAGMA foreign_keys = ON;"+ runReaderT (f x) conn
@@ -2,7 +2,7 @@ For a full list of contributors, see https://github.com/swarm-game/swarm/graphs/contributors. Join the community!-IRC: #swarm on libera.chat+Discord: https://discord.gg/kp8MuSgkPw Wiki: https://github.com/swarm-game/swarm/wiki Interested in contributing to Swarm? All are welcome! See
@@ -3,1457 +3,1292 @@ attr: plant char: 'T' description:- - |- A tall, living entity made of a tough cellular material called "wood".- They regrow after being harvested and are an important raw ingredient used- in making many different devices.- properties: [portable, growable, opaque, combustible]- growth: [500, 600]- combustion:- ignition: 0.01- duration: [80, 120]- product: ash--- name: ash- display:- attr: rock- char: '#'- description:- - |- Burned-out remnants of combustion.- properties: [portable]--- name: branch- display:- attr: wood- char: 'y'- description:- - A branch cut from a tree. It's as if the tree had to make a decision- and was exploring two options.- properties: [portable]--- name: log- display:- attr: wood- char: 'l'- description:- - A wooden log, obtained by harvesting a tree and cutting off its branches.- properties: [portable, combustible]- combustion:- ignition: 0.05- duration: [40, 80]- product: ash--- name: board- display:- attr: wood- char: 'w'- description:- - A wooden board, made by cutting a log into pieces.- properties: [portable, combustible]- combustion:- ignition: 0.2- duration: [20, 40]- product: ash--- name: workbench- display:- attr: wood- char: 'π'- description:- - A plain wooden workbench, providing space to make other- things using the `make` command.- - |- Example:- ```- make "log"- ```- properties: [portable]- capabilities: [make]--- name: paper- display:- attr: snow- char: '■'- description:- - A flat material made of pressed and dried wood fibers,- used as a surface on which to inscribe symbols.- properties: [portable, combustible]- combustion:- ignition: 0.5- duration: [10, 20]- product: ash--- name: PhD thesis- display:- attr: snow- char: 'P'- description:- - Perhaps writing one of these will help gain the trust and respect of- the native inhabitants.- properties: [portable]--- name: rock- display:- attr: rock- char: 'o'- description:- - A medium-sized rock, picked up from the ground or created by drilling.- Can be ground into sand or used to build a simple furnace, among other things.- properties: [portable]--- name: handle- display:- attr: device- char: 'h'- description:- - Ergonomic affordance for manipulating objects. Also grants the "setname" capability, allowing one- to assign a "handle" to robots.- properties: [portable]- capabilities: [setname]--- name: lodestone- display:- attr: iron- char: 'o'- description:- - A medium-sized rock... that looks a little different.- It seems to react to iron and surprisingly also to naturally growing bits.- properties: [portable]- capabilities: [negation]--- name: beaglepuss- display:- attr: rubber- char: 'B'- description:- - Iconic novelty disguise. Renders one either completely inconspicuous, or the opposite.- properties: [portable]- capabilities: [appear]--- name: boulder- display:- attr: rock- char: '@'- description:- - A very large, impassable rock. A drill can be used to get rid of it and turn it into smaller rocks.- properties: [unwalkable]--- name: mountain- display:- attr: snow- char: 'A'- description:- - A mountain. Can be tunneled through with a drill, but it takes time.- properties: [unwalkable, opaque]--- name: mountain tunnel- display:- attr: snow- char: 'Å'- priority: 11- description:- - A tunnel in a mountain through which anything can freely move.- properties: []--- name: copper ore- display:- attr: copper- char: 'C'- description:- - Raw copper ore, useful for making wires, pipes, and other metal things.- Patches of copper ore can be found on the surface, but are quickly exhausted.- - Scanners seem to indicate larger quantities of copper could be found beneath some of the- mountains, but those would require a drill to access and mine.- properties: [portable]--- name: copper mine- display:- attr: copper'- char: 'Å'- priority: 11- description:- - A copper vein that can be actively mined to produce copper ore.- properties: []--- name: copper wire- display:- attr: copper- char: '|'- description:- - Copper wire is very good at conducting electricity and useful for- making various types of circuits and machines.- properties: [portable]--- name: strange loop- display:- attr: copper- char: '8'- description:- - Two copper wires twisted together in a strange shape that loops- back on itself. It must be useful for something...- properties: [portable]- capabilities: [recursion]--- name: copper pipe- display:- attr: copper- char: 'I'- description:- - A pipe made out of a thin sheet of copper. Great for transmitting- water or steam.- properties: [portable]--- name: iron plate- display:- attr: iron- char: '■'- description:- - Worked iron suitable for crafting resilient tools.- - It also possess some electro-magnetic properties.- properties: [portable]--- name: iron gear- display:- attr: iron- char: '*'- description:- - An iron gear, suitable for constructing larger, more powerful- machinery than a wooden gear.- properties: [portable]--- name: iron ore- display:- attr: iron- char: 'F'- description:- - Raw iron ore. Used to create more resilient tools than copper.- - It can only be mined by drilling in the mountains.- properties: [portable]--- name: iron mine- display:- attr: iron'- char: 'Å'- priority: 11- description:- - An iron vein that can be actively mined to produce iron ore.- properties: []--- name: quartz- display:- attr: quartz- char: 'Q'- description:- - Raw quartz crystals. Useful for creating devices like clocks, and- can be processed to extract silicon.- - It can only be mined by drilling in the mountains.- properties: [portable]--- name: quartz mine- display:- attr: quartz- char: 'Å'- priority: 11- description:- - A quartz vein that can be actively mined to produce quartz.- properties: []--- name: silicon- display:- attr: quartz- char: 'S'- description:- - Extracted by processing quartz at high temperatures, silicon can- be used to construct integrated circuits.- properties: [portable]--- name: deep mine- display:- attr: rock- char: 'Å'- priority: 11- description:- - A deep mine that yields rare and wonderful treasures to those who are patient.- - But be careful lest you delve too greedily and too deep.- properties: []--- name: silver- display:- attr: silver- char: '•'- description:- - A shiny, metallic substance, noted for its high reflectivity when polished.- properties: [portable]--- name: gold- display:- attr: gold- char: '•'- description:- - A shiny, metallic substance, with applications in specialized electronics.- - It also seems to be highly valued by local aliens.- properties: [portable]--- name: mithril- display:- attr: silver- char: 'M'- description:- - Mithril can be beaten like copper, and polished like glass. One- can also make of it a metal, light and yet harder than tempered- steel. Its beauty is like to that of common silver, but the beauty- of mithril does not tarnish or grow dim.- properties: [portable]--- name: furnace- display:- attr: fire- char: '#'- description:- - A furnace can be used to turn metal ore into various useful products.- properties: [portable]--- name: big furnace- display:- attr: fire- char: '#'- description:- - A big furnace can get even hotter than a normal furnace, and can be used- to process quartz into silicon.- properties: [portable]--- name: small motor- display:- attr: entity- char: 'm'- description:- - A motor is useful for making devices that can turn when electric- current is applied.- - This one is rather small, but surprisingly efficient.- properties: [portable]--- name: big motor- display:- attr: entity- char: 'M'- description:- - A motor is useful for making devices that can turn when electric- current is applied.- - This one is huge and could be used to construct powerful machinery.- properties: [portable]--- name: flower- display:- attr: flower- char: '*'- description:- - A beautiful flower that grows wild in local meadows. It is not clear- what it might be useful for, but it looks nice.- properties: [portable, growable]- growth: [30, 50]--- name: cotton- display:- attr: silver- char: 'i'- description:- - A plant with tufts of soft fibers that can be harvested and used- to make things, including sheets of material that the local- aliens like to drape over their bodies.- properties: [portable, growable, combustible]- growth: [100, 800]- combustion:- ignition: 0.1- duration: [20, 40]- product: ash--- name: linotype- display:- attr: silver- char: 't'- description:- - Employs hot lead typesetting to arrange glyphs into a mold for printing.- - |- An equipped `linotype`{=entity} device enables the `format` command:- ```- format : a -> text- ```- which can turn any value into a suitable text representation.- properties: [portable]- capabilities: [format]--- name: Elmer's glue- display:- attr: snow- char: 'g'- description:- - Polyvinyl acetate. Popular adhesive for crafting. Of dubious nutritional value.- - |- Facilitates the concatenation of text values.- - |- The infix operator `++ : text -> text -> text`{=snippet}- can be used to concatenate two text values. For example,- - |- "Number of widgets: " ++ format numWidgets- properties: [portable]- capabilities: [concat]--- name: caliper- display:- attr: silver- char: 'C'- description:- - Simple, yet accurate measuring device. Can determine the length of a text value.- - |- ```- chars : text -> int- ```- computes the number of characters in a `text`{=type} value.- properties: [portable]- capabilities: [charcount]--- name: wedge- display:- attr: silver- char: 'v'- description:- - A simple machine for the textually-inclined; plain but effective.- - |- An equipped `wedge`{=entity} enables the `split` command:- ```- split : int -> text -> text * text- ```- splits a `text`{=type} value into two pieces, one before the given index and one after.- properties: [portable]- capabilities: [split]--- name: string- display:- attr: silver- char: '~'- description:- - A long, flexible device for transferring either force or- information, made of twisted cotton fibers. Multiple strings can- also be woven into larger configurations such as cloth or nets.- - |- An equipped `string`{=entity} device enables several commands for working with- `text`{=type} values:- - |- `format : a -> text` can turn any value into a suitable text- representation.- - |- The infix operator `++ : text -> text -> text`{=snippet}- can be used to concatenate two text values. For example,- - |- ```- let numWidgets = 42- in "Number of widgets: " ++ format numWidgets- ```- - |- `chars : text -> int` computes the number of characters in a- `text`{=type} value.- - |- `split : int -> text -> text * text` splits a `text`{=type} value into- two pieces, one before the given index and one after.- properties: [portable]- capabilities: [format, concat, charcount, split]--- name: decoder ring- display:- attr: silver- char: 'O'- description:- - |- A handy lookup table for converting from characters to numeric codes and- back, shaped for some reason into a ring. When equipped, it- enables two functions:- - |- `charAt : int -> text -> int` returns the numeric code of the- character at a specific index in a (0-indexed) `text`{=type} value.- - |- `toChar : int -> text` creates a singleton (length-1) `text`{=type}- value containing a character with the given numeric code.- properties: [portable]- capabilities: [code]--- name: lambda- display:- attr: flower- char: 'λ'- description:- - A wild lambda. They are somewhat rare, but regrow when picked. Lambdas- are delicious when cooked into curry.- - Lambdas can also be used to create functions. For example,- - |- ```- def thrice : cmd unit -> cmd unit = \c. c;c;c end- ```- - defines the function `thrice`{=snippet} which repeats a command three times.- properties: [portable, growable]- growth: [100, 200]- capabilities: [lambda]--- name: curry- display:- attr: flower- char: 'C'- description:- - Delicious curry cooked from wild lambdas.- properties: [portable]--- name: water- display:- attr: water- char: ' '- description:- - Liquid dihydrogen monoxide, which seems to be plentiful on this planet.- properties: [portable, infinite, liquid]--- name: wavy water- display:- attr: water- char: '~'- description:- - A wavy section of water. The same as normal water, but with more waves.- properties: [portable, infinite, liquid]- yields: water--- name: boat- display:- attr: wood- char: 'B'- description:- - A robot with a boat equipped can float on top of water without drowning.- - |- **NOTE:** most devices are automatically equipped on robots that- will require them; but this doesn't work in the case of boats since floating is not- associated with any particular command. To manually ensure a boat is equipped on- a robot, just add the special command `require "boat"` to the robot's program.- properties: [portable]- capabilities: [float]--- name: sand- display:- attr: sand- char: '█'- description:- - A substance composed mostly of tiny rocks and mineral particles that can be- used in a furnace to make glass. You can often find it near water, or- make it yourself by grinding up rocks.- properties: [portable]--- name: glass- display:- attr: entity- char: '□'- description:- - A pane of a brittle, clear substance, made from melting sand in a furnace.- properties: [portable]--- name: LaTeX- display:- attr: flower- char: '$'- description:- - A naturally occurring substance derived from trees, useful for producing- rubber and for typesetting mathematical documents.- properties: [portable, growable]- growth: [2000, 3000]--- name: rubber- display:- attr: rubber- char: '%'- description:- - A flexible, durable material made from LaTeX.- properties: [portable]--- name: bit (0)- display:- attr: entity- char: '0'- description:- - A bit is used to represent the smallest possible amount of information.- Useful for constructing various information-processing devices, as well as drills.- properties: [portable, growable]- growth: [200, 400]--- name: bit (1)- display:- attr: entity- char: '1'- description:- - A bit is used to represent the smallest possible amount of information.- Useful for constructing various information-processing devices, as well as drills.- properties: [portable, growable]- growth: [200, 400]--- name: pixel (R)- display:- attr: red- char: '.'- description:- - A tiny picture element, used either to emit or detect red light.- properties: [portable, growable]- growth: [1000, 1500]--- name: pixel (G)- display:- attr: green- char: '.'- description:- - A tiny picture element, used either to emit or detect green light.- properties: [portable, growable]- growth: [1000, 1500]--- name: pixel (B)- display:- attr: blue- char: '.'- description:- - A tiny picture element, used either to emit or detect blue light.- properties: [portable, growable]- growth: [1000, 1500]--- name: camera- display:- attr: device- char: '@'- description:- - A camera is a device for capturing images.- properties: [portable]--- name: circuit- display:- attr: plant- char: '#'- description:- - |- A circuit is needed for constructing various "smart" devices.- properties: [portable]--- name: drill bit- display:- attr: entity- char: '!'- description:- - A drill bit is the most important component of a drill, and must be made- out of two bits of opposite parity, for strength.- properties: [portable]--- name: box- display:- attr: wood- char: '□'- description:- - A wooden box. It can hold things or be used as housing for other devices.- properties: [portable]--- name: wooden gear- display:- attr: wood- char: '*'- description:- - A wooden gear. Not quite as strong or versatile as an iron gear, but easy to produce.- properties: [portable]--- name: teeter-totter- display:- attr: wood- char: '/'- description:- - A rotating board apparently popular with young aliens. Perhaps it- could also be used as a primitive balance scale.- properties: [portable]--- name: Linux- display:- attr: entity- char: 'L'- description:- - A copy of the Linux operating system.- properties: [portable]--- name: gold coin- display:- char: '©'- attr: gold- description:- - A small round shaped piece of gold metal that the aliens pass between- each other occasionaly.- - Besides staying shiny it does not appear to have practical use.- properties: [portable]--############################################################-### Utility ################################################-############################################################--- name: upper left corner- display:- attr: entity- char: '┌'- description:- - Upper left corner.- properties: [unwalkable, known]--- name: upper right corner- display:- attr: entity- char: '┐'- description:- - An upper right corner wall.- properties: [unwalkable, known]--- name: lower left corner- display:- attr: entity- char: '└'- description:- - A lower left corner wall.- properties: [unwalkable, known]--- name: lower right corner- display:- attr: entity- char: '┘'- description:- - A lower right corner wall.- properties: [unwalkable, known]--- name: down and horizontal wall- display:- attr: entity- char: '┬'- description:- - A down and horizontal wall.- properties: [unwalkable, known]--- name: up and horizontal wall- display:- attr: entity- char: '┴'- description:- - A up and horizontal wall.- properties: [unwalkable, known]--- name: left and vertical wall- display:- attr: entity- char: '┤'- description:- - A left and vertical wall.- properties: [unwalkable, known]--- name: right and vertical wall- display:- attr: entity- char: '├'- description:- - A right and vertical wall.- properties: [unwalkable, known]--- name: horizontal wall- display:- attr: entity- char: '─'- description:- - A horizontal wall.- properties: [unwalkable, known]--- name: vertical wall- display:- attr: entity- char: '│'- description:- - A vertical wall.- properties: [unwalkable, known]--############################################################-### Devices ################################################-############################################################--- name: bitcoin- display:- char: '₿'- attr: gold- description:- - A beautiful round shaped piece of metal that seems to be of great value- to the aliens on this planet.- - Just like the bit it has two sides and when you flip it, it lands perfectly- randomly on one of the sides.- properties: [portable]- capabilities: [random]--- name: treads- plural: treads- display:- attr: device- char: '%'- description:- - Equipping treads on a robot allows it to move and turn.- - The `move` command moves the robot forward one unit.- - |- For example to move two units:- - |- `move; move;`- - The `turn` command takes a direction as an argument, which- can be either absolute (north, west, east, south) or relative- (left, right, forward, back, down).- - |- Example:- - |- `move; turn left; move; turn right`- capabilities: [move, turn]- properties: [portable]--- name: tank treads- plural: tank treads- display:- attr: device- char: '%'- description:- - Tank treads work like treads, but are large enough to move even heavy robots around.- capabilities: [move, turn, moveheavy]- properties: [portable]--- name: tape drive- display:- attr: device- char: '%'- description:- - A `tape drive`{=entity} allows you to `backup`; that is, to drive in reverse.- capabilities: [backup]- properties: [portable]--- name: dozer blade- display:- attr: silver- char: '/'- description:- - A broad, sturdy surface that can be attached to a robot and used to `push` objects.- - |- `push : cmd unit` will advance the robot and the entity in front of it forward by one step.- properties: [portable]- capabilities: [push]--- name: grabber- display:- attr: device- char: '<'- description:- - A grabber arm is an all-purpose, hydraulically controlled device that can- manipulate other items and robots via the `grab`, `place`, and `give`- commands.- - The `grab` command takes no arguments; it simply grabs whatever is- available, and also returns the name of the grabbed thing as a string.- It raises an exception if run in a cell that does not contain an item.- - The `place` command takes one argument, the name of the item to- place. The item is removed from the robot's inventory and placed- in the robot's current cell (which must be empty). Raises an- exception if the operation fails.- - "The `give` command takes two arguments: the actor to- give an item to (which can be at most 1 cell away), and the name- of the item to give. Raises an exception if the operation fails."- capabilities: [grab, give, place]- properties: [portable]--- name: fast grabber- display:- attr: device- char: '≪'- description:- - A fast grabber is an improved version of the basic grabber - not only- can it `grab`, `place`, and `give`, it can also `swap`.- - The `swap` command allows the robot to execute grab and place at the- same time so that the location where the robot is standing does not- become empty.- - You can use this to prevent failures where multiple robots- are trying to grab, place or scan a given location.- - In addition you retain the capability to use the `atomic` command,- with which you can implement other commands that are safe when- run in parallel.- capabilities: [grab, swap, give, place, atomic]- properties: [portable]--- name: binoculars- display:- attr: device- char: 'B'- description:- - Allows one to `scout` for other robots- capabilities: [recondir]- properties: [portable]--- name: welder- display:- attr: device- char: 'f'- description:- - |- A welder can be used to affix other gadgets to one's robot, providing- the `equip` and `unequip` commands.- - |- The `equip` command takes one argument: the name of the device to equip.- Raises an exception if the device is not in your inventory.- - |- The `unequip` command takes one argument: the name of the device to unequip.- Raises an exception if the device is not equipped.- capabilities: [equip, unequip]- properties: [portable]--- name: harvester- display:- attr: device- char: '≤'- description:- - A harvester can be used via the `harvest` command, which is- almost identical to the `grab` command. The big difference- is that some entities, when harvested instead of grabbed,- leave behind a seed which will eventually grow into another copy- of the original entity.- - For entities which do not grow, `harvest` behaves exactly the same- as `grab`.- capabilities: [grab, harvest, place]- properties: [portable]--- name: toolkit- display:- attr: device- char: 'Ѣ'- description:- - "A toolkit can be used, via the `salvage` command, to take apart old robots."- - "`salvage` takes no arguments. It looks for an inactive- robot (one which is not currently running a program) in the- current cell. If an inactive robot is found, its log (if any) is- downloaded and it is dismantled, transferring its knowledge, devices, and inventory to the- robot running `salvage`. If no inactive robots are found in the- current cell, `salvage` does nothing."- capabilities: [salvage]- properties: [portable]--- name: solar panel- display:- attr: device- char: '#'- description:- - An extremely efficient solar panel, capable of generating sufficient power- from ambient starlight alone. A robot powered by one of these can operate any time,- including on cloudy days and at night.- capabilities: [power]- properties: [portable]--- name: drill- display:- attr: device- char: '!'- description:- - A drill allows robots to `drill` through rocks and mountains (with- e.g. `drill forward`), and extract resources from mines (with- `drill down`).- capabilities: [drill]- properties: [portable]--- name: metal drill- display:- attr: iron- char: '!'- description:- - A metal drill allows robots to drill through rocks and mountains,- and extract resources from mines, faster than a regular drill.- - A metal drill is also able to drill deeper than a regular drill. Thus, some resources- are only reachable using a metal drill.- capabilities: [drill]- properties: [portable]--- name: typewriter- display:- attr: device- char: 'Д'- description:- - A typewriter is used to inscribe symbols on paper, thus reifying pure, platonic- information into a physical form.- properties: [portable]--- name: 3D printer- display:- attr: device- char: '3'- description:- - A 3D printer gives you the capability of printing more robots! You- can access the 3D printer via the `build` command.- - 'Example:'- - |- ```- build {move; grab; turn back; move; give base "tree"}- ```- - |- builds a robot to get the tree on the cell to the- north (if there is one) and bring it back to the base. The `build` command- always returns a reference to the newly constructed robot. For example,- - |- ```- r <- build {move}; view r- ```- - |- builds a robot and then views it.-- properties: [portable]- capabilities: [build]--- name: dictionary- display:- attr: device- char: 'D'-- description:- - |- A dictionary allows a robot to remember definitions and reuse them- later. You can access this ability with either a `def`{=snippet} command,- which creates a name for an expression or command that is- available from then on, or with a `let`{=snippet} expression, which names an- expression or command locally within another expression.- - |- ```- def m2 : cmd unit = move; move end- ```- - |- ```- let x : int = 3 in x^2 + 2*x + 1- ```- - The type annotations in `def`{=snippet} are optional.-- properties: [portable]- capabilities: [env]--- name: branch predictor- display:- attr: device- char: 'y'- description:- - |- A branch predictor is a device which allows a robot to interpret- conditional expressions. The syntax for a conditional expression- is `if` followed by three arguments: a boolean test and then- two delayed expressions (i.e. expressions in curly braces) of the same type.- - 'Example:'- - |- ```- let x = 2 in- if (x > 3) {move} {turn right; move}- ```- properties: [portable]- capabilities: [cond]--- name: detonator- display:- attr: fire- char: '*'- description:- - An explosive device which can be used to self-destruct, via the- `selfdestruct` command. Immediately vaporizes the robot and any- inventory it is carrying. Can be useful, say, if you are sending- out some exploratory robots and don't want them cluttering up the- world once they are done.- properties: [portable]- capabilities: [selfdestruct]--- name: life support system- display:- attr: device- char: 'Ж'- description:- - A state-of-the-art life support system which maintains the- particular temperature and mixture of gases you need to survive.- It uses a sophisticated recirculating system and can run pretty- much indefinitely. Unfortunately, the atmosphere outside is- severely toxic (why do the inhabitants of this planet need so much- nitrogen!?), so you'll have to stay inside for now.- properties: [portable]--- name: scanner- display:- attr: device- char: '$'- description:- - "With a scanner device, robots can use the `scan` command to learn- about their surroundings. Simply give `scan` a direction in which to scan,- and information about the scanned item (if any) will be added to the robot's- inventory."- - "A scanner also enables `blocked : cmd bool`, which returns a- boolean value indicating whether the robot's path is blocked- (i.e. whether executing a `move` command would fail);- `ishere : text -> cmd bool` for checking whether the current- cell contains a particular entity; and `isempty : cmd bool` for- checking whether the current cell is empty of entities. Note that- `ishere` and `isempty` do not detect robots, only entities."- - "Finally, robots can use the `upload` command to copy their accumulated- knowledge to another nearby robot; for example, `upload base`."- properties: [portable]- capabilities: [scan, sensefront, sensehere]--- name: olfactometer- display:- char: 'N'- description:- - An electronic "nose" that can tell how far away something is.- - |- `sniff : text -> cmd int` returns the distance to the nearest specified entity.- properties: [portable]- capabilities: [detectdistance]--- name: flash memory- display:- attr: device- char: '§'- description:- - "A compact, non-volatile memory device, capable of storing- up to 8 pZ of data."- - "Flash memory can be used as a component of other devices. In addition,- a flash memory device can be used to reprogram other robots using the- `reprogram` command."- - "The robot being reprogrammed must be idle, and must possess enough capabilities to run the new command;- otherwise reprogramming will fail."- properties: [portable]- capabilities: [reprogram]--- name: mirror- display:- attr: device- char: 'U'- description:- - "With a mirror, robots can reflect on themselves and see their own name."- - "A mirror enables the `whoami` command, which returns the robot's- name as a string."- - "It also enables the special `self` variable, which gives a robot- a reference to itself."- properties: [portable]- capabilities: [whoami]--- name: logger- display:- attr: device- char: 'l'- description:- - "Allows a robot to generate and store messages for later viewing,- using the `log` command, which takes a string. Log messages are- also automatically generated by uncaught exceptions."- properties: [portable]- capabilities: [log]--- name: hearing aid- display:- attr: device- char: '@'- description:- - "Allows a robot to hear anything being said nearby."- - "Simply having this device equipped will automatically- add messages said by nearby actors to this robot's log,- assuming it has a logger equipped."- - "That way you can view any heard message later either in- the logger or the message window."- - "To wait for a message and get the string value, use:"- - |- ```- l <- listen; log $ "I have waited for someone to say " ++ l- ```- properties: [portable]- capabilities: [listen]--- name: counter- display:- attr: device- char: 'C'- description:- - |- A counter enables the command `count : text -> cmd int`,- which counts how many occurrences of an entity are currently- in the inventory. This is an upgraded version of the `has`- command, which returns a bool instead of an int and does- not require any special device.- properties: [portable]- capabilities: [count]--- name: calculator- display:- attr: device- char: '+'- description:- - "A calculator allows a robot to do basic arithmetic calculations:- addition, subtraction, multiplication, division, and- exponentiation."- properties: [portable]- capabilities: [arith]--- name: ADT calculator- display:- attr: device- char: '±'- description:- - |- A calculator with Advanced Display Technology (an attached- typewriter that can print out the results). For some reason, in- addition to the usual arithmetic on numbers, an ADT calculator can- also do arithmetic on types! After all, the helpful typewritten manual- explains, a type is just a collection of values, and a finite collection- of values is just a fancy number. For example, the type `bool`{=type} is- just a fancy version of the number 2, where the two things happen to be- labelled `false` and `true`. There are also types `unit`{=type} and- `void`{=type} that correspond to 1 and 0, respectively.- - |- The product of two types is a type of pairs, since, for example,- if `t`{=type} is a type with three elements, then there are 2 * 3 = 6- different pairs containing a `bool`{=type} and a `t`{=type}, that is, 6 elements- of type `bool * t`{=type}. For working with products of types, the ADT- calculator enables pair syntax `(1, "Hi!")` as well as the projection- functions `fst : a * b -> a` and `snd : a * b -> b`.- - |- The sum of two types is a type with two options; for example, a- value of type `bool + t`{=type} is either a `bool`{=type} value or a `t`{=type} value,- and there are `2 + 3 == 5` such values. For working with sums of- types, the ADT calculator provides the injection functions `inl :- a -> a + b` and `inr : b -> a + b`, as well as the case analysis- function `case : (a + b) -> (a -> c) -> (b -> c) -> c`. For- example, `case (inl 3) (\x. 2*x) (\y. 3*y) == 6`, and `case (inr- 3) (\x. 2*x) (\y. 3*y) == 9`.-- properties: [portable]- capabilities: [arith, sum, prod]--- name: compass- display:- attr: device- char: 'N'- description:- - |- A compass gives a robot the ability to orient using the cardinal- directions north, south, west, and east. For example:- - |- `turn west; move; turn north`- - |- It also enables the `heading : cmd dir` command, which returns the- robot's current heading. For example, the following code moves- east and then restores the same heading as before:- - |- `d <- heading; turn east; move; turn d`- properties: [portable]- capabilities: [orient]--- name: clock- display:- attr: device- char: '0'- description:- - A clock is a device for keeping track of time. It enables the `wait` and `time` commands.- - |- `time : cmd int` returns the current time, measured in game ticks since the beginning of the game.- - |- `wait : int -> cmd unit` causes a robot to sleep for a specified amount of time (measured in game ticks).- properties: [portable]- capabilities: [timeabs, timerel]--- name: hourglass- display:- attr: device- char: '8'- description:- - An hourglass can measure the relative passage of time. It enables the `wait` command.- - |- `wait : int -> cmd unit` causes a robot to sleep for a specified amount of time (measured in game ticks).- properties: [portable]- capabilities: [timerel]--- name: rolex- display:- char: R- attr: silver- description:- - Enables robots to use the `watch` command.- - |- `watch : dir -> cmd unit` will mark an adjacent (in the specified direction) location of interest to monitor for placement or removal of items.- A subsequent call to `wait` will be interrupted upon a change to the location.- properties: [portable]- capabilities: [wakeself]--- name: comparator- display:- attr: device- char: '>'- description:- - "A comparator allows comparing two values to see whether the first- is less, equal, or greater than the second."- - "Valid comparison operators are <, <=, >, >=, ==, and !=."- properties: [portable]- capabilities: [compare]--- name: I/O cable- display:- attr: device- char: 'Ю'- description:- - An I/O cable can be used to communicate with adjacent actors.- properties: [portable]--- name: rubber band- display:- attr: device- char: 'O'- description:- - "A rubber band can tie multiple commands together so that other robots can't execute- commands in between them. It can be used via the `atomic` command. For example, suppose- robot A executes the following code:"- - |- ```- b <- ishere "rock"; if b {grab; return ()} {}- ```- - "This seems like a safe way to execute `grab` only when there is a- rock to grab. However, it is actually possible for the `grab` to- fail, if some other robot B snatches the rock right after robot A sensed- it and before robot A got around to grabbing it on the next game tick."- - "This will make robot A very sad and it will crash."- - "To prevent this situation, robot A can wrap the commands in `atomic`, like so:"- - |- ```- atomic (b <- ishere "rock"; if b {grab; return ()} {})- ```-- properties: [portable]- capabilities: [atomic]--- name: net- display:- attr: silver- char: '#'- description:- - A net is a device woven out of many strings. With a net- equipped, you can use the `try` command to catch errors. For example- - |- ```- try {move} {turn left}- ```- - will attempt to move, but if that fails, turn left instead.- properties: [portable]- capabilities: [try]--- name: antenna- display:- attr: silver- char: 'Y'- description:- - A device for transforming electric current into radio waves, and- vice versa. Antennas can be used to increase the viable range- over which you can communicate with your robots.- - |- Antennas can also be used to locate nearby actors, by bouncing radio- waves off them and listening for the echo. This capability can be- accessed via two commands:- - |- `meet : cmd (unit + actor)` tries to locate a- nearby actor (a robot, or... something else?) up to one cell away.- It returns a reference to the nearest actor, or a unit value if- none are found.- - |- `meetAll : (b -> actor -> cmd b) -> b -> cmd b` runs a command on- every nearby actor (other than oneself), folding over the results- to compute a final result of type `b`{=type}. For example, if- `x`{=snippet}, `y`{=snippet}, and `z`{=snippet}- are nearby actors, then `meetAll f b0`{=snippet} is equivalent to- `b1 <- f b0 x; b2 <- f b1 y; f b2 z`{=snippet}.- properties: [portable]- capabilities: [meet]--- name: GPS receiver- display:- attr: device- char: 'G'- description:- - |- A GPS receiver triangulates your current (x,y) coordinates from- some convenient satellite signals,- enabling the command `whereami : cmd (int * int)`.- properties: [portable]- capabilities: [senseloc]--- name: tweezers- display:- attr: device- char: 'V'- description:- - |- Sometimes small, self-reproducing creatures get stuck inside a robot's- relays, preventing it from executing properly. Tweezers are- useful for removing such pests, and for inspecting robots' detailed- inner workings.- properties: [portable]- capabilities: [debug]--- name: victrola- display:- attr: device- char: 'Q'- description:- - |- A device for reading and writing data on circular platters made of- a soft plastic material. The stylus must be made of a- hard and durable material, with a special tip that relies on- quantum effects to extract high-density information.- - |- Also allows manipulating composite values consisting of a- collection of named fields. For example, `[x = 2, y = "hi"]`- is a value of type `[x : int, y : text]`{=type}. Individual fields- can be projected using dot notation. For example,- `let r = [y="hi", x=2] in r.x` has the value `2`. The order- of the fields does not matter.- properties: [portable]- capabilities: [record]--- name: quantum dot- display:- attr: gold- char: '.'- description:- - |- A nanoscale semiconductor particle with a wide range of- applications.- properties: [portable]--- name: 'key'- display:- attr: gold- char: 'k'- description:- - A versatile item, with uses such as opening- locked doors, entering input, and retrieving stored values.- properties: [portable]--- name: keyboard- display:- attr: device- char: 'K'- description:- - A small device with multiple keys, adapted for your unique anatomy.- - |- `installKeyHandler : text -> (key -> cmd unit) -> cmd unit`- installs a custom handler function that can be activated to- respond to keyboard inputs typed at the REPL.- - |- `key : text -> key` constructs values of type `key`{=type}, for- example `key "Down"` or `key "C-S-x"`.- properties: [portable]- capabilities: [handleinput]--- name: halting oracle- display:- attr: device- char: '?'- description:- - A device to solve the halting problem. When asked if a- particular robot program will halt, it always answers YES.- And it is always correct... or else!- - |- Enables the command `halt : actor -> cmd unit` which takes- a robot as an argument and, if it is up to one cell away,- cancels its currently running program (if any). In creative mode,- there is no distance limitation.- properties: [portable]- capabilities: [halt]+ - |+ A tall, living entity made of a tough cellular material called "wood".+ They regrow after being harvested and are an important raw ingredient used+ in making many different devices.+ properties: [pickable, growable, opaque, combustible]+ growth: [500, 600]+ combustion:+ ignition: 0.01+ duration: [80, 120]+ product: ash+- name: ash+ display:+ attr: rock+ char: '#'+ description:+ - |+ Burned-out remnants of combustion.+ properties: [pickable]+- name: branch+ display:+ attr: wood+ char: 'y'+ description:+ - A branch cut from a tree. It's as if the tree had to make a decision and was exploring two options.+ properties: [pickable]+- name: log+ display:+ attr: wood+ char: 'l'+ description:+ - A wooden log, obtained by harvesting a tree and cutting off its branches.+ properties: [pickable, combustible]+ combustion:+ ignition: 0.05+ duration: [40, 80]+ product: ash+- name: board+ display:+ attr: wood+ char: 'w'+ description:+ - A wooden board, made by cutting a log into pieces.+ properties: [pickable, combustible]+ combustion:+ ignition: 0.2+ duration: [20, 40]+ product: ash+- name: workbench+ display:+ attr: wood+ char: 'π'+ description:+ - A plain wooden workbench, providing space to make other things using the `make` command.+ - |+ Example:+ ```+ make "log"+ ```+ properties: [pickable]+ capabilities: [make]+- name: paper+ display:+ attr: snow+ char: '■'+ description:+ - A flat material made of pressed and dried wood fibers, used as a surface on which to inscribe symbols.+ properties: [pickable, combustible]+ combustion:+ ignition: 0.5+ duration: [10, 20]+ product: ash+- name: PhD thesis+ display:+ attr: snow+ char: 'P'+ description:+ - Perhaps writing one of these will help gain the trust and respect of the native inhabitants.+ properties: [pickable]+- name: rock+ display:+ attr: rock+ char: 'o'+ description:+ - A medium-sized rock, picked up from the ground or created by drilling. Can be ground into sand or used to build a simple furnace, among other things.+ properties: [pickable]+- name: handle+ display:+ attr: device+ char: 'h'+ description:+ - Ergonomic affordance for manipulating objects. Also grants the "setname" capability, allowing one to assign a "handle" to robots.+ properties: [pickable]+ capabilities: [setname]+- name: lodestone+ display:+ attr: iron+ char: 'o'+ description:+ - A medium-sized rock... that looks a little different. It seems to react to iron and surprisingly also to naturally growing bits.+ properties: [pickable]+ capabilities: [negation]+- name: beaglepuss+ display:+ attr: rubber+ char: 'B'+ description:+ - Iconic novelty disguise. Renders one either completely inconspicuous, or the opposite.+ properties: [pickable]+ capabilities: [appear]+- name: boulder+ display:+ attr: rock+ char: '@'+ description:+ - A very large, impassable rock. A drill can be used to get rid of it and turn it into smaller rocks.+ properties: [unwalkable]+- name: mountain+ display:+ attr: snow+ char: 'A'+ description:+ - A mountain. Can be tunneled through with a drill, but it takes time.+ properties: [unwalkable, opaque]+- name: mountain tunnel+ display:+ attr: snow+ char: 'Å'+ priority: 11+ description:+ - A tunnel in a mountain through which anything can freely move.+ properties: []+- name: copper ore+ display:+ attr: copper+ char: 'C'+ description:+ - Raw copper ore, useful for making wires, pipes, and other metal things. Patches of copper ore can be found on the surface, but are quickly exhausted.+ - Scanners seem to indicate larger quantities of copper could be found beneath some of the mountains, but those would require a drill to access and mine.+ properties: [pickable]+- name: copper mine+ display:+ attr: copper'+ char: 'Å'+ priority: 11+ description:+ - A copper vein that can be actively mined to produce copper ore.+ properties: []+- name: copper wire+ display:+ attr: copper+ char: '|'+ description:+ - Copper wire is very good at conducting electricity and useful for making various types of circuits and machines.+ properties: [pickable]+- name: strange loop+ display:+ attr: copper+ char: '8'+ description:+ - Two copper wires twisted together in a strange shape that loops back on itself. It must be useful for something...+ properties: [pickable]+ capabilities: [recursion]+- name: copper pipe+ display:+ attr: copper+ char: 'I'+ description:+ - A pipe made out of a thin sheet of copper. Great for transmitting water or steam.+ properties: [pickable]+- name: iron plate+ display:+ attr: iron+ char: '■'+ description:+ - Worked iron suitable for crafting resilient tools.+ - It also possess some electro-magnetic properties.+ properties: [pickable]+- name: iron gear+ display:+ attr: iron+ char: '*'+ description:+ - An iron gear, suitable for constructing larger, more powerful machinery than a wooden gear.+ properties: [pickable]+- name: iron ore+ display:+ attr: iron+ char: 'F'+ description:+ - Raw iron ore. Used to create more resilient tools than copper.+ - It can only be mined by drilling in the mountains.+ properties: [pickable]+- name: iron mine+ display:+ attr: iron'+ char: 'Å'+ priority: 11+ description:+ - An iron vein that can be actively mined to produce iron ore.+ properties: []+- name: quartz+ display:+ attr: quartz+ char: 'Q'+ description:+ - Raw quartz crystals. Useful for creating devices like clocks, and can be processed to extract silicon.+ - It can only be mined by drilling in the mountains.+ properties: [pickable]+- name: quartz mine+ display:+ attr: quartz+ char: 'Å'+ priority: 11+ description:+ - A quartz vein that can be actively mined to produce quartz.+ properties: []+- name: silicon+ display:+ attr: quartz+ char: 'S'+ description:+ - Extracted by processing quartz at high temperatures, silicon can be used to construct integrated circuits.+ properties: [pickable]+- name: deep mine+ display:+ attr: rock+ char: 'Å'+ priority: 11+ description:+ - A deep mine that yields rare and wonderful treasures to those who are patient.+ - But be careful lest you delve too greedily and too deep.+ properties: []+- name: silver+ display:+ attr: silver+ char: '•'+ description:+ - A shiny, metallic substance, noted for its high reflectivity when polished.+ properties: [pickable]+- name: gold+ display:+ attr: gold+ char: '•'+ description:+ - A shiny, metallic substance, with applications in specialized electronics.+ - It also seems to be highly valued by local aliens.+ properties: [pickable]+- name: mithril+ display:+ attr: silver+ char: 'M'+ description:+ - Mithril can be beaten like copper, and polished like glass. One can also make of it a metal, light and yet harder than tempered steel. Its beauty is like to that of common silver, but the beauty of mithril does not tarnish or grow dim.+ properties: [pickable]+- name: furnace+ display:+ attr: fire+ char: '#'+ description:+ - A furnace can be used to turn metal ore into various useful products.+ properties: [pickable]+- name: big furnace+ display:+ attr: fire+ char: '#'+ description:+ - A big furnace can get even hotter than a normal furnace, and can be used to process quartz into silicon.+ properties: [pickable]+- name: small motor+ display:+ attr: entity+ char: 'm'+ description:+ - A motor is useful for making devices that can turn when electric current is applied.+ - This one is rather small, but surprisingly efficient.+ properties: [pickable]+- name: big motor+ display:+ attr: entity+ char: 'M'+ description:+ - A motor is useful for making devices that can turn when electric current is applied.+ - This one is huge and could be used to construct powerful machinery.+ properties: [pickable]+- name: flower+ display:+ attr: flower+ char: '*'+ description:+ - A beautiful flower that grows wild in local meadows. It is not clear what it might be useful for, but it looks nice.+ properties: [pickable, growable]+ growth: [30, 50]+- name: tea plant+ display:+ attr: plant+ char: 't'+ description:+ - Camellia sinensis.+ properties: [pickable, growable]+ growth: [5000, 6000]+ yields: tea leaves+- name: cup of tea+ display:+ attr: sand+ char: 'u'+ description:+ - A nice hot cup of tea.+ properties: [pickable]+- name: tea leaves+ display:+ attr: plant+ char: 'l'+ description:+ - Leaves picked from a tea plant. They give off a nice smell when crushed.+ properties: [pickable]+- name: cotton+ display:+ attr: silver+ char: 'i'+ description:+ - A plant with tufts of soft fibers that can be harvested and used to make things, including sheets of material that the local aliens like to drape over their bodies.+ properties: [pickable, growable, combustible]+ growth: [100, 800]+ combustion:+ ignition: 0.1+ duration: [20, 40]+ product: ash+- name: linotype+ display:+ attr: silver+ char: 't'+ description:+ - Employs hot lead typesetting to arrange glyphs into a mold for printing.+ - |+ An equipped `linotype`{=entity} device enables the `format` command:+ ```+ format : a -> Text+ ```+ which can turn any value into a suitable text representation.+ properties: [pickable]+ capabilities: [format]+- name: Elmer's glue+ display:+ attr: snow+ char: 'g'+ description:+ - Polyvinyl acetate. Popular adhesive for crafting. Of dubious nutritional value.+ - |+ Facilitates the concatenation of text values.+ - |+ The infix operator `++ : Text -> Text -> Text`{=snippet}+ can be used to concatenate two `Text`{=type} values. For example,+ - |+ ```+ let numWidgets = 42+ in "Number of widgets: " ++ format numWidgets+ ```+ properties: [pickable]+ capabilities: [concat]+- name: caliper+ display:+ attr: silver+ char: 'C'+ description:+ - Simple, yet accurate measuring device. Can determine the length of a text value.+ - |+ ```+ chars : Text -> Int+ ```+ computes the number of characters in a `Text`{=type} value.+ properties: [pickable]+ capabilities: [charcount]+- name: wedge+ display:+ attr: silver+ char: 'v'+ description:+ - A simple machine for the textually-inclined; plain but effective.+ - |+ An equipped `wedge`{=entity} enables the `split` command:+ ```+ split : Int -> Text -> Text * Text+ ```+ splits a `Text`{=type} value into two pieces, one before the given index and one after.+ properties: [pickable]+ capabilities: [split]+- name: string+ display:+ attr: silver+ char: '~'+ description:+ - A long, flexible device for transferring either force or information, made of twisted cotton fibers. Multiple strings can also be woven into larger configurations such as cloth or nets.+ - |+ An equipped `string`{=entity} device enables several commands for working with+ `Text`{=type} values:+ - |+ `format : a -> Text` can turn any value into a suitable text+ representation.+ - |+ The infix operator `++ : Text -> Text -> Text`{=snippet}+ can be used to concatenate two text values. For example,+ - |+ ```+ let numWidgets = 42+ in "Number of widgets: " ++ format numWidgets+ ```+ - |+ `chars : Text -> Int` computes the number of characters in a+ `Text`{=type} value.+ - |+ `split : Int -> Text -> Text * Text` splits a `Text`{=type} value into+ two pieces, one before the given index and one after.+ properties: [pickable]+ capabilities: [format, concat, charcount, split]+- name: decoder ring+ display:+ attr: silver+ char: 'O'+ description:+ - |+ A handy lookup table for converting from characters to numeric codes and+ back, shaped for some reason into a ring. When equipped, it+ enables two functions:+ - |+ `charAt : Int -> Text -> Int` returns the numeric code of the+ character at a specific index in a (0-indexed) `Text`{=type} value.+ - |+ `toChar : Int -> Text` creates a singleton (length-1) `Text`{=type}+ value containing a character with the given numeric code.+ properties: [pickable]+ capabilities: [code]+- name: lambda+ display:+ attr: flower+ char: 'λ'+ description:+ - A wild lambda. They are somewhat rare, but regrow when picked. Lambdas are delicious when cooked into curry.+ - Lambdas can also be used to create functions. For example,+ - |+ ```+ def thrice : Cmd Unit -> Cmd Unit = \c. c;c;c end+ ```+ - defines the function `thrice`{=snippet} which repeats a command three times.+ properties: [pickable, growable]+ growth: [100, 200]+ capabilities: [lambda]+- name: curry+ display:+ attr: flower+ char: 'C'+ description:+ - Delicious curry cooked from wild lambdas.+ properties: [pickable]+- name: water+ display:+ attr: water+ char: ' '+ description:+ - Liquid dihydrogen monoxide, which seems to be plentiful on this planet.+ properties: [pickable, infinite, liquid]+- name: wavy water+ display:+ attr: water+ char: '~'+ description:+ - A wavy section of water. The same as normal water, but with more waves.+ properties: [pickable, infinite, liquid]+ yields: water+- name: boat+ display:+ attr: wood+ char: 'B'+ description:+ - A robot with a boat equipped can float on top of water without drowning.+ - |+ **NOTE:** most devices are automatically equipped on robots that+ will require them; but this doesn't work in the case of boats since floating is not+ associated with any particular command. To manually ensure a boat is equipped on+ a robot, just add the special command `require "boat"` to the robot's program.+ properties: [pickable]+ capabilities: [float]+- name: sand+ display:+ attr: sand+ char: '█'+ description:+ - A substance composed mostly of tiny rocks and mineral particles that can be used in a furnace to make glass. You can often find it near water, or make it yourself by grinding up rocks.+ properties: [pickable]+- name: glass+ display:+ attr: entity+ char: '□'+ description:+ - A pane of a brittle, clear substance, made from melting sand in a furnace.+ properties: [pickable]+- name: lens+ display:+ attr: entity+ char: 'O'+ description:+ - A polished, rounded piece of glass, capable of focusing rays of light.+ properties: [pickable]+- name: LaTeX+ display:+ attr: flower+ char: '$'+ description:+ - A naturally occurring substance derived from trees, useful for producing rubber and for typesetting mathematical documents.+ properties: [pickable, growable]+ growth: [2000, 3000]+- name: rubber+ display:+ attr: rubber+ char: '%'+ description:+ - A flexible, durable material made from LaTeX.+ properties: [pickable]+- name: bit (0)+ display:+ attr: entity+ char: '0'+ description:+ - A bit is used to represent the smallest possible amount of information. Useful for constructing various information-processing devices, as well as drills.+ properties: [pickable, growable]+ growth: [200, 400]+- name: bit (1)+ display:+ attr: entity+ char: '1'+ description:+ - A bit is used to represent the smallest possible amount of information. Useful for constructing various information-processing devices, as well as drills.+ properties: [pickable, growable]+ growth: [200, 400]+- name: pixel (R)+ display:+ attr: red+ char: '.'+ description:+ - A tiny picture element, used either to emit or detect red light.+ properties: [pickable, growable]+ growth: [1000, 1500]+- name: pixel (G)+ display:+ attr: green+ char: '.'+ description:+ - A tiny picture element, used either to emit or detect green light.+ properties: [pickable, growable]+ growth: [1000, 1500]+- name: pixel (B)+ display:+ attr: blue+ char: '.'+ description:+ - A tiny picture element, used either to emit or detect blue light.+ properties: [pickable, growable]+ growth: [1000, 1500]+- name: camera+ display:+ attr: device+ char: '@'+ description:+ - A camera is a device for capturing images.+ properties: [pickable]+- name: circuit+ display:+ attr: plant+ char: '#'+ description:+ - |+ A circuit is needed for constructing various "smart" devices.+ properties: [pickable]+- name: blueprint+ display:+ attr: blue+ char: 'B'+ description:+ - This enables the `structure` and `floorplan` commands to locate and analyze structures placed in the world.+ - |+ `structure : Text -> Int -> Cmd (Unit + (Int * (Int * Int)))`+ - Gets the x, y coordinates of the southwest corner of a constructed structure, by name and index.+ - |+ `floorplan : Text -> Cmd (Int * Int)`+ - Gets the dimensions of a structure template.+ properties: [pickable]+ capabilities: [structure]+- name: drill bit+ display:+ attr: entity+ char: '!'+ description:+ - A drill bit is the most important component of a drill, and must be made out of two bits of opposite parity, for strength.+ properties: [pickable]+- name: box+ display:+ attr: wood+ char: '□'+ description:+ - A wooden box. It can hold things or be used as housing for other devices.+ properties: [pickable]+- name: wooden gear+ display:+ attr: wood+ char: '*'+ description:+ - A wooden gear. Not quite as strong or versatile as an iron gear, but easy to produce.+ properties: [pickable]+- name: teeter-totter+ display:+ attr: wood+ char: '/'+ description:+ - A rotating board apparently popular with young aliens. Perhaps it could also be used as a primitive balance scale.+ properties: [pickable]+- name: Linux+ display:+ attr: entity+ char: 'L'+ description:+ - A copy of the Linux operating system.+ properties: [pickable]+- name: gold coin+ display:+ char: '©'+ attr: gold+ description:+ - A small round shaped piece of gold metal that the aliens pass between each other occasionaly.+ - Besides staying shiny it does not appear to have practical use.+ properties: [pickable]+############################################################+### Utility ################################################+############################################################+- name: upper left corner+ display:+ attr: entity+ char: '┌'+ description:+ - Upper left corner.+ properties: [unwalkable, known]+- name: upper right corner+ display:+ attr: entity+ char: '┐'+ description:+ - An upper right corner wall.+ properties: [unwalkable, known]+- name: lower left corner+ display:+ attr: entity+ char: '└'+ description:+ - A lower left corner wall.+ properties: [unwalkable, known]+- name: lower right corner+ display:+ attr: entity+ char: '┘'+ description:+ - A lower right corner wall.+ properties: [unwalkable, known]+- name: down and horizontal wall+ display:+ attr: entity+ char: '┬'+ description:+ - A down and horizontal wall.+ properties: [unwalkable, known]+- name: up and horizontal wall+ display:+ attr: entity+ char: '┴'+ description:+ - A up and horizontal wall.+ properties: [unwalkable, known]+- name: left and vertical wall+ display:+ attr: entity+ char: '┤'+ description:+ - A left and vertical wall.+ properties: [unwalkable, known]+- name: right and vertical wall+ display:+ attr: entity+ char: '├'+ description:+ - A right and vertical wall.+ properties: [unwalkable, known]+- name: horizontal wall+ display:+ attr: entity+ char: '─'+ description:+ - A horizontal wall.+ properties: [unwalkable, known]+- name: vertical wall+ display:+ attr: entity+ char: '│'+ description:+ - A vertical wall.+ properties: [unwalkable, known]+############################################################+### Devices ################################################+############################################################+- name: bitcoin+ display:+ char: '₿'+ attr: gold+ description:+ - A beautiful round shaped piece of metal that seems to be of great value to the aliens on this planet.+ - Just like the bit it has two sides and when you flip it, it lands perfectly randomly on one of the sides.+ properties: [pickable]+ capabilities: [random]+- name: treads+ plural: treads+ display:+ attr: device+ char: '%'+ description:+ - Equipping treads on a robot allows it to move and turn.+ - The `move` command moves the robot forward one unit.+ - |+ For example to move two units:+ - |+ `move; move;`+ - The `turn` command takes a direction as an argument, which can be either absolute (north, west, east, south) or relative (left, right, forward, back, down).+ - |+ Example:+ - |+ `move; turn left; move; turn right`+ capabilities: [move, turn]+ properties: [pickable]+- name: tank treads+ plural: tank treads+ display:+ attr: device+ char: '%'+ description:+ - Tank treads work like treads, but are large enough to move even heavy robots around.+ capabilities: [move, turn, moveheavy]+ properties: [pickable]+- name: tape drive+ display:+ attr: device+ char: '%'+ description:+ - A `tape drive`{=entity} allows you to `backup`; that is, to drive in reverse.+ capabilities: [backup]+ properties: [pickable]+- name: dozer blade+ display:+ attr: silver+ char: '/'+ description:+ - A broad, sturdy surface that can be attached to a robot and used to `push` objects.+ - |+ `push : Cmd Unit` will advance the robot and the entity in front of it forward by one step.+ properties: [pickable]+ capabilities: [push]+- name: grabber+ display:+ attr: device+ char: '<'+ description:+ - A grabber arm is an all-purpose, hydraulically controlled device that can manipulate other items and robots via the `grab`, `place`, and `give` commands.+ - The `grab` command takes no arguments; it simply grabs whatever is available, and also returns the name of the grabbed thing as a string. It raises an exception if run in a cell that does not contain an item.+ - The `place` command takes one argument, the name of the item to place. The item is removed from the robot's inventory and placed in the robot's current cell (which must be empty). Raises an exception if the operation fails.+ - "The `give` command takes two arguments: the `Actor`{=type} to give an item to (which can be at most 1 cell away), and the name of the item to give. Raises an exception if the operation fails."+ capabilities: [grab, give, place]+ properties: [pickable]+- name: fast grabber+ display:+ attr: device+ char: '≪'+ description:+ - A fast grabber is an improved version of the basic grabber - not only can it `grab`, `place`, and `give`, it can also `swap`.+ - The `swap` command allows the robot to execute grab and place at the same time so that the location where the robot is standing does not become empty.+ - You can use this to prevent failures where multiple robots are trying to grab, place or scan a given location.+ - In addition you retain the capability to use the `atomic` command, with which you can implement other commands that are safe when run in parallel.+ capabilities: [grab, swap, give, place, atomic]+ properties: [pickable]+- name: binoculars+ display:+ attr: device+ char: 'B'+ description:+ - Allows one to `scout` for other robots+ capabilities: [recondir]+ properties: [pickable]+- name: welder+ display:+ attr: device+ char: 'f'+ description:+ - |+ A welder can be used to affix other gadgets to one's robot, providing+ the `equip` and `unequip` commands.+ - |+ The `equip` command takes one argument: the name of the device to equip.+ Raises an exception if the device is not in your inventory.+ - |+ The `unequip` command takes one argument: the name of the device to unequip.+ Raises an exception if the device is not equipped.+ capabilities: [equip, unequip]+ properties: [pickable]+- name: harvester+ display:+ attr: device+ char: '≤'+ description:+ - A harvester can be used via the `harvest` command, which is almost identical to the `grab` command. The big difference is that some entities, when harvested instead of grabbed, leave behind a seed which will eventually grow into another copy of the original entity.+ - For entities which do not grow, `harvest` behaves exactly the same as `grab`.+ capabilities: [grab, harvest, place]+ properties: [pickable]+- name: toolkit+ display:+ attr: device+ char: 'Ѣ'+ description:+ - "A toolkit can be used, via the `salvage` command, to take apart old robots."+ - "`salvage` takes no arguments. It looks for an inactive robot (one which is not currently running a program) in the current cell. If an inactive robot is found, its log (if any) is downloaded and it is dismantled, transferring its knowledge, devices, and inventory to the robot running `salvage`. If no inactive robots are found in the current cell, `salvage` does nothing."+ capabilities: [salvage]+ properties: [pickable]+- name: solar panel+ display:+ attr: device+ char: '#'+ description:+ - An extremely efficient solar panel, capable of generating sufficient power from ambient starlight alone. A robot powered by one of these can operate any time, including on cloudy days and at night.+ capabilities: [power]+ properties: [pickable]+- name: drill+ display:+ attr: device+ char: '!'+ description:+ - A drill allows robots to `drill` through rocks and mountains (with e.g. `drill forward`), and extract resources from mines (with `drill down`).+ capabilities: [drill]+ properties: [pickable]+- name: metal drill+ display:+ attr: iron+ char: '!'+ description:+ - A metal drill allows robots to drill through rocks and mountains, and extract resources from mines, faster than a regular drill.+ - A metal drill is also able to drill deeper than a regular drill. Thus, some resources are only reachable using a metal drill.+ capabilities: [drill]+ properties: [pickable]+- name: typewriter+ display:+ attr: device+ char: 'Д'+ description:+ - A typewriter is used to inscribe symbols on paper, thus reifying pure, platonic information into a physical form.+ properties: [pickable]+- name: 3D printer+ display:+ attr: device+ char: '3'+ description:+ - A 3D printer gives you the capability of printing more robots! You can access the 3D printer via the `build` command.+ - 'Example:'+ - |+ ```+ build {move; grab; turn back; move; give base "tree"}+ ```+ - |+ builds a robot to get the tree on the cell to the+ north (if there is one) and bring it back to the base. The `build` command+ always returns a reference to the newly constructed robot. For example,+ - |+ ```+ r <- build {move}; view r+ ```+ - |+ builds a robot and then views it.+ properties: [pickable]+ capabilities: [build]+- name: dictionary+ display:+ attr: device+ char: 'D'+ description:+ - |+ A dictionary allows a robot to remember definitions and reuse them+ later. You can access this ability with either a `def`{=snippet} command,+ which creates a name for an expression or command that is+ available from then on, or with a `let`{=snippet} expression, which names an+ expression or command locally within another expression.+ - |+ ```+ def m2 : Cmd Unit = move; move end+ ```+ - |+ ```+ let x : Int = 3 in x^2 + 2*x + 1+ ```+ - The type annotations in `def`{=snippet} are optional.+ properties: [pickable]+ capabilities: [env]+- name: branch predictor+ display:+ attr: device+ char: 'y'+ description:+ - |+ A branch predictor is a device which allows a robot to interpret+ conditional expressions. The syntax for a conditional expression+ is `if` followed by three arguments: a boolean test and then+ two delayed expressions (i.e. expressions in curly braces) of the same type.+ - 'Example:'+ - |+ ```+ let x = 2 in+ if (x > 3) {move} {turn right; move}+ ```+ properties: [pickable]+ capabilities: [cond]+- name: detonator+ display:+ attr: fire+ char: '*'+ description:+ - An explosive device which can be used to self-destruct, via the `selfdestruct` command. Immediately vaporizes the robot and any inventory it is carrying. Can be useful, say, if you are sending out some exploratory robots and don't want them cluttering up the world once they are done.+ properties: [pickable]+ capabilities: [selfdestruct]+- name: life support system+ display:+ attr: device+ char: 'Ж'+ description:+ - A state-of-the-art life support system which maintains the particular temperature and mixture of gases you need to survive. It uses a sophisticated recirculating system and can run pretty much indefinitely. Unfortunately, the atmosphere outside is severely toxic (why do the inhabitants of this planet need so much nitrogen!?), so you'll have to stay inside for now.+ properties: [pickable]+- name: scanner+ display:+ attr: device+ char: '$'+ description:+ - "With a scanner device, robots can use the `scan` command to learn about their surroundings. Simply give `scan` a direction in which to scan, and information about the scanned item (if any) will be added to the robot's inventory."+ - "A scanner also enables `blocked : Cmd Bool`, which returns a boolean value indicating whether the robot's path is blocked (i.e. whether executing a `move` command would fail); `ishere : Text -> Cmd Bool` for checking whether the current cell contains a particular entity; and `isempty : Cmd Bool` for checking whether the current cell is empty of entities. Note that `ishere` and `isempty` do not detect robots, only entities."+ - "Finally, robots can use the `upload` command to copy their accumulated knowledge to another nearby robot; for example, `upload base`."+ properties: [pickable]+ capabilities: [scan, sensefront, sensehere]+- name: olfactometer+ display:+ char: 'N'+ description:+ - An electronic "nose" that can tell how far away something is.+ - |+ `sniff : Text -> Cmd Int` returns the distance to the nearest specified entity.+ properties: [pickable]+ capabilities: [detectdistance]+- name: flash memory+ display:+ attr: device+ char: '§'+ description:+ - "A compact, non-volatile memory device, capable of storing up to 8 pZ of data."+ - "Flash memory can be used as a component of other devices. In addition, a flash memory device can be used to reprogram other robots using the `reprogram` command."+ - "The robot being reprogrammed must be idle, and must possess enough capabilities to run the new command; otherwise reprogramming will fail."+ properties: [pickable]+ capabilities: [reprogram]+- name: mirror+ display:+ attr: device+ char: 'U'+ description:+ - "With a mirror, robots can reflect on themselves and see their own name."+ - "A mirror enables the `whoami` command, which returns the robot's name as a string."+ - "It also enables the special `self` variable, which gives a robot a reference to itself."+ properties: [pickable]+ capabilities: [whoami]+- name: logger+ display:+ attr: device+ char: 'l'+ description:+ - "Allows a robot to generate and store messages for later viewing, using the `log` command, which takes a string. Log messages are also automatically generated by uncaught exceptions."+ properties: [pickable]+ capabilities: [log]+- name: hearing aid+ display:+ attr: device+ char: '@'+ description:+ - "Allows a robot to hear anything being said nearby."+ - "Simply having this device equipped will automatically add messages said by nearby actors to this robot's log, assuming it has a logger equipped."+ - "That way you can view any heard message later either in the logger or the message window."+ - "To wait for a message and get the string value, use:"+ - |+ ```+ l <- listen; log $ "I have waited for someone to say " ++ l+ ```+ properties: [pickable]+ capabilities: [listen]+- name: counter+ display:+ attr: device+ char: 'C'+ description:+ - |+ A counter enables the command `count : Text -> Cmd Int`,+ which counts how many occurrences of an entity are currently+ in the inventory. This is an upgraded version of the `has`+ command, which returns a `Bool`{=type} instead of an `Int`{=type} and does+ not require any special device.+ properties: [pickable]+ capabilities: [count]+- name: calculator+ display:+ attr: device+ char: '+'+ description:+ - "A calculator allows a robot to do basic arithmetic calculations: addition, subtraction, multiplication, division, and exponentiation."+ properties: [pickable]+ capabilities: [arith]+- name: ADT calculator+ display:+ attr: device+ char: '±'+ description:+ - |+ A calculator with Advanced Display Technology (an attached+ typewriter that can print out the results). For some reason, in+ addition to the usual arithmetic on numbers, an ADT calculator can+ also do arithmetic on types! After all, the helpful typewritten manual+ explains, a type is just a collection of values, and a finite collection+ of values is just a fancy number. For example, the type `Bool`{=type} is+ just a fancy version of the number 2, where the two things happen to be+ labelled `false` and `true`. There are also types `Unit`{=type} and+ `Void`{=type} that correspond to 1 and 0, respectively.+ - |+ The product of two types is a type of pairs, since, for example,+ if `t`{=type} is a type with three elements, then there are 2 * 3 = 6+ different pairs containing a `Bool`{=type} and a `t`{=type}, that is, 6 elements+ of type `Bool * t`{=type}. For working with products of types, the ADT+ calculator enables pair syntax `(1, "Hi!")` as well as the projection+ functions `fst : a * b -> a` and `snd : a * b -> b`.+ - |+ The sum of two types is a type with two options; for example, a+ value of type `Bool + t`{=type} is either a `Bool`{=type} value or a `t`{=type} value,+ and there are `2 + 3 == 5` such values. For working with sums of+ types, the ADT calculator provides the injection functions `inl :+ a -> a + b` and `inr : b -> a + b`, as well as the case analysis+ function `case : (a + b) -> (a -> c) -> (b -> c) -> c`. For+ example, `case (inl 3) (\x. 2*x) (\y. 3*y) == 6`, and `case (inr+ 3) (\x. 2*x) (\y. 3*y) == 9`.+ properties: [pickable]+ capabilities: [arith, sum, prod]+- name: hyperloop+ display:+ attr: device+ char: '∞'+ description:+ - |+ Is it a calculator with a strange antenna? A strange loop with+ a built-in calculator? Who can say? A `hyperloop`{=entity}+ gives you the ability to create recursive types: the type+ `rec t. T(t)`{=snippet} (where `T(t)`{=snippet} is some type+ containing `t`{=type}) is the type `t`{=type} such that+ `t = T(t)`{=snippet}. For exmple, `rec l. Unit + Int * l`{=type} is+ the type of lists of integers.+ properties: [pickable]+ capabilities: [arith, sum, prod, rectype]+- name: compass+ display:+ attr: device+ char: 'N'+ description:+ - |+ A compass gives a robot the ability to orient using the cardinal+ directions north, south, west, and east. For example:+ - |+ `turn west; move; turn north`+ - |+ It also enables the `heading : Cmd Dir` command, which returns the+ robot's current heading. For example, the following code moves+ east and then restores the same heading as before:+ - |+ `d <- heading; turn east; move; turn d`+ properties: [pickable]+ capabilities: [orient]+- name: clock+ display:+ attr: device+ char: '0'+ description:+ - A clock is a device for keeping track of time. It enables the `wait` and `time` commands.+ - |+ `time : Cmd Int` returns the current time, measured in game ticks since the beginning of the game.+ - |+ `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks).+ properties: [pickable]+ capabilities: [timeabs, timerel]+- name: hourglass+ display:+ attr: device+ char: '8'+ description:+ - An hourglass can measure the relative passage of time. It enables the `wait` command.+ - |+ `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks).+ properties: [pickable]+ capabilities: [timerel]+- name: rolex+ display:+ char: R+ attr: silver+ description:+ - Enables robots to use the `watch` and `wait` commands.+ - |+ `watch : Dir -> Cmd Unit` will mark an adjacent (in the specified direction) location of interest to monitor for placement or removal of items.+ A subsequent call to `wait` will be interrupted upon a change to the location.+ properties: [pickable]+ capabilities: [timerel, wakeself]+- name: comparator+ display:+ attr: device+ char: '>'+ description:+ - "A comparator allows comparing two values to see whether the first is less, equal, or greater than the second."+ - "Valid comparison operators are <, <=, >, >=, ==, and !=."+ properties: [pickable]+ capabilities: [compare]+- name: I/O cable+ display:+ attr: device+ char: 'Ю'+ description:+ - An I/O cable can be used to communicate with adjacent actors.+ properties: [pickable]+- name: rubber band+ display:+ attr: device+ char: 'O'+ description:+ - "A rubber band can tie multiple commands together so that other robots can't execute commands in between them. It can be used via the `atomic` command. For example, suppose robot A executes the following code:"+ - |+ ```+ b <- ishere "rock"; if b {grab; return ()} {}+ ```+ - "This seems like a safe way to execute `grab` only when there is a rock to grab. However, it is actually possible for the `grab` to fail, if some other robot B snatches the rock right after robot A sensed it and before robot A got around to grabbing it on the next game tick."+ - "This will make robot A very sad and it will crash."+ - "To prevent this situation, robot A can wrap the commands in `atomic`, like so:"+ - |+ ```+ atomic (b <- ishere "rock"; if b {grab; return ()} {})+ ```+ properties: [pickable]+ capabilities: [atomic]+- name: net+ display:+ attr: silver+ char: '#'+ description:+ - A net is a device woven out of many strings. With a net equipped, you can use the `try` command to catch errors. For example+ - |+ ```+ try {move} {turn left}+ ```+ - will attempt to move, but if that fails, turn left instead.+ properties: [pickable]+ capabilities: [try]+- name: antenna+ display:+ attr: silver+ char: 'Y'+ description:+ - A device for transforming electric current into radio waves, and vice versa. Antennas can be used to increase the viable range over which you can communicate with your robots.+ - |+ Antennas can also be used to locate nearby actors, by bouncing radio+ waves off them and listening for the echo. This capability can be+ accessed via two commands:+ - |+ `meet : Cmd (Unit + Actor)` tries to locate a+ nearby actor (a robot, or... something else?) up to one cell away.+ It returns a reference to the nearest actor, or a unit value if+ none are found.+ - |+ `meetAll : Cmd (rec l. Unit + Actor * l)` returns a list of+ all the nearby actors other than oneself.+ properties: [pickable]+ capabilities: [meet]+- name: GPS receiver+ display:+ attr: device+ char: 'G'+ description:+ - |+ A GPS receiver triangulates your current (x,y) coordinates from+ some convenient satellite signals,+ enabling the command `whereami : Cmd (Int * Int)`.+ properties: [pickable]+ capabilities: [senseloc]+- name: tweezers+ display:+ attr: device+ char: 'V'+ description:+ - |+ Sometimes small, self-reproducing creatures get stuck inside a robot's+ relays, preventing it from executing properly. Tweezers are+ useful for removing such pests, and for inspecting robots' detailed+ inner workings.+ properties: [pickable]+ capabilities: [debug]+- name: victrola+ display:+ attr: device+ char: 'Q'+ description:+ - |+ A device for reading and writing data on circular platters made of+ a soft plastic material. The stylus must be made of a+ hard and durable material, with a special tip that relies on+ quantum effects to extract high-density information.+ - |+ Also allows manipulating composite values consisting of a+ collection of named fields. For example, `[x = 2, y = "hi"]`+ is a value of type `[x : Int, y : Text]`{=type}. Individual fields+ can be projected using dot notation. For example,+ `let r = [y="hi", x=2] in r.x` has the value `2`. The order+ of the fields does not matter.+ properties: [pickable]+ capabilities: [record]+- name: quantum dot+ display:+ attr: gold+ char: '.'+ description:+ - |+ A nanoscale semiconductor particle with a wide range of+ applications.+ properties: [pickable]+- name: 'key'+ display:+ attr: gold+ char: 'k'+ description:+ - A versatile item, with uses such as opening locked doors, entering input, and retrieving stored values.+ properties: [pickable]+- name: keyboard+ display:+ attr: device+ char: 'K'+ description:+ - A small device with multiple keys, adapted for your unique anatomy.+ - |+ `installKeyHandler : Text -> (Key -> Cmd Unit) -> Cmd Unit`+ installs a custom handler function that can be activated to+ respond to keyboard inputs typed at the REPL.+ - |+ `key : Text -> Key` constructs values of type `Key`{=type}, for+ example `key "Down"` or `key "C-S-x"`.+ properties: [pickable]+ capabilities: [handleinput]+- name: halting oracle+ display:+ attr: device+ char: '?'+ description:+ - A device to solve the halting problem. When asked if a particular robot program will halt, it always answers YES. And it is always correct... or else!+ - |+ Enables the command `halt : Actor -> Cmd Unit` which takes+ a robot as an argument and, if it is up to one cell away,+ cancels its currently running program (if any). In creative mode,+ there is no distance limitation.+ properties: [pickable]+ capabilities: [halt]+- name: atomic vector plotter+ display:+ attr: device+ char: 'A'+ description:+ - A plot device for plotting interstellar and intermolecular atomic vector gradients.+ properties: [pickable]+- name: infinite improbability drive+ display:+ attr: device+ char: 'I'+ description:+ - |+ Enables the `teleport` command, which takes as arguments an+ `Actor`{=type} and a location in the form of a pair of+ coordinates, and teleports the given actor to the specified+ coordinates (and may also have some improbable side effects).+ properties: [pickable]+ capabilities: [teleport]
@@ -3,847 +3,799 @@ ######################################### - in:- - [1, tree]+ - [1, tree] out:- - [2, branch]- - [1, log]-+ - [2, branch]+ - [1, log] - in:- - [1, log]+ - [1, log] out:- - [4, board]-+ - [4, board] - in:- - [1, log]- - [8, water]+ - [1, log]+ - [8, water] out:- - [8, paper]-+ - [8, paper] - in:- - [32, paper]- - [1, flash memory]+ - [32, paper]+ - [1, flash memory] out:- - [1, dictionary]-+ - [1, dictionary] - in:- - [256, paper]- - [1, LaTeX]+ - [256, paper]+ - [1, LaTeX] required:- - [1, big furnace]+ - [1, big furnace] out:- - [1, PhD thesis]+ - [1, PhD thesis] time: 65536- - in:- - [1, log]+ - [1, log] out:- - [1, logger]-+ - [1, logger] - in:- - [1, board]- - [2, branch]+ - [1, board]+ - [2, branch] out:- - [1, workbench]-+ - [1, workbench] - in:- - [2, branch]+ - [2, branch] out:- - [1, branch predictor]-+ - [1, branch predictor] - in:- - [6, board]+ - [6, board] out:- - [1, box]-+ - [1, box] - in:- - [5, board]+ - [5, board] out:- - [1, boat]-+ - [1, boat] - in:- - [2, board]+ - [2, board] out:- - [1, wooden gear]-+ - [1, wooden gear] - in:- - [1, board]- - [2, wooden gear]+ - [1, board]+ - [2, wooden gear] out:- - [1, teeter-totter]-+ - [1, teeter-totter] - in:- - [1, teeter-totter]- - [2, copper wire]+ - [1, teeter-totter]+ - [2, copper wire] out:- - [1, comparator]-+ - [1, comparator] - in:- - [2, board]- - [2, wooden gear]- - [1, box]+ - [2, board]+ - [2, wooden gear]+ - [1, box] out:- - [1, harvester]-+ - [1, harvester] - in:- - [1, circuit]- - [1, board]- - [8, wooden gear]+ - [1, circuit]+ - [1, board]+ - [8, wooden gear] out:- - [1, typewriter]-+ - [1, typewriter] ######################################### ## BITS ## #########################################- - in:- - [1, bit (0)]- - [1, bit (1)]+ - [1, bit (0)]+ - [1, bit (1)] out:- - [1, drill bit]-+ - [1, drill bit] - in:- - [1, bit (0)]+ - [1, bit (0)] out:- - [1, bit (1)]+ - [1, bit (1)] required:- - [1, lodestone]-+ - [1, lodestone] - in:- - [1, bit (1)]+ - [1, bit (1)] out:- - [1, bit (0)]+ - [1, bit (0)] required:- - [1, lodestone]-+ - [1, lodestone] - in:- - [8, bit (0)]- - [8, bit (1)]+ - [8, bit (0)]+ - [8, bit (1)] out:- - [1, flash memory]-+ - [1, flash memory] - in:- - [1, flash memory]- - [8, wooden gear]+ - [1, flash memory]+ - [8, wooden gear] out:- - [1, counter]-+ - [1, counter] ######################################### ## STONE ## #########################################- - in:- - [1, boulder]+ - [1, boulder] out:- - [3, rock]+ - [3, rock] required:- - [1, drill]+ - [1, drill] time: 9 weight: 3- - in:- - [1, boulder]+ - [1, boulder] out:- - [4, rock]+ - [4, rock] required:- - [1, drill]+ - [1, drill] time: 9 weight: 1- - in:- - [1, boulder]+ - [1, boulder] out:- - [3, rock]+ - [3, rock] required:- - [1, metal drill]+ - [1, metal drill] time: 3 weight: 3- - in:- - [1, boulder]+ - [1, boulder] out:- - [4, rock]+ - [4, rock] required:- - [1, metal drill]+ - [1, metal drill] time: 3 weight: 3- - in:- - [1, rock]+ - [1, rock] out:- - [4, sand]+ - [4, sand] required:- - [1, drill]+ - [1, drill] time: 9- - in:- - [1, rock]+ - [1, rock] out:- - [4, sand]+ - [4, sand] required:- - [1, metal drill]+ - [1, metal drill] time: 3- - in:- - [1, mountain]+ - [1, mountain] out:- - [8, rock]- - [1, mountain tunnel]+ - [8, rock]+ - [1, mountain tunnel] required:- - [1, drill]+ - [1, drill] time: 90 weight: 16- - in:- - [1, mountain]+ - [1, mountain] out:- - [8, lodestone]- - [4, iron ore]- - [1, mountain tunnel]+ - [8, lodestone]+ - [4, iron ore]+ - [1, mountain tunnel] required:- - [1, drill]+ - [1, drill] time: 90 weight: 1- - in:- - [1, mountain]+ - [1, mountain] out:- - [16, rock]- - [1, mountain tunnel]+ - [16, rock]+ - [1, mountain tunnel] required:- - [1, metal drill]+ - [1, metal drill] time: 9- weight: 160-+ weight: 34 - in:- - [1, mountain]+ - [1, mountain] out:- - [16, lodestone]- - [8, iron ore]- - [1, mountain tunnel]+ - [16, lodestone]+ - [8, iron ore]+ - [1, mountain tunnel] required:- - [1, metal drill]+ - [1, metal drill] time: 9- weight: 10-+ weight: 2 - in:- - [5, rock]+ - [5, rock] out:- - [1, furnace]-+ - [1, furnace] - in:- - [10, rock]- - [10, solar panel]+ - [100, rock]+ - [10, solar panel] out:- - [1, big furnace]-+ - [1, big furnace] ######################################### ## METAL ## #########################################- ## VEINS- - in:- - [1, mountain]+ - [1, mountain] out:- - [1, copper mine]- - [1, copper ore]+ - [1, copper mine]+ - [1, copper ore] required:- - [1, drill]+ - [1, drill] time: 42 weight: 2- - in:- - [1, mountain]+ - [1, mountain] out:- - [1, iron mine]- - [1, iron ore]+ - [1, iron mine]+ - [1, iron ore] required:- - [1, drill]+ - [1, drill] time: 64 weight: 2- - in:- - [1, mountain]+ - [1, mountain] out:- - [1, quartz mine]- - [1, quartz]+ - [1, quartz mine]+ - [1, quartz] required:- - [1, drill]+ - [1, drill] time: 64 weight: 1- - in:- - [1, mountain]+ - [1, mountain] out:- - [1, copper mine]- - [1, copper ore]+ - [1, copper mine]+ - [1, copper ore] required:- - [1, metal drill]+ - [1, metal drill] time: 6- weight: 10-+ weight: 5 - in:- - [1, mountain]+ - [1, mountain] out:- - [1, iron mine]- - [1, iron ore]+ - [1, iron mine]+ - [1, iron ore] required:- - [1, metal drill]+ - [1, metal drill] time: 7- weight: 10-+ weight: 5 - in:- - [1, mountain]+ - [1, mountain] out:- - [1, quartz mine]- - [1, quartz]+ - [1, quartz mine]+ - [1, quartz] required:- - [1, metal drill]+ - [1, metal drill] time: 7- weight: 10-+ weight: 3 ## MINES- - in:- - [1, copper mine]+ - [1, copper mine] out:- - [1, copper ore]- - [1, copper mine]+ - [1, copper ore]+ - [1, copper mine] required:- - [1, drill]+ - [1, drill] time: 42 weight: 9- - in:- - [1, copper mine]+ - [1, copper mine] out:- - [2, rock]- - [1, copper mine]+ - [2, rock]+ - [1, copper mine] required:- - [1, drill]+ - [1, drill] time: 42- - in:- - [1, iron mine]+ - [1, iron mine] out:- - [1, iron ore]- - [1, iron mine]+ - [1, iron ore]+ - [1, iron mine] required:- - [1, drill]+ - [1, drill] time: 64 weight: 9- - in:- - [1, iron mine]+ - [1, iron mine] out:- - [2, rock]- - [1, iron mine]+ - [2, rock]+ - [1, iron mine] required:- - [1, drill]+ - [1, drill] time: 64- - in:- - [1, quartz mine]+ - [1, quartz mine] out:- - [1, quartz]- - [1, quartz mine]+ - [1, quartz]+ - [1, quartz mine] required:- - [1, drill]+ - [1, drill] time: 64 weight: 9- - in:- - [1, quartz mine]+ - [1, quartz mine] out:- - [2, rock]- - [1, quartz mine]+ - [2, rock]+ - [1, quartz mine] required:- - [1, drill]+ - [1, drill] time: 64- - in:- - [1, copper mine]+ - [1, copper mine] out:- - [1, copper ore]- - [1, copper mine]+ - [1, copper ore]+ - [1, copper mine] required:- - [1, metal drill]+ - [1, metal drill] time: 6- - in:- - [1, iron mine]+ - [1, iron mine] out:- - [1, iron ore]- - [1, iron mine]+ - [1, iron ore]+ - [1, iron mine] required:- - [1, metal drill]+ - [1, metal drill] time: 7- - in:- - [1, quartz mine]+ - [1, quartz mine] out:- - [1, quartz]- - [1, quartz mine]+ - [1, quartz]+ - [1, quartz mine] required:- - [1, metal drill]+ - [1, metal drill] time: 7- ## SMELTING- - in:- - [1, copper ore]- - [1, log]+ - [1, copper ore]+ - [1, log] out:- - [10, copper wire]+ - [10, copper wire] required:- - [1, furnace]-+ - [1, furnace] - in:- - [1, copper ore]- - [1, log]+ - [1, copper ore]+ - [1, log] out:- - [2, copper pipe]+ - [2, copper pipe] required:- - [1, furnace]-+ - [1, furnace] - in:- - [1, iron ore]- - [2, log]+ - [1, iron ore]+ - [2, log] out:- - [2, iron plate]+ - [2, iron plate] required:- - [1, furnace]-+ - [1, furnace] - in:- - [1, copper ore]+ - [1, copper ore] out:- - [10, copper wire]+ - [10, copper wire] required:- - [1, big furnace]-+ - [1, big furnace] - in:- - [1, copper ore]+ - [1, copper ore] out:- - [2, copper pipe]+ - [2, copper pipe] required:- - [1, big furnace]-+ - [1, big furnace] - in:- - [1, iron ore]+ - [1, iron ore] out:- - [2, iron plate]+ - [2, iron plate] required:- - [1, big furnace]-+ - [1, big furnace] - in:- - [1, iron plate]+ - [2, iron plate] out:- - [1, lodestone]+ - [1, dozer blade]+- in:+ - [1, iron plate]+ out:+ - [1, lodestone] required:- - [2, lodestone]+ - [2, lodestone] time: 64- ## TOOLS- - in:- - [1, iron plate]+ - [1, iron plate] out:- - [2, iron gear]-+ - [2, iron gear] - in:- - [1, iron plate]- - [1, water]- - [1, box]+ - [1, iron plate]+ - [1, water]+ - [1, box] out:- - [1, compass]+ - [1, compass] required:- - [1, lodestone]-+ - [1, lodestone] - in:- - [32, wooden gear]- - [6, copper wire]+ - [32, wooden gear]+ - [6, copper wire] out:- - [1, small motor]-+ - [1, small motor] - in:- - [16, iron gear]- - [6, copper wire]+ - [16, iron gear]+ - [6, copper wire] out:- - [1, big motor]-+ - [1, big motor] - in:- - [1, box]- - [1, drill bit]- - [1, small motor]+ - [1, box]+ - [1, drill bit]+ - [1, small motor] out:- - [1, drill]-+ - [1, drill] - in:- - [1, box]- - [3, drill bit]- - [1, big motor]+ - [1, box]+ - [3, drill bit]+ - [1, big motor] out:- - [1, metal drill]-+ - [1, metal drill] - in:- - [1, box]- - [2, board]- - [4, copper pipe]- - [2, iron plate]- - [2, rubber]+ - [1, box]+ - [2, board]+ - [4, copper pipe]+ - [2, iron plate]+ - [2, rubber] out:- - [1, toolkit]-+ - [1, toolkit] - in:- - [2, small motor]- - [8, iron plate]- - [2, rubber]+ - [2, small motor]+ - [8, iron plate]+ - [2, rubber] out:- - [1, treads]-+ - [1, treads] - in:- - [4, big motor]- - [64, iron plate]- - [16, rubber]+ - [4, big motor]+ - [64, iron plate]+ - [16, rubber] required:- - [1, welder]+ - [1, welder] out:- - [1, tank treads]-+ - [1, tank treads] - in:- - [2, copper pipe]- - [2, iron gear]- - [1, iron plate]- - [1, water]- - [1, small motor]+ - [2, copper pipe]+ - [2, iron gear]+ - [1, iron plate]+ - [1, water]+ - [1, small motor] out:- - [1, grabber]-+ - [1, grabber] - in:- - [2, grabber]- - [1, rubber band]+ - [2, grabber]+ - [1, rubber band] out:- - [1, fast grabber]-+ - [1, fast grabber] - in:- - [2, copper wire]- - [1, copper pipe]- - [1, iron plate]- - [1, I/O cable]+ - [2, copper wire]+ - [1, copper pipe]+ - [1, iron plate]+ - [1, I/O cable] out:- - [1, welder]-+ - [1, welder] - in:- - [1, copper pipe]+ - [1, copper pipe] out:- - [1, handle]+ - [1, handle] required:- - [1, welder]-+ - [1, welder] - in:- - [4, circuit]- - [1, iron plate]- - [3, copper pipe]- - [16, iron gear]+ - [4, circuit]+ - [1, iron plate]+ - [3, copper pipe]+ - [16, iron gear] out:- - [1, 3D printer]-+ - [1, 3D printer] - in:- - [1, gold]+ - [1, gold] out:- - [8, gold coin]+ - [8, gold coin] required:- - [1, furnace]-+ - [1, furnace] - in:- - [1, gold]+ - [1, gold] out:- - [8, gold coin]+ - [8, gold coin] required:- - [1, big furnace]-+ - [1, big furnace] - in:- - [1, gold coin]- - [1, bit (1)]- - [1, bit (0)]+ - [1, gold coin]+ - [1, bit (1)]+ - [1, bit (0)] required:- - [1, metal drill]+ - [1, metal drill] out:- - [1, bitcoin]-+ - [1, bitcoin] - in:- - [2, silver]- - [2, copper wire]+ - [2, silver]+ - [2, copper wire] out:- - [1, antenna]-+ - [1, antenna] - in:- - [1, antenna]- - [1, clock]- - [1, circuit]- - [1, compass]+ - [1, antenna]+ - [1, clock]+ - [1, circuit]+ - [1, compass] out:- - [1, GPS receiver]-+ - [1, GPS receiver] - in:- - [1, iron plate]+ - [1, iron plate] out:- - [1, tweezers]-+ - [1, tweezers] ## MAGIC- - in:- - [2, copper wire]+ - [2, copper wire] out:- - [1, strange loop]-+ - [1, strange loop] - in:- - [2, copper pipe]- - [4, copper wire]- - [1, paper]- - [1, lodestone]+ - [2, copper pipe]+ - [4, copper wire]+ - [1, paper]+ - [1, lodestone] out:- - [2, hearing aid]--+ - [2, hearing aid] ######################################### ## QUARTZ + SILICON ## #########################################- - in:- - [4, quartz]+ - [4, quartz] out:- - [1, silicon]+ - [1, silicon] required:- - [1, big furnace]-+ - [1, big furnace] - in:- - [1, quartz]- - [32, iron gear]- - [1, glass]+ - [1, quartz]+ - [32, iron gear]+ - [1, glass] out:- - [1, clock]-+ - [1, clock] - in:- - [4, silicon]- - [1, strange loop]- - [16, copper wire]- - [8, bit (0)]- - [8, bit (1)]+ - [1, clock]+ - [1, scanner] out:- - [1, circuit]-+ - [1, rolex]+- in:+ - [4, silicon]+ - [1, strange loop]+ - [16, copper wire]+ - [8, bit (0)]+ - [8, bit (1)]+ out:+ - [1, circuit] ######################################### ## DEEP MINES ## #########################################- - in:- - [1, mountain]+ - [1, mountain] out:- - [1, deep mine]+ - [1, deep mine] required:- - [1, metal drill]+ - [1, metal drill] time: 512 weight: 1- - in:- - [1, deep mine]+ - [1, deep mine] out:- - [1, copper ore]- - [1, deep mine]+ - [1, copper ore]+ - [1, deep mine] required:- - [1, metal drill]+ - [1, metal drill] time: 64 weight: 1000- - in:- - [1, deep mine]+ - [1, deep mine] out:- - [1, iron ore]- - [1, deep mine]+ - [1, iron ore]+ - [1, deep mine] required:- - [1, metal drill]+ - [1, metal drill] time: 64 weight: 500- - in:- - [1, deep mine]+ - [1, deep mine] out:- - [1, silver]- - [1, deep mine]+ - [1, silver]+ - [1, deep mine] required:- - [1, metal drill]+ - [1, metal drill] time: 64 weight: 50- - in:- - [1, deep mine]+ - [1, deep mine] out:- - [1, gold]- - [1, deep mine]+ - [1, gold]+ - [1, deep mine] required:- - [1, metal drill]+ - [1, metal drill] time: 64 weight: 20- - in:- - [1, deep mine]+ - [1, deep mine] out:- - [1, mithril]- - [1, deep mine]+ - [1, mithril]+ - [1, deep mine] required:- - [1, metal drill]+ - [1, metal drill] time: 64 weight: 1- ######################################### ## PIXELS ## #########################################- - in:- - [1, glass]- - [10, pixel (R)]- - [10, pixel (G)]- - [10, pixel (B)]+ - [1, glass]+ - [10, pixel (R)]+ - [10, pixel (G)]+ - [10, pixel (B)] out:- - [1, camera]-+ - [1, camera] - in:- - [1, camera]- - [1, circuit]+ - [1, camera]+ - [1, circuit] out:- - [1, scanner]-+ - [1, scanner] ######################################### ## SAND ## #########################################- - in:- - [1, sand]+ - [1, sand] out:- - [1, glass]+ - [1, glass] required:- - [1, furnace]-+ - [1, furnace] - in:- - [1, glass]- - [8, copper wire]+ - [1, water]+ - [1, copper pipe]+ - [1, glass] out:- - [1, solar panel]+ - [1, olfactometer]+- in:+ - [1, sand]+ out:+ - [1, glass] required:- - [1, 3D printer]-+ - [1, big furnace] - in:- - [1, counter]- - [1, solar panel]+ - [2, board]+ - [1, glass]+ - [1, sand] out:- - [1, calculator]-+ - [1, hourglass] - in:- - [1, calculator]- - [1, typewriter]- - [1, I/O cable]+ - [1, glass]+ - [1, mithril] out:- - [1, ADT calculator]-+ - [1, lens]+ required:+ - [1, drill] - in:- - [1, glass]- - [1, silver]+ - [1, glass]+ - [8, copper wire] out:- - [1, mirror]-+ - [1, solar panel]+ required:+ - [1, 3D printer]+- in:+ - [1, counter]+ - [1, solar panel]+ out:+ - [1, calculator]+- in:+ - [1, calculator]+ - [1, typewriter]+ - [1, I/O cable]+ out:+ - [1, ADT calculator]+- in:+ - [1, ADT calculator]+ - [1, strange loop]+ out:+ - [1, hyperloop]+- in:+ - [1, glass]+ - [1, silver]+ out:+ - [1, mirror] ######################################### ## LAMBDA ## #########################################- - in:- - [5, lambda]- - [1, water]+ - [5, lambda]+ - [1, water] out:- - [1, curry]-+ - [1, curry] ######################################### ## LATEX ## #########################################- - in:- - [1, LaTeX]- - [1, log]+ - [1, LaTeX]+ - [1, log] out:- - [1, rubber]+ - [1, rubber] required:- - [1, furnace]-+ - [1, furnace] - in:- - [8, copper wire]- - [1, rubber]+ - [1, LaTeX] out:- - [1, I/O cable]-+ - [1, rubber]+ required:+ - [1, big furnace] - in:- - [1, rubber]- - [1, strange loop]+ - [8, copper wire]+ - [1, rubber] out:- - [1, rubber band]-+ - [1, I/O cable] - in:- - [1, rubber]- - [1, glass]- - [1, string]+ - [1, rubber]+ - [1, strange loop] out:- - [1, beaglepuss]-+ - [1, rubber band]+- in:+ - [1, rubber]+ - [1, glass]+ - [1, string]+ out:+ - [1, beaglepuss] ######################################### ## COTTON ## #########################################- - in:- - [4, cotton]+ - [4, cotton] out:- - [1, string]+ - [1, string] required:- - [1, small motor]-+ - [1, small motor] - in:- - [256, string]+ - [256, string] out:- - [1, net]-+ - [1, net] ######################################### ## MISC ## #########################################- - in:- - [1, water]- - [1, silicon]+ - [1, lens]+ - [1, string]+ - [10, curry]+ out:+ - [1, detonator]+- in:+ - [1, water]+ - [1, silicon] required:- - [50, solar panel]+ - [50, solar panel] out:- - [1, quantum dot]-+ - [1, quantum dot] - in:- - [1, small motor]- - [1, copper pipe]- - [1, mithril]- - [1, quantum dot]- - [1, iron plate]+ - [1, small motor]+ - [1, copper pipe]+ - [1, mithril]+ - [1, quantum dot]+ - [1, iron plate] out:- - [1, victrola]-+ - [1, victrola] - in:- - [1, iron plate]+ - [1, iron plate] out:- - [4, key]-+ - [4, key] - in:- - [1, board]- - [16, key]+ - [1, board]+ - [16, key] out:- - [1, keyboard]-+ - [1, keyboard] - in:- - [1, branch predictor]- - [1, grabber]- - [1, toolkit]+ - [1, branch predictor]+ - [1, grabber]+ - [1, toolkit] out:- - [1, halting oracle]+ - [1, halting oracle]+- in:+ - [1, tea leaves]+ - [1, water]+ required:+ - [1, furnace]+ out:+ - [1, cup of tea]+- in:+ - [1, rubber band]+ - [1, typewriter]+ - [1, compass]+ - [1, counter]+ out:+ - [1, atomic vector plotter]+- in:+ - [1, cup of tea]+ - [5, bitcoin]+ - [3, PhD thesis]+ - [1, atomic vector plotter]+ out:+ - [1, infinite improbability drive]
@@ -8,3 +8,4 @@ Testing Vignettes Mechanics+World Examples
@@ -13,9 +13,12 @@ lights-out.yaml bucket-brigade.yaml wave.yaml+gallery.yaml wolf-goat-cabbage.yaml blender.yaml friend.yaml+pack-tetrominoes.yaml+dimsum.yaml Mazes Ranching Sokoban
@@ -4,19 +4,14 @@ description: Make 2048! objectives: - goal:- - OK, OK, it's not really the same as the classic "2048" game.- However, your goal is still to make 2048! You start with a `1`{=entity}- which regrows immediately when- it is `harvest`ed, so if you plant it, you can get as many as you want. Your- job is to combine `1`{=entity}s in order to make a `2048`{=entity}- entity.- - "Hint: the `format` command can turn numbers into strings!"+ - OK, OK, it's not really the same as the classic "2048" game. However, your goal is still to make 2048! You start with a `1`{=entity} which regrows immediately when it is `harvest`ed, so if you plant it, you can get as many as you want. Your job is to combine `1`{=entity}s in order to make a `2048`{=entity} entity.+ - "Hint: the `format` command can turn numbers into strings!" condition: | try { as base {has "2048"} } { return false } solution: |- def makeN : int -> cmd unit = \n.+ def makeN : Int -> Cmd Unit = \n. if (n == 1) {harvest; return ()} {makeN (n/2); makeN (n/2); make (format n)}@@ -29,135 +24,133 @@ attr: gold char: "#" description:- - This is a one. Maybe you can combine it with other ones- somehow.- properties: [growable, portable, infinite]+ - This is a one. Maybe you can combine it with other ones somehow.+ properties: [growable, pickable, infinite] - name: "2" display: attr: gold char: "#" description:- - This is a two. Maybe you can combine it with other twos- somehow.- properties: [portable]+ - This is a two. Maybe you can combine it with other twos somehow.+ properties: [pickable] - name: "4" display: attr: gold char: "#" description:- - This is a four. You get the idea.- properties: [portable]+ - This is a four. You get the idea.+ properties: [pickable] - name: "8" display: attr: gold char: "#" description:- - An eight.- properties: [portable]+ - An eight.+ properties: [pickable] - name: "16" display: attr: gold char: "#" description:- - A 16.- properties: [portable]+ - A 16.+ properties: [pickable] - name: "32" display: attr: gold char: "#" description:- - A 32.- properties: [portable]+ - A 32.+ properties: [pickable] - name: "64" display: attr: gold char: "#" description:- - A 64.- properties: [portable]+ - A 64.+ properties: [pickable] - name: "128" display: attr: gold char: "#" description:- - A 128.- properties: [portable]+ - A 128.+ properties: [pickable] - name: "256" display: attr: gold char: "#" description:- - A 256.- properties: [portable]+ - A 256.+ properties: [pickable] - name: "512" display: attr: gold char: "#" description:- - A 512.- properties: [portable]+ - A 512.+ properties: [pickable] - name: "1024" display: attr: gold char: "#" description:- - A 1024.- properties: [portable]+ - A 1024.+ properties: [pickable] - name: "2048" display: attr: gold char: "#" description:- - A 2048.- properties: [portable]+ - A 2048.+ properties: [pickable] recipes: - in:- - [2, "1"]+ - [2, "1"] out:- - [1, "2"]+ - [1, "2"] - in:- - [2, "2"]+ - [2, "2"] out:- - [1, "4"]+ - [1, "4"] - in:- - [2, "4"]+ - [2, "4"] out:- - [1, "8"]+ - [1, "8"] - in:- - [2, "8"]+ - [2, "8"] out:- - [1, "16"]+ - [1, "16"] - in:- - [2, "16"]+ - [2, "16"] out:- - [1, "32"]+ - [1, "32"] - in:- - [2, "32"]+ - [2, "32"] out:- - [1, "64"]+ - [1, "64"] - in:- - [2, "64"]+ - [2, "64"] out:- - [1, "128"]+ - [1, "128"] - in:- - [2, "128"]+ - [2, "128"] out:- - [1, "256"]+ - [1, "256"] - in:- - [2, "256"]+ - [2, "256"] out:- - [1, "512"]+ - [1, "512"] - in:- - [2, "512"]+ - [2, "512"] out:- - [1, "1024"]+ - [1, "1024"] - in:- - [2, "1024"]+ - [2, "1024"] out:- - [1, "2048"]+ - [1, "2048"] robots: - name: base- dir: [1,0]+ dir: east display: attr: robot char: "Ω"
@@ -3,14 +3,14 @@ author: Ondřej Šebek description: A maze shaped like a cave. It only goes down or forward. objectives:-- goal:- - You are at the top of a cave that gradually descends until reaching a dead end.- - At its bottom is a great treasure.- - Luckily, the cave does not branch out, so it is easy to find the path to the treasure.- - Send a robot to the the item marked as '**!**'. You win once the robot `grab`s it.- condition: |- j <- robotNamed "judge";- as j {has "goal"}+ - goal:+ - You are at the top of a cave that gradually descends until reaching a dead end.+ - At its bottom is a great treasure.+ - Luckily, the cave does not branch out, so it is easy to find the path to the treasure.+ - Send a robot to the the item marked as '**!**'. You win once the robot `grab`s it.+ condition: |+ j <- robotNamed "judge";+ as j {has "goal"} solution: | def until = \p. \c. b <- p; if b {} {c; until p c} end; def fwd = until blocked move end;@@ -21,7 +21,7 @@ } robots: - name: base- dir: [0,1]+ dir: north display: char: 'Ω' attr: robot@@ -42,7 +42,7 @@ - [50, grabber] - [0, goal] - name: judge- dir: [0,0]+ dir: [0, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end;@@ -55,15 +55,15 @@ char: █ attr: rock description:- - An impassable stone wall.+ - An impassable stone wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description:- - The place you're trying to reach! You win by executing `grab` on this item.- properties: [known, portable]+ - The place you're trying to reach! You win by executing `grab` on this item.+ properties: [known, pickable] world: dsl: | {ice}@@ -73,7 +73,7 @@ '~': [stone, water] '█': [stone, wall] '!': [stone, goal, judge]- upperleft: [0,0]+ upperleft: [0, 0] map: | ██████████████████████████████ █Ω ████████ █████████████████
@@ -3,15 +3,14 @@ author: Ondřej Šebek description: A maze shaped like a spiral, with a twist! objectives:-- goal:- - You find yourself in the middle of a large maze.- - It's straightforward to get out, but the path is long and dull.- - You need to send a robot to the goal square, labelled with an exclamation mark;- you win by `grab`bing the `goal`{=entity}.- - Beware! The winding corridors are wider then they look!- condition: |- j <- robotNamed "judge";- as j {has "goal"}+ - goal:+ - You find yourself in the middle of a large maze.+ - It's straightforward to get out, but the path is long and dull.+ - You need to send a robot to the goal square, labelled with an exclamation mark; you win by `grab`bing the `goal`{=entity}.+ - Beware! The winding corridors are wider then they look!+ condition: |+ j <- robotNamed "judge";+ as j {has "goal"} solution: | def until = \p. \c. b <- p; if b {} {c; until p c} end; def fwd = until blocked move end;@@ -22,7 +21,7 @@ } robots: - name: base- dir: [0,1]+ dir: north display: char: 'Ω' attr: robot@@ -43,7 +42,7 @@ - [50, grabber] - [0, goal] - name: judge- dir: [0,0]+ dir: [0, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end;@@ -55,15 +54,15 @@ char: █ attr: rock description:- - An impassable stone wall.+ - An impassable stone wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description:- - The place you're trying to reach! You win by executing `grab` on this item.- properties: [known, portable]+ - The place you're trying to reach! You win by executing `grab` on this item.+ properties: [known, pickable] world: dsl: | {ice}@@ -72,7 +71,7 @@ ' ': [stone, null] '█': [stone, wall] '!': [stone, goal, judge]- upperleft: [0,0]+ upperleft: [0, 0] map: | ████████████████████████████████████ ██ ██
@@ -1,22 +1,17 @@ version: 1 name: Invisible maze author: Brent Yorgey-description: There is a maze, but it can't be seen, only sensed... can you- program a robot to navigate it successfully?+description: There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? objectives:-- goal:- - There is a maze, but it can't be seen, only sensed... can you- program a robot to navigate it successfully? You need to get a robot- to the goal square, labelled with an exclamation mark; you win by `grab`bing- the `goal`{=entity}.- - In this challenge, it is guaranteed that the maze is a tree, that is,- there are no loops within the maze.- condition: |- try {- teleport self (27, -17);- b <- ishere "goal";- return (not b)- } { return false }+ - goal:+ - There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? You need to get a robot to the goal square, labelled with an exclamation mark; you win by `grab`bing the `goal`{=entity}.+ - In this challenge, it is guaranteed that the maze is a tree, that is, there are no loops within the maze.+ condition: |+ try {+ teleport self (27, -17);+ b <- ishere "goal";+ return (not b)+ } { return false } solution: | def tL = turn left end; def tR = turn right end;@@ -29,7 +24,7 @@ } robots: - name: base- dir: [0,1]+ dir: north display: char: 'Ω' attr: robot@@ -55,15 +50,15 @@ display: invisible: true description:- - An invisible wall.+ - An invisible wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description:- - The place you're trying to reach! You win by executing `grab` on this item.- properties: [known, portable]+ - The place you're trying to reach! You win by executing `grab` on this item.+ properties: [known, pickable] world: dsl: | {grass}@@ -73,7 +68,7 @@ 'x': [grass, wall] '@': [grass, boulder] '!': [grass, goal]- upperleft: [-1,1]+ upperleft: [-1, 1] map: | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @Ω........x...x..............@
@@ -1,27 +1,22 @@ version: 1 name: Invisible, loopy maze author: Brent Yorgey-description: There is a maze, but it can't be seen, only sensed... can you- program a robot to navigate it successfully?+description: There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? objectives:-- goal:- - There is a maze, but it can't be seen, only sensed... can you- program a robot to navigate it successfully? You need to get a robot- to the goal square, labelled with an exclamation mark; you win by `grab`bing- the `goal`{=entity}.- - In this challenge, you are NOT guaranteed that the maze is a tree, that is,- the maze may contain loops.- condition: |- try {- teleport self (27, -17);- b <- ishere "goal";- return (not b)- } { return false }+ - goal:+ - There is a maze, but it can't be seen, only sensed... can you program a robot to navigate it successfully? You need to get a robot to the goal square, labelled with an exclamation mark; you win by `grab`bing the `goal`{=entity}.+ - In this challenge, you are NOT guaranteed that the maze is a tree, that is, the maze may contain loops.+ condition: |+ try {+ teleport self (27, -17);+ b <- ishere "goal";+ return (not b)+ } { return false } solution: | run "scenarios/Challenges/Mazes/loopy_maze_sol.sw" robots: - name: base- dir: [0,1]+ dir: north display: char: 'Ω' attr: robot@@ -48,15 +43,15 @@ display: invisible: true description:- - An invisible wall.+ - An invisible wall. properties: [unwalkable, known] - name: goal display: char: '!' attr: device description:- - The place you're trying to reach! You win by executing `grab` on this item.- properties: [known, portable]+ - The place you're trying to reach! You win by executing `grab` on this item.+ properties: [known, pickable] world: dsl: | {grass}@@ -66,7 +61,7 @@ 'x': [grass, wall] '@': [grass, boulder] '!': [grass, goal]- upperleft: [-1,1]+ upperleft: [-1, 1] map: | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @.........x...x..............@
@@ -1,3 +1,5 @@+beekeeping.yaml capture.yaml powerset.yaml+fishing.yaml gated-paddock.yaml
@@ -0,0 +1,298 @@+// Spawns worker bees when structures are detected++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+def mod : Int -> Int -> Int = \a. \b. a - (a/b)*b end;+def abs = \n. if (n < 0) {-n} {n} end;+def min = \x. \y. if (x < y) {x} {y} end;++def elif = \t. \then. \else. {if t then else} end+def else = \t. t end++def sumTuples = \t1. \t2.+ (fst t1 + fst t2, snd t1 + snd t2);+ end;++def mapTuple = \f. \t.+ (f $ fst t, f $ snd t)+ end;++def negateTuple = \t.+ mapTuple (\x. -x) t;+ end;++def subtractTuple = \t1. \t2.+ sumTuples t1 $ negateTuple t2;+ end;++// Deprecated+def moveTuple = \tup.+ let x = fst tup in+ let y = snd tup in+ turn $ if (x > 0) {east} {west};+ doN (abs x) move;++ turn $ if (y > 0) {north} {south};+ doN (abs y) move;+ end;++def randomDir =+ r <- random 4;+ return $ if (r == 1) {north}+ $ elif (r == 2) {west}+ $ elif (r == 3) {south}+ $ else {east};+ end;++def moveHorizontal = \maxDirect. \dist.+ turn $ if (dist > 0) {east} {west};+ doN (min maxDirect $ abs dist) move;+ end;++def moveVertical = \maxDirect. \dist.+ turn $ if (dist > 0) {north} {south};+ doN (min maxDirect $ abs dist) move;+ end;++def randomStep =+ randDir <- randomDir;+ turn randDir;+ move;+ end;++def moveToward = \maxDirect. \goal.++ currLocOrig <- whereami;+ if (currLocOrig == goal) {} {++ // Include some random motion+ randomStep;++ currLoc <- whereami;+ let delta = subtractTuple goal currLoc in+ let x = fst delta in+ let y = snd delta in++ moveHorizontal maxDirect x;+ moveVertical maxDirect y;++ moveToward maxDirect goal;+ }+ end;++def watchForHoneycombRemoval = \dist.+ if (dist > 0) {+ move;+ honeycombHere <- ishere "honeycomb";+ if honeycombHere {+ watch down;+ } {};++ watchForHoneycombRemoval $ dist - 1;+ } {};+ end;++/**+Tries to find an open cell to deposit+the honeycomb. Gives up when distance+threshold exceeded.+*/+def depositHoneycomb = \dist.+ if (dist < 5) {+ emptyHere <- isempty;+ if emptyHere {+ place "honeycomb";+ } {+ move;+ depositHoneycomb $ dist + 1;+ };+ } {+ turn back;+ watchForHoneycombRemoval dist;++ // Hibernate+ wait 2000;++ // Alternative method to get rid of honeycomb+ make "buzz";+ };+ end;++def goToHive = \hiveLoc.+ let depositLoc = (fst hiveLoc - 1, snd hiveLoc) in+ moveToward 2 depositLoc;+ turn north;+ depositHoneycomb 0;+ end;++/**+Harvests an item when reached+*/+def takeStepTowardItem = \item.+ // NOTE: Max radius is hard-coded to 256+ // (see maxSniffRange in Syntax.hs)+ direction <- chirp item;+ if (direction == down) {+ // Need a try block in case+ // another bee gets here first+ try {+ harvest;+ return ();+ } {};+ } {+ // Include some random motion+ r <- random 4;+ if (r == 0) {+ randomStep;+ } {+ turn direction;+ move;+ };++ takeStepTowardItem item;+ }+ end;++/**+Searches through the existing instances of+a given structure template, starting at a supplied+index.+Either returns the (potentially new) index of the structure+(in the case that more had been built since the last check),+or unit. Re-using the newly found index amortizes the "search"+within the structure list over many ticks to constant time+rather than linear time.+*/+def findStructureNewIndex = \remainingCount. \structureLoc. \lastIdx.+ if (remainingCount > 0) {+ foundStructure <- structure "beehive" lastIdx;+ case foundStructure (\_. return $ inL ()) (\fs.+ if (structureLoc == snd fs) {+ return $ inR lastIdx;+ } {+ findStructureNewIndex (remainingCount - 1) structureLoc $ lastIdx + 1;+ }+ );+ } {+ return $ inL ();+ }+ end;++def workerProgram = \hiveIdx. \structureLoc.+ eitherFoundStructure <- structure "beehive" hiveIdx;+ case eitherFoundStructure return (\fs.+ let hasSameStructure = structureLoc == snd fs in+ if hasSameStructure {+ try {make "honeycomb";} {};+ hasHoneycomb <- has "honeycomb";+ if hasHoneycomb {+ goToHive structureLoc;+ } {+ takeStepTowardItem "wildflower";+ return ();+ };+ workerProgram hiveIdx structureLoc;+ } {+ eitherNewIdx <- findStructureNewIndex (fst fs) structureLoc hiveIdx;+ case eitherNewIdx+ (\_. selfdestruct)+ (\newIdx. workerProgram newIdx structureLoc);+ }+ );+ end;++def mkBeeName = \structureLoc.+ "bee" ++ format structureLoc;+ end;++def workerProgramInit = \beename. \hiveIdx. \structureLoc.+ setname beename;+ appear "B" (inl ());+ workerProgram hiveIdx structureLoc;+ end;++def createWorkerForStructure = \structureIdx. \fs.+ // Build worker bee, assign ID, location+ create "wax gland";+ create "proboscis";++ create "ADT calculator";+ create "beaglepuss";+ create "bitcoin";+ create "branch predictor";+ create "comparator";+ create "compass";+ create "detonator";+ create "dictionary";+ create "fast grabber";+ create "GPS receiver";+ create "harvester";+ create "hourglass";+ create "lambda";+ create "net";+ create "rolex";+ create "scanner";+ create "strange loop";+ create "solar panel";+ create "treads";+ create "workbench";++ teleport self $ snd fs;+ let beename = mkBeeName (snd fs) in+ build {+ require 1 "wax gland";+ workerProgramInit beename structureIdx $ snd fs;+ };+ return ();+ end;++def associateAllHives = \remainingCount. \idx.+ if (remainingCount > 0) {++ foundStructure <- structure "beehive" idx;+ case foundStructure return (\fs.+ let beename = mkBeeName (snd fs) in+ try {+ // Fails if the robot does not exist+ robotnamed beename;+ return ();+ } {+ createWorkerForStructure idx fs;++ // Give the child robot time to register its new+ // name so that we don't end up spawning multiple+ // bees for the same location+ wait 1;+ };++ associateAllHives (remainingCount - 1) (idx + 1);+ );+ } {}+ end;++/**+Each tick, iterates through all hives,+and makes sure a "bee" robot is associated with+their location.+If a structure exists without such an association,+creates a bee named after the location.+*/+def observeHives =++ // This invocation is just to get the total structure count.+ // We will invoke it again once per iteration of 'associateAllHives'.+ foundStructure <- structure "beehive" 0;+ case foundStructure return (\fs.+ associateAllHives (fst fs) 0;+ );++ // Wait at least 1 tick so that we do not spin infinitely until+ // we saturate our computation quota for the tick.+ wait 1;+ observeHives;+ end;++def go =+ instant $ observeHives;+ end;++go;
@@ -0,0 +1,362 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def intersperse = \n. \f2. \f1. if (n > 0) {+ f1;+ if (n > 1) {+ f2;+ } {};+ intersperse (n - 1) f2 f1;+ } {};+ end;++def abs = \n. if (n < 0) {-n} {n} end;++def sumTuples = \t1. \t2.+ (fst t1 + fst t2, snd t1 + snd t2);+ end;++def mapTuple = \f. \t.+ (f $ fst t, f $ snd t)+ end;++def negateTuple = \t.+ mapTuple (\x. -x) t;+ end;++def subtractTuple = \t1. \t2.+ sumTuples t1 $ negateTuple t2;+ end;++def moveTuple = \tup.+ let x = fst tup in+ let y = snd tup in+ turn $ if (x > 0) {east} {west};+ doN (abs x) move;++ turn $ if (y > 0) {north} {south};+ doN (abs y) move;+ end;++def nextRow = \d.+ intersperse 2 move $ turn d;+ end;++def harvestTrees =+ turn back;+ doN 14 move;+ turn left;++ intersperse 4 (nextRow left;) (+ intersperse 15 move harvest;+ nextRow right;+ intersperse 15 move harvest;+ );+ end;++def slatRow =+ let item = "honey frame" in+ intersperse 3 move $ place item;+ end;++def buildHive =+ // Make 16 boards+ doN 4 (make "log"; make "board");++ // Make 9 honey frames+ doN 3 $ make "log";+ doN 3 (make "board"; make "honey frame");++ doN 4 (intersperse 4 move (place "board"); turn right; move;);+ turn right;+ move;++ slatRow;+ nextRow left;+ slatRow;+ nextRow right;+ slatRow;+ end;++def moveToNextHive =+ doN 7 move;+ end;++/* Makes 8 staves */+def makeStaveBatch =+ // 1 per tree+ make "log";++ // 4 per log+ make "board";++ // 2 per board+ doN 4 $ make "stave";+ end;++def buildCasks = \caskCount.+ // 40 staves+ doN 5 makeStaveBatch;+ doN 4 $ make "steel hoop";+ doN caskCount $ make "cask";+ end;++/*+Moves forward until finding objective+item, stops when a gap is reached.+*/+def collectContiguous = \maxdist. \item. \hadFound. \dist.+ if (dist <= maxdist) {+ honeycombHere <- ishere item;+ if honeycombHere {+ grab;+ move;+ collectContiguous maxdist item true $ dist + 1;+ } {+ if hadFound {+ return dist;+ } {+ move;+ collectContiguous maxdist item false $ dist + 1;+ }+ }+ } {+ return dist;+ }+ end;++def collectHoneycomb =+ distTravelled <- collectContiguous 10 "honeycomb" false 0;+ turn back;+ doN distTravelled move;+ end;++def collectAllHoneycombs = \targetCount.++ honeycombHere <- ishere "honeycomb";+ if honeycombHere {} {+ watch down;+ wait 2000;+ };++ intersperse 4 (turn left; doN 9 move; turn left;) collectHoneycomb;++ currentCount <- count "honeycomb";+ if (currentCount < targetCount) {+ turn right;+ doN 27 move;+ turn right;++ collectAllHoneycombs targetCount;+ } {+ return currentCount;+ };+ end;++def moveUntilBlocked =+ thing <- scan forward;+ let isBlocked = case thing (\_. false) (\x. x == "lakewater") in+ if isBlocked {} {+ move;+ moveUntilBlocked;+ }+ end;++def getLakewater = \caskCount.+ turn right;+ doN 2 move;+ turn left;+ doN 5 move;+ turn right;+ moveUntilBlocked;++ doN caskCount $ use "siphon" forward;+ end;++def pickRock =+ isRock <- ishere "rock";+ if isRock {+ grab;+ return ();+ } {};+ end;++def collectRocks =+ doN 22 move;+ turn right;+ doN 59 move;+ turn left;++ doN 7 (+ intersperse 15 move pickRock;+ nextRow right;+ intersperse 15 move pickRock;+ nextRow left;+ );+ end;++def makeTables =++ doN 18 (make "log"; make "board";);+ doN 36 $ make "table";++ turn right;+ move;+ turn right;+ doN 2 move;+ doN 9 (swap "table"; move);+ doN 8 move;+ doN 9 (swap "table"; move);+ turn left;+ doN 2 move;+ turn left;+ move;+ doN 9 (swap "table"; move);+ doN 8 move;+ doN 9 (swap "table"; move);+ end;++def buildTavern =++ // x16 per rock = + doN 12 $ make "stone tile";++ doN 2 (+ intersperse 30 move $ place "stone tile";+ nextRow left;+ intersperse 30 move $ place "stone tile";+ nextRow right;+ );+ intersperse 30 move $ place "stone tile";++ makeTables;++ // hearth+ nextRow right;+ doN 12 move;+ intersperse 4 move (make "hearth"; swap "hearth");+ turn right;+ doN 6 move;+ turn right;+ intersperse 4 move (make "archway"; place "archway");+ nextRow right;+ intersperse 4 move (make "archway"; place "archway");+ move;++ // Make enough logs for 70 wall pieces+ doN 35 (make "log"; make "wall");+ + intersperse 14 move (place "wall");+ turn left;+ doN 6 (move; place "wall");+ turn left;+ doN 31 (move; place "wall";);+ turn left;+ doN 6 (move; place "wall");+ turn left;+ doN 13 (move; place "wall");+ end;++def combCollectionLoop = \targetCount.++ currentCount <- count "honeycomb";+ if (currentCount < targetCount) {+ watch down;+ wait 2000;+ collectHoneycomb;+ turn back;+ combCollectionLoop targetCount;+ } {}+ end;++def buildRobot = \targetCount. \meetingLoc.++ // Unpack the "botkit"+ make "solar panel";++ build {+ require 8 "tree";+ buildHive;++ // Move to northwest corner+ turn back;+ doN 3 move;+ turn left;+ doN 4 move;+ turn left;++ combCollectionLoop targetCount;++ currLoc <- whereami;+ let delta = subtractTuple meetingLoc currLoc in+ moveTuple delta;++ // Assume that the base has already arrived+ // at the rendezvous point+ honeycombCount <- count "honeycomb";+ doN honeycombCount $ give parent "honeycomb";+ };+ end;++def placeHives = \targetCount. \meetingLoc.+ buildRobot targetCount meetingLoc;+ doN 38 move;+ buildRobot targetCount meetingLoc;+ doN 56 move;+ turn right;+ doN 15 move;+ turn left;+ buildRobot targetCount meetingLoc;+ doN 2 move;+ turn right;+ doN 26 move;+ turn left;+ buildRobot targetCount meetingLoc;+ end;++def acceptHoneyDeliveries =+ currentCount <- count "honeycomb";+ if (currentCount < 60) {+ wait 32;+ acceptHoneyDeliveries;+ } {+ // Use the "honey extractor"+ doN currentCount $ make "honey";+ }+ end;++def go =+ harvestTrees;+ turn east;+ doN 19 move;+ + let meetingLoc = (0, -12) in+ placeHives 15 meetingLoc;++ turn right;++ buildCasks 2;+ getLakewater 2;++ turn right;++ collectRocks;++ doN 7 move;+ turn left;+ doN 80 move;+ buildTavern;++ nextRow right;+ + currLoc <- whereami;+ let delta = subtractTuple meetingLoc currLoc in+ moveTuple delta;++ acceptHoneyDeliveries;+ doN 4 salvage;++ doN 2 $ make "mead";++ end;++go;
@@ -39,12 +39,9 @@ def countBlocked = \n. if (n > 0) { isBlocked <- blocked;- // This assignment has to happen before the recursive- // "countBlocked" call due to #1032- let localBlockCount = boolToInt isBlocked in turn left; lastCount <- countBlocked $ n - 1;- return $ lastCount + localBlockCount;+ return $ lastCount + boolToInt isBlocked; } { return 0; }
@@ -0,0 +1,90 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def intersperse = \n. \f2. \f1. if (n > 0) {+ f1;+ if (n > 1) {+ f2;+ } {};+ intersperse (n - 1) f2 f1;+ } {};+ end;++def isEnclosureFull = \idx.+ foundBox <- structure "rubbish enclosure" idx;+ case foundBox (\_. return false) (\enclosure.+ let boxPos = snd enclosure in+ + prevLoc <- whereami;++ dims <- floorplan "rubbish enclosure";+ teleport self boxPos;++ c <- density ((0, 0), dims);+ let area = fst dims * snd dims in+ let notFull = c < area in++ teleport self prevLoc;+ return $ not notFull;+ );+ end;++def isEitherEnclosureFull =+ full1 <- isEnclosureFull 0;+ full2 <- isEnclosureFull 1;+ return $ full1 || full2;+ end;++def tryGrab =+ try {+ grab;+ return ()+ } {};+ end;+++def turnAround = \d.+ intersperse 2 move $ turn d;+ end;++def waitUntilEnclosureFull =++ isFull <- instant isEitherEnclosureFull;+ if isFull {+ // Drive down the road+ turn south;+ doN 13 move;+ turn right;+ doN 3 move;+ turn right;+ doN 2 move;+ turn left;++ // North enclosure+ intersperse 2 (turnAround left) $ intersperse 3 move tryGrab;++ intersperse 2 (doN 3 move) $ turn right;++ // South enclosure+ intersperse 2 (turnAround right) $ intersperse 3 move tryGrab;++ turn left;+ move;++ // Leave again+ turn right;+ doN 3 move;+ turn left;+ doN 13 move;+ turn back;+ } {+ wait 10;+ waitUntilEnclosureFull;+ }+ end;++def go =+ waitUntilEnclosureFull;+ go;+ end;++go;
@@ -0,0 +1,24 @@+/**+Swims back and forth forever.+*/++def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def swim =+ appear "^" (inl ());+ doN 3 (move; wait 3);+ turn back;+ wait 15;+ doN 3 (move; wait 3);+ turn back;+ appear " " (inl ());+ end;++def go =+ waitR <- random 100;+ wait $ 50 + waitR;+ swim;+ go;+ end;++go;
@@ -0,0 +1,195 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def intersperse = \n. \f2. \f1. if (n > 0) {+ f1;+ if (n > 1) {+ f2;+ } {};+ intersperse (n - 1) f2 f1;+ } {};+ end;++def makeRoll =+ make "nori";+ make "california roll";+ end;++def checkIngredients =+ hasTuna <- has "crab";+ hasSeaweed <- has "seaweed";+ return $ hasTuna && hasSeaweed;+ end;++def catchFish = \rod.+ use rod forward;+ ready <- checkIngredients;+ if ready {+ makeRoll;+ } {+ catchFish rod;+ };+ end;++def turnAround = \d.+ intersperse 2 move $ turn d;+ end;++/*+Precondition:+At the top-right corner+*/+def harvestRectangle =+ intersperse 4 move $ harvest; return ();+ turnAround left;+ intersperse 4 move $ harvest; return ();+ end;++def harvestIngredients =+ turn north;+ doN 2 move;+ turn left;+ doN 3 move;++ intersperse 3 (turn right; doN 2 move; turn right;) harvestRectangle;+ wait 400;+ turn left;+ doN 7 move;+ turn left;+ intersperse 3 (turn right; doN 2 move; turn right;) harvestRectangle;++ doN 6 move;+ turn left;+ move;+ end;++def getJunkItem = \idx.+ result <- tagmembers "junk" idx;+ let totalCount = fst result in+ let member = snd result in+ let nextIdx = idx + 1 in++ hasProhibited <- has member;+ if hasProhibited {+ return $ inr member;+ } {+ if (nextIdx < totalCount) {+ getJunkItem nextIdx;+ } {+ return $ inl ();+ }+ }+ end;++def tryPlace = \item.+ try {+ place item;+ } {};+ end;++/**+Precondition: facing north in lower-left corner of enclosure++Navigates a serpentine pattern through the space to+place items.+*/+def placeSerpentine = \placeFunc.+ placeFunc;++ move;+ placeFunc;++ turn right;++ move;+ placeFunc;++ turn right;++ move;+ placeFunc;++ turn left;++ move;+ placeFunc;++ turn left;++ move;+ placeFunc;++ end;++def returnToCorner =+ turn back;+ move; move;+ turn right;+ move; move;+ turn right;+ end;++def unloadTrash =+ try {+ placeSerpentine (+ item <- getJunkItem 0;+ case item (\_. fail "done") (\item. place item);+ );+ watch down;+ wait 1000;++ // Go back to corner+ turn back;+ move;+ turn right;+ move; move;+ turn right;++ wait 50;+ unloadTrash;+ } {};+ end;++def burnTires =+ hasCarTire <- has "car tire";+ if hasCarTire {++ intersperse 2 move $ (+ placeSerpentine $ tryPlace "car tire";+ returnToCorner;+ ignite forward;++ turn right;+ move; move;+ turn right;+ );++ wait 60;+ move;++ burnTires;+ } {}+ end;++def disposeTrash =+ turn back;+ doN 5 move;+ turn left;+ doN 11 move;+ turn left;+ move;++ burnTires;++ unloadTrash;+ end;++def go =+ harvestIngredients;+ let rod = "fishing tackle" in+ make rod;+ equip rod;+ doN 16 $ catchFish rod;+ disposeTrash;+ end;++go;
@@ -202,7 +202,7 @@ turn back; - let forever : cmd unit -> cmd unit = \c. c ; forever c in+ let forever : Cmd Unit -> Cmd Unit = \c. c ; forever c in forever sweepAreaForWool; end;
@@ -36,7 +36,7 @@ def decideDirection = - let randdir : cmd dir =+ let randdir : Cmd Dir = d <- random 4; return $ if (d == 0) { north@@ -62,8 +62,8 @@ } end; -let forever : cmd unit -> cmd unit = \c. c ; forever c in-let repeat : int -> cmd unit -> cmd unit =+let forever : Cmd Unit -> Cmd Unit = \c. c ; forever c in+let repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} in
@@ -2,7 +2,7 @@ def else = \t. t end // modulus function (%)-def mod : int -> int -> int = \i. \m.+def mod : Int -> Int -> Int = \i. \m. i - m * (i / m) end @@ -138,13 +138,9 @@ def naiveRandomStack = \valueFunc. \maxval. \bitmask. \n. val <- if (n > 1) { nextRandomVal <- getUnusedRandom maxval bitmask;-- // Recursion bug workaround (see #1032):- let blahNextRandomVal = nextRandomVal in- let newBitmask = bitmask + shiftLeft 1 nextRandomVal in naiveRandomStack valueFunc maxval newBitmask $ n - 1;- return blahNextRandomVal;+ return nextRandomVal; } { // We're at the peak of the stack. // Now we unwind it.@@ -218,7 +214,7 @@ /** One-based ordinal of the item. */-def getOrdinal : text -> cmd int = \item.+def getOrdinal : Text -> Cmd Int = \item. count item; end;
@@ -0,0 +1,452 @@+version: 1+name: Beekeeping+author: Karl Ostmo+description: |+ Bootstrap an organic *bee*verage industry.+creative: false+seed: 2+attrs:+ - name: bee+ fg: '#ffff00'+ bg: '#000000'+ - name: water_cask+ fg: '#4488ff'+ bg: '#8B4513'+ - name: mybase+ fg: '#e0c0e0'+ - name: iceblue+ fg: '#ddddff'+objectives:+ - teaser: Apiarist+ goal:+ - |+ Build a `beehive`{=structure}.+ - |+ This will attract bees, which will gather+ `nectar`{=entity} from nearby `wildflower`{=entity}s.+ - |+ Do not crowd hives; provide at least one cell margin+ between them.+ - |+ Given that `wildflower`{=entity}s cannot be relocated,+ judicious placement is essential for efficient+ `honeycomb`{=entity} production.+ condition: |+ foundStructure <- structure "beehive" 0;+ return $ case foundStructure (\_. false) (\_. true);+ - teaser: Collect honeycomb+ goal:+ - |+ Collect `honeycomb`{=entity} from the `beehive`{=structure}s.+ - |+ After gathering a certain amount of nectar, a bee will return+ to its hive and place honeycomb alongside it.+ A finite amount of honeycomb may be accumulated before the+ bee becomes dormant.+ condition: |+ as base {+ has "honeycomb"+ }+ - teaser: Cooper+ goal:+ - |+ Make a `cask`{=entity}.+ - |+ Use local timber and your on-hand supply of iron material.+ - |+ You may `use "siphon" forward` when positioned in front of+ a lake to fill a `cask`{=entity} with `lakewater`{=entity}.+ condition: |+ as base {+ has "cask"+ }+ - teaser: Brewmeister+ goal:+ - |+ Ferment 2 barrels of `mead`{=entity}.+ condition: |+ as base {+ meadCount <- count "mead";+ return $ meadCount >= 2;+ }+ - teaser: Tavern keeper+ optional: true+ goal:+ - |+ Construct a `mead hall`{=structure}.+ condition: |+ foundStructure <- structure "mead hall" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ display:+ attr: mybase+ dir: east+ devices:+ - 3D printer+ - blueprint+ - branch predictor+ - ADT calculator+ - clock+ - comparator+ - compass+ - counter+ - dictionary+ - fast grabber+ - GPS receiver+ - harvester+ - hearing aid+ - honey extractor+ - keyboard+ - lambda+ - logger+ - net+ - rolex+ - scanner+ - siphon+ - strange loop+ - toolkit+ - treads+ - welder+ - workbench+ inventory:+ - [20, iron plate]+ - [4, botkit]+ - name: queenbee+ dir: east+ system: true+ display:+ invisible: true+ char: 'Q'+ attr: bee+ program: |+ run "scenarios/Challenges/Ranching/_beekeeping/queenbee.sw"+solution: |+ run "scenarios/Challenges/Ranching/_beekeeping/solution.sw"+structures:+ - name: beehive+ recognize: [north]+ structure:+ palette:+ '-': [dirt, honey frame]+ 'b': [dirt, board]+ map: |+ bbbbb+ b---b+ b---b+ b---b+ bbbbb+ - name: mead hall+ recognize: [north]+ structure:+ palette:+ 'w': [dirt, wall]+ 't': [dirt, table]+ 'h': [dirt, hearth]+ 'a': [dirt, archway]+ '.': [stone, stone tile]+ mask: 'x'+ map: |+ wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww+ w.............hhhh.............w+ w..ttttttttt........ttttttttt..w+ w..............................w+ w..ttttttttt........ttttttttt..w+ w..............................w+ wwwwwwwwwwwwwwaaaawwwwwwwwwwwwww+ xxxxxxxxxxxxxxaaaaxxxxxxxxxxxxxx+entities:+ - name: wildflower+ display:+ attr: flower+ char: '*'+ description:+ - A delicate flower that grows wild in local meadows. Produces `nectar`{=entity} when `harvest`ed.+ properties: [known, growable]+ yields: nectar+ growth: [80, 120]+ - name: botkit+ display:+ attr: device+ char: 'k'+ description:+ - All the essentials to equip your own "worker bee"+ properties: [known, pickable]+ - name: reed+ display:+ attr: plant+ char: 'r'+ description:+ - Reeds, grow near water+ properties: [known, pickable, growable]+ - name: honeycomb+ display:+ char: 'x'+ attr: gold+ description:+ - Product of bees that have consumed nectar+ properties: [known, pickable]+ - name: proboscis+ display:+ char: 'p'+ attr: device+ description:+ - Senses direction to nectar-producing flowers+ properties: [known, pickable]+ capabilities: [detectdirection, structure]+ - name: honey+ display:+ char: 'h'+ attr: gold+ description:+ - Pure liquid honey+ properties: [known, pickable]+ - name: mead+ display:+ char: 'm'+ description:+ - Honey-based alcoholic beverage+ properties: [known, pickable]+ - name: honey extractor+ display:+ char: 'e'+ attr: device+ description:+ - Device for extracting honey from the comb+ properties: [known, pickable]+ - name: buzz+ display:+ char: 'z'+ description:+ - Result of discarding surplus honeycomb+ properties: [known, pickable]+ - name: wax gland+ display:+ char: 'g'+ description:+ - Required to make honeycomb+ properties: [known]+ - name: nectar+ display:+ char: 'n'+ attr: gold+ description:+ - Obtained from wildflowers+ properties: [known, pickable]+ - name: honey frame+ display:+ char: '-'+ attr: iceblue+ description:+ - Internal component of a beehive+ properties: [known, pickable]+ - name: stave+ display:+ char: 'l'+ attr: wood+ description:+ - Wooden plank comprising the sides of a cask+ properties: [known, pickable]+ - name: cask+ display:+ char: 'c'+ attr: wood+ description:+ - Wooden barrel for liquids+ properties: [known, pickable]+ - name: water cask+ display:+ char: 'c'+ attr: water_cask+ description:+ - Water-filled cask+ properties: [known, pickable]+ - name: lakewater+ display:+ attr: water+ char: ' '+ description:+ - Potable water from a lake+ properties: [known, infinite, liquid]+ - name: siphon+ display:+ char: 's'+ attr: device+ description:+ - Used to fill a cask with water+ properties: [known, pickable]+ - name: steel hoop+ display:+ char: 'o'+ attr: iron+ description:+ - Binds staves into a cask+ properties: [known, pickable]+ - name: wall+ display:+ char: 'w'+ attr: wood+ description:+ - Outer walls of the building+ properties: [known, unwalkable]+ - name: table+ display:+ char: 't'+ attr: wood+ description:+ - A segment of banquet table+ properties: [known, pickable]+ - name: hearth+ display:+ char: 'h'+ attr: rock+ description:+ - Encloses a fire to warm the hall+ properties: [known, unwalkable]+ - name: archway+ display:+ char: 'a'+ attr: rock+ description:+ - Grand entrance+ properties: [known, pickable]+ - name: stone tile+ display:+ char: '.'+ attr: rock+ description:+ - Refined flooring+ properties: [known, pickable]+recipes:+ - in:+ - [1, botkit]+ out:+ - [1, branch predictor]+ - [1, ADT calculator]+ - [1, blueprint]+ - [1, clock]+ - [1, comparator]+ - [1, compass]+ - [1, counter]+ - [1, dictionary]+ - [1, grabber]+ - [1, GPS receiver]+ - [1, harvester]+ - [1, lambda]+ - [1, logger]+ - [1, net]+ - [1, rolex]+ - [1, scanner]+ - [1, solar panel]+ - [1, strange loop]+ - [1, treads]+ - [1, welder]+ - [1, workbench]+ - in:+ - [1, board]+ out:+ - [3, honey frame]+ - in:+ - [1, rock]+ out:+ - [16, stone tile]+ - in:+ - [2, rock]+ out:+ - [1, hearth]+ - in:+ - [4, rock]+ out:+ - [1, archway]+ - in:+ - [2, board]+ out:+ - [1, table]+ - in:+ - [1, rock]+ - [1, log]+ out:+ - [2, wall]+ - in:+ - [1, board]+ out:+ - [2, stave]+ - in:+ - [2, iron plate]+ out:+ - [1, steel hoop]+ - in:+ - [20, stave]+ - [2, steel hoop]+ out:+ - [1, cask]+ - in:+ - [1, cask]+ - [1, lakewater]+ out:+ - [1, water cask]+ - [1, lakewater]+ required:+ - [1, siphon]+ - in:+ - [16, nectar]+ out:+ - [1, honeycomb]+ required:+ - [1, wax gland]+ - in:+ - [1, water cask]+ - [30, honey]+ out:+ - [1, mead]+ - in:+ - [1, honeycomb]+ out:+ - [1, honey]+ required:+ - [1, honey extractor]+ - in:+ - [1, honeycomb]+ out:+ - [1, buzz]+ required:+ - [1, wax gland]+known: [tree, rock, board]+world:+ dsl: |+ let+ flowerNoise = perlin seed 1 0.15 0.0,+ stoneNoise = perlin (seed + 1) 1 0.05 0.0,+ lakeNoise = perlin seed 1 0.02 0.0,+ forestNoise = perlin seed 2 0.04 1.0,++ flowers = flowerNoise > 0.65,+ rubble = stoneNoise > 0.8,+ rock = stoneNoise > 0.9,+ outerShore = -0.55 <= lakeNoise && lakeNoise < -0.5,+ innerShore = lakeNoise < -0.55,+ lakes = lakeNoise < -0.6,+ trees = forestNoise > 0.8+ in+ overlay+ [ {grass}+ , mask (flowers && (x - y) % 3 == 0) {wildflower}+ , mask (rubble && (x + y) % 2 == 0) {rock}+ , mask rock {rock}+ , mask trees {tree}+ , mask (outerShore && (x + y) % 2 == 0) {reed}+ , mask innerShore {reed}+ , mask lakes {lakewater}+ ]+ upperleft: [0, 0]+ offset: false+ palette:+ 'B': [grass, erase, base]+ 'Q': [grass, erase, queenbee]+ '.': [grass, erase]+ map: |+ Q....+ .....+ ..B..+ .....+ .....
@@ -72,7 +72,7 @@ }; robots: - name: base- dir: [1, 0]+ dir: east devices: - 3D printer - branch predictor@@ -114,7 +114,7 @@ - [6, welder] - name: opponent system: true- dir: [0, 1]+ dir: north display: char: P attr: pig@@ -122,21 +122,21 @@ program: | run "scenarios/Challenges/Ranching/_capture/opponent.sw" solution: |- run "scenarios/Challenges/Ranching/_capture/solution.sw"+ run "scenarios/Challenges/Ranching/_capture/solution.sw" entities: - name: monolith display: char: '@' description:- - Pushable rock- properties: [known, unwalkable, portable]+ - Pushable rock+ properties: [known, unwalkable, pickable] capabilities: [push] - name: bacon display: attr: bacon char: 'Z' description:- - Odiferous constitution of pig+ - Odiferous constitution of pig properties: [known] known: [flower, tree] world:@@ -160,4 +160,3 @@ ................ .B..*......@.... ................-
@@ -0,0 +1,544 @@+version: 1+name: Responsible Fishing+author: Karl Ostmo+description: |+ Catch the appropriate seafood to make lunch.++ If you haul any trash out of the lake, you+ must throw it away in the enclosures to the southeast.+ No littering!+creative: false+seed: 0+attrs:+ - name: shark+ bg: "#2040bb"+objectives:+ - teaser: Hot rod+ goal:+ - |+ `equip` your `fishing tackle`{=entity}, i.e. a rod and its accoutrements.+ condition: |+ as base {+ equipped "fishing tackle";+ }+ - teaser: Sushi chain+ id: lots_of_sushi+ goal:+ - |+ Make 16 `california roll`{=entity}s+ condition: |+ as base {+ rollCount <- count "california roll";+ return $ rollCount >= 16;+ }+ prerequisite: made_sushi+ - teaser: Sushi chef+ id: made_sushi+ goal:+ - |+ Make a `california roll`{=entity}+ condition: |+ as base {+ has "california roll"+ }+ - teaser: Waste disposal+ prerequisite:+ logic:+ and:+ - lots_of_sushi+ - not: littered+ goal:+ - |+ Inventory must be free of all `junk`{=tag}.+ - |+ Dispose of `junk`{=tag} only in designated `rubbish enclosure`{=structure}s.+ - |+ Certain items can be burned to make room.+ Good thing you brought your `torch`{=entity}!+ - |+ Otherwise, when the enclosure becomes full, the trash+ hauler will come to empty it.+ condition: |+ // Returns true if prohibited item is in inventory.+ def checkProhibited = \idx.+ result <- tagmembers "junk" idx;+ let totalCount = fst result in+ let member = snd result in+ let nextIdx = idx + 1 in++ hasProhibited <- as base {has member};+ if hasProhibited {+ return false;+ } {+ if (nextIdx < totalCount) {+ checkProhibited nextIdx;+ } {+ return true;+ }+ }+ end;++ checkProhibited 0;+ - teaser: No littering+ id: littered+ hidden: true+ optional: true+ goal:+ - |+ You may dispose of `junk`{=tag} only in either of the designated `rubbish enclosure`{=structure}s.+ - |+ Note that certain items can be burned with a `torch`{=entity} to make room.+ condition: |+ def locIsInsideEnclosure = \loc. \dims. \idx.+ foundBox <- structure "rubbish enclosure" idx;+ case foundBox (\_. return false) (\enclosure.+ let boxPos = snd enclosure in+ return $ snd loc >= snd boxPos+ && snd loc < snd dims + snd boxPos+ && fst loc >= fst boxPos+ && fst loc < fst dims + fst boxPos;+ );+ end;++ def junkOutsideEnclosure =+ result <- scan down;+ case result (\_. return false) (\item.+ isJunk <- hastag item "junk";+ if isJunk {+ foundBox <- structure "rubbish enclosure" 0;++ case foundBox (\_. return false) (\enclosure.++ dims <- floorplan "rubbish enclosure";+ loc <- whereami;++ insideFirst <- locIsInsideEnclosure loc dims 0;+ insideSecond <- locIsInsideEnclosure loc dims 1;+ return $ not $ insideFirst || insideSecond;+ );+ } {+ return false;+ };+ );+ end;++ // If a junk entity was placed on the ground,+ // it will be in the same cell as the base robot.+ as base {+ junkOutsideEnclosure;+ }+robots:+ - name: base+ dir: [1, 0]+ devices:+ - branch predictor+ - ADT calculator+ - hourglass+ - comparator+ - compass+ - dictionary+ - grabber+ - harvester+ - keyboard+ - lambda+ - logger+ - net+ - pawn star+ - rolex+ - scanner+ - strange loop+ - torch+ - treads+ - welder+ - workbench+ inventory:+ - [1, branch]+ - [1, string]+ - [1, fish hook]+ - [1, lead weight]+ - name: hauler+ dir: [1, 0]+ system: true+ display:+ char: W+ invisible: false+ program: |+ run "scenarios/Challenges/Ranching/_fishing/hauler.sw"+ - name: shark+ dir: [1, 0]+ system: true+ display:+ char: ' '+ attr: shark+ invisible: false+ program: |+ run "scenarios/Challenges/Ranching/_fishing/shark.sw"+solution: |+ run "scenarios/Challenges/Ranching/_fishing/solution.sw"+structures:+ - name: rubbish enclosure+ recognize: [north, south]+ structure:+ palette:+ 'j': [grass, concrete wall]+ '.': [stone, null]+ map: |+ jjjjj+ j...j+ j...j+entities:+ - name: concrete wall+ display:+ attr: rock+ char: '-'+ description:+ - Enclosure for rubbish+ properties: [known, unwalkable]+ - name: lakewater+ display:+ attr: water+ char: ' '+ description:+ - Potable water from a lake+ properties: [known, infinite, liquid]+ - name: pawn star+ display:+ attr: gold+ char: '*'+ description:+ - |+ Can tell you if something is `junk`{=tag}+ via the `hastag` command. E.g.:+ - |+ `hastag "car tire" "junk"`+ - |+ Also allows you to iterate over the list of junk, e.g.:+ - |+ `tagmembers "junk" 0`+ capabilities: [hastag, tagmembers]+ - name: torch+ display:+ attr: wood+ char: 't'+ description:+ - Can set things on fire+ properties: [known, pickable]+ capabilities: [ignite]+ - name: fishing tackle+ display:+ char: 'r'+ attr: wood+ description:+ - A fishing rod equipped with hook, line and sinker.+ - Use on `water`{=entity} to catch fish+ properties: [known, pickable]+ - name: lead weight+ display:+ char: 'w'+ attr: device+ description:+ - Used as a fishing sinker+ properties: [known, pickable]+ - name: fish hook+ display:+ char: 'j'+ attr: device+ description:+ - Use to catch fish+ properties: [known, pickable]+ - name: california roll+ display:+ char: 'c'+ description:+ - Delicious+ properties: [known, pickable]+ - name: rice+ display:+ char: 'i'+ attr: plant+ description:+ - Perfect for sushi+ properties: [known, pickable, growable]+ - name: avocado+ display:+ char: 'A'+ attr: plant+ description:+ - Perfect for sushi+ properties: [known, pickable, growable]+ - name: cucumber+ display:+ char: 'u'+ attr: plant+ description:+ - Perfect for sushi+ properties: [known, pickable, growable]+ - name: tuna+ display:+ char: 't'+ description:+ - Edible fish+ properties: [known, pickable]+ - name: crab+ display:+ char: 'c'+ description:+ - Perfect for sushi+ properties: [known, pickable]+ - name: pufferfish+ display:+ char: 'p'+ description:+ - Poisonous+ properties: [known, pickable]+ - name: trout+ display:+ char: 't'+ description:+ - Good to eat+ properties: [known, pickable]+ - name: salmon+ display:+ char: 't'+ description:+ - Good to eat+ properties: [known, pickable]+ - name: oarfish+ display:+ char: 'r'+ description:+ - Too long+ properties: [known, pickable]+ - name: narwhal+ display:+ char: 'n'+ description:+ - Too big+ properties: [known, pickable]+ - name: marlin+ display:+ char: 'm'+ description:+ - Pointy+ properties: [known, pickable]+ - name: seaweed+ display:+ char: 'w'+ description:+ - Inedible...?+ properties: [known, pickable]+ - name: nori+ display:+ char: 'n'+ description:+ - Dried seaweed wrap for sushi rolls+ properties: [known, pickable]+ - name: car tire+ display:+ char: 'o'+ description:+ - Rubber waste. Flammable.+ tags: [junk]+ properties: [known, pickable, combustible]+ combustion:+ ignition: 0.5+ duration: [40, 80]+ product: null+ - name: kitchen sink+ display:+ char: 'i'+ description:+ - Everything but!+ tags: [junk]+ properties: [known, pickable]+ - name: boot+ display:+ char: 'b'+ description:+ - A soggy, worn-out boot.+ tags: [junk]+ properties: [known, pickable]+ - name: rusty bicycle+ display:+ char: '8'+ description:+ - Its riding days are over.+ tags: [junk, metal]+ properties: [known, pickable]+recipes:+ - in:+ - [1, lakewater]+ out:+ - [1, rusty bicycle]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, car tire]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 6+ - in:+ - [1, lakewater]+ out:+ - [1, boot]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, kitchen sink]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, seaweed]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, tuna]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, salmon]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, narwhal]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, oarfish]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, trout]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, marlin]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, pufferfish]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, lakewater]+ out:+ - [1, crab]+ - [1, lakewater]+ required:+ - [1, fishing tackle]+ time: 10+ weight: 1+ - in:+ - [1, seaweed]+ out:+ - [1, nori]+ - in:+ - [1, crab]+ - [1, rice]+ - [1, nori]+ - [1, cucumber]+ - [1, avocado]+ out:+ - [1, california roll]+ - in:+ - [1, branch]+ - [1, fish hook]+ - [1, string]+ - [1, lead weight]+ out:+ - [1, fishing tackle]+known: []+world:+ dsl: |+ {grass}+ upperleft: [0, 0]+ placements:+ - src: rubbish enclosure+ offset: [19, -10]+ - src: rubbish enclosure+ offset: [19, -14]+ orient:+ up: south+ palette:+ 'B': [grass, erase, base]+ '.': [grass]+ 'w': [grass, lakewater]+ 's': [grass, lakewater, shark]+ 'A': [grass, avocado]+ 'i': [grass, rice]+ 'c': [grass, cucumber]+ 'r': [dirt, erase]+ 'h': [dirt, erase, hauler]+ map: |+ .........................h.+ .........................r.+ AAAA.....................r.+ AAAA.......wwwwww........r.+ ......B...wwwwwwww.......r.+ iiii......wwswwwww.......r.+ iiii.....wwwwwwwww.......r.+ .........wwwwwwww........r.+ cccc.......wwww..........r.+ cccc.....................r.+ .........................r.+ .........................r.+ .........................r.+ ....................rrrrrr.+ ...........................+ ...........................+ ...........................
@@ -191,7 +191,7 @@ prerequisite: feed_sheep robots: - name: base- dir: [0, 1]+ dir: north devices: - treads - scanner@@ -221,11 +221,12 @@ invisible: false char: '@' system: true- dir: [0, 1]+ dir: north inventory: - [4, wool]- unwalkable:- - gate+ walkable:+ never:+ - gate program: | run "scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw"; entities:@@ -234,7 +235,7 @@ char: '#' description: - Keeps sheep in. And some other things out.- properties: [known, portable, unwalkable]+ properties: [known, pickable, unwalkable] - name: post puller display: char: 'P'@@ -242,27 +243,27 @@ capabilities: [drill] description: - Good for dismantling fences.- properties: [known, portable]+ properties: [known, pickable] - name: scrap wood display: char: '\' description: - Scrap wood. Can be reconditioned into boards.- properties: [known, portable]+ properties: [known, pickable] - name: sweater display: attr: gold char: 'S' description: - A warm wool sweater. Just in time for winter!- properties: [known, portable]+ properties: [known, pickable] - name: clover display: attr: flower char: '%' description: - A tasty stack for fluffy ruminants.- properties: [portable, growable]+ properties: [pickable, growable] growth: [80, 100] - name: gate display:@@ -277,7 +278,7 @@ attr: rock description: - Facilitates swinging action.- properties: [known, portable]+ properties: [known, pickable] - name: cabin display: char: Π@@ -287,7 +288,7 @@ properties: [known, unwalkable] - name: pier display:- char: 且+ char: H attr: rock description: - Docking area for ships@@ -297,19 +298,19 @@ char: '.' description: - A marker that can be put down and found again. Used only by judge robot.- properties: [portable]+ properties: [pickable] - name: treaded breadcrumb display: char: 'x' description: - A marker that can be put down and found again (for a second time). Used only by judge robot.- properties: [portable]+ properties: [pickable] - name: evaporator display: char: 'E' description: - A tool that allows clearing a water tile. Used only by judge robot.- properties: [portable]+ properties: [pickable] capabilities: [drill] - name: wool display:@@ -317,13 +318,13 @@ attr: gold description: - A bundle of raw animal fiber.- properties: [portable]+ properties: [pickable] - name: steam display: char: 'Z' description: - What's left after evaporating water. Used only by judge robot.- properties: [portable]+ properties: [pickable] recipes: - in: - [2, board]
@@ -35,7 +35,7 @@ After you have done this, `place` the `bell`{=entity} anywhere, and then Bill will inspect your work. prerequisite:- not: wrong_anwser+ not: wrong_anwser condition: | r <- robotnamed "setup"; as r {has "bit (1)"};@@ -50,7 +50,7 @@ as r {has "bit (0)"}; robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor@@ -75,7 +75,7 @@ - treads - name: setup system: true- dir: [1, 0]+ dir: east display: invisible: true inventory:@@ -90,15 +90,15 @@ program: | run "scenarios/Challenges/Ranching/_powerset/setup.sw" solution: |- run "scenarios/Challenges/Ranching/_powerset/solution.sw"+ run "scenarios/Challenges/Ranching/_powerset/solution.sw" entities: - name: rocket skates display: attr: silver char: 's' description:- - Allows one to `stride` across multiple cells- properties: [known, portable]+ - Allows one to `stride` across multiple cells+ properties: [known, pickable] capabilities: [movemultiple] - name: bell display:@@ -106,7 +106,7 @@ attr: gold description: - A bell for Bill- properties: [known, portable]+ properties: [known, pickable] - name: fruit picker display: char: 'P'@@ -127,7 +127,7 @@ attr: fruit0 description: - Dragonfruits- properties: [known, growable, portable]+ properties: [known, growable, pickable] growth: [10, 10] - name: grape display:@@ -136,7 +136,7 @@ description: - Grapes growth: [10, 10]- properties: [known, growable, portable]+ properties: [known, growable, pickable] - name: lemon display: char: 'Y'@@ -144,7 +144,7 @@ description: - Lemons growth: [10, 10]- properties: [known, growable, portable]+ properties: [known, growable, pickable] - name: apple display: char: 'Y'@@ -152,7 +152,7 @@ description: - Apple growth: [10, 10]- properties: [known, growable, portable]+ properties: [known, growable, pickable] - name: blueberry display: char: 'Y'@@ -160,7 +160,7 @@ description: - Blueberries growth: [10, 10]- properties: [known, growable, portable]+ properties: [known, growable, pickable] - name: watermelon display: char: 'Y'@@ -168,7 +168,7 @@ description: - Watermelons growth: [10, 10]- properties: [known, growable, portable]+ properties: [known, growable, pickable] - name: orange display: char: 'Y'@@ -176,7 +176,7 @@ description: - Oranges growth: [10, 10]- properties: [known, growable, portable]+ properties: [known, growable, pickable] known: [sand] world: dsl: |@@ -184,7 +184,6 @@ upperleft: [-1, -1] offset: false palette:- '.': [grass] 'B': [grass, null, base] 'S': [grass, null, setup] map: |
@@ -31,7 +31,7 @@ as j {run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/validate-board.sw"}; robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor@@ -84,7 +84,7 @@ - [25, y-tile-ordinal] - name: maintainer system: true- dir: [1, 0]+ dir: east display: invisible: true attr: 'gold'@@ -118,7 +118,7 @@ run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/maintainer.sw"; - name: setup system: true- dir: [1, 0]+ dir: east display: invisible: true attr: 'iron'@@ -151,7 +151,7 @@ program: | run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/setup.sw"; solution: |- run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw"+ run "scenarios/Challenges/Sliding Puzzles/_sliding-puzzle/solution.sw" entities: - name: gradiator display:@@ -184,8 +184,8 @@ attr: silver char: '/' description:- - Facilitates pushing- properties: [known, portable]+ - Facilitates pushing+ properties: [known, pickable] capabilities: [push] - name: sliding-tile display:@@ -199,175 +199,175 @@ attr: oddtile description: - One- properties: [known, portable]+ properties: [known, pickable] - name: b-tile display: char: 'b' attr: eventile description: - Two- properties: [known, portable]+ properties: [known, pickable] - name: c-tile display: char: 'c' attr: oddtile description: - Three- properties: [known, portable]+ properties: [known, pickable] - name: d-tile display: char: 'd' attr: eventile description: - Four- properties: [known, portable]+ properties: [known, pickable] - name: e-tile display: char: 'e' attr: oddtile description: - Five- properties: [known, portable]+ properties: [known, pickable] - name: f-tile display: char: 'f' attr: eventile description: - Six- properties: [known, portable]+ properties: [known, pickable] - name: g-tile display: char: 'g' attr: oddtile description: - Seven- properties: [known, portable]+ properties: [known, pickable] - name: h-tile display: char: 'h' attr: eventile description: - Eight- properties: [known, portable]+ properties: [known, pickable] - name: i-tile display: char: 'i' attr: oddtile description: - Nine- properties: [known, portable]+ properties: [known, pickable] - name: j-tile display: char: 'j' attr: eventile description: - Ten- properties: [known, portable]+ properties: [known, pickable] - name: k-tile display: char: 'k' attr: oddtile description: - Eleven- properties: [known, portable]+ properties: [known, pickable] - name: l-tile display: char: 'l' attr: eventile description: - Twelve- properties: [known, portable]+ properties: [known, pickable] - name: m-tile display: char: 'm' attr: oddtile description: - Thirteen- properties: [known, portable]+ properties: [known, pickable] - name: n-tile display: char: 'n' attr: eventile description: - Fourteen- properties: [known, portable]+ properties: [known, pickable] - name: o-tile display: char: 'o' attr: oddtile description: - Fifteen- properties: [known, portable]+ properties: [known, pickable] - name: p-tile display: char: 'p' attr: eventile description: - Sixteen- properties: [known, portable]+ properties: [known, pickable] - name: q-tile display: char: 'q' attr: oddtile description: - Seventeen- properties: [known, portable]+ properties: [known, pickable] - name: r-tile display: char: 'r' attr: eventile description: - Eighteen- properties: [known, portable]+ properties: [known, pickable] - name: s-tile display: char: 's' attr: oddtile description: - Nineteen- properties: [known, portable]+ properties: [known, pickable] - name: t-tile display: char: 't' attr: eventile description: - Twenty- properties: [known, portable]+ properties: [known, pickable] - name: u-tile display: char: 'u' attr: oddtile description: - Twenty-one- properties: [known, portable]+ properties: [known, pickable] - name: v-tile display: char: 'v' attr: eventile description: - Twenty-two- properties: [known, portable]+ properties: [known, pickable] - name: w-tile display: char: 'w' attr: oddtile description: - Twenty-three- properties: [known, portable]+ properties: [known, pickable] - name: x-tile display: char: 'x' attr: eventile description: - Twenty-four- properties: [known, portable]+ properties: [known, pickable] - name: y-tile display: char: 'y' attr: oddtile description: - Twenty-five- properties: [known, portable]+ properties: [known, pickable] - name: a-tile-ordinal display: char: 'a'
@@ -11,7 +11,7 @@ (n * (n + 1)) / 2 end; -def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m); end @@ -46,7 +46,7 @@ teleport self newLoc; end; -def getOrdinal : text -> cmd int = \item.+def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -60,12 +60,8 @@ let idx = n - 1 in teleport self (idx/boardHeight, -(mod idx boardWidth)); valueHere <- getValueHere;-- // This reassignment has to happen before the- // recursive call due to #1032- let valueHereBlah = valueHere in runningTotal <- getIndexesTotal boardWidth boardHeight $ n - 1;- return $ valueHereBlah + runningTotal;+ return $ valueHere + runningTotal; } { return 0; }@@ -166,7 +162,7 @@ Precondition: Facing east at location (0, 0). */-def iterateAllTiles : cmd unit -> cmd unit = \func.+def iterateAllTiles : Cmd Unit -> Cmd Unit = \func. let b = "border" in isOnBottomBorder <- itemIsHere b; if isOnBottomBorder {} {
@@ -8,7 +8,7 @@ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end; -def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -23,7 +23,7 @@ letter ++ "-tile"; end; -def getOrdinal : text -> cmd int = \item.+def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -112,7 +112,7 @@ Left is a Boolean indicating whether the tile has been drilled. Right is a valid tile entity name. */-def scanValid : dir -> cmd (bool + text) = \d.+def scanValid : Dir -> Cmd (Bool + Text) = \d. maybeTileForward <- scan d; case maybeTileForward (\_. return $ inL false)
@@ -21,7 +21,7 @@ $ else {0}; end; -def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m); end @@ -35,7 +35,7 @@ (fst t1 + fst t2, snd t1 + snd t2); end; -def getOrdinal : text -> cmd int = \item.+def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -60,7 +60,7 @@ return $ sumTuples negatedLoc absLoc; end; -def getRelativeRectangle : (int * int) * (int * int) -> cmd ((int * int) * (int * int)) = \corners.+def getRelativeRectangle : (Int * Int) * (Int * Int) -> Cmd ((Int * Int) * (Int * Int)) = \corners. myloc <- whereami; let negatedLoc = negateTuple myloc in return $ mapTuple (sumTuples negatedLoc) corners;
@@ -7,7 +7,7 @@ case x (\_. return false) (\found. return $ found == item); end; -def getOrdinal : text -> cmd int = \item.+def getOrdinal : Text -> Cmd Int = \item. count $ item ++ "-ordinal"; end; @@ -16,7 +16,7 @@ Returns a Left if we are non-monotonic. Otherwise returns the next expected value. */-def isMonotonic : int -> cmd (unit + int) = \expectedVal.+def isMonotonic : Int -> Cmd (Unit + Int) = \expectedVal. maybeItem <- scan down; case maybeItem (\_. return $ inR expectedVal) // Cell was blank@@ -38,7 +38,7 @@ Precondition: Facing east at location (0, 0). */-def loopMonotonicityCheck : int -> cmd bool = \expectedVal.+def loopMonotonicityCheck : Int -> Cmd Bool = \expectedVal. isOnBottomBorder <- itemIsHere "border"; if isOnBottomBorder { return true;
@@ -14,7 +14,7 @@ }; robots: - name: base- dir: [0, -1]+ dir: south display: attr: gold devices:@@ -62,8 +62,8 @@ display: char: '@' description:- - Pushable rock- properties: [known, unwalkable, portable]+ - Pushable rock+ properties: [known, unwalkable, pickable] known: [mountain, water, flower] world: dsl: |
@@ -14,7 +14,7 @@ }; robots: - name: base- dir: [1, 0]+ dir: east display: attr: gold devices:@@ -45,8 +45,8 @@ display: char: '@' description:- - Pushable rock- properties: [known, unwalkable, portable]+ - Pushable rock+ properties: [known, unwalkable, pickable] known: [mountain, water, flower] world: dsl: |
@@ -21,7 +21,7 @@ }; robots: - name: base- dir: [1, 0]+ dir: east display: attr: gold devices:@@ -97,8 +97,8 @@ display: char: '@' description:- - Pushable rock- properties: [known, unwalkable, portable]+ - Pushable rock+ properties: [known, unwalkable, pickable] known: [mountain, water, flower] world: dsl: |
@@ -139,7 +139,7 @@ pushUntilBarrier; wait 4;- move;+ moveUntilBlocked; doN 5 (turn left; moveUntilBlocked); turn right;
@@ -32,7 +32,7 @@ - name: base display: attr: bluish- dir: [0, 1]+ dir: north devices: - branch predictor - ADT calculator@@ -70,28 +70,28 @@ - [5, strange loop] - [5, treads] solution: |- run "scenarios/Challenges/Sokoban/_foresight/solution.sw"+ run "scenarios/Challenges/Sokoban/_foresight/solution.sw" entities: - name: monolith display: char: '@' attr: gold description:- - Pushable rock- properties: [known, unwalkable, portable]+ - Pushable rock+ properties: [known, unwalkable, pickable] - name: crate display: attr: wood char: '▪' description:- - Pushable crate- properties: [known, portable, unwalkable]+ - Pushable crate+ properties: [known, pickable, unwalkable] - name: wall display: attr: barrier char: '#' description:- - Unmovable barrier+ - Unmovable barrier properties: [known, unwalkable] known: [mountain, water, 3D printer, flower] world:@@ -108,7 +108,6 @@ '@': [grass, monolith] 'c': [grass, crate] 'A': [grass, wall]- 'w': [dirt, water] 'x': [stone, erase] 'z': [dirt, erase] map: |
@@ -18,7 +18,7 @@ Distinguishes system bots from the base by name. Returns true if a bot has "met" the base. */-def anyHasMetBase : int -> cmd bool = \idx.+def anyHasMetBase : Int -> Cmd Bool = \idx. try { bot <- robotnumbered idx;
@@ -4,7 +4,6 @@ end; def cycleCombos = \n.- wait 1; entityNorth <- scan north; let hasGate = case entityNorth (\_. false) (\x. x == "gate") in if hasGate {
@@ -0,0 +1,24 @@+def modifyCart = \cartType. \device.+ result <- scan forward;+ case result return (\item.+ if (item == cartType) {+ use device forward;+ return ();+ } {+ return ();+ };+ );+ end;++def watchSpot =+ watch forward;+ wait 1000;+ modifyCart "empty cart" "spatula";+ end;++def go =+ watchSpot;+ go;+ end;++go;
@@ -0,0 +1,24 @@+def modifyCart = \cartType. \device.+ result <- scan forward;+ case result return (\item.+ if (item == cartType) {+ use device forward;+ return ();+ } {+ return ();+ };+ );+ end;++def watchSpot =+ watch forward;+ wait 1000;+ modifyCart "full cart" "fork";+ end;++def go =+ watchSpot;+ go;+ end;++go;
@@ -0,0 +1,27 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def moveOne =+ move;+ move;+ turn back;+ push;+ turn back;+ end;++def oneLap =+ doN 4 (+ doN 8 moveOne;+ turn right;+ );+ end;++def moveCartToDiagonal =+ doN 16 oneLap;+ end;+++def go =+ doN 4 moveCartToDiagonal;+ end;++go;
@@ -1,6 +1,6 @@-def forever : cmd unit -> cmd unit = \c. c ; forever c end+def forever : Cmd Unit -> Cmd Unit = \c. c ; forever c end -def repeat : int -> cmd unit -> cmd unit =+def repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end @@ -9,7 +9,7 @@ def abs = \n. if (n < 0) {-n} {n} end -def randdir : cmd dir =+def randdir : Cmd Dir = d <- random 4; return ( if (d == 0) {north}@@ -19,7 +19,7 @@ ) end -def chooseWait : cmd int =+def chooseWait : Cmd Int = t <- random (16*2); return (16 + t) end@@ -35,7 +35,7 @@ def disappointed = \cat. say "meow??"; cat end -def follow : cmd unit -> actor -> cmd unit = \cat. \r.+def follow : Cmd Unit -> Actor -> Cmd Unit = \cat. \r. rLoc <- as r {whereami}; myLoc <- whereami; let dx = fst rLoc - fst myLoc in
@@ -0,0 +1,161 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def isDivisibleBy = \dividend. \divisor.+ (dividend / divisor) * divisor == dividend;+ end;++def isEven = \x.+ isDivisibleBy x 2+ end;++def getMissingBitRecursive = \bitmask. \idx.+ if (idx > 0) {+ if (isEven bitmask) {+ idx+ } {+ getMissingBitRecursive (bitmask / 2) $ idx - 1;+ }+ } {+ // The MSB was the missing bit.+ 0;+ }+ end;++/**+Returns the index of the right-most bit that is zero.+*/+def getMissingBit = \bitmask. \maxIdx.+ let val = getMissingBitRecursive bitmask maxIdx in+ maxIdx - val;+ end;++/**+Performs a right bitshift of "x" by "n" places+*/+def shiftRight = \x. \n.+ x / (2^n);+ end;++/**+Performs a left bitshift of "x" by "n" places+*/+def shiftLeft = \x. \n.+ x * (2^n);+ end;++/**+Checks whether the bit at index "idx" is set in the "bitmask".+zero-based indexing; 0 is the LSB.+*/+def isBitSet = \bitmask. \idx.+ not $ isEven $ shiftRight bitmask idx;+ end;++/**+Repeatedly generate a random number until+we find one that's not in the bitmask.+*/+def getUnusedRandom = \maxval. \bitmask.+ nextRandomVal <- random maxval;+ if (isBitSet bitmask nextRandomVal) {+ getUnusedRandom maxval bitmask;+ } {+ return nextRandomVal;+ }+ end;++/**+Use the `random` function to generate a random permuation of `n` contiguous values.+Uses a bitmask to ensure uniqueness.++Fisher-Yates would be more efficient, but requires a physical array.+*/+def naiveRandomStack = \valueFunc. \maxval. \bitmask. \n.+ val <- if (n > 1) {+ nextRandomVal <- getUnusedRandom maxval bitmask;+ let newBitmask = bitmask + shiftLeft 1 nextRandomVal in+ naiveRandomStack valueFunc maxval newBitmask $ n - 1;+ return nextRandomVal;+ } {+ // We're at the peak of the stack.+ // Now we unwind it.++ // Saves some time in generating the last number by inferring the+ // only remaining possible choice.+ let missingBit = getMissingBit bitmask maxval in+ return missingBit;+ };+ valueFunc val;+ end;++def getEntName = \idx.+ result <- tagmembers "bust" idx;+ return $ snd result;+ end;++def placeThing = \entIdx.+ entName <- getEntName entIdx;+ create entName;+ place entName;+ end;++def placeEntByIndex = \bitIndex.+ placeThing bitIndex;+ move;+ end;++/*+Generates a constant-time lookup table from+name to ordinal for both the judge robot+and the base.++The "baseExtraCount" gets carried over+across iterations to ensure the count for each+bust in the base's inventory increases monotonically.++"idx" counts upwards.+*/+def populateInventory = \baseCount. \idx.+ + result <- tagmembers "bust" idx;+ let total = fst result in++ if (idx < total) {++ let item = snd result in++ // Give copies to the base+ baseExtras <- random 5;+ let newBaseCount = 1 + baseCount + baseExtras in+ doN newBaseCount (+ create item;+ give base item;+ );++ // Keep copies for myself+ doN (idx + 1) (+ create item;+ );++ populateInventory newBaseCount $ idx + 1;+ } {};++ end;++def setup =+ result <- tagmembers "bust" 0;+ let totalCount = fst result in++ populateInventory 0 0;++ naiveRandomStack placeEntByIndex totalCount 0 totalCount;+ turn back;+ move;+ create "bitcoin";+ end;++def go =+ instant setup;+ end;++go;
@@ -0,0 +1,117 @@+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++def countRow = \currentCount.+ emptyHere <- isempty;+ if emptyHere {+ return currentCount;+ } {+ move;+ countRow $ 1 + currentCount;+ };+ end;++def getOrdinal = \d.+ maybeEntity <- scan d;+ case maybeEntity (\nothing. return $ inL nothing) (\item.+ myCount <- count item;+ return $ inR myCount;+ );+ end;++/*+Precondition:+Facing west, just north of the row.+*/+def moveToBeginning =+ thingLeft <- scan left;+ case thingLeft (\_.+ turn back;+ move; + ) (\_.+ move;+ moveToBeginning;+ );+ end;++def doSwap =+ turn right;+ push;+ turn right;+ move;+ move;+ turn back;+ push;+ move;+ move;+ turn right;+ move;+ turn right;+ push;+ turn left;+ move;+ turn right;+ move;+ turn right;+ push;+ move;+ move;+ turn right;+ move;+ end;++/*+Precondition:+Standing just north of the eastern+member in the pair, and facing east.++Postcondition:+Moved one space east from staring position+in the same orientation.+*/+def swapAdjacent = \remainingSteps. \previousOrdinal.+ thisOrdinal <- if (remainingSteps > 1) {+ getOrdinal right;+ } {+ return $ inL ();+ };++ case thisOrdinal (\_.+ turn back;+ move;+ moveToBeginning;+ ) (\num.+ let shouldSwap = num < previousOrdinal in+ ordinal <- if shouldSwap {+ doSwap;+ return previousOrdinal;+ } {+ return num;+ };+ move;+ swapAdjacent (remainingSteps - 1) ordinal;+ );+ end;++def doLoop = \unsortedCount.+ if (unsortedCount > 1) {+ prevOrdinal <- getOrdinal right;+ move;+ case prevOrdinal return $ swapAdjacent unsortedCount;+ doLoop $ unsortedCount - 1;+ } {}+ end;++def go =+ move;+ move;+ move;+ totalCount <- countRow 0;+ turn back;+ doN totalCount move;+ turn right;+ move;+ turn right;+ doLoop totalCount;+ end;++go;
@@ -99,11 +99,11 @@ say $ snd tauntStage; } {}; - appear "o";+ appear "o" (inl ()); arrive width height; place dropping;- appear "G";+ appear "G" (inl ()); waitWhileHere dropping 150; go width height tauntIndex startingAmount dropping; } {
@@ -37,7 +37,7 @@ return isBlocked; end; -def chooseDirection : cmd dir =+def chooseDirection : Cmd Dir = leftBlocked <- checkLeftBlocked; rightBlocked <- checkRightBlocked; forwardBlocked <- isBlockedAhead;@@ -117,19 +117,6 @@ } end; -// Ghosts must implement teleporting logic themselves.-// Hard-codes location of the teleporter.-def checkNeedsTeleport = \offset.- currentLoc <- whereami;- if (fst currentLoc < -offset) {- teleport self (offset, snd currentLoc)- } {- if (fst currentLoc > offset) {- teleport self (-offset, snd currentLoc)- } {}- }- end;- startPos <- whereami; def go =@@ -138,7 +125,6 @@ teleport self startPos; } { move;- checkNeedsTeleport 11; newDirection <- chooseDirection; turn newDirection; go;
@@ -126,7 +126,7 @@ end; def invadeDen =- doN 14 move;+ doN 13 move; turn right; doN 2 move; turn left;
@@ -0,0 +1,22 @@+/* Algorithm:+If, at any point, the base is more than two cells from its previous location,+it must have teleported.+*/++def abs = \n. if (n<0) {-n} {n} end;++def getBasePos =+ as base {whereami};+ end;++def go = \lastBasePos.+ wait 1;+ curBasePos <- getBasePos;+ let deltaX = abs(fst curBasePos - fst lastBasePos) in+ if (deltaX > 1) {+ create "bit (0)";+ } {go curBasePos};+ end;++curBasePos <- getBasePos;+go curBasePos;
@@ -1,41 +0,0 @@-/* Algorithm:-If the player was previously on one side of me upon last inspection-and is now on top of me or on the other side, teleport them across-the map.-*/--def isBeyond = \func.- basePos <- as base {- whereami;- };- return $ func $ fst basePos;- end;--def observeAndTeleport = \criteriaFunc. \telporterPos. \wasExceeded.- currentlyExceeded <- isBeyond criteriaFunc;-- // Boundary was crossed- if (currentlyExceeded && not wasExceeded) {- teleport base (-(fst telporterPos), snd telporterPos);- create "bit (0)";- } {};-- observeAndTeleport criteriaFunc telporterPos currentlyExceeded;- end;--def init =- telporterPos <- whereami;- let teleX = fst telporterPos in- let isWesternTeleporter = teleX < 0 in-- criteriaFunc <- if isWesternTeleporter {- return $ \baseX. baseX < teleX;- } {- return $ \baseX. baseX > teleX;- };-- initiallyBeyond <- isBeyond criteriaFunc;- observeAndTeleport criteriaFunc telporterPos initiallyBeyond;- end;--init;
@@ -42,12 +42,12 @@ end; def hanoi :- int -> // The number of disks in each column- int -> // Current column (basically offset of all columns)- int -> // The offset to first column- int -> // The offset to second column- int -> // The offset to third column- cmd int+ Int -> // The number of disks in each column+ Int -> // Current column (basically offset of all columns)+ Int -> // The offset to first column+ Int -> // The offset to second column+ Int -> // The offset to third column+ Cmd Int = \n. \o. \a. \b. \c. if (n == 0) {return o} {
@@ -7,7 +7,7 @@ end; // modulus function (%)-def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -137,7 +137,7 @@ teleport self (0, snd curLoc - 1); end; -def shouldCorrectTile : (bool * bool) -> (bool * bool) -> cmd bool = \evenOverlaps. \isQuietTiles.+def shouldCorrectTile : (Bool * Bool) -> (Bool * Bool) -> Cmd Bool = \evenOverlaps. \isQuietTiles. if (evenOverlaps == isQuietTiles) { toggleLightHere; return true;@@ -189,13 +189,8 @@ return (0, 0); } { advanceRowViaTeleport;-- // This reassignment has to happen before the recursive- // "prepareBoardAllRows" call due to #1032- let rowCommonCountFoo = rowCommonCount in totalCommonCount <- prepareBoardAllRows abortFunc boardWidth $ rowIdx - 1;-- return $ sumTuples rowCommonCountFoo totalCommonCount+ return $ sumTuples rowCommonCount totalCommonCount } } { return (0, 0);@@ -220,7 +215,7 @@ return retval; end; -def analyzeSolvability : int -> int -> cmd (bool * bool) = \boardWidth. \boardHeight.+def analyzeSolvability : Int -> Int -> Cmd (Bool * Bool) = \boardWidth. \boardHeight. atLocation (0, 0) $ checkIsSolvable boardWidth boardHeight; end;
@@ -2,7 +2,7 @@ def else = \t. t end def abs = \n. if (n < 0) {-n} {n} end // modulus function (%)-def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -17,7 +17,7 @@ This is same as the standard graph quadrants in mathematics, except for 0-based numbering rather than 1-based. */-def getQuadrant : (int * int) -> (int * int) -> int = \baseLoc. \myLoc.+def getQuadrant : (Int * Int) -> (Int * Int) -> Int = \baseLoc. \myLoc. let baseX = fst baseLoc in let baseY = snd baseLoc in @@ -53,7 +53,7 @@ $ else {0} end; -def getCurrentQuadrant : (int * int) -> cmd int = \myLoc.+def getCurrentQuadrant : (Int * Int) -> Cmd Int = \myLoc. baseLoc <- as base {whereami}; return $ getQuadrant baseLoc myLoc; end;@@ -80,7 +80,7 @@ means that the traversal number could get out of sync with the absolute quadrant index. */-def monitorAngle : (int * int) -> int -> int -> int -> cmd unit =+def monitorAngle : (Int * Int) -> Int -> Int -> Int -> Cmd Unit = \myLoc. \targetQuadrantCount. \prevQuadrant. \quadrantTraversalCount. result <- instant $ checkNewQuadrant myLoc prevQuadrant quadrantTraversalCount; let currentQuadrant = fst result in
@@ -0,0 +1,67 @@+move;+place "j-tile";+move;+place "j-tile";+turn left;+move;+place "j-tile";+move;+place "j-tile";++turn back;+move; move;+turn left;+move;++place "t-tile";+move;+place "t-tile";+turn left;+move;+place "t-tile";+turn back;+move;+turn left;+move;+place "t-tile";++turn back;+move;+move;+turn right;+move;++place "z-tile";+move;+place "z-tile";+turn right;+move;+place "z-tile";+turn left;+move;+place "z-tile";++turn left;+move;++place "i-tile";+move;+place "i-tile";+move;+place "i-tile";+move;+place "i-tile";++turn left;+move;++place "q-tile";+move;+turn left;+place "q-tile";+move;+turn left;+place "q-tile";+move;+turn left;+place "q-tile";
@@ -153,7 +153,7 @@ return letterIndex; end; -def crossBack = \n.+def crossBack = \_n. currentLoc <- whereami; teleport self (0, snd currentLoc - 1); end;
@@ -1,183 +0,0 @@-/**-Algorithm:-We only need to check the base's-current position: if we find three contiguous highlights,-then we know that the player has just completed their-third highlight.-*/--def whichOrdinal =- isC <- ishere "lowercase c";- if (isC) {- return 0;- } {- isO <- ishere "lowercase o";- if (isO) {- return 1;- } {- isW <- ishere "lowercase w";- if (isW) {- return 2;- } {- return (-1);- }- }- }- end;---def whichHighlightedOrdinal = \str.- if (str == "lowercase c") {- return 0;- } {- if (str == "lowercase o") {- return 1;- } {- if (str == "lowercase w") {- return 2;- } {- return (-1);- }- }- }- end;--def countConsecutive = \expectedOrdinal. \n.-- thisOrdinal <- whichOrdinal;- nextOrdinal <- if (thisOrdinal == expectedOrdinal) {- return $ expectedOrdinal + 1;- } {- return 0;- };-- if (nextOrdinal == 3) {- return true;- } {- if (n > 1) {- move;- countConsecutive nextOrdinal $ n - 1;- } {- return false;- };- };- end;--def checkBackAndForth =-- foundBackward <- countConsecutive 0 3;- if (foundBackward) {- return true;- } {- turn back;- countConsecutive 0 3;- }- end;--def checkDirections = \n.- if (n > 0) {- wasFound <- checkBackAndForth;- if wasFound {- return true;- } {- turn left;- checkDirections $ n - 1;- }- } {- return false;- }- end;--def isMarkedInDirection = \d.- scanResult <- scan d;- ordinalNum <- case scanResult- (\_. return (-1))- whichHighlightedOrdinal;- return $ ordinalNum >= 0;- end;--/**-It's possible we could be one cell away from-a marked cell after finishing, either due-to using a directional `drill` command instead of-`drill down`, or due to an apparent bug which-does not evaluate the goal condition between the-`drill` and a `move` command.-*/-def moveToMarkedCell = \n.- if (n > 0) {- isMarkedAhead <- isMarkedInDirection forward;- if isMarkedAhead {- move;- return true;- } {- turn left;- moveToMarkedCell $ n - 1;- };- } {- return false;- };- end;--/**-Orient ourselves such that-a marked cell is behind us.-*/-def findMarkBehind = \n.- if (n > 0) {- isMarkedBehind <- isMarkedInDirection back;- if isMarkedBehind {- return true;- } {- turn left;- findMarkBehind $ n - 1;- };- } {- return false;- };- end;--/**-The cell we're on might be in the middle of a word,-rather than the end. Determine the orientation of-the line, then move along it until reaching the end.--Algorithm:-0. Assumption: we are currently on a marked cell.-1. Turn in all all four directions to `scan back`- for a second marked cell. Stop turning if- we encounter one.- If none found after 4 turns, abort.-2. `scan forward` to see if there is a marked cell in- the opposite direction.- `move` (foward) once if there is. Since the word- is only three cells long, this will be the other- end of it.-*/-def moveToWordExtrema =- foundCellBehind <- findMarkBehind 4;- if foundCellBehind {- isMarkedAhead <- isMarkedInDirection forward;- if isMarkedAhead {- move;- } {};- } {};- end;--def checkSoln =- isMarkedHere <- isMarkedInDirection down;- atMarkedCell <- if isMarkedHere {- return true;- } {- moveToMarkedCell 4;- };-- if atMarkedCell {- moveToWordExtrema;- checkDirections 4;- } {- return false;- }- end;--as base {checkSoln};
@@ -57,7 +57,7 @@ bg: '#000000' robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - antenna@@ -78,7 +78,7 @@ inventory: - [5, paperclip] solution: |- run "scenarios/Challenges/_arbitrage/solution.sw"+ run "scenarios/Challenges/_arbitrage/solution.sw" entities: - name: paperclip display:@@ -87,95 +87,95 @@ description: - An ubiquitous office accoutrement. - Practically worthless as a single unit.- properties: [known, portable]+ properties: [known, pickable] - name: pinwheel display: char: 'P' attr: gold description: - Watch it spin. Wheee!- properties: [portable]+ properties: [pickable] - name: stapler display: char: 'S' attr: red description: - A shiny red stapler- properties: [portable]+ properties: [pickable] - name: toothbrush display: char: 'b' attr: blue description: - Brushy brushy- properties: [portable]+ properties: [pickable] - name: Pez dispenser display: char: 'P' description: - Classic collectible toy. Absent its chalky candy.- properties: [portable]+ properties: [pickable] - name: shoehorn display: char: 'h' description: - Handheld apparatus for donning snug footwear- properties: [portable]+ properties: [pickable] - name: trivet display: char: 'v' description: - Protective silicone mat for hot cookware- properties: [portable]+ properties: [pickable] - name: coffee mug display: char: 'c' description: - Caffeine conveyance- properties: [portable]+ properties: [pickable] - name: toaster display: char: 'A' description: - Bread warmer-upper- properties: [portable]+ properties: [pickable] - name: blender display: char: 'B' description: - Essential for smoothie preparation- properties: [portable]+ properties: [pickable] - name: electric can opener display: char: 'B' description: - | For when you can't be bothered to manually open a can- properties: [portable]+ properties: [pickable] - name: wok display: char: 'w' description: - One must wok before one can run.- properties: [portable]+ properties: [pickable] - name: sous vide cooker display: char: 's' description: - trendy gourmet cooking appliance- properties: [portable]+ properties: [pickable] - name: french press display: char: 'f' description: - plunger-based coffee maker- properties: [portable]+ properties: [pickable] - name: stand mixer display: char: 'm' description: - whips, kneads, and mixes- properties: [portable]+ properties: [pickable] - name: shopA display: char: 'A'
@@ -44,8 +44,8 @@ Distinguishes system bots from the base by name. Returns true if a bot has "met" the base. */- def anyHasMetBase : int -> cmd bool = \idx.- + def anyHasMetBase : Int -> Cmd Bool = \idx.+ try { bot <- robotnumbered idx; intermediate <- hasMetBase bot;@@ -63,7 +63,7 @@ anyHasMetBase 1; robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - binoculars@@ -87,7 +87,7 @@ - welder - name: cw_robot system: true- dir: [0, 1]+ dir: north display: invisible: false char: 'X'@@ -96,7 +96,7 @@ run "scenarios/Challenges/_blender/patrol-clockwise.sw" - name: cw_robot_down system: true- dir: [0, -1]+ dir: south display: invisible: false char: 'X'@@ -105,7 +105,7 @@ run "scenarios/Challenges/_blender/patrol-clockwise.sw" - name: ccw_robot system: true- dir: [0, 1]+ dir: north display: invisible: false char: 'X'@@ -114,7 +114,7 @@ run "scenarios/Challenges/_blender/patrol-counter-clockwise.sw" - name: ccw_robot_down system: true- dir: [0, -1]+ dir: south display: invisible: false char: 'X'@@ -151,7 +151,7 @@ attr: gold description: - used to unlock a door- properties: [known, portable]+ properties: [known, pickable] capabilities: [drill] - name: bind gt display:@@ -173,7 +173,7 @@ attr: snow description: - The figurative jewel of category theory- properties: [known, portable]+ properties: [known, pickable] recipes: - in: - [1, locked door]
@@ -87,13 +87,8 @@ - id: get_map teaser: Get the map goal:- - As a humble `peat`{=entity} farmer, you subsist in a simple cabin by the `bog`{=entity}.- Though long content with this ascetic lifestyle, recently the barren walls have- left you restless. Something is missing...- - "The majestic landscape that is your back yard is insufficient to distract you---not- even the ferocious, `lava`{=entity}-spewing volcano little more than a stone's throw from- your porch.- You are preoccupied by one task: to find the perfect household decoration."+ - As a humble `peat`{=entity} farmer, you subsist in a simple cabin by the `bog`{=entity}. Though long content with this ascetic lifestyle, recently the barren walls have left you restless. Something is missing...+ - "The majestic landscape that is your back yard is insufficient to distract you---not even the ferocious, `lava`{=entity}-spewing volcano little more than a stone's throw from your porch. You are preoccupied by one task: to find the perfect household decoration." - First, grab a `map`{=entity} to orient yourself. condition: | as base {@@ -104,19 +99,11 @@ prerequisite: get_map goal: - You study the `map`{=entity}.- - Glacier-bound mountains tower in the `east`,- a volcano oozes a river of `lava`{=entity} to the `north`, and beyond that lies a mountain lake, punctuated with islands- in the northwest.- Iron mines penetrate the base of the volcano. They could be useful, but how will you get there?- - A `jungle`{=entity} abuts the volcano, ensconcing an ancient ruin.- The map notes that bygone travelers have stashed tools among the northeasterly mountains to- blaze a path through the jungle.+ - Glacier-bound mountains tower in the `east`, a volcano oozes a river of `lava`{=entity} to the `north`, and beyond that lies a mountain lake, punctuated with islands in the northwest. Iron mines penetrate the base of the volcano. They could be useful, but how will you get there?+ - A `jungle`{=entity} abuts the volcano, ensconcing an ancient ruin. The map notes that bygone travelers have stashed tools among the northeasterly mountains to blaze a path through the jungle. - Your only neighbor, a `hemp`{=entity} farmer to the northwest, has evacuated since the sudden volcanic eruption.- - A disused quarry and clay pit flanks your cabin to the `west`, as does the familiar, swampy `bog`{=entity} to the `east`.- A highly-prized `flower`{=entity} is said to grow in the caves beyond the bog.- - Your mind is made up. You will pillage the ruins for treasure! Head to the ruins and `scan` them.- Ingenuity and endurance are your allies as you forge paths through varied obstacles.- Study your "recipes" for clues!+ - A disused quarry and clay pit flanks your cabin to the `west`, as does the familiar, swampy `bog`{=entity} to the `east`. A highly-prized `flower`{=entity} is said to grow in the caves beyond the bog.+ - Your mind is made up. You will pillage the ruins for treasure! Head to the ruins and `scan` them. Ingenuity and endurance are your allies as you forge paths through varied obstacles. Study your "recipes" for clues! condition: | as base { knows "temple";@@ -126,8 +113,7 @@ prerequisite: find_temple goal: - "A note on the door says:"- - '"Greetings, intrepid traveler. Encircle this temple with the rare `flower`{=entity} of the southeastern- caves, and the treasure of this `temple`{=entity} shall be revealed."'+ - '"Greetings, intrepid traveler. Encircle this temple with the rare `flower`{=entity} of the southeastern caves, and the treasure of this `temple`{=entity} shall be revealed."' - Plant a ring of flowers around the jungle temple. condition: | as base {@@ -145,7 +131,7 @@ }; robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor@@ -181,7 +167,7 @@ - [0, jungle] - name: flowercheck system: true- dir: [0, 1]+ dir: north display: invisible: true devices:@@ -192,7 +178,7 @@ run "scenarios/Challenges/_bridge-building/flower-ring-check.sw" - name: platecheck system: true- dir: [0, 1]+ dir: north display: invisible: true solution: |@@ -204,21 +190,21 @@ attr: 'magenta' description: - The map describes local points of interest, relative to your cabin.- properties: [portable, known]+ properties: [pickable, known] - name: peat furnace display: char: 'F' attr: tan description: - Fueled by peat.- properties: [portable, known]+ properties: [pickable, known] - name: clay display: char: 'c' attr: tan description: - Can be fired in a peat furnace into a vessel.- properties: [portable, known]+ properties: [pickable, known] - name: lava display: char: 'w'@@ -232,21 +218,21 @@ attr: tan description: - A tiny, inconsequential rock.- properties: [known, portable]+ properties: [known, pickable] - name: machete display: char: '/' attr: cyan description: - Easily cuts through jungle overgrowth.- properties: [known, portable]+ properties: [known, pickable] - name: painted plate display: char: 'o' attr: obsidian description: - Limited edition 1978 collectible Helix the Cat ornamental hand-painted dinner plate.- properties: [known, portable]+ properties: [known, pickable] - name: oven mitts display: char: 'm'@@ -286,7 +272,7 @@ attr: silver description: - Can break hard objects- properties: [known, portable]+ properties: [known, pickable] - name: granite mountain display: char: 'A'@@ -312,35 +298,35 @@ char: 'L' description: - Can be used to traverse down a cliff.- properties: [known, portable]+ properties: [known, pickable] - name: hemp display: char: 'h' attr: plant description: - Can be used to make rope- properties: [known, portable, growable]+ properties: [known, pickable, growable] - name: flimsy board display: char: 'b' attr: wood description: - Board made from a soft log. Has poor rigidity.- properties: [known, portable]+ properties: [known, pickable] - name: soft log display: char: 'l' attr: wood description: - Log made from a palm tree. A bit flexible.- properties: [known, portable]+ properties: [known, pickable] - name: coconut display: char: 'c' attr: wood description: - Spherical, buoyant husk- properties: [known, portable]+ properties: [known, pickable] - name: floating boardwalk display: char: '▒'@@ -354,7 +340,7 @@ attr: wood description: - Burnable plant material- properties: [known, portable]+ properties: [known, pickable] - name: peat bog display: char: 'b'@@ -388,14 +374,14 @@ char: 'c' description: - An empty crucible. Can carry lava.- properties: [known, portable]+ properties: [known, pickable] - name: lava-filled crucible display: char: 'C' attr: lavaBG description: - Crucible filled with lava- properties: [known, portable]+ properties: [known, pickable] - name: quarry display: char: 'Q'@@ -450,13 +436,13 @@ char: 'r' description: - An empty container for rubble.- properties: [known, portable]+ properties: [known, pickable] - name: rubble-filled skip display: char: 'R' description: - An full container of rubble. Can be dumped in the water as fill to form a causeway.- properties: [known, portable]+ properties: [known, pickable] - name: causeway display: char: '▒'@@ -468,14 +454,14 @@ char: 'k' description: - Tank with nothing in it- properties: [known, portable]+ properties: [known, pickable] - name: water-filled tank display: char: 'K' attr: blueBG description: - Tank filled with water- properties: [known, portable]+ properties: [known, pickable] - name: obsidian path display: char: '`'@@ -489,14 +475,14 @@ attr: obsidian description: - Dislodged fragment of obsidian- properties: [known, portable]+ properties: [known, pickable] - name: palm tree display: char: 'P' attr: beach description: - Palm tree.- properties: [known, portable, growable]+ properties: [known, pickable, growable] recipes: - in: - [8, clay]
@@ -10,7 +10,7 @@ char: 'Ω' attr: robot heavy: true- dir: [0, 1]+ dir: north devices: - 3D printer - ADT calculator@@ -35,7 +35,7 @@ - [1, treads] - name: hauler system: true- dir: [-1, 0]+ dir: west devices: - furnace display:@@ -46,7 +46,7 @@ run "scenarios/Challenges/_bucket-brigade/hauler.sw" - name: powerplant system: true- dir: [1, 0]+ dir: east display: invisible: false char: '▒'@@ -70,10 +70,8 @@ as base {has "coal lump"} - goal: - Your base got some coal!- - Now fashion more of it into a "coal briquette", and place it- so that the hauler (=) can pick it up.- - The hauler will periodically stop at the base- to check if a load is available.+ - Now fashion more of it into a "coal briquette", and place it so that the hauler (=) can pick it up.+ - The hauler will periodically stop at the base to check if a load is available. condition: | hauler <- robotnamed "hauler"; as hauler {has "coal briquette"}@@ -86,7 +84,7 @@ char: 'x' description: - A powerful machine designed to remove overburden in mining operations.- properties: [known, portable]+ properties: [known, pickable] capabilities: [drill] - name: lignite mine display:@@ -100,31 +98,31 @@ char: 'c' description: - Primitive, sooty fuel.- properties: [known, portable]+ properties: [known, pickable] - name: coal briquette display: char: 'q' description: - A compressed, convenient form of coal for consumption and transport.- properties: [known, portable]+ properties: [known, pickable] - name: briquette press display: char: 'P' description: - A device to compress coal lumps into briquettes.- properties: [known, portable]+ properties: [known, pickable] - name: energy display: char: 'E' description: - The result of burning a coal briquettte.- properties: [portable]+ properties: [pickable] - name: repro kit display: char: 'k' description: - Kit that can be unpacked into everything a robot needs to reproduce.- properties: [known, portable]+ properties: [known, pickable] recipes: - in: - [1, repro kit]@@ -174,8 +172,6 @@ - [1, energy] required: - [1, furnace]-- known: [boulder, lignite mine] seed: 0 world:
@@ -4,9 +4,8 @@ description: In this quirky challenge, you move as the chess knight piece. Can you capture the enemy king? objectives: - goal:- - Robots can use the `move` command to move.- But they only `turn` in cardinal directions.- - You are special. You are a knight. + - Robots can use the `move` command to move. But they only `turn` in cardinal directions.+ - You are special. You are a knight. - Go forth and capture the King! condition: | try {@@ -19,8 +18,8 @@ move; move; move; turn right; move; turn left; move; robots: - name: horse- loc: [0,0]- dir: [2,-1]+ loc: [0, 0]+ dir: [2, -1] devices: - treads - logger@@ -28,8 +27,8 @@ display: char: '♘' - name: king- loc: [7,-6]- dir: [0,0]+ loc: [7, -6]+ dir: [0, 0] display: char: '♚' known: [water]
@@ -22,7 +22,7 @@ as base {has "bitcoin"}; robots: - name: base- dir: [1, 0]+ dir: east display: invisible: false devices:@@ -44,13 +44,13 @@ - treads - name: lockbot system: true- dir: [1, 0]+ dir: east display: invisible: true program: | run "scenarios/Challenges/_combo-lock/setup.sw" solution: |- run "scenarios/Challenges/_combo-lock/solution.sw"+ run "scenarios/Challenges/_combo-lock/solution.sw" entities: - name: gate display:@@ -81,25 +81,25 @@ properties: [known] recipes: - in:- - [1, "dial (R)"]+ - [1, "dial (R)"] out:- - [1, "dial (G)"]+ - [1, "dial (G)"] required:- - [1, drill]+ - [1, drill] time: 0 - in:- - [1, "dial (G)"]+ - [1, "dial (G)"] out:- - [1, "dial (B)"]+ - [1, "dial (B)"] required:- - [1, drill]+ - [1, drill] time: 0 - in:- - [1, "dial (B)"]+ - [1, "dial (B)"] out:- - [1, "dial (R)"]+ - [1, "dial (R)"] required:- - [1, drill]+ - [1, drill] time: 0 known: [boulder, water, bitcoin] world:
@@ -0,0 +1,157 @@+version: 1+name: Dim sum+creative: false+description: Serve restaurant patrons with the dim sum cart.+objectives:+ - goal:+ - It is the grand opening of Sigma (Σ), the hot new dim sum restaurant in town. You are the solitary wait staff.+ - It seems that the manager went a bit overboard on furniture; there are dozens of `table`{=entity}s, but hardly any room to walk!+ - Serve the blue patron with a `full cart`{=entity} (f) of food, twice.+ - The `empty cart`{=entity} (e) must be `push`ed to the northwest corner for the cook to load it with food.+ condition: |+ p <- robotnamed "patron";+ as p {+ foodCount <- count "food";+ return $ foodCount >= 2;+ }+solution: |+ run "scenarios/Challenges/_dimsum/solution.sw"+robots:+ - name: base+ dir: [1, 0]+ devices:+ - branch predictor+ - ADT calculator+ - compass+ - comparator+ - dictionary+ - grabber+ - lambda+ - logger+ - net+ - scanner+ - strange loop+ - treads+ - dozer blade+ - name: cook+ dir: [0, -1]+ system: false+ display:+ invisible: false+ attr: red+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - dictionary+ - lambda+ - logger+ - rolex+ - scanner+ - spatula+ program: |+ run "scenarios/Challenges/_dimsum/cook.sw"+ - name: patron+ dir: [0, 1]+ system: false+ display:+ invisible: false+ attr: blue+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - dictionary+ - lambda+ - logger+ - rolex+ - scanner+ - strange loop+ - fork+ inventory:+ - [2, bitcoin]+ program: |+ run "scenarios/Challenges/_dimsum/patron.sw"+entities:+ - name: table+ display:+ attr: wood+ char: 't'+ description:+ - Pushable table+ properties: [known, pushable]+ - name: spatula+ display:+ char: 's'+ description:+ - Serving utensil for the cart+ properties: [known, pickable]+ - name: fork+ display:+ char: 'k'+ description:+ - Eating utensil for patron+ properties: [known, pickable]+ - name: food+ display:+ char: 'f'+ description:+ - Food from the cart+ properties: [known, pickable]+ - name: empty cart+ display:+ attr: copper+ char: 'e'+ description:+ - Food cart+ properties: [known, pushable]+ - name: full cart+ display:+ attr: gold+ char: 'f'+ description:+ - Food cart+ properties: [known, pushable]+recipes:+ - in:+ - [1, empty cart]+ out:+ - [1, full cart]+ required:+ - [1, spatula]+ - in:+ - [1, full cart]+ out:+ - [1, empty cart]+ - [1, food]+ required:+ - [1, fork]+known: [boulder, bitcoin]+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, erase, base]+ '.': [grass, erase]+ 'S': [dirt, erase]+ '@': [grass, boulder]+ 'd': [grass, table]+ 'k': [grass, table, cook]+ 'p': [grass, table, patron]+ 's': [grass, empty cart]+ 'x': [stone, erase]+ upperleft: [0, 0]+ map: |+ .@@@.........+ .@k@@@@@@@@x@+ .@Bddddddddd@+ .@dxxxxxxxd@@+ .@dxSSSSSxd@.+ .@dxxSxxxxd@.+ .@dxxxSxxxd@.+ .@dxxSxxxxd@.+ .@dxSSSSSxd@.+ @@dxxxxxxxd@.+ @ddddddddds@.+ @x@@@@@@@@p@.+ .........@@@.
@@ -10,7 +10,7 @@ char: 'Ω' attr: robot heavy: true- dir: [0, 1]+ dir: north devices: - 3D printer - ADT calculator@@ -47,7 +47,7 @@ - [10, calculator] - name: cat system: true- dir: [-1, 0]+ dir: west display: invisible: false char: 'c'@@ -58,9 +58,7 @@ run "scenarios/Challenges/_friend/cat.sw" objectives: - goal:- - There's a cat wandering around in the field. Bring it back to- your base. If you give it something it likes, perhaps you can- get it to follow you.+ - There's a cat wandering around in the field. Bring it back to your base. If you give it something it likes, perhaps you can get it to follow you. condition: | c <- robotNamed "cat"; catLoc <- as c {whereami};@@ -74,8 +72,7 @@ char: 'f' description: - A smelly fish. Rather unappetizing to a robot.- properties: [known, portable]-+ properties: [known, pickable] known: [fish] seed: 0 world:
@@ -0,0 +1,263 @@+version: 1+name: Art museum+author: Karl Ostmo+description: |+ Rearrange sculpture exhibit+creative: false+attrs:+ - name: bust1+ fg: "#008800"+ - name: bust2+ fg: "#ff8888"+ - name: bust3+ fg: "#0000ff"+ - name: bust4+ fg: "#880088"+ - name: bust5+ fg: "#884444"+ - name: bust6+ fg: "#00ffff"+ - name: bust7+ fg: "#880000"+ - name: bust8+ fg: "#ff0000"+ - name: bust9+ fg: "#000088"+ - name: bust10+ fg: "#884488"+ - name: bust11+ fg: "#ffff00"+ - name: bust12+ fg: "#008888"+ - name: bust13+ fg: "#ff00ff"+ - name: bust14+ fg: "#448844"+ - name: bust15+ fg: "#444488"+ - name: bust16+ fg: "#00ff00"+objectives:+ - teaser: Rearrange+ goal:+ - |+ A prankster has wreaked mischief in the hall of presidential busts!+ The sculptures just happen now to be in order of your personal presidential preference.+ - |+ Put the exhibits back into chronological order before the museum opens.+ - |+ The museum also sells replicas, and it so happens that the inventory of earlier+ presidents are invariably understocked relative to later ones.+ condition: |+ def ensureMonotonicDecreasing = \itemCount. \prevOrdinal.+ maybeEntity <- scan down;+ case maybeEntity (\_. return $ itemCount == 0) (\item.+ myCount <- count item;+ if (myCount <= prevOrdinal) {+ move;+ ensureMonotonicDecreasing (itemCount - 1) myCount;+ } {+ return false;+ };+ );+ end;++ j <- robotnamed "judge";+ as j {+ // Flag that setup is done+ hasBitcoin <- has "bitcoin";+ if hasBitcoin {+ result <- tagmembers "bust" 0;+ let itemCount = fst result in+ ensureMonotonicDecreasing itemCount $ itemCount + 1;+ } {+ return false;+ }+ };+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - counter+ - dozer blade+ - dictionary+ - Elmer's glue+ - lambda+ - linotype+ - logger+ - keyboard+ - scanner+ - strange loop+ - treads+ - name: judge+ system: true+ dir: east+ display:+ invisible: true+ program: |+ run "scenarios/Challenges/_gallery/setup.sw"+solution: |+ run "scenarios/Challenges/_gallery/solution.sw"+entities:+ - name: wall+ display:+ char: 'w'+ description:+ - Building boundary+ properties: [known, unwalkable]+ - name: George Washington+ display:+ char: '@'+ attr: bust1+ description:+ - The first president+ properties: [known, pushable]+ tags: [bust]+ - name: John Adams+ display:+ char: '@'+ attr: bust2+ description:+ - The second president+ properties: [known, pushable]+ tags: [bust]+ - name: Thomas Jefferson+ display:+ char: '@'+ attr: bust3+ description:+ - The third president+ properties: [known, pushable]+ tags: [bust]+ - name: James Madison+ display:+ char: '@'+ attr: bust4+ description:+ - The fourth president+ properties: [known, pushable]+ tags: [bust]+ - name: James Monroe+ display:+ char: '@'+ attr: bust5+ description:+ - The fifth president+ properties: [known, pushable]+ tags: [bust]+ - name: John Quincy Adams+ display:+ char: '@'+ attr: bust6+ description:+ - The sixth president+ properties: [known, pushable]+ tags: [bust]+ - name: Andrew Jackson+ display:+ char: '@'+ attr: bust7+ description:+ - The seventh president+ properties: [known, pushable]+ tags: [bust]+ - name: Martin Van Buren+ display:+ char: '@'+ attr: bust8+ description:+ - The eighth president+ properties: [known, pushable]+ tags: [bust]+ - name: William Henry Harrison+ display:+ char: '@'+ attr: bust9+ description:+ - The ninth president+ properties: [known, pushable]+ tags: [bust]+ - name: John Tyler+ display:+ char: '@'+ attr: bust10+ description:+ - The tenth president+ properties: [known, pushable]+ tags: [bust]+ - name: James K. Polk+ display:+ char: '@'+ attr: bust11+ description:+ - The eleventh president+ properties: [known, pushable]+ tags: [bust]+ - name: Zachary Taylor+ display:+ char: '@'+ attr: bust12+ description:+ - The twelfth president+ properties: [known, pushable]+ tags: [bust]+ - name: Millard Fillmore+ display:+ char: '@'+ attr: bust13+ description:+ - The thirteenth president+ properties: [known, pushable]+ tags: [bust]+ - name: Franklin Pierce+ display:+ char: '@'+ attr: bust14+ description:+ - The fourteenth president+ properties: [known, pushable]+ tags: [bust]+ - name: James Buchanan+ display:+ char: '@'+ attr: bust15+ description:+ - The fifteenth president+ properties: [known, pushable]+ tags: [bust]+ - name: Abraham Lincoln+ display:+ char: '@'+ attr: bust16+ description:+ - The sixteenth president+ properties: [known, pushable]+ tags: [bust]+known: []+world:+ dsl: |+ overlay+ [ {terrain: stone}+ , if (x/5 + (-y)/5) % 2 == 0 then {terrain: dirt} else {blank}+ , if (((3 - y) % 20)/11 + ((x + 3) % 20)/11) == 0 then {terrain: grass} else {blank}+ ]+ upperleft: [0, 11]+ offset: false+ palette:+ 'B': [stone, null, base]+ 'j': [stone, null, judge]+ 'x': [stone]+ 'd': [dirt]+ '.': [stone]+ 'w': [stone, wall]+ map: |+ wwwwwwwwwwwwwwwwwwwwwwwwww+ w........................w+ w...dddddddddddddddddd...w+ w.B.djxxxxxxxxxxxxxxxd...w+ w...dddddddddddddddddd...w+ w........................w+ wwwwwwwwwwwwwwwwwwwwwwwwww
@@ -41,7 +41,7 @@ loc: [-1, 1] display: attr: blue- dir: [1, 0]+ dir: east devices: - ADT calculator - 3D printer@@ -77,7 +77,7 @@ - [120, flower] - name: gopher system: true- dir: [0, 1]+ dir: north display: char: 'G' invisible: false@@ -110,14 +110,14 @@ capabilities: [turn] description: - Allows a robot to "turn" but not "move".- properties: [known, portable]+ properties: [known, pickable] - name: uranium display: char: 'U' attr: silver description: - Unearthed by industrious gophers.- properties: [known, portable]+ properties: [known, pickable] recipes: - in: - [1, mound]@@ -126,7 +126,7 @@ required: - [1, drill] solution: |- run "scenarios/Challenges/_gopher/solution.sw"+ run "scenarios/Challenges/_gopher/solution.sw" known: [] world: dsl: |
@@ -45,7 +45,7 @@ hasPowerup <- as ghost { has "donut"; };- + if hasPowerup { return true; } {@@ -76,7 +76,7 @@ - | Be teleported condition: |- r <- robotnamed "teleporter";+ r <- robotnamed "teleport_monitor"; loc <- as r { has "bit (0)" };@@ -104,7 +104,7 @@ hasPowerup <- as ghost { has "donut"; };- + if hasPowerup { if (n > 1) { allHasPowerup $ n - 1;@@ -127,7 +127,7 @@ south: 'n' char: 'U' attr: gold- dir: [1, 0]+ dir: east devices: - ADT calculator - antenna@@ -149,16 +149,16 @@ - strange loop - treads - workbench- - name: teleporter- dir: [0, 1]+ - name: teleport_monitor+ dir: north system: true display: invisible: true char: 'T' program: |- run "scenarios/Challenges/_hackman/teleporter.sw"+ run "scenarios/Challenges/_hackman/teleport_monitor.sw" - name: ghost1- dir: [0, 1]+ dir: north system: true display: invisible: false@@ -167,7 +167,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: ghost2- dir: [0, 1]+ dir: north system: true display: invisible: false@@ -176,7 +176,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: ghost3- dir: [0, 1]+ dir: north system: true display: invisible: false@@ -185,7 +185,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: ghost4- dir: [0, 1]+ dir: north system: true display: invisible: false@@ -194,7 +194,7 @@ program: | run "scenarios/Challenges/_hackman/ghost.sw" - name: fruit_maker- dir: [0, 1]+ dir: north system: true display: invisible: true@@ -211,7 +211,7 @@ description: - A caffeine pellet. - Helps Hackman produce more code.- properties: [known, portable]+ properties: [known, pickable] - name: donut display: char: 'o'@@ -219,14 +219,14 @@ description: - Breakfast of champions. - Fancied by ghosts. Will you share?- properties: [known, portable]+ properties: [known, pickable] - name: den key display: char: 'k' attr: gold description: - Opens a gate- properties: [known, portable]+ properties: [known, pickable] - name: strawberry display: char: 'v'@@ -234,7 +234,7 @@ description: - A tart berry - Possessing this fruit gives you great satisfaction.- properties: [known, portable]+ properties: [known, pickable] - name: gate display: char: '='@@ -249,17 +249,17 @@ properties: [known, unwalkable] recipes: - in:- - [181, "pellet"]+ - [181, "pellet"] out:- - [1, "den key"]+ - [1, "den key"] - in:- - [1, "den key"]- - [1, "gate"]+ - [1, "den key"]+ - [1, "gate"] out:- - [1, "den key"]+ - [1, "den key"] required:- - [1, drill]-solution:+ - [1, drill]+solution: | run "scenarios/Challenges/_hackman/solution.sw" known: [] seed: 0@@ -272,10 +272,10 @@ 'b': [blank, null, ghost2] 'c': [blank, null, ghost3] 'd': [blank, null, ghost4]- 'T': [blank, null, teleporter] '.': [blank, pellet] '*': [blank, donut] 'x': [blank, wall]+ 'T': [blank, null, teleport_monitor] '=': [blank, gate] '┌': [stone, upper left corner] '┐': [stone, upper right corner]@@ -283,27 +283,50 @@ '┘': [stone, lower right corner] '─': [stone, horizontal wall] '│': [stone, vertical wall]- upperleft: [-11, 10]+ 'W':+ cell: [blank]+ waypoint:+ name: western_exit+ 'X':+ cell: [blank]+ waypoint:+ name: western_entrance+ 'Y':+ cell: [blank]+ waypoint:+ name: eastern_exit+ 'Z':+ cell: [blank]+ waypoint:+ name: eastern_entrance+ portals:+ - entrance: eastern_entrance+ exitInfo:+ exit: western_exit+ - entrance: western_entrance+ exitInfo:+ exit: eastern_exit+ upperleft: [-12, 10] map: |-- xxxxxxxxxxxxxxxxxxxxxxx- x..........x..........x- x*xxx.xxxx.x.xxxx.xxx*x- x.xxx.xxxx.x.xxxx.xxx.x- x.....................x- x.xxx.x.xxxxxxx.x.xxx.x- x.....x....x....x.....x- xxxxx.xxxxBxBxxxx.xxxxx- BBBBx.xBBBBBBBBBx.xBBBB- xxxxx.xB┌──=──┐Bx.xxxxx- TBBBB.BB│abBcd│BB.BBBBT- xxxxx.xB└─────┘Bx.xxxxx- BBBBx.xBBBfΩBBBBx.xBBBB- xxxxx.xBxxxxxxxBx.xxxxx- x..........x..........x- x.xxx.xxxx.x.xxxx.xxx.x- x*..x.............x..*x- xxx.x.x.xxxxxxx.x.x.xxx- x.....x....x....x.....x- x.xxxxxxxx.x.xxxxxxxx.x- x.....................x- xxxxxxxxxxxxxxxxxxxxxxx+ BxxxxxxxxxxxxxxxxxxxxxxxT+ Bx..........x..........xB+ Bx*xxx.xxxx.x.xxxx.xxx*xB+ Bx.xxx.xxxx.x.xxxx.xxx.xB+ Bx.....................xB+ Bx.xxx.x.xxxxxxx.x.xxx.xB+ Bx.....x....x....x.....xB+ Bxxxxx.xxxxBxBxxxx.xxxxxB+ BBBBBx.xBBBBBBBBBx.xBBBBB+ Bxxxxx.xB┌──=──┐Bx.xxxxxB+ ZYBBBB.BB│abBcd│BB.BBBBWX+ Bxxxxx.xB└─────┘Bx.xxxxxB+ BBBBBx.xBBBfΩBBBBx.xBBBBB+ Bxxxxx.xBxxxxxxxBx.xxxxxB+ Bx..........x..........xB+ Bx.xxx.xxxx.x.xxxx.xxx.xB+ Bx*..x.............x..*xB+ Bxxx.x.x.xxxxxxx.x.x.xxxB+ Bx.....x....x....x.....xB+ Bx.xxxxxxxx.x.xxxxxxxx.xB+ Bx.....................xB+ BxxxxxxxxxxxxxxxxxxxxxxxB
@@ -4,10 +4,8 @@ description: The classic Towers of Hanoi puzzle with three disks. objectives: - goal:- - Move all the numbers (traditionally, "disks") from the- left column to the right column.- - You may only pick up one disk at a time, and you may never- place a larger disk on top of a smaller one.+ - Move all the numbers (traditionally, "disks") from the left column to the right column.+ - You may only pick up one disk at a time, and you may never place a larger disk on top of a smaller one. condition: | teleport self (2,-1); x <- ishere "one";@@ -20,7 +18,7 @@ run "scenarios/Challenges/_hanoi/hanoi-solution.sw" robots: - name: base- dir: [0,-1]+ dir: south devices: - net - treads@@ -35,17 +33,17 @@ - scanner - ADT calculator - name: invariant- dir: [0,0]+ dir: [0, 0] system: true devices:- - logger+ - logger inventory:- - [1, one]- - [1, two]- - [1, three]- - [1, blocked one]- - [1, blocked two]- - [1, blocked three]+ - [1, one]+ - [1, two]+ - [1, three]+ - [1, blocked one]+ - [1, blocked two]+ - [1, blocked three] program: | // if // 0. I stand on locked X@@ -62,12 +60,12 @@ // - lock X run "scenarios/Challenges/_hanoi/hanoi-invariant.sw" - name: increasing- dir: [0,0]+ dir: [0, 0] system: true inventory:- - [1, OK]+ - [1, OK] devices:- - logger+ - logger program: | // if // 0. all (but max 3) disks in my column are sorted@@ -77,13 +75,13 @@ // - try to grab "OK" run "scenarios/Challenges/_hanoi/hanoi-increasing.sw" - name: count- dir: [0,0]+ dir: [0, 0] system: true inventory:- - [1, two]- - [0, three]+ - [1, two]+ - [0, three] devices:- - logger+ - logger program: | // count all entities placed in columns // the final count should be either 2 or 3@@ -95,49 +93,49 @@ char: '┴' attr: entity description:- - A bottom tee wall.+ - A bottom tee wall. properties: [unwalkable] - name: three display: char: '3' attr: gold description:- - A disk of radius 3.- properties: [portable]+ - A disk of radius 3.+ properties: [pickable] - name: two display: char: '2' attr: gold description:- - A disk of radius 2.- properties: [portable]+ - A disk of radius 2.+ properties: [pickable] - name: one display: char: '1' attr: gold description:- - A disk of radius 1.- properties: [portable]+ - A disk of radius 1.+ properties: [pickable] - name: blocked one display: char: '1' attr: entity description:- - A disk of radius 1.+ - A disk of radius 1. properties: [unwalkable] - name: blocked two display: char: '2' attr: entity description:- - A disk of radius 2.+ - A disk of radius 2. properties: [unwalkable] - name: blocked three display: char: '3' attr: entity description:- - A disk of radius 3.+ - A disk of radius 3. properties: [unwalkable] - name: OK display:@@ -174,7 +172,6 @@ '.': [stone, null, invariant] '^': [grass, null, increasing] 'X': [grass, three, count]- upperleft: [-3, 1] map: | ┌─────┐
@@ -38,7 +38,7 @@ }; robots: - name: base- dir: [0, 1]+ dir: north devices: - branch predictor - treads@@ -61,7 +61,7 @@ - [5000, vanilla] - name: customer system: true- dir: [0, -1]+ dir: south display: invisible: false attr: 'iron'@@ -70,26 +70,26 @@ program: | run "scenarios/Challenges/_ice-cream/customer.sw" solution: |- run "scenarios/Challenges/_ice-cream/solution.sw"+ run "scenarios/Challenges/_ice-cream/solution.sw" entities: - name: scoop display: char: '@' description: - A single scoop of vanilla ice cream- properties: [portable]+ properties: [pickable] - name: cherry display: char: '6' attr: 'red'- properties: [portable]+ properties: [pickable] description: - A traditional ice cream garnish - name: Counter display: char: '▒' attr: 'sand'- properties: [portable, known]+ properties: [pickable, known] capabilities: [count] description: - Where customers are served.@@ -98,42 +98,42 @@ display: char: 'V' attr: 'sand'- properties: [portable]+ properties: [pickable] description: - A conical, edible container for ice cream - name: egg display: char: 'e' attr: 'gold'- properties: [portable]+ properties: [pickable] description: - Organic from local, free-range, meticulously pampered chickens. - name: milk display: char: 'm' attr: 'silver'- properties: [portable]+ properties: [pickable] description: - Pasteurized, homogenized, commoditized, metabolized. - name: ice display: char: 'i' attr: 'snow'- properties: [portable]+ properties: [pickable] description: - Ice cream is better cold, don't you think? - name: sugar display: char: 's' attr: 'snow'- properties: [portable]+ properties: [pickable] description: - Basis of most desserts - name: vanilla display: char: 'v' attr: 'wood'- properties: [portable]+ properties: [pickable] description: - Traditional ice cream flavoring - name: briefcase@@ -141,7 +141,7 @@ char: 'B' attr: rubber capabilities: [sum, prod]- properties: [portable]+ properties: [pickable] description: - Standard business accoutrement. - Particularly useful for `meet`-ings.@@ -211,7 +211,6 @@ upperleft: [0, 0] offset: false palette:- '@': [stone, boulder] '.': [grass] ':': [stone] 'B': [stone, briefcase]@@ -243,4 +242,3 @@ ┌─┐x┌──┐..^^^^ │B:Ω:V6│..\ZZ/ └──────┘...\/.-
@@ -66,7 +66,7 @@ }; robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - antenna@@ -90,13 +90,13 @@ - workbench - name: judge system: true- dir: [1, 0]+ dir: east display: invisible: true program: | run "scenarios/Challenges/_lights-out/assistant.sw"; solution: |- run "scenarios/Challenges/_lights-out/solution.sw"+ run "scenarios/Challenges/_lights-out/solution.sw" entities: - name: pending-off display:@@ -150,7 +150,6 @@ z: [blank, null, judge] '.': [blank] 'x': [blank, "off"]- 'o': [blank, "on"] map: | B...... .xxxxx.@@ -159,4 +158,3 @@ .xxxxx. .xxxxx. z......-
@@ -25,7 +25,7 @@ as monitor {has "dizzy"}; robots: - name: base- dir: [0, 1]+ dir: north devices: - branch predictor - treads@@ -44,7 +44,7 @@ - strange loop - name: monitor system: true- dir: [0, 1]+ dir: north display: invisible: true inventory:@@ -56,14 +56,14 @@ program: | run "scenarios/Challenges/_maypole/monitor.sw" solution: |- run "scenarios/Challenges/_maypole/solution.sw"+ run "scenarios/Challenges/_maypole/solution.sw" entities: - name: dizzy display: char: '@' description: - A disorienting vestibular affliction- properties: [portable]+ properties: [pickable] - name: maypole display: char: 'M'@@ -117,4 +117,3 @@ .........B...... ................ ................-
@@ -0,0 +1,147 @@+version: 1+name: Tetrominoes+description: |+ Pack tetrominoes into a rectangle+creative: false+attrs:+ - name: q-tile+ fg: "#ffff00"+ - name: z-tile+ fg: "#ff0000"+ - name: i-tile+ fg: "#00ffff"+ - name: j-tile+ fg: "#0000ff"+ - name: t-tile+ fg: "#ff00ff"+objectives:+ - teaser: Place all+ goal:+ - |+ Place all five tetrominoes.+ condition: |+ def found = \s.+ fs <- structure s 0;+ return $ case fs (\_. false) (\_. true);+ end;++ foundT <- found "tee";+ foundJ <- found "jay";+ foundI <- found "line";+ foundZ <- found "zee";+ foundQ <- found "square";+ return $ foundT && foundJ && foundI && foundZ && foundQ;+robots:+ - name: base+ dir: east+ devices:+ - grabber+ - treads+ inventory:+ - [4, z-tile]+ - [4, j-tile]+ - [4, i-tile]+ - [4, q-tile]+ - [4, t-tile]+entities:+ - name: q-tile+ display:+ char: 'q'+ attr: q-tile+ description:+ - q-tile+ properties: [known, pickable]+ - name: j-tile+ display:+ char: 'j'+ attr: j-tile+ description:+ - j-tile+ properties: [known, pickable]+ - name: i-tile+ display:+ char: 'i'+ attr: i-tile+ description:+ - i-tile+ properties: [known, pickable]+ - name: t-tile+ display:+ char: 't'+ attr: t-tile+ description:+ - t-tile+ properties: [known, pickable]+ - name: z-tile+ display:+ char: 'z'+ attr: z-tile+ description:+ - z-tile+ properties: [known, pickable]+solution: |+ run "scenarios/Challenges/_pack-tetrominoes/solution.sw"+structures:+ - name: tee+ recognize: [north, south, east, west]+ description: "Tee tetromino"+ structure:+ mask: '.'+ palette:+ 'x': [stone, t-tile]+ map: |+ .x.+ xxx+ - name: square+ recognize: [north]+ description: "Square tetromino"+ structure:+ mask: '.'+ palette:+ 'x': [stone, q-tile]+ map: |+ xx+ xx+ - name: line+ recognize: [north, east]+ description: "Line tetromino"+ structure:+ mask: '.'+ palette:+ 'x': [stone, i-tile]+ map: |+ xxxx+ - name: jay+ recognize: [north, east, south, west]+ description: "Jay tetromino"+ structure:+ mask: '.'+ palette:+ 'x': [stone, j-tile]+ map: |+ xxx+ ..x+ - name: zee+ recognize: [north, east]+ description: "Zee tetromino"+ structure:+ mask: '.'+ palette:+ 'x': [stone, z-tile]+ map: |+ xx.+ .xx+known: [boulder]+world:+ name: root+ dsl: |+ {boulder}+ palette:+ '.': [grass, erase]+ 'B': [grass, erase, base]+ upperleft: [0, 0]+ map: |+ ......+ ......+ ......+ B.....
@@ -18,8 +18,8 @@ turn back; move;move;move; w10; move;move;move; grab robots: - name: base- loc: [3,0]- dir: [1,0]+ loc: [3, 0]+ dir: east devices: - treads - logger@@ -29,8 +29,8 @@ - [0, lambda] - name: portkey1 system: true- loc: [0,0]- dir: [0,0]+ loc: [0, 0]+ dir: [0, 0] program: | def forever = \prog. wait 10; prog; forever prog; end; destRob <- robotNamed "portkey2";@@ -42,8 +42,8 @@ ); - name: portkey2 system: true- loc: [16,0]- dir: [0,0]+ loc: [16, 0]+ dir: [0, 0] program: | def forever = \prog. wait 10; prog; forever prog; end; wait 5;
@@ -24,7 +24,7 @@ as base {x <- meet; return $ case x (\_. false) (\_. true)}; robots: - name: base- dir: [0, 1]+ dir: north devices: - branch predictor - comparator@@ -40,7 +40,7 @@ - treads - name: wavebot system: true- dir: [0, 1]+ dir: north display: invisible: false attr: 'plant'@@ -61,14 +61,14 @@ end; start; solution: |- run "scenarios/Challenges/_wave/solution.sw"+ run "scenarios/Challenges/_wave/solution.sw" entities: [] known: [wavy water, water, bitcoin] world: dsl: | overlay [ {dirt, water}- , if (x + y / 2) % 5 == 0 then {dirt, wavy water} else {blank}+ , if (x / 2 - y) % 5 == 0 then {dirt, wavy water} else {blank} ] upperleft: [-3, 6] offset: false@@ -86,4 +86,3 @@ x............................................................................................................................................................................................................................................................x xxx........................................................................................................................................................................................................................................................xxx xxxxxxwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwxxxxxx-
@@ -9,7 +9,7 @@ display: char: 'U' attr: wood- dir: [0, 1]+ dir: north devices: - ADT calculator - branch predictor@@ -29,12 +29,12 @@ - boat - name: east_detector system: true- dir: [0, 1]+ dir: north display: invisible: true - name: west_detector system: true- dir: [0, 1]+ dir: north display: invisible: true objectives:@@ -51,7 +51,7 @@ previewable: true logic: not:- or: + or: - id: unattended_disaster - id: carrying_two_items - goal:@@ -70,7 +70,7 @@ condition: | run "data/scenarios/Challenges/_wolf-goat-cabbage/unattended-together.sw"; optional: true- hidden: true + hidden: true solution: | run "scenarios/Challenges/_wolf-goat-cabbage/cross.sw" entities:@@ -80,21 +80,21 @@ attr: silver description: - A wolf. Likes to eat goats.- properties: [known, portable]+ properties: [known, pickable] - name: goat display: char: 'g' attr: sand description: - A goat. Likes to eat cabbage.- properties: [known, portable]+ properties: [known, pickable] - name: cabbage display: char: 'c' attr: green description: - A cabbage.- properties: [known, portable]+ properties: [known, pickable] known: [water, boulder] seed: 0 world:
@@ -7,204 +7,20 @@ creative: false objectives: - goal:- - Use the `drill` command (e.g. `drill down` when on top of the- intended letter) to mark the sequence of letters that- spells `C`{=entity}`O`{=entity}`W`{=entity} within the designated playfield.+ - Use the `drill` command (e.g. `drill down` when on top of the intended letter) to mark the sequence of letters that spells `C`{=entity}`O`{=entity}`W`{=entity} within the designated playfield. - | The sequence may appear horizontally in either the leftward or rightward direction, or vertically in either the upward or downward direction. Diagonal appearances are not valid. condition: |- /**- Algorithm:- We only need to check the base's- current position: if we find three contiguous highlights,- then we know that the player has just completed their- third highlight.- */-- def whichOrdinal =- isC <- ishere "lowercase c";- if (isC) {- return 0;- } {- isO <- ishere "lowercase o";- if (isO) {- return 1;- } {- isW <- ishere "lowercase w";- if (isW) {- return 2;- } {- return (-1);- }- }- }- end;--- def whichHighlightedOrdinal = \str.- if (str == "lowercase c") {- return 0;- } {- if (str == "lowercase o") {- return 1;- } {- if (str == "lowercase w") {- return 2;- } {- return (-1);- }- }- }- end;-- def countConsecutive = \expectedOrdinal. \n.-- thisOrdinal <- whichOrdinal;- nextOrdinal <- if (thisOrdinal == expectedOrdinal) {- return $ expectedOrdinal + 1;- } {- return 0;- };-- if (nextOrdinal == 3) {- return true;- } {- if (n > 1) {- move;- countConsecutive nextOrdinal $ n - 1;- } {- return false;- };- };- end;-- def checkBackAndForth =-- foundBackward <- countConsecutive 0 3;- if (foundBackward) {- return true;- } {- turn back;- countConsecutive 0 3;- }- end;-- def checkDirections = \n.- if (n > 0) {- wasFound <- checkBackAndForth;- if wasFound {- return true;- } {- turn left;- checkDirections $ n - 1;- }- } {- return false;- }- end;-- def isMarkedInDirection = \d.- scanResult <- scan d;- ordinalNum <- case scanResult- (\_. return (-1))- whichHighlightedOrdinal;- return $ ordinalNum >= 0;- end;-- /**- It's possible we could be one cell away from- a marked cell after finishing, either due- to using a directional `drill` command instead of- `drill down`, or due to an apparent bug which- does not evaluate the goal condition between the- `drill` and a `move` command.- */- def moveToMarkedCell = \n.- if (n > 0) {- isMarkedAhead <- isMarkedInDirection forward;- if isMarkedAhead {- move;- return true;- } {- turn left;- moveToMarkedCell $ n - 1;- };- } {- return false;- };- end;-- /**- Orient ourselves such that- a marked cell is behind us.- */- def findMarkBehind = \n.- if (n > 0) {- isMarkedBehind <- isMarkedInDirection back;- if isMarkedBehind {- return true;- } {- turn left;- findMarkBehind $ n - 1;- };- } {- return false;- };- end;-- /**- The cell we're on might be in the middle of a word,- rather than the end. Determine the orientation of- the line, then move along it until reaching the end.-- Algorithm:- 0. Assumption: we are currently on a marked cell.- 1. Turn in all all four directions to `scan back`- for a second marked cell. Stop turning if- we encounter one.- If none found after 4 turns, abort.- 2. `scan forward` to see if there is a marked cell in- the opposite direction.- `move` (foward) once if there is. Since the word- is only three cells long, this will be the other- end of it.- */- def moveToWordExtrema =- foundCellBehind <- findMarkBehind 4;- if foundCellBehind {- isMarkedAhead <- isMarkedInDirection forward;- if isMarkedAhead {- move;- } {};- } {};- end;-- def checkSoln =- isMarkedHere <- isMarkedInDirection down;- atMarkedCell <- if isMarkedHere {- return true;- } {- moveToMarkedCell 4;- };-- if atMarkedCell {- moveToWordExtrema;- checkDirections 4;- } {- return false;- }- end;-- as base {checkSoln};-+ foundStructure <- structure "cow" 0;+ return $ case foundStructure (\_. false) (\_. true); robots: - name: base display: attr: flower- dir: [-1, 0]+ dir: west devices: - treads - ADT calculator@@ -226,7 +42,7 @@ - [3, ink] - name: lettersetter system: true- dir: [1, 0]+ dir: east display: invisible: true inventory:@@ -296,14 +112,24 @@ capabilities: [drill] description: - Instrument for marking found words- properties: [known, portable]+ properties: [known, pickable] - name: ink display: char: 'K' attr: gold description: - Ink for marking found words- properties: [known, portable]+ properties: [known, pickable]+structures:+ - name: cow+ recognize: [north, south, east, west]+ structure:+ palette:+ 'c': [dirt, lowercase c]+ 'o': [dirt, lowercase o]+ 'w': [dirt, lowercase w]+ map: |+ cow recipes: - in: - [1, capital C]
@@ -1,2 +1,4 @@ GoL.yaml logo-burst.yaml+horton.yaml+snake.yaml
@@ -7,8 +7,8 @@ display: attr: robot char: 'Ω'- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - treads - compass@@ -19,7 +19,7 @@ - [1000, rock] - name: cell system: true- dir: [0,1]+ dir: north display: invisible: true inventory:@@ -35,7 +35,7 @@ b <- scan back; return (cnt h + cnt f + cnt b) end;- def mod : int -> int -> int = \a. \b. a - (a/b)*b end;+ def mod : Int -> Int -> Int = \a. \b. a - (a/b)*b end; def waitUntil = \p. b <- p; if b {wait 1} {waitUntil p}@@ -63,7 +63,7 @@ palette: 'o': [ice, rock, cell] '.': [ice, null, cell]- upperleft: [1,-1]+ upperleft: [1, -1] map: | .............................. ..............................
@@ -1,4 +1,4 @@-def forever : cmd unit -> cmd unit = \c. c ; forever c end+def forever : Cmd Unit -> Cmd Unit = \c. c ; forever c end def alternate = wait 50;
@@ -1,12 +1,12 @@ -def repeat : int -> cmd unit -> cmd unit =+def repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} end def abs = \n. if (n < 0) {-n} {n} end def elif = \t. \then. \else. {if t then else} end def else = \t. t end -def randdir : cmd dir =+def randdir : Cmd Dir = d <- random 4; return ( if (d == 0) {north}
@@ -0,0 +1,160 @@+/**+Uses a string to maintain a queue of coordinates.+*/++def coordsToString : (Int * Int) -> Text = \coords.+ format (fst coords) ++ "," ++ format (snd coords)+ end++def indexOfRec : Int -> Text -> Text -> (Unit + Int) = \pos. \inputString. \targetChar.+ if (pos >= chars inputString) {+ inL ()+ } {+ if (toChar (charAt pos inputString) == targetChar) {+ inR pos+ } {+ indexOfRec (pos + 1) inputString targetChar+ }+ }+ end++def indexOf : Text -> Text -> (Unit + Int) =+ indexOfRec 0+ end++// Drops the first character of a string+def strTail : Text -> Text = \inputString.+ snd $ split 1 inputString+ end++def splitOnFirstChar : Text -> Text -> (Text * Text) = \inputString. \splitChar.+ case (indexOf inputString splitChar) (\_.+ // Did not find the split character, so return the original string+ (inputString, "")+ ) (\foundIdx.+ let parts = split foundIdx inputString in+ (fst parts, strTail $ snd parts)+ )+ end++def getDecimalCharValue = \inputString. \idx.+ charAt idx inputString - charAt 0 "0"+ end++// Works from right to left+def parseDecimalRec : Int -> Text -> Int = \charsRemaining. \inputString.+ if (charsRemaining > 0) {+ getDecimalCharValue inputString (charsRemaining - 1) + 10 * parseDecimalRec (charsRemaining - 1) inputString+ } {0}+ end++def parseDecimal : Text -> Int = \inputString.+ let isNegative = toChar (charAt 0 inputString) == "-" in+ let negationMultiplier = if isNegative {-1} {1} in+ let modifiedString = if isNegative {strTail inputString} {inputString} in+ let stringLength = chars modifiedString in+ negationMultiplier * parseDecimalRec stringLength modifiedString;+ end++// Comma (",") is the separator between abscissa and ordinate+def stringToCoords : Text -> (Int * Int) = \coordsString.+ let pair = splitOnFirstChar coordsString "," in+ (parseDecimal $ fst pair, parseDecimal $ snd pair)+ end++// APPEND to string representation of a coordinate list+def snoc : (Int * Int) -> Text -> Text = \coords. \strList.+ let delimiter = if (chars strList > 0) {";"} {""} in+ strList ++ delimiter ++ coordsToString coords;+ end++// Extracts the first element and returns the shortened list+def pop : Text -> (Unit + ((Int * Int) * Text)) = \strList.+ if (chars strList > 0) {+ let pair = splitOnFirstChar strList ";" in+ inR (stringToCoords $ fst pair, snd pair)+ } {+ inL ();+ }+ end++def getDir = \dest.+ path (inL ()) (inL dest);+ end;++def doAtLoc = \currLoc. \targetLoc. \func.+ teleport self targetLoc;+ x <- func;+ teleport self currLoc;+ return x;+ end;++def moveTail = \tailList.+ emptyHere <- isempty;+ if emptyHere {+ let maybeShifted = pop tailList in+ case maybeShifted (\_.+ // Nothing to pick up or replace+ return tailList;++ ) (\newPair.++ let farthestTail = fst newPair in+ let newInit = snd newPair in+ newLoc <- whereami;+ grabbedItem <- doAtLoc newLoc farthestTail grab;+ place grabbedItem;++ return $ snoc newLoc newInit;+ );+ } {+ return tailList;+ }+ end;++def moveOneStep = \tailList.++ // This robot will always be sitting atop the apple+ r <- robotnamed "spawn";+ targetLoc <- as r {whereami};++ maybeD <- getDir targetLoc;+ case maybeD (\_. say "Dead!"; return "") (\d.+ turn $ fst d;+ newList <- moveTail tailList;+ move;+ return newList+ );+ end++// Invariant: No tail pieces shall ever be moved underneath the+// snake robot, unless an apple was just picked up.+def moveToApple = \tailList.++ myLoc <- whereami;++ appleHere <- ishere "apple";+ if appleHere {++ modifiedTailList <- try {+ make "tail";+ swap "tail";+ return $ snoc myLoc tailList;+ } {+ grab;+ return tailList;+ };+ // Need to move here so that we get out of the way+ // if the tail gets elongated+ moveOneStep modifiedTailList;+ } {+ moveOneStep tailList;+ }+ end;++def go = \tailList.+ newList <- instant $ moveToApple tailList;+ go newList;+ end;++go "";
@@ -0,0 +1,35 @@+def waitForConsumption =+ watch down;+ wait 2000;+ appleHere <- ishere "apple";+ if appleHere {+ waitForConsumption;+ } {}+ end;++// TODO Ensure we don't spawn inside a coil of the tail+def placeAtOpenLocation = \range.+ randX <- random range;+ randY <- random range;+ let x = range/2 - randX in+ let y = range/2 - randY in+ teleport self (x, y);+ emptyHere <- isempty;+ if emptyHere {+ place "apple";+ } {+ placeAtOpenLocation range;+ }+ end;++def repeatedlyPlaceApple = \range.+ placeAtOpenLocation range;+ waitForConsumption;+ end;++def go =+ instant $ repeatedlyPlaceApple 20;+ go;+ end;++go;
@@ -0,0 +1,96 @@+version: 1+name: Horton's Field+author: Karl Ostmo+seed: 1+description: |+ Horton picks all of the flowers+creative: false+objectives:+ - goal:+ - |+ Pluck every flower.+ condition: |+ as base {+ flowerCount <- count "flower";+ return $ flowerCount >= 399;+ }+robots:+ - name: Horton+ dir: north+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - compass+ - dictionary+ - grabber+ - hourglass+ - clock+ - lambda+ - logger+ - net+ - scanner+ - strange loop+ - treads+ - wayfinder+solution: |+ def goDir = \f. \result.+ let d = fst result in+ if (d == down) {grab; f;} {turn d; move; f;}+ end;++ def followRoute =+ nextDir <- path (inL ()) (inR "flower");+ case nextDir return $ goDir followRoute;+ end;++ followRoute;+entities:+ - name: wayfinder+ display:+ char: 'w'+ description:+ - |+ Enables the `path` command:+ - |+ `path : (Unit + Int) -> ((Int * Int) + Text) -> Cmd (Unit + (Dir * Int))`+ - |+ Optionally supply a distance limit as the first argument, and+ supply either a location (`inL`) or an entity (`inR`) as the second argument.+ - |+ Example:+ - |+ `path (inL ()) (inR "tree");`+ - If a path exists, returns the direction to proceed along.+ properties: [known, pickable]+ capabilities: [path]+known: [water, boulder, flower]+world:+ dsl: |+ let+ cl = perlin seed 4 0.08 0.5,+ patch = cl > 0.0,+ prize = cl < -0.8+ in+ overlay+ [ {dirt}+ , mask (patch) {boulder}+ , mask (prize) {flower}+ , mask (x < -80 || x > 80 || y < -60 || y > 60) (overlay [{water}])+ ]+ upperleft: [-4, 4]+ offset: false+ palette:+ 'B': [grass, erase, Horton]+ '.': [grass, erase]+ 'x': [blank]+ map: |+ xxx...xxx+ x.......x+ x.......x+ .........+ ....B....+ .........+ x.......x+ x.......x+ xxx...xxx
@@ -10,7 +10,7 @@ - name: base display: invisible: true- dir: [1, 0]+ dir: east devices: - logger - hearing aid@@ -18,42 +18,41 @@ system: true display: invisible: false- dir: [1, 0]+ dir: east program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: botUp system: true display: invisible: false- dir: [0, 1]+ dir: north program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: botLeft system: true display: invisible: false- dir: [-1, 0]+ dir: west program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: botDown system: true display: invisible: false- dir: [0, -1]+ dir: south program: | run "scenarios/Fun/_logo-burst/drone.sw" - name: stoplight system: true display: invisible: false- dir: [0, 1]+ dir: north devices: - lodestone inventory: - [1, bit (0)] program: | run "scenarios/Fun/_logo-burst/coordinator.sw"- known: [boulder, tree, water, wavy water] world: upperleft: [0, 0]@@ -73,11 +72,11 @@ 'v': [blank, null, botDown] map: | s v .- . . + . . . v<^vv<<@ ^^ vv >^v^T ^^^v< <>< v > T ^< >^ < >> v> v< >T <v> <<▒^ @><> .- . <@v^^>> @v > <T <v<T<Ω^> v><v< << <<T^ v< . + . <@v^^>> @v > <T <v<T<Ω^> v><v< << <<T^ v< . . > >> v@ @@> << ~v < >~ ^~ >> @^ >v .- . >>^v^^^ < ~ T~v v< <~ >>T <v vv ▒> . - . ▒ . + . >>^v^^^ < ~ T~v v< <~ >>T <v vv ▒> .+ . ▒ . . ^ ^ v > > .
@@ -0,0 +1,122 @@+version: 1+name: Snake+author: Karl Ostmo+seed: 1+description: |+ Watch the snake eat the apples+creative: false+objectives:+ - goal:+ - |+ Eat and "digest" many apples+ condition: |+ r <- robotnamed "snake";+ as r {+ appleCoreCount <- count "apple core";+ return $ appleCoreCount >= 40;+ }+robots:+ - name: base+ dir: north+ devices:+ - ADT calculator+ - branch predictor+ - clock+ - comparator+ - compass+ - dictionary+ - grabber+ - hourglass+ - hearing aid+ - keyboard+ - lambda+ - logger+ - net+ - scanner+ - strange loop+ - string+ - treads+ - wayfinder+ - name: snake+ dir: north+ system: true+ display:+ attr: green+ invisible: false+ devices:+ - rattle+ program: |+ run "scenarios/Fun/_snake/snake.sw"+ - name: spawn+ dir: north+ system: true+ display:+ invisible: true+ inventory:+ - [100, apple]+ program: |+ run "scenarios/Fun/_snake/spawn.sw"+solution: |+ noop+entities:+ - name: wayfinder+ display:+ char: 'w'+ description:+ - |+ Enables the `path` command+ properties: [known, pickable]+ capabilities: [path]+ - name: apple+ display:+ char: 'a'+ attr: red+ description:+ - |+ Tasty snack+ properties: [known, pickable]+ - name: apple core+ display:+ char: 'I'+ attr: wood+ description:+ - |+ Remains of an eaten apple+ properties: [known, pickable]+ - name: rattle+ display:+ char: 'r'+ attr: green+ description:+ - |+ Device unique to a snake+ properties: [known]+ - name: tail+ display:+ char: '@'+ attr: green+ description:+ - |+ Segment of snake's tail+ properties: [known, unwalkable]+recipes:+ - in:+ - [3, apple]+ out:+ - [1, tail]+ - [3, apple core]+ required:+ - [1, rattle]+known: []+world:+ dsl: |+ {grass}+ upperleft: [0, 0]+ palette:+ 'B': [grass, erase, base]+ 'S': [grass, erase, snake]+ 's': [grass, erase, spawn]+ '.': [grass, erase]+ map: |+ B..+ s.S
@@ -19,7 +19,7 @@ display: char: 'ω' attr: robot- dir: [0, 1]+ dir: north devices: - treads - 3D printer@@ -43,7 +43,7 @@ - [1, treads] - name: gate system: true- dir: [0, 1]+ dir: north display: invisible: true inventory:
@@ -1,16 +1,15 @@ version: 1 name: Curry author: Brent Yorgey-description: Race to make a bowl of `curry`{=entity} as quickly as possible.- See the Swarm wiki for more information on Swarm speedrunning.+description: Race to make a bowl of `curry`{=entity} as quickly as possible. See the Swarm wiki for more information on Swarm speedrunning. objectives: - goal: - Make a bowl of curry as quickly as possible! condition: as base {has "curry"} robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω@@ -19,6 +18,7 @@ - 3D printer - dictionary - grabber+ - welder - life support system - logger - toolkit@@ -31,6 +31,7 @@ - [70, grabber] - [100, solar panel] - [50, scanner]+ - [50, clock] - [5, toolkit] world: offset: true
@@ -1,16 +1,15 @@ version: 1 name: Forester author: Brent Yorgey-description: Race to harvest 1024 `tree`{=entity}s as quickly as possible.- See the Swarm wiki for more information on Swarm speedrunning.+description: Race to harvest 1024 `tree`{=entity}s as quickly as possible. See the Swarm wiki for more information on Swarm speedrunning. objectives: - goal: - Harvest 1024 `tree`{=entity}s as quickly as possible! condition: as base {n <- count "tree"; return (n >= 1024)} robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω@@ -19,6 +18,7 @@ - 3D printer - dictionary - grabber+ - welder - life support system - logger - toolkit@@ -31,6 +31,7 @@ - [70, grabber] - [100, solar panel] - [50, scanner]+ - [50, clock] - [5, toolkit] world: offset: true
@@ -1,16 +1,15 @@ version: 1 name: Mithril author: Brent Yorgey-description: Race to mine some `mithril`{=entity}.- See the Swarm wiki for more information on Swarm speedrunning.+description: Race to mine some `mithril`{=entity}. See the Swarm wiki for more information on Swarm speedrunning. objectives: - goal: - Mine some `mithril`{=entity} as quickly as possible! condition: as base {has "mithril"} robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω@@ -19,6 +18,7 @@ - 3D printer - dictionary - grabber+ - welder - life support system - logger - toolkit@@ -31,6 +31,7 @@ - [70, grabber] - [100, solar panel] - [50, scanner]+ - [50, clock] - [5, toolkit] world: offset: true
@@ -36,16 +36,34 @@ 1218-stride-command.yaml 1234-push-command.yaml 1256-halt-command.yaml+1262-display-device-commands.yaml 1295-density-command.yaml 1138-structures 1320-world-DSL 1356-portals 144-subworlds 836-pathfinding+1569-pathfinding-cache 1341-command-count.yaml 1355-combustion.yaml 1379-single-world-portal-reorientation.yaml+1322-wait-with-instant.yaml+1598-detect-entity-change.yaml 1399-backup-command.yaml 1430-built-robot-ownership.yaml 1536-custom-unwalkable-entities.yaml+1721-custom-walkable-entities.yaml+1721-walkability-whitelist-path-cache.yaml 1535-ping+1575-structure-recognizer+1631-tags.yaml+1634-message-colors.yaml+1681-pushable-entity.yaml+1747-volume-command.yaml+1777-capability-cost.yaml+1775-custom-terrain.yaml+1642-biomes.yaml+1780-structure-merge-expansion+1533-sow-command.yaml+1533-sow-seed-maturation.yaml+231-requirements
@@ -17,7 +17,7 @@ grab; robots: - name: base- dir: [1,0]+ dir: east display: char: Ω attr: robot@@ -28,34 +28,34 @@ - treads - welder entities:-- name: fence- display:- attr: wood- char: '#'- description:- - Impassable barrier- properties: [known, unwalkable]-- name: gate key- display:- attr: iron- char: 'k'- description:- - Can open a closed gate- properties: [known, portable]-- name: closed gate- display:- attr: wood- char: '|'- description:- - Cannot pass through this- properties: [known, unwalkable]-- name: open gate- display:- attr: wood- char: '/'- description:- - Can pass through this- properties: [known]+ - name: fence+ display:+ attr: wood+ char: '#'+ description:+ - Impassable barrier+ properties: [known, unwalkable]+ - name: gate key+ display:+ attr: iron+ char: 'k'+ description:+ - Can open a closed gate+ properties: [known, pickable]+ - name: closed gate+ display:+ attr: wood+ char: '|'+ description:+ - Cannot pass through this+ properties: [known, unwalkable]+ - name: open gate+ display:+ attr: wood+ char: '/'+ description:+ - Can pass through this+ properties: [known] recipes: - in: - [1, closed gate]@@ -74,8 +74,8 @@ 'k': [grass, gate key] upperleft: [0, 0] map: |- ......- ..###.- Ωk|*#.- ..###.- ......+ ......+ ..###.+ Ωk|*#.+ ..###.+ ......
@@ -27,7 +27,7 @@ forever drill_for_sand robots: - name: base- dir: [1,0]+ dir: east devices: - dictionary - logger@@ -40,6 +40,6 @@ palette: '>': [grass, null, base] 'Å': [stone, copper mine]- upperleft: [0,0]+ upperleft: [0, 0] map: | >Å
@@ -1,9 +1,13 @@ version: 1 name: Rainbow color custom attributes description: |- Custom attributes with rainbow colors+ Custom attributes with rainbow colors.++ Participates as a do-nothing integration test to ensure parseability. creative: false attrs:+ - name: robotWithBackground+ bg: "#880088" - name: rainbow1 fg: "#ffadad" - name: rainbow2@@ -18,24 +22,46 @@ fg: "#a0c4ff" - name: rainbow7 fg: "#bdb2ff"+ - name: rainbow1bg+ bg: "#ffadad"+ - name: rainbow2bg+ bg: "#ffd6a5"+ - name: rainbow3bg+ bg: "#ffff96"+ - name: rainbow4bg+ bg: "#caffbf"+ - name: rainbow5bg+ bg: "#9bf6ff"+ - name: rainbow6bg+ bg: "#a0c4ff"+ - name: rainbow7bg+ bg: "#bdb2ff" - name: redOnYellow fg: "#ff0000"- bg: ffff00+ bg: "#ffff00" - name: cyanOnMagenta- fg: "#00ffff+ fg: "#00ffff" bg: "#ff00ff" - name: greenForeground fg: "#00ff00" - name: blueBackround bg: "#0000ff" - name: italicAndUnderline+ fg: "#ffffff" style: - Italic - Underline - name: boldAndStrikethrough+ fg: "#ffffff" style: - Bold - Strikethrough+objectives:+ - goal:+ - Do nothing+ condition: |+ pos <- as base {whereami};+ return $ fst pos > 7; entities: - name: color1 display:@@ -86,6 +112,55 @@ description: - c7 properties: [known]+ - name: color1bg+ display:+ char: ' '+ attr: rainbow1bg+ description:+ - c1bg+ properties: [known]+ - name: color2bg+ display:+ char: ' '+ attr: rainbow2bg+ description:+ - c2bg+ properties: [known]+ - name: color3bg+ display:+ char: ' '+ attr: rainbow3bg+ description:+ - c3bg+ properties: [known]+ - name: color4bg+ display:+ char: ' '+ attr: rainbow4bg+ description:+ - c4bg+ properties: [known]+ - name: color5bg+ display:+ char: ' '+ attr: rainbow5bg+ description:+ - c5bg+ properties: [known]+ - name: color6bg+ display:+ char: ' '+ attr: rainbow6bg+ description:+ - c6bg+ properties: [known]+ - name: color7bg+ display:+ char: ' '+ attr: rainbow7bg+ description:+ - c7bg+ properties: [known] - name: color1f display: char: '█'@@ -177,9 +252,35 @@ description: - Bold and Strikethrough properties: [known]-robots: []+robots:+ - name: base+ dir: east+ devices:+ - treads+ - name: companion+ dir: east+ devices:+ - treads+ program: |+ move; move; move; move;+ move; move; move; move;+ - name: companion2+ dir: east+ display:+ attr: robotWithBackground+ devices:+ - treads+ program: |+ move; move; move; move;+ move; move; move; move;+solution: |+ move; move; move; move;+ move; move; move; move; world: palette:+ 'Ω': [blank, null, base]+ 'α': [blank, null, companion]+ 'β': [blank, null, companion2] '.': [blank] '1': [blank, color1] '2': [blank, color2]@@ -188,6 +289,13 @@ '5': [blank, color5] '6': [blank, color6] '7': [blank, color7]+ 'T': [blank, color1bg]+ 'U': [blank, color2bg]+ 'V': [blank, color3bg]+ 'W': [blank, color4bg]+ 'X': [blank, color5bg]+ 'Y': [blank, color6bg]+ 'Z': [blank, color7bg] 'a': [blank, color1f] 'b': [blank, color2f] 'c': [blank, color3f]@@ -203,7 +311,7 @@ 'B': [blank, boldStrikethrough] upperleft: [0, 0] map: |-- .1234567..Rzzy...IIy- .1234567y.R.z.......- .abcdefg......C..BBz- .abcdefgyy.yy..Cz.z.+ α.1234567..Rzzy...IIy+ Ω.TUVWXYZy.R.z.......+ β.TUVWXYZ......C..BBz+ α.abcdefgyy.yy..Cz.z.
@@ -5,7 +5,7 @@ robots: - name: base loc: [11, 0]- dir: [1, 0]+ dir: east known: [flower, bit (0), bit (1)] world: palette:
@@ -5,7 +5,7 @@ robots: - name: base loc: [11, 0]- dir: [1, 0]+ dir: east known: [tree, flower, bit (0), bit (1)] world: palette:
@@ -5,7 +5,7 @@ robots: - name: base loc: [11, 0]- dir: [1, 0]+ dir: east known: [water, sand] world: palette:@@ -68,11 +68,11 @@ xx xx placements:- - src: tiny rectangle- - src: small rectangle- - src: medium rectangle- - src: big rectangle - src: huge rectangle+ - src: big rectangle+ - src: medium rectangle+ - src: small rectangle+ - src: tiny rectangle map: | ............ ............
@@ -22,7 +22,7 @@ ); robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot@@ -41,12 +41,12 @@ 'T': [grass, tree] upperleft: [-4, 4] map: |- .........- .........- .........- .........- ......T..- .........- .........- .Ω.......- .........+ .........+ .........+ .........+ .........+ ......T..+ .........+ .........+ .Ω.......+ .........
@@ -11,7 +11,7 @@ case out return place; robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot@@ -28,31 +28,31 @@ 'x': [grass, gumball machine] upperleft: [-1, 2] map: |- ...- .x.- .Ω.- ...+ ...+ .x.+ .Ω.+ ... entities: - name: gumball machine display: attr: red char: 'G' description:- - Yields a gumball when drilled+ - Yields a gumball when drilled properties: [unwalkable, known] - name: gumball display: attr: blue char: 'o' description:- - Dispensed from a gumball machine- properties: [portable]+ - Dispensed from a gumball machine+ properties: [pickable] recipes: - in:- - [1, gumball machine]+ - [1, gumball machine] out:- - [1, gumball machine]- - [1, gumball]+ - [1, gumball machine]+ - [1, gumball] required:- - [1, drill]+ - [1, drill] time: 1
@@ -22,7 +22,7 @@ takeStep "tree"; robots: - name: base- dir: [0,-1]+ dir: south display: char: Ω attr: robot@@ -39,9 +39,9 @@ 'T': [grass, tree] upperleft: [0, 0] map: |- .........- ......T..- .........- .........- .Ω.......- .........+ .........+ ......T..+ .........+ .........+ .Ω.......+ .........
@@ -16,7 +16,7 @@ doN 7 (place "tree"; move) robots: - name: base- dir: [1, 0]+ dir: east display: char: Ω attr: robot@@ -30,7 +30,7 @@ inventory: - [7, "tree"] - name: judge- dir: [1, 0]+ dir: east system: true display: invisible: false@@ -45,6 +45,6 @@ '.': [grass, erase] upperleft: [4, -1] map: |- J........- .Ω.......- .........+ J........+ .Ω.......+ .........
@@ -31,7 +31,7 @@ homeIn item initialDistance; robots: - name: base- dir: [0,-1]+ dir: south display: char: Ω attr: robot@@ -48,9 +48,9 @@ 'T': [grass, tree] upperleft: [0, 0] map: |- .........- ......T..- .........- .........- .Ω.......- .........+ .........+ ......T..+ .........+ .........+ .Ω.......+ .........
@@ -32,7 +32,7 @@ grabFlower robots: - name: base- dir: [0,-1]+ dir: south display: char: Ω attr: robot@@ -47,21 +47,21 @@ - string - treads - name: bot- dir: [0,1]+ dir: north system: true display: invisible: false char: b attr: robot - name: obscuredbot- dir: [0,1]+ dir: north system: true display: invisible: false char: o attr: robot - name: invisiblebot- dir: [0,1]+ dir: north system: true display: invisible: true@@ -80,10 +80,10 @@ 'T': [grass, tree] upperleft: [0, 0] map: |- .........- ..o.i.b..- .........- ..T...*..- .........- Ω.......@- .........+ .........+ ..o.i.b..+ .........+ ..T...*..+ .........+ Ω.......@+ .........
@@ -8,9 +8,9 @@ condition: | as base {has "tree"} prerequisite:- logic:- not:- id: grab_flower+ logic:+ not:+ id: grab_flower - id: grab_flower teaser: Grab flower goal:@@ -32,7 +32,7 @@ }; turn west;- try { + try { stride 1; } { log "Could not stride west";@@ -46,13 +46,13 @@ } { log "Could not grab southern flower"; };- + turn east; stride 5; grab; robots: - name: base- dir: [1, 0]+ dir: east display: char: Ω attr: robot@@ -68,14 +68,14 @@ - treads - turbocharger entities:-- name: turbocharger- display:- attr: silver- char: 't'- description:- - Allows one to "stride" across multiple cells- properties: [known, portable]- capabilities: [movemultiple]+ - name: turbocharger+ display:+ attr: silver+ char: 't'+ description:+ - Allows one to "stride" across multiple cells+ properties: [known, pickable]+ capabilities: [movemultiple] known: [tree, flower, boulder, water] world: palette:@@ -87,16 +87,16 @@ 'w': [grass, water] upperleft: [0, 0] map: |- ..............- ......*.......- ..............- ......w.......- ..............- ...www........- .*.wwwΩ....T..- ...www@.......- ..............- ..............- ..............- ......*.......- ..............+ ..............+ ......*.......+ ..............+ ......w.......+ ..............+ ...www........+ .*.wwwΩ....T..+ ...www@.......+ ..............+ ..............+ ..............+ ......*.......+ ..............
@@ -19,7 +19,7 @@ push; robots: - name: base- dir: [1, 0]+ dir: east display: char: Ω attr: robot@@ -35,20 +35,20 @@ - treads - dozer blade - name: judge- dir: [0, 1]+ dir: north system: true display: char: j attr: robot invisible: true entities:-- name: crate- display:- attr: wood- char: '▪'- description:- - Pushable crate- properties: [known, portable, unwalkable]+ - name: crate+ display:+ attr: wood+ char: '▪'+ description:+ - Pushable crate+ properties: [known, pickable, unwalkable] known: [tree, flower, boulder, water] world: palette:@@ -61,8 +61,8 @@ 'x': [grass, crate] upperleft: [0, 0] map: |- ..............- ......w.......- .....@Ωx.x....- ......*..j....- ......*.......+ ..............+ ......w.......+ .....@Ωx.x....+ ......*..j....+ ......*.......
@@ -4,8 +4,7 @@ description: Stop a robot using halt objectives: - goal:- - The robot next to you is holding a flower, but is stuck in an- infinite loop. Get the flower!+ - The robot next to you is holding a flower, but is stuck in an infinite loop. Get the flower! condition: | as base {has "flower"} solution: |@@ -13,7 +12,7 @@ case mr (\_. return ()) (\r. halt r; turn west; move; salvage ) robots: - name: base- dir: [0,-1]+ dir: south display: char: Ω attr: robot@@ -28,7 +27,7 @@ - ADT calculator - halting oracle - name: infinitebot- dir: [0,1]+ dir: north display: invisible: false devices:@@ -47,10 +46,10 @@ '.': [grass] upperleft: [0, 0] map: |- .........- .........- .........- ...^Ω....- .........- .........- .........+ .........+ .........+ .........+ ...^Ω....+ .........+ .........+ .........
@@ -0,0 +1,54 @@+version: 1+name: Device commands+description: |+ Demo display of commands offered by each device, along with their cost.+creative: false+robots:+ - name: base+ dir: east+ devices:+ - treads+ - logger+ - Fresnel lens+ - string+ inventory:+ - [1, flash bulb]+ - [1, photographic plate]+entities:+ - name: flash bulb+ display:+ char: 'f'+ description:+ - Consumables for a `Fresnel lens`{=entity} that enable `ignite`ing+ properties: [known, pickable]+ - name: photographic plate+ display:+ char: 'p'+ description:+ - Consumables for a `Fresnel lens`{=entity} that enable `scan`ning+ properties: [known, pickable]+ - name: Fresnel lens+ display:+ char: 'z'+ description:+ - Ignites things with sufficiently powerful light source+ properties: [known, pickable]+ capabilities:+ - capability: ignite+ cost:+ - [1, "flash bulb"]+ - capability: scan+ cost:+ - [2, "photographic plate"]+known: [water]+world:+ dsl: |+ {water}+ palette:+ 'B': [grass, erase, base]+ '.': [grass, erase]+ upperleft: [-1, 1]+ map: |+ ...+ .B.+ ...
@@ -16,7 +16,7 @@ doN 3 (move; grab); robots: - name: base- dir: [1, 0]+ dir: east display: char: Ω attr: robot@@ -28,7 +28,7 @@ - treads - ADT calculator - name: judge- dir: [1, 0]+ dir: east system: true display: invisible: false@@ -44,7 +44,7 @@ '*': [grass, flower] upperleft: [76, -89] map: |- *.*.- Ω*.*- *.*.- J*.*+ *.*.+ Ω*.*+ *.*.+ J*.*
@@ -1,3 +1,5 @@ constant.yaml erase.yaml override.yaml+coords.yaml+reflect.yaml
@@ -7,13 +7,13 @@ - condition: | as base { n <- count "tree"; return (n >= 4) } goal:- - Get 4 trees+ - Get 4 trees solution: | grab; move; grab; move; grab; move; grab robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - treads
@@ -0,0 +1,22 @@+version: 1+name: Coordinate test+description: |+ Ensure x and y are handled correctly in the world DSL+creative: false+objectives:+ - goal:+ - Must pick up a rock+ condition: |+ as base {has "rock"}+solution: |+ grab+robots:+ - name: base+ loc: [1, 2]+ dir: east+ devices:+ - logger+ - grabber+world:+ dsl: |+ mask (x == 1) (mask (y == 2) {rock,dirt})
@@ -6,7 +6,7 @@ - condition: | as base { n <- count "tree"; return (n == 0) } goal:- - Get rid of your trees.+ - Get rid of your trees. solution: | place "tree"; move; move; place "tree"; move; move;@@ -14,8 +14,8 @@ place "tree" robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - treads
@@ -6,13 +6,13 @@ - condition: | as base { n <- count "tree"; return (n == 1) } goal:- - Get a tree.+ - Get a tree. solution: | grab robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - treads
@@ -0,0 +1,46 @@+version: 1+name: Reflection (imap) test+description: |+ A world with both horizontal and vertical reflection symmetry,+ created with 'imap'.+creative: false+objectives:+ - goal:+ - Pick up four trees+ condition: |+ as base {n <- count "tree"; return (n >= 4)}+robots:+ - name: base+ loc: [0, 0]+ dir: north+ devices:+ - logger+ - grabber+ - treads+ - branch predictor+ - scanner+ - ADT calculator+ - comparator+ - GPS receiver+ - bitcoin+solution: |+ def x = \n. \c. if (n==0) {} {c; x (n-1) c} end+ def ifC = \p. \t. \e. b <- p; if b t e end+ def findTree = ifC (ishere "tree") {whereami} {move; findTree} end+ def ell = \d. turn right; x (2*d) move; grab; return () end+ def grabTrees = \loc. let x = fst loc in let y = snd loc in grab; ell y; ell x; ell y end+ n <- random 10;+ x (n+1) move; turn right; move;+ loc <- findTree;+ grabTrees loc+known: [tree]+world:+ dsl: |+ let trees = if (hash % 4 == 0) then {tree, dirt} else {stone}+ in+ overlay+ [ mask (x >= 0 && y >= 0) trees+ , mask (x >= 0 && y < 0) (imap x (-y) trees)+ , mask (x < 0 && y >= 0) (imap (-x) y trees)+ , mask (x < 0 && y < 0) (imap (-x) (-y) trees)+ ]
@@ -0,0 +1,72 @@+version: 1+name: Using wait with instant+author: Karl Ostmo+description: |+ Observe timing of (instant $ wait 1)+ interspersed with other commands+creative: false+seed: 0+objectives:+ - goal:+ - |+ Hare must win by three cells+ condition: |+ h <- robotnamed "hare";+ hareloc <- as h {whereami};++ t <- robotnamed "tortoise";+ tortoiseloc <- as t {whereami};++ let xDiff = fst hareloc - fst tortoiseloc in++ return $ fst hareloc == 0 && xDiff == 3;+solution: |+ noop;+robots:+ - name: base+ dir: [1, 0]+ display:+ invisible: true+ devices:+ - hourglass+ - logger+ - name: tortoise+ system: true+ display:+ invisible: false+ attr: green+ dir: [1, 0]+ program: |+ move; move;+ move; move;+ move; move;+ - name: hare+ system: true+ display:+ invisible: false+ attr: snow+ dir: [1, 0]+ program: |+ instant (+ move; move;+ wait 1;+ move; move;+ wait 1;+ move; move;+ );+world:+ dsl: |+ {blank}+ upperleft: [-6, 2]+ offset: false+ palette:+ '.': [grass, erase]+ 'd': [dirt, erase]+ 'B': [grass, erase, base]+ 'T': [grass, erase, tortoise]+ 'H': [grass, erase, hare]+ map: |+ B.....d.+ T.....d.+ H.....d.+ ......d.
@@ -8,25 +8,25 @@ of ticks that they `wait`. objectives: - goal:- - |- `grab` the "tree".+ - |+ `grab` the "tree". condition: | as base {has "tree"} solution: |- move;+ move;+ move;+ wait 10;+ x <- harvest;+ if (x == "flower") {+ turn right; move;- wait 10;- x <- harvest;- if (x == "flower") {- turn right;- move;- grab;- } {- return "";- };+ grab;+ } {+ return "";+ }; robots: - name: base- dir: [1, 0]+ dir: east devices: - treads - grabber@@ -36,7 +36,7 @@ - hourglass - branch predictor - name: idler1- dir: [1, 0]+ dir: east system: true devices: - dictionary@@ -49,7 +49,7 @@ end; go; - name: idler2- dir: [1, 0]+ dir: east system: true devices: - dictionary@@ -62,7 +62,7 @@ end; go; - name: idler3- dir: [1, 0]+ dir: east system: true devices: - dictionary@@ -75,7 +75,7 @@ end; go; - name: idler4- dir: [1, 0]+ dir: east system: true devices: - dictionary
@@ -40,7 +40,7 @@ ignite right; robots: - name: base- dir: [1, 0]+ dir: east devices: - branch predictor - calculator@@ -50,49 +50,49 @@ - treads - torch - name: judge- dir: [1, 0]+ dir: east system: true display: invisible: true char: J entities:-- name: torch- display:- attr: wood- char: 't'- description:- - Can set things on fire- properties: [known, portable]- capabilities: [ignite]-- name: fuse- display:- attr: wood- char: '~'- description:- - Reliably combustible- combustion:- ignition: 1- duration: [8, 8]- product: null- properties: [known, portable, combustible]-- name: dynamite- display:- attr: red- char: '!'- description:- - Explosive material- combustion:- ignition: 1- duration: [2, 2]- product: crater- properties: [known, portable, combustible]-- name: crater- display:- attr: rock- char: '@'- description:- - Result of explosive excavation- properties: [known]+ - name: torch+ display:+ attr: wood+ char: 't'+ description:+ - Can set things on fire+ properties: [known, pickable]+ capabilities: [ignite]+ - name: fuse+ display:+ attr: wood+ char: '~'+ description:+ - Reliably combustible+ combustion:+ ignition: 1+ duration: [8, 8]+ product: null+ properties: [known, pickable, combustible]+ - name: dynamite+ display:+ attr: red+ char: '!'+ description:+ - Explosive material+ combustion:+ ignition: 1+ duration: [2, 2]+ product: crater+ properties: [known, pickable, combustible]+ - name: crater+ display:+ attr: rock+ char: '@'+ description:+ - Result of explosive excavation+ properties: [known] known: [ash, tree, log, board, paper, cotton] world: palette:@@ -107,27 +107,27 @@ '.': [grass] upperleft: [0, 0] map: |- ..iiii....bbbb..TT..llll....iiii.....- ..iiii....bbbb..TT..llll....iiii.....- ..iiii....bbbb..TT..llll....iiii.....- ..iiii....bbbb..TT..llll....iiii.....- ..iiii....bbbb..TT..llll....iiii.....- ..iiii....bbbb..TT..llll....iiii.....- ..TTTT....TTTT..TT..TTTT....TTTT.....- ..TTTT....TTTT..TT..TTTT....TTTT.....- ................TT...................- ................TT...................- iiiiiiiiiii.....TT....FFFFF...FFFFF..- ......iiiiii....TT....F...F...F...F..- iiiiiiiiiiiii...TT....F...F...F...F..- ......iiiiiiii........F...F...F...F..- iiiiiiiiiiiiiii..Ω.FFFF...FFFFF...d..- ......iiiiiiii.......................- iiiiiiiiiiiii.....qqqqqqqqqqqqqqqq...- ......iiiiii......qqqqqqqqqqqqqqqq...- iiiiiiiiiii.......qqqqqqqqqqqqqqqq...- ..................qqqqqqqqqqqqqqqq...- ..................qqqqqqqqqqqqqqqq...- ..................qqqqqqqqqqqqqqqq...- ..................qqqqqqqqqqqqqqqq...- ..................qqqqqqqqqqqqqqqq...+ ..iiii....bbbb..TT..llll....iiii.....+ ..iiii....bbbb..TT..llll....iiii.....+ ..iiii....bbbb..TT..llll....iiii.....+ ..iiii....bbbb..TT..llll....iiii.....+ ..iiii....bbbb..TT..llll....iiii.....+ ..iiii....bbbb..TT..llll....iiii.....+ ..TTTT....TTTT..TT..TTTT....TTTT.....+ ..TTTT....TTTT..TT..TTTT....TTTT.....+ ................TT...................+ ................TT...................+ iiiiiiiiiii.....TT....FFFFF...FFFFF..+ ......iiiiii....TT....F...F...F...F..+ iiiiiiiiiiiii...TT....F...F...F...F..+ ......iiiiiiii........F...F...F...F..+ iiiiiiiiiiiiiii..Ω.FFFF...FFFFF...d..+ ......iiiiiiii.......................+ iiiiiiiiiiiii.....qqqqqqqqqqqqqqqq...+ ......iiiiii......qqqqqqqqqqqqqqqq...+ iiiiiiiiiii.......qqqqqqqqqqqqqqqq...+ ..................qqqqqqqqqqqqqqqq...+ ..................qqqqqqqqqqqqqqqq...+ ..................qqqqqqqqqqqqqqqq...+ ..................qqqqqqqqqqqqqqqq...+ ..................qqqqqqqqqqqqqqqq...
@@ -6,13 +6,13 @@ robots: - name: base loc: [0, 0]- dir: [1, 0]+ dir: east - name: patroller loc: [5, -4]- dir: [1, 0]+ dir: east display: invisible: false- attr: robot + attr: robot program: | run "scenarios/Testing/1356-portals/_automatic-waypoint-patrol/program.sw" known: [flower, boulder]
@@ -10,32 +10,32 @@ - name: portal_out fg: "#00a2ff" bg: "#0065ff"+solution: turn left; move; move; turn left; move; move; move; turn left; move; move; move; move; move; entities: - name: telepad entrance display: attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base loc: [0, 4]- dir: [1, 0]+ dir: east known: [tree, flower, sand, bit (0), bit (1)] world: upperleft: [-4, 7] palette: '.': [grass] '*': [stone, flower]- 'P': [grass, telepad entrance] 'p': [grass, telepad exit] '┌': [stone, upper left corner] '┐': [stone, upper right corner]
@@ -4,8 +4,8 @@ Validate proper flip/rotate of portal waypoints objectives: - goal:- - |- `grab` the "bitcoin"+ - |+ `grab` the "bitcoin" condition: | as base {has "bitcoin"} solution: |@@ -23,18 +23,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor
@@ -8,28 +8,28 @@ bg: "#ff5d00" objectives: - goal:- - |- `place` the "flower" on the white cell.+ - |+ `place` the "flower" on the white cell. condition: | j <- robotnamed "judge"; as j {ishere "flower"} solution: |- def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;- doN 23 move;- f <- grab;- doN 23 move;- place f;+ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;+ doN 23 move;+ f <- grab;+ doN 23 move;+ place f; entities: - name: telepad entrance display: attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] robots: - name: base- dir: [0, 1]+ dir: north devices: - branch predictor - calculator@@ -41,7 +41,7 @@ - strange loop - treads - name: judge- dir: [1, 0]+ dir: east system: true display: char: 'J'
@@ -4,15 +4,15 @@ Locomote backwards without access to the turn command objectives: - goal:- - |- `grab` the "flower".+ - |+ `grab` the "flower". condition: | as base {has "flower"} solution: |- backup; backup; grab;+ backup; backup; grab; robots: - name: base- dir: [0, 1]+ dir: north devices: - tape drive - grabber
@@ -4,7 +4,7 @@ description: Demo of system robot construction robots: - name: base- dir: [1, 0]+ dir: east display: char: Ω attr: robot@@ -21,7 +21,7 @@ - grabber - hearing aid - name: sysbot- dir: [-1, 0]+ dir: west system: true display: char: j@@ -40,11 +40,11 @@ program: | build {move; say (format parent)} solution: |- listen; build {move; say (format parent)}+ listen; build {move; say (format parent)} objectives: - goal:- - Check that system robots build system robots and normal robots do not.- - This check is performed in integration tests.+ - Check that system robots build system robots and normal robots do not.+ - This check is performed in integration tests. condition: | r2 <- robotNumbered 2; r3 <- robotNumbered 3;@@ -57,8 +57,8 @@ '.': [grass] upperleft: [0, 0] map: |- .........- .........- ...Ω..r..- .........- .........+ .........+ .........+ ...Ω..r..+ .........+ .........
@@ -4,8 +4,8 @@ Surface and underground with portals. objectives: - goal:- - |- `place` the "flower" on the white cell.+ - |+ `place` the "flower" on the white cell. condition: | j <- robotnamed "judge"; as j {ishere "flower"}@@ -24,18 +24,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor@@ -50,7 +50,7 @@ - strange loop - treads - name: judge- dir: [1, 0]+ dir: east system: true display: char: 'J'
@@ -15,18 +15,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor
@@ -4,8 +4,8 @@ Demonstrate that system robots can be placed in any subworld. objectives: - goal:- - |- `give` the "flower" to the robot underground.+ - |+ `give` the "flower" to the robot underground. condition: | j <- robotnamed "judge"; as j {has "flower"}@@ -24,18 +24,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east loc: subworld: root loc: [2, 0]@@ -54,7 +54,7 @@ - strange loop - treads - name: judge- dir: [1, 0]+ dir: east loc: subworld: underground loc: [4, 0]@@ -69,7 +69,6 @@ palette: '.': [dirt] 'b': [dirt, boulder]- 't': [grass, null, judge] 'p': cell: [dirt, telepad exit] waypoint:@@ -94,8 +93,6 @@ palette: '.': [grass] 'f': [grass, flower]- 'B': [grass, null, base]- 't': [grass, null, judge] 'p': cell: [grass, telepad exit] waypoint:
@@ -7,10 +7,10 @@ on subworld. objectives: - goal:- - |- `give` the "bitcoin" to the robot in the "root" world.- - |- First obtain it from the robot living underground.+ - |+ `give` the "bitcoin" to the robot in the "root" world.+ - |+ First obtain it from the robot living underground. condition: | j <- robotnumbered 1; as j {has "bitcoin"}@@ -29,18 +29,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - antenna@@ -56,7 +56,7 @@ - strange loop - treads - name: judge- dir: [1, 0]+ dir: east system: true display: char: 'J'
@@ -1,7 +1,7 @@ version: 1 name: Subworld shared structures description: |- Traverse floors of the tower+ Traverse the floors of the tower, then grab the flower in the middle attrs: - name: portal_in fg: "#ff9a00"@@ -9,25 +9,33 @@ - name: portal_out fg: "#00a2ff" bg: "#0065ff"+objectives:+ - goal:+ - |+ Visit all of the floors+ condition: |+ as base {has "flower"} entities: - name: telepad entrance display: attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]- loc: [0, 0]+ dir: east+ loc:+ subworld: root+ loc: [0, 0] devices: - ADT calculator - branch predictor@@ -41,6 +49,20 @@ - logger - strange loop - treads+solution: |+ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++ doN 4 (+ doN 4 move;+ turn right;+ doN 4 move;+ );++ doN 2 move;+ turn right;+ doN 2 move;++ grab; known: [flower] structures: - name: minibox@@ -48,7 +70,6 @@ palette: '.': [stone] 'd': [dirt]- 'f': [stone, flower] 'p': cell: [grass, telepad exit] waypoint:@@ -77,27 +98,19 @@ default: [blank] palette: '.': [dirt]- 'f': [dirt, flower]- 'p':- cell: [dirt, telepad exit]- waypoint:- name: portal_out- 'P':- cell: [dirt, telepad entrance]- waypoint:- name: portal_in placements:- - src: flowers- offset: [1, 1] - src: minibox offset: [0, 0] orient: up: west+ - src: flowers+ offset: [1, 1] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: floor2+ reorient: back upperleft: [0, 0] map: | .....@@ -109,27 +122,19 @@ default: [blank] palette: '.': [dirt]- 'f': [dirt, flower]- 'p':- cell: [dirt, telepad exit]- waypoint:- name: portal_out- 'P':- cell: [dirt, telepad entrance]- waypoint:- name: portal_in placements:- - src: flowers- offset: [1, 0] - src: minibox offset: [0, 0] orient: up: south+ - src: flowers+ offset: [1, 0] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: floor3+ reorient: back upperleft: [0, 0] map: | .....@@ -141,27 +146,19 @@ default: [blank] palette: '.': [dirt]- 'f': [dirt, flower]- 'p':- cell: [dirt, telepad exit]- waypoint:- name: portal_out- 'P':- cell: [dirt, telepad entrance]- waypoint:- name: portal_in placements:- - src: flowers- offset: [1, -2] - src: minibox offset: [0, 0] orient: up: east+ - src: flowers+ offset: [1, -2] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: root+ reorient: back upperleft: [0, 0] map: | .....@@ -171,20 +168,20 @@ ..... world: name: root- default: [blank] palette: '.': [grass] upperleft: [0, 0] placements:- - src: flowers- offset: [0, -2] - src: minibox offset: [0, 0]+ - src: flowers+ offset: [0, -2] portals: - entrance: portal_in exitInfo: exit: portal_out subworldName: floor1+ reorient: back map: | ..... .....
@@ -0,0 +1,195 @@+version: 1+name: Sow command and spread+seed: 0+description: |+ Demonstrate `sow` command and spreading growth with biome restrictions.++ Illustrates different rates of spread for different crops.+creative: false+attrs:+ - name: clay+ fg: "#444444"+ bg: "#c2b280"+ - name: wheat+ fg: "#444444"+ bg: "#F5DEB3"+ - name: barley+ fg: "#444444"+ bg: "#F6E9B1"+ - name: maize+ fg: "#444444"+ bg: "#FBEC5D"+ - name: mint+ bg: "#3EB489"+terrains:+ - name: clay+ attr: clay+ description: |+ Sandy soil+objectives:+ - goal:+ - |+ Observe `kudzu`{=entity} spread+ condition: |+ r <- robotnamed "kudzubot";+ as r {+ kCount <- resonate "kudzu" ((0, 0), (10, 4));+ return $ kCount >= 45;+ }+solution: |+ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++ doN 6 move;+ harvest;++ doN 13 move;+ turn right;+ harvest;+ doN 6 move;++ sow "mint";+ turn right;+ doN 13 move;++ sow "barley";+ turn left;+ doN 7 move;+ sow "barley";+ turn left;++ doN 13 move;+ sow "kudzu";+ doN 6 move;+robots:+ - name: base+ dir: east+ devices:+ - branch predictor+ - calculator+ - comparator+ - dictionary+ - harvester+ - logger+ - seed spreader+ - treads+ inventory:+ - [2, barley]+ - [1, kudzu]+ - [1, mint]+ - name: kudzubot+ dir: east+ system: true+entities:+ - name: wheat+ display:+ char: 'w'+ attr: wheat+ description:+ - Grain+ properties: [known, pickable, growable]+ growth:+ duration: [20, 30]+ spread:+ radius: 2+ density: 0.3+ biomes: [dirt, clay]+ - name: barley+ display:+ char: 'b'+ attr: barley+ description:+ - Grain+ properties: [known, pickable, growable]+ growth:+ duration: [30, 50]+ spread:+ radius: 2+ density: 0.3+ biomes: [dirt, clay]+ - name: corn+ display:+ char: 'c'+ attr: maize+ description:+ - Animal feed+ properties: [known, pickable, growable]+ growth:+ duration: [30, 60]+ spread:+ radius: 3+ density: 0.1+ biomes: [dirt, clay]+ - name: kudzu+ display:+ char: 'k'+ attr: plant+ description:+ - Dense, impassable plant.+ properties: [known, unwalkable, growable]+ growth:+ duration: [30, 50]+ spread:+ radius: 1+ density: 3+ biomes: [dirt, clay]+ - name: mint+ display:+ char: 'm'+ attr: mint+ description:+ - Invasive+ properties: [known, pickable, growable]+ growth:+ duration: [10, 50]+ spread:+ radius: 2+ density: 0.6+ biomes: [dirt, clay]+ - name: seed spreader+ display:+ char: 's'+ description:+ - A handheld pouch with a manual crank to broadcast seeds evenly within a small radius+ properties: [known]+ capabilities: [sow]+known: [flower]+world:+ default: [blank]+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ 'd': [dirt]+ 'c': [clay]+ 'K': [clay, null, kudzubot]+ 'C': [dirt, corn]+ 'W': [clay, wheat]+ upperleft: [-1, 1]+ map: |+ ..........................+ .ddddddddddd..ccccccccccc.+ .ddddddddddd..ccccccccccc.+ BdddddCddddd..cccccWccccc.+ .ddddddddddd..ccccccccccc.+ .ddddddddddd..ccccccccccc.+ ..........................+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ ..........................+ ..........................+ .ddddddddddd..ccccccccccc.+ .ddddddddddd..ccccccccccc.+ .ddddddddddd..ccccccccccc.+ .ddddddddddd..ccccccccccc.+ .ddddddddddd..Kcccccccccc.+ ..........................+ ..........................+ ..........................+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ .ccccccccccc..ddddddddddd.+ ..........................
@@ -0,0 +1,101 @@+version: 1+name: Seed maturation+description: |+ A seed grows into a different entity, which again+ yields the original seed when harvested.++ The 'mature' sub-property of the 'growth' property+ facilitates the distinction between seeds and the+ entities those seeds produce. For example, it doesn't make much sense+ to plant an `acorn`{=entity} and call the resulting,+ fully-grown plant also an `acorn`{=entity}.++ In combination with 'yields', it+ effectively precludes the grown entity (as it exists in the world)+ from entering into the player's inventory.+creative: false+objectives:+ - id: plant_acorn+ goal:+ - |+ Plant an `acorn`{=entity}+ condition: |+ as base {+ x <- has "acorn";+ return $ not x;+ }+ - goal:+ - |+ Go to the `oak`{=entity}+ condition: |+ as base {+ ishere "oak";+ }+ - goal:+ - |+ Pick another `acorn`{=entity}+ prerequisite: plant_acorn+ condition: |+ as base {+ has "acorn";+ }+solution: |+ sow "acorn";+ move;+ watch back;+ turn back;+ wait 1000;+ move;+ harvest;+robots:+ - name: base+ dir: east+ devices:+ - branch predictor+ - calculator+ - comparator+ - dictionary+ - harvester+ - logger+ - rolex+ - scanner+ - seed spreader+ - treads+ inventory:+ - [1, acorn]+entities:+ - name: acorn+ display:+ char: 'a'+ description:+ - Seed of an `oak`{=entity}+ properties: [known, pickable, growable]+ growth:+ duration: [200, 300]+ mature: oak+ - name: oak+ display:+ char: 'k'+ description:+ - Grows from an `acorn`{=entity}+ properties: [known, pickable, growable]+ growth:+ duration: [200, 300]+ yields: acorn+ - name: seed spreader+ display:+ char: 's'+ description:+ - A handheld pouch with a manual crank to broadcast seeds evenly within a small radius+ properties: [known]+ capabilities: [sow]+world:+ default: [blank]+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ upperleft: [-2, 2]+ map: |+ .....+ ..B..+ .....
@@ -22,17 +22,17 @@ char: 'x' description: - Enables `ping` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [ping] - name: map piece display: char: 'm' description: - Half of a treasure map- properties: [known, portable]+ properties: [known, pickable] robots: - name: base- dir: [1,0]+ dir: east devices: - ADT calculator - antenna@@ -48,7 +48,7 @@ inventory: - [1, map piece] - name: buddy- dir: [-1, 0]+ dir: west system: true display: invisible: false@@ -75,8 +75,8 @@ dsl: | overlay [ {terrain: stone}- , if (x/5 + y/5) % 2 == 0 then {terrain: dirt} else {blank}- , if ((x + 3) % 19)/12 + (y % 19)/12 == 0 then {terrain: grass} else {blank}+ , if (x/5 + (-y)/5) % 2 == 0 then {terrain: dirt} else {blank}+ , if ((3 - y) % 19)/12 + (x % 19)/12 == 0 then {terrain: grass} else {blank} ] palette: 'B': [blank, null, base]
@@ -21,11 +21,11 @@ char: 'x' description: - Enables `ping` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [ping] robots: - name: base- dir: [-1,0]+ dir: west devices: - calculator - antenna@@ -38,7 +38,7 @@ - transponder - welder - name: buddy- dir: [1, 0]+ dir: east devices: - ADT calculator - grabber@@ -47,15 +47,15 @@ - transponder inventory: - [1, treads]- program:+ program: | give base "treads"; known: [] world: dsl: | overlay [ {terrain: blank}- , if (x/4 + y/4) % 2 == 0 then {terrain: dirt} else {blank}- , if ((x + 3) % 19)/12 + (y % 19)/12 == 0 then {terrain: grass} else {blank}+ , if (x/4 + (-y)/4) % 2 == 0 then {terrain: dirt} else {blank}+ , if ((3 - y) % 19)/12 + (x % 19)/12 == 0 then {terrain: grass} else {blank} ] palette: 'B': [stone, null, base]
@@ -1,9 +1,6 @@ version: 1 name: Custom unwalkability-description: The base robot cannot walk through trees.- The scenario shall be failed if the robot- manages to walk through the tree by moving- three cells to the east.+description: The base robot cannot walk through trees. The scenario shall be failed if the robot manages to walk through the tree by moving three cells to the east. objectives: - goal: - Get the flower@@ -25,7 +22,7 @@ grab; robots: - name: base- dir: [1, 0]+ dir: east display: attr: robot devices:@@ -34,17 +31,16 @@ - treads - dictionary - net- unwalkable:- - tree+ walkable:+ never:+ - tree known: [tree, flower, bitcoin] world: palette: 'B': [grass, null, base]- '.': [grass] 'T': [grass, tree] 'b': [grass, bitcoin] 'f': [grass, flower] upperleft: [0, 0] map: | BfTb-
@@ -0,0 +1,3 @@+1569-harvest-batch.yaml+1569-cache-invalidation-modes.yaml+1569-cache-invalidation-distance-limit.yaml
@@ -0,0 +1,127 @@+version: 1+name: Pathfinding cache - changing distance limit+description: |+ Demonstrates various sequences of distance limit increases and decreases.+creative: false+objectives:+ - goal:+ - Make lemonade+ condition: |+ as base {+ has "lemonade";+ };+solution: |+ def go =++ // The cache gets initially populated with an+ // unlimited distance, so in a sequence of+ // (1) a decreased limit followed by+ // (2) an increased finite limit,+ // the increase in (2) is still considered a decrease+ // relative to the cache.++ // Invocation #1: Expect RECOMPUTATION+ path (inL ()) (inR "flower");++ // Invocation #2: Expect SUCCESS+ path (inL ()) (inR "flower");++ // Invocation #3: Expect SUCCESS+ path (inR 5) (inR "flower");++ // Invocation #4: Expect SUCCESS+ // Even though this is an increase relative to the previous invocation,+ // it is a decrease relative to the cached limit.+ path (inR 6) (inR "flower");++ move;++ // Invocation #5: Expect RECOMPUTATION+ // We have invoked 'path' from a new location, so evict the cache.+ path (inR 6) (inR "flower");++ // Invocation #6: Expect SUCCESS+ path (inR 4) (inR "flower");++ // Invocation #7: Expect RECOMPUTATION+ path (inR 7) (inR "flower");++ // Invocation #8: Expect SUCCESS+ path (inR 5) (inR "flower");++ // Invocation #9: Expect FAILURE+ // This failure is not cached.+ path (inR 2) (inR "flower");++ // Invocation #10: Expect SUCCESS+ // The cache is still valid from the previous success.+ path (inR 4) (inR "flower");++ make "lemonade";+ end;++ go;+entities:+ - name: wayfinder+ display:+ char: 'w'+ description:+ - Enables `path` command+ properties: [known, pickable]+ capabilities: [path]+ - name: monolith+ display:+ char: '@'+ attr: rock+ description:+ - Pushable rock+ properties: [known, unwalkable, pickable]+ - name: lemon+ display:+ char: 'o'+ attr: gold+ description:+ - Sour fruit+ properties: [known, pickable]+ - name: lemonade+ display:+ char: 'c'+ attr: gold+ description:+ - Sweet drink+ properties: [known, pickable]+recipes:+ - in:+ - [1, lemon]+ out:+ - [1, lemonade]+robots:+ - name: base+ dir: north+ devices:+ - ADT calculator+ - antenna+ - branch predictor+ - comparator+ - compass+ - dictionary+ - linotype+ - logger+ - grabber+ - toolkit+ - treads+ - wayfinder+ - workbench+ inventory:+ - [1, lemon]+known: [flower]+world:+ palette:+ 'B': [grass, erase, base]+ '.': [grass]+ 'f': [grass, flower]+ upperleft: [0, 0]+ map: |+ ....+ B..f+ ....
@@ -0,0 +1,176 @@+version: 1+name: Pathfinding cache - invalidation modes+description: |+ The following sequence is performed:++ 1. An unwalkable entity is added to the path.+ 2. An unwalkable entity is removed from the path.+ 3. The target entity is added somewhere outside of the path+ 4. The target entity is added somewhere on the path++ These events are recorded in the caching log and inspected in the+ integration test.+creative: false+objectives:+ - goal:+ - Make lemonade+ condition: |+ as base {+ has "lemonade";+ };+solution: |+ def queryFlowerPath =+ p <- path (inL ()) (inR "flower");+ log $ format p;+ end;++ def waitUntilSalvaged =+ salvage;+ gotPanel <- has "solar panel";+ if gotPanel {} {waitUntilSalvaged};+ end;++ def forceBlockageInvalidation =+ build {+ require 1 "monolith";+ move;+ place "monolith";+ turn back;+ move;+ };++ waitUntilSalvaged;+ end;++ def forceRemovedUnwalkableInvalidation =+ build {+ turn back;+ push;+ turn back;+ move;+ };++ waitUntilSalvaged;+ end;++ def forceCompetingTargetInvalidation =+ build {+ require 1 "flower";+ turn right;+ move;+ place "flower";+ turn back;+ move;+ };++ waitUntilSalvaged;+ end;++ def go =+ // Invocation #1: Expect RECOMPUTATION+ queryFlowerPath;+ forceBlockageInvalidation;++ // Invocation #2: Expect RECOMPUTATION+ queryFlowerPath;++ turn right;+ move;+ turn left;+ move; move;+ turn left;+ move;+ turn right;++ // Invocation #3: Expect SUCCESS+ queryFlowerPath;+ forceRemovedUnwalkableInvalidation;++ // Invocation #4: Expect RECOMPUTATION+ queryFlowerPath;++ forceCompetingTargetInvalidation;++ // Invocation #5: Expect RECOMPUTATION+ queryFlowerPath;++ place "flower";++ // Invocation #6: Expect SUCCESS+ queryFlowerPath;++ make "lemonade";+ end;++ go;+entities:+ - name: wayfinder+ display:+ char: 'w'+ description:+ - Enables `path` command+ properties: [known, pickable]+ capabilities: [path]+ - name: monolith+ display:+ char: '@'+ attr: rock+ description:+ - Pushable rock+ properties: [known, unwalkable, pickable]+ - name: lemon+ display:+ char: 'o'+ attr: gold+ description:+ - Sour fruit+ properties: [known, pickable]+ - name: lemonade+ display:+ char: 'c'+ attr: gold+ description:+ - Sweet drink+ properties: [known, pickable]+recipes:+ - in:+ - [1, lemon]+ out:+ - [1, lemonade]+robots:+ - name: base+ dir: east+ devices:+ - 3D printer+ - ADT calculator+ - antenna+ - branch predictor+ - comparator+ - compass+ - dictionary+ - linotype+ - logger+ - grabber+ - toolkit+ - treads+ - wayfinder+ - workbench+ inventory:+ - [1, solar panel]+ - [1, treads]+ - [1, dozer blade]+ - [1, grabber]+ - [1, monolith]+ - [2, flower]+ - [1, lemon]+known: [flower]+world:+ palette:+ 'B': [grass, erase, base]+ '.': [grass]+ 'f': [grass, flower]+ upperleft: [0, 0]+ map: |+ .....+ B...f+ .....
@@ -0,0 +1,60 @@+version: 1+name: Pathfinding cache - harvest entity batches+description: |+ Demonstrates repeated application of `path` command to+ harvest a cluster of entities. Upon each harvest,+ the path cache shall be invalidated since the destination+ entity has been removed.+creative: false+objectives:+ - goal:+ - Get 4 flowers.+ condition: |+ as base {+ fCount <- count "flower";+ return $ fCount >= 4;+ };+solution: |+ def goDir = \f. \result.+ let d = fst result in+ if (d == down) {grab; f;} {turn d; move; f;}+ end;++ def followRoute =+ nextDir <- path (inL ()) (inR "flower");+ case nextDir return $ goDir followRoute;+ end;++ followRoute;+entities:+ - name: wayfinder+ display:+ char: 'w'+ description:+ - Enables `path` command+ properties: [known, pickable]+ capabilities: [path]+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - compass+ - dictionary+ - logger+ - grabber+ - treads+ - wayfinder+known: [flower]+world:+ palette:+ 'B': [grass, erase, base]+ '.': [grass]+ 'f': [grass, flower]+ upperleft: [0, 0]+ map: |+ B...+ ..ff+ ..ff
@@ -0,0 +1,16 @@+1575-browse-structures.yaml+1575-nested-structure-definition.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+1575-interior-entity-placement.yaml+1575-floorplan-command.yaml+1575-bounding-box-overlap.yaml+1644-rotated-recognition.yaml+1644-rotated-preplacement-recognition.yaml
@@ -0,0 +1,83 @@+version: 1+name: Structure recognizer - overlapping bounding boxes+description: |+ Recognize non-rectangular structures even when+ bounding boxes overlap with each other,+ or when non-participating entities encroach within+ the candidate bounding box.++ In this scenario, there is only one possible arrangement.+creative: false+objectives:+ - teaser: Build structures+ goal:+ - |+ Build 3 `chevron`{=structure} structures+ condition: |+ foundStructure <- structure "chevron" 0;+ return $ case foundStructure (\_. false) (\x. fst x >= 3);+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - dictionary+ - fast grabber+ - lambda+ - logger+ - strange loop+ - treads+ inventory:+ - [10, boulder]+solution: |+ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++ doN 2 move;+ turn right;++ doN 2 (place "boulder"; move;);+ turn right;+ doN 2 (place "boulder"; move;);+ place "boulder";++ turn left;+ doN 2 move;++ turn left;+ doN 2 move;++ doN 2 (place "boulder"; move;);+ turn left;+ doN 3 (place "boulder"; move;);+structures:+ - name: chevron+ recognize: [north]+ structure:+ palette:+ 'g': [stone, boulder]+ mask: '.'+ map: |+ ..g+ ..g+ ggg+known: [boulder, mountain, water]+world:+ name: root+ dsl: |+ {water}+ palette:+ '.': [grass, erase]+ 'B': [grass, erase, base]+ 'M': [grass, mountain]+ placements:+ - src: chevron+ offset: [1, -1]+ upperleft: [0, 0]+ map: |+ B....+ .M...+ .....+ .....+ .....
@@ -0,0 +1,130 @@+version: 1+name: Structure browser+description: |+ Hit *F6* to view the recognizable structures.++ Only the subset of the structures marked with+ *recognize: [north]* are browseable.+ In particular, the `donut`{=structure} structure is placed+ in the map but not displayed in the *F6* dialog.+creative: false+objectives:+ - teaser: Build structure+ goal:+ - |+ Build a `precious`{=structure} structure+ condition: |+ foundStructure <- structure "precious" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ dir: east+ 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: [north]+ description: "A diamond pattern of flowers"+ structure:+ mask: '.'+ palette:+ 'x': [stone, flower]+ map: |+ ...x...+ ..xxx..+ .xxxxx.+ xxxxxxx+ .xxxxx.+ ..xxx..+ ...x...+ - name: contraption+ recognize: [north]+ 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: [north]+ structure:+ mask: '.'+ palette:+ 'q': [stone, quartz]+ 'g': [stone, gold]+ 's': [stone, silver]+ 'm': [stone, mithril]+ map: |+ qgs+ gsq+ qqm+ - name: smallish+ recognize: [north]+ 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]+ 'c': [grass, cotton]+ 'B': [grass, null, base]+ upperleft: [0, 0]+ placements:+ - src: donut+ offset: [6, 0]+ map: |+ .qgs.........+ .gsq.........+ B............+ .cqq.........+ .............
@@ -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} structure+ condition: |+ foundGreen <- structure "green_jewel" 0;+ return $ case foundGreen (\_. false) (\x. fst x >= 12);+robots:+ - name: base+ dir: east+ 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: [north]+ 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........+ .........+ .........+ .........+ .........+ .........+ .........+ .........+ .........+ .........+ .........+ .........
@@ -0,0 +1,85 @@+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 `chessboard`{=structure}s+ 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: south+ devices:+ - grabber+ - treads+ inventory:+ - [3, silver]+solution: |+ move;+ turn left;+ place "silver";+ move; move;+ place "silver";+ move; move;+ place "silver";+structures:+ - name: chessboard+ recognize: [north]+ structure:+ mask: '.'+ palette:+ 'g': [stone, gold]+ 's': [stone, silver]+ map: |+ gsgs+ sgsg+ gsgs+ sgsg+known: [water, gold, silver]+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
@@ -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 `chessboard`{=structure}s+ 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: south+ 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: [north]+ 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.
@@ -0,0 +1,75 @@+version: 1+name: Floorplan command+description: |+ Query the dimensions of a structure+ template to build one.+creative: false+objectives:+ - teaser: Build structure+ goal:+ - |+ Build a `wooden box`{=structure} structure.+ condition: |+ def isRight = \x. case x (\_. false) (\_. true); end;+ foundBox <- structure "wooden box" 0;+ return $ isRight foundBox;+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - blueprint+ - branch predictor+ - comparator+ - dictionary+ - grabber+ - logger+ - treads+ inventory:+ - [100, board]+solution: |+ def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;++ def mkRow = \width.+ doN width $ (place "board"; move;);+ turn back;+ doN width move;+ end;++ def mkRows = \height. \width.+ doN height $ (mkRow width; turn left; move; turn left);+ end;++ dims <- floorplan "wooden box";+ let width = fst dims in+ let height = snd dims in++ mkRows height width;+structures:+ - name: wooden box+ recognize: [north]+ structure:+ palette:+ 'b': [stone, board]+ map: |+ bbbbbbb+ bbbbbbb+ bbbbbbb+ bbbbbbb+ bbbbbbb+known: [board]+world:+ dsl: |+ {blank}+ palette:+ '.': [grass, erase]+ 'B': [grass, erase, base]+ upperleft: [0, 0]+ map: |+ ..........+ .B........+ ..........+ ..........+ ..........+ ..........+ ..........
@@ -0,0 +1,75 @@+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} structure+ condition: |+ foundStructure <- structure "precious" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ dir: east+ 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: [north]+ structure:+ mask: '.'+ palette:+ 'q': [stone, quartz]+ 'g': [stone, gold]+ 's': [stone, silver]+ 'm': [stone, mithril]+ map: |+ qgs+ gsq+ qqm+ - name: smallish+ recognize: [north]+ 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]+ 'c': [grass, cotton]+ 'B': [grass, null, base]+ upperleft: [0, 0]+ map: |+ .qgs.+ .gsq.+ B....+ .cqq.
@@ -0,0 +1,109 @@+version: 1+name: Structure recognition - interior space+description: |+ Entities can be added and removed+ on empty cells within the rectangular+ boundary of an already-placed structure without+ affecting its recognition status.++ Additionally, recognition of statically-placed+ structures at scenario initialization is also+ unaffected by interior entities.++ However, any such "contaminating" entities+ will prevent the recognition of a structure+ when constructed by a robot.+creative: false+objectives:+ - teaser: Replace rock+ prerequisite: grab_rock+ goal:+ - |+ Place the `rock`{=entity} entity back inside the `pigpen`{=structure}.+ condition: |+ foundBox <- structure "pigpen" 0;+ case foundBox (\_. return false) (\struc.+ let structPos = snd struc in+ j <- robotnamed "judge";+ as j {+ structBounds <- floorplan "pigpen";++ // Move to bottom-left corner+ teleport self structPos;++ rockCount <- resonate "rock" ((0, 0), structBounds);+ return $ rockCount > 0;+ }+ );+ - teaser: Grab rock+ id: grab_rock+ prerequisite: prerecognized+ goal:+ - |+ Grab an entity from inside a `pigpen`{=structure} structure.+ condition: |+ as base {+ has "rock";+ }+ - teaser: Prerecognize+ id: prerecognized+ goal:+ - |+ `pigpen`{=structure} structure should be recognized upon initialization,+ even with an extraneous entity within its bounds.+ condition: |+ def isRight = \x. case x (\_. false) (\_. true); end;+ foundBox <- structure "pigpen" 0;+ return $ isRight foundBox;+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - blueprint+ - grabber+ - logger+ - treads+ - name: judge+ dir: east+ system: true+ display:+ invisible: true+solution: |+ move; move;+ x <- grab;+ move;+ place x;+structures:+ - name: pigpen+ recognize: [north]+ structure:+ palette:+ 'b': [stone, board]+ mask: '.'+ map: |+ bbbb+ b..b+ b..b+ bbbb+known: [board, rock]+world:+ dsl: |+ {blank}+ placements:+ - src: pigpen+ offset: [1, 0]+ - src: pigpen+ offset: [3, -6]+ palette:+ '.': [grass, erase]+ 'B': [grass, erase, base]+ 'r': [grass, rock]+ 'j': [grass, erase, judge]+ upperleft: [-7, 3]+ map: |+ j.....+ ......+ B.r...+ ......+ ......
@@ -0,0 +1,100 @@+version: 1+name: Structure recognizer - nested structure+description: |+ Ensure nested structures are assembled correctly.+ Demonstrate structure recognition both before+ a member is removed and after replacing it.+creative: false+objectives:+ - teaser: Re-recognized+ prerequisite: grab_tree+ goal:+ - |+ Replace `tree`{=entity} after grabbing.+ The `double ring`{=structure} structure should be recognized again.+ condition: |+ foundStructure <- structure "double ring" 0;+ return $ case foundStructure (\_. false) (\_. true);+ - teaser: Pre-recognized+ id: pre_recognized+ prerequisite:+ not: grab_tree+ goal:+ - |+ Pre-placed structure must be recognized+ condition: |+ foundStructure <- structure "double ring" 0;+ return $ case foundStructure (\_. false) (\_. true);+ - teaser: Grab tree+ id: grab_tree+ goal:+ - |+ Grab a `tree`{=entity}+ condition: |+ as base {+ has "tree";+ }+solution: |+ move; move;+ t <- grab;+ place t;+robots:+ - name: base+ dir: south+ devices:+ - grabber+ - treads+structures:+ - name: double ring+ recognize: [north]+ structure:+ palette:+ 's': [ice, tree]+ mask: '.'+ structures:+ - name: treering+ structure:+ palette:+ 'p': [dirt, tree]+ map: |+ p+ p+ placements:+ - src: treering+ offset: [0, 0]+ - src: treering+ offset: [2, 0]+ map: |+ .s.+ ...+ - name: flowerbox+ recognize: [north]+ structure:+ palette:+ 'f': [ice, flower]+ mask: '.'+ map: |+ fff+ f.f+ f.f+ fff+known: [tree, flower]+world:+ name: root+ dsl: |+ {blank}+ placements:+ - src: double ring+ offset: [4, -2]+ - src: flowerbox+ offset: [1, 0]+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ upperleft: [-4, 7]+ map: |+ ....B...+ ........+ ........+ ........+ ........
@@ -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: east+ devices:+ - grabber+ - treads+ inventory:+ - [1, gold]+ - [1, silver]+solution: |+ move;+ place "gold";+structures:+ - name: large+ recognize: [north]+ structure:+ mask: '.'+ palette:+ 'g': [stone, gold]+ 's': [stone, silver]+ map: |+ sss+ ggs+ ggs+ - name: small+ recognize: [north]+ 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
@@ -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 `topleft`{=structure} 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} structure shouldn't be recognized.+ condition: |+ foundStructure <- structure "bottomright" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ dir: east+ devices:+ - grabber+ - treads+ inventory:+ - [1, gold]+ - [1, silver]+solution: |+ move; move; move;+ place "gold";+structures:+ - name: topleft+ recognize: [north]+ structure:+ mask: '.'+ palette:+ 'g': [stone, gold]+ 's': [stone, silver]+ map: |+ ss+ gg+ gg+ - name: bottomright+ recognize: [north]+ 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
@@ -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} 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} 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: east+ devices:+ - fast grabber+ - treads+ inventory:+ - [1, pixel (R)]+solution: |+ noop;+structures:+ - name: red_jewel+ recognize: [north]+ structure:+ palette:+ 'r': [stone, pixel (R)]+ map: |+ rrr+ rrr+ rrr+ - name: green_jewel+ recognize: [north]+ 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: red_jewel+ offset: [1, -1]+ - src: red_jewel+ offset: [1, -5]+ - src: red_jewel+ offset: [5, -1]+ - src: red_jewel+ offset: [5, -5]+ - src: green_jewel+ offset: [3, -3]+ map: |+ .........+ .........+ .........+ B........+ .........+ .........+ .........+ .........+ .........
@@ -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 `chessboard`{=structure} structure+ condition: |+ foundStructure <- structure "chessboard" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ dir: south+ devices:+ - grabber+ - treads+ inventory:+ - [1, gold]+ - [1, silver]+solution: |+ move;+ place "silver";+ grab;+structures:+ - name: chessboard+ recognize: [north]+ 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
@@ -0,0 +1,115 @@+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} 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} 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} structure+ condition: |+ def isRight = \x. case x (\_. false) (\_. true); end;++ foundRed <- structure "red_jewel" 0;+ return $ isRight foundRed;+robots:+ - name: base+ dir: east+ 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: [north]+ structure:+ mask: '.'+ palette:+ 'g': [stone, gold]+ 's': [stone, silver]+ 'j': [stone, pixel (R)]+ map: |+ ggggg+ gsssg+ gsjsg+ gsssg+ ggggg+ - name: green_jewel+ recognize: [north]+ structure:+ mask: '.'+ palette:+ 'g': [stone, gold]+ 's': [stone, silver]+ 'j': [stone, pixel (G)]+ map: |+ ggggg+ gsssg+ gsjsg+ gsssg+ ggggg+ - name: blue_jewel+ recognize: [north]+ 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]+ 'B': [grass, null, base]+ upperleft: [0, 0]+ placements:+ - src: red_jewel+ offset: [1, 0]+ map: |+ ......+ ......+ B.....+ ......+ ......
@@ -0,0 +1,47 @@+version: 1+name: Rotated pre-placed structure recognition+description: |+ Pre-placed structure recognition with rotation+creative: false+objectives:+ - teaser: Have structure+ goal:+ - |+ Have a `tee`{=structure} structure+ condition: |+ foundStructure <- structure "tee" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ dir: east+solution: |+ noop;+structures:+ - name: tee+ recognize: [north, south, east, west]+ description: "A tee pattern of flowers"+ structure:+ mask: '.'+ palette:+ 'x': [stone, flower]+ map: |+ .x.+ xxx+known: [flower]+world:+ name: root+ dsl: |+ {blank}+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ upperleft: [0, 0]+ placements:+ - src: tee+ offset: [2, 0]+ orient:+ up: east+ map: |+ B....+ .....+ .....
@@ -0,0 +1,51 @@+version: 1+name: Rotated structure recognition+description: |+ Structure recognition with rotation+creative: false+objectives:+ - teaser: Build structure+ goal:+ - |+ Build a `tee`{=structure} structure+ condition: |+ foundStructure <- structure "tee" 0;+ return $ case foundStructure (\_. false) (\_. true);+robots:+ - name: base+ dir: east+ devices:+ - grabber+ - treads+ inventory:+ - [4, flower]+solution: |+ move; move;+ turn right;+ move; move;+ place "flower";+structures:+ - name: tee+ recognize: [north, south, east, west]+ description: "A tee pattern of flowers"+ structure:+ mask: '.'+ palette:+ 'x': [stone, flower]+ map: |+ .x.+ xxx+known: [flower]+world:+ name: root+ dsl: |+ {blank}+ palette:+ '.': [grass]+ 'x': [stone, flower]+ 'B': [grass, null, base]+ upperleft: [0, 0]+ map: |+ B.x..+ ..xx.+ .....
@@ -0,0 +1,109 @@+version: 1+name: Entity change detection+author: Karl Ostmo+description: |+ Ensure that a change to an entity can be observed+ by a system robot within a single tick.++ In this scenario, the base will first `swap` the+ existing `dial (R)`{=entity} with a `dial (G)`{=entity},+ then immediately `swap` again with a `dial (B)`{=entity}.++ The system robot should be able to detect the presence+ of the `dial (G)`{=entity} before it is `swap`ped a second time.+creative: false+seed: 0+objectives:+ - goal:+ - |+ Turn the light green+ condition: |+ as base {has "flower"};+ prerequisite:+ not: blue_light+ - id: blue_light+ teaser: No blue light+ optional: true+ goal:+ - |+ Turn the light blue+ condition: |+ r <- robotnamed "lockbot";+ as r {ishere "dial (B)"};+robots:+ - name: base+ dir: [1, 0]+ display:+ invisible: true+ devices:+ - hourglass+ - fast grabber+ - logger+ - treads+ inventory:+ - [1, "dial (R)"]+ - [1, "dial (G)"]+ - [1, "dial (B)"]+ - name: lockbot+ system: true+ display:+ invisible: true+ dir: [1, 0]+ program: |+ def doUntilCorrect =+ herenow <- ishere "dial (G)";+ if herenow {+ give base "flower";+ } {+ loc <- whereami;+ surveil loc;+ wait 1000;+ doUntilCorrect;+ }+ end;++ def go =+ doUntilCorrect;+ end;++ go;+ inventory:+ - [1, flower]+solution: |+ move;+ move;+ swap "dial (G)";+ swap "dial (B)";+entities:+ - name: "dial (R)"+ display:+ char: '•'+ attr: red+ description:+ - A red dial+ properties: [known, pickable]+ - name: "dial (G)"+ display:+ char: '•'+ attr: green+ description:+ - A green dial+ properties: [known, pickable]+ - name: "dial (B)"+ display:+ char: '•'+ attr: blue+ description:+ - A blue dial+ properties: [known, pickable]+world:+ dsl: |+ {blank}+ upperleft: [-1, -1]+ offset: false+ palette:+ '.': [grass, erase]+ 'B': [grass, erase, base]+ 'c': [grass, dial (R), lockbot]+ map: |+ B.c
@@ -0,0 +1,130 @@+version: 1+name: Test tag commands+description: |+ Test the `hastag` and `tagmembers` command.+objectives:+ - condition: |+ as base {has "mushroom"}+ prerequisite:+ not: got_fruit+ goal:+ - |+ Pick up something `edible`{=tag} that is not a `fruit`{=tag}.+ - teaser: "No fruit!"+ id: got_fruit+ optional: true+ condition: |+ // Returns true if prohibited item is in inventory.+ def checkFruit = \idx.+ result <- tagmembers "fruit" idx;+ let totalCount = fst result in+ let member = snd result in+ let nextIdx = idx + 1 in++ hasProhibited <- as base {has member};+ if hasProhibited {+ return true;+ } {+ if (nextIdx < totalCount) {+ checkFruit nextIdx;+ } {+ return false;+ }+ }+ end;++ checkFruit 0;+ goal:+ - |+ Do not pick up any fruit.+solution: |+ def findTarget =+ result <- scan down;+ isTarget <- case result (\_. return false) (\item.+ isEdible <- hastag item "edible";+ isFruit <- hastag item "fruit";+ return $ isEdible && not isFruit;+ );++ if isTarget {+ grab;+ return ();+ } {+ move;+ findTarget;+ }+ end;++ findTarget;+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - branch predictor+ - barcode scanner+ - dictionary+ - grabber+ - lambda+ - lodestone+ - logger+ - scanner+ - solar panel+ - strange loop+ - treads+entities:+ - name: barcode scanner+ display:+ attr: red+ char: 'S'+ description:+ - Reads the 'tag' of an item+ properties: [pickable]+ capabilities: [hastag, tagmembers]+ - name: canteloupe+ display:+ char: 'c'+ description:+ - Melon+ tags: [edible, fruit]+ properties: [pickable]+ - name: mushroom+ display:+ char: 'm'+ description:+ - Nature's tiny umbrella.+ tags: [edible, fungus]+ properties: [pickable]+ - name: gravel+ display:+ char: 'g'+ description:+ - Crushed rock+ properties: [pickable]+ - name: strawberry+ display:+ char: 's'+ description:+ - Just ripe+ tags: [edible, fruit]+ - name: peach+ display:+ char: 'g'+ description:+ - Just ripe+ tags: [edible, fruit]+ properties: [pickable]+world:+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ 'a': [grass, canteloupe]+ 'b': [grass, gravel]+ 'c': [grass, strawberry]+ 'd': [grass, mushroom]+ 'e': [grass, peach]+ upperleft: [-5, 5]+ map: |+ .......+ B.abcde+ .......
@@ -0,0 +1,40 @@+version: 1+name: Robot message log coloring+description: |+ Demo color selection for robot log messages+robots:+ - name: base+ devices:+ - logger+ - hearing aid+ - name: saybot+ system: true+ display:+ invisible: false+ attr: blue+ program: |+ loc <- whereami;+ let idx = -(snd loc) in+ wait $ idx + 1;+ say $ "Hello saybot" ++ format idx;+world:+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ 's': [grass, null, saybot]+ upperleft: [0, 0]+ map: |+ B.s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s+ ..s
@@ -0,0 +1,102 @@+version: 1+name: Demo growth biomes+description: |+ Demonstrate growth restrictions.++ `move`-ing to the distant goal cell gives the+ `wheat`{=entity} enough time to grow back.+objectives:+ - id: harvested+ goal:+ - |+ `harvest` both `wheat`{=entity},+ from west to east.+ Only the eastern wheat should grow back.+ condition: |+ as base {+ c <- count "wheat";+ return $ c == 2;+ }+ - id: western_wheat_regrew+ optional: true+ goal:+ - |+ Wheat in grass must not regrow+ condition: |+ observer <- robotnamed "observer";+ as observer {+ ishere "wheat";+ }+ prerequisite: harvested+ - goal:+ - |+ Go to the stone patch.+ This takes at least 10 ticks,+ by which time the+ `wheat`{=entity} would have grown back.+ Fails if the western wheat does grow back.+ condition: |+ goalbot <- robotnamed "goalbot";+ baseLoc <- as base {whereami};+ as goalbot {+ goalLoc <- whereami;+ return $ baseLoc == goalLoc;+ }+ prerequisite:+ logic:+ and:+ - harvested+ - not: western_wheat_regrew+solution: |+ move; harvest;+ move; harvest;+ move;+ move; move; move; move; move;+ move; move; move; move; move;+robots:+ - name: base+ dir: east+ devices:+ - logger+ - scythe+ - treads+ - name: observer+ dir: east+ system: true+ - name: goalbot+ dir: east+ system: true+entities:+ - name: wheat+ display:+ char: 'w'+ attr: gold+ description:+ - Grain+ properties: [known, pickable, growable]+ growth: [2, 4]+ biomes: [dirt]+ - name: scythe+ display:+ char: 'y'+ description:+ - Curved blade on a long handle+ properties: [known]+ capabilities:+ - harvest+ biomes: [dirt]+known: [flower]+world:+ default: [blank]+ palette:+ '.': [grass]+ 'd': [dirt]+ 's': [stone, null, goalbot]+ 'w': [grass, wheat, observer]+ 'W': [dirt, wheat]+ 'B': [grass, null, base]+ upperleft: [-1, 1]+ map: |+ ..dd..........+ BwWd.........s+ ..............
@@ -0,0 +1,56 @@+version: 1+name: Push test+creative: false+description: Push item+objectives:+ - goal:+ - Push a crate onto the stone pad+ condition: |+ j <- robotnamed "judge";+ as j {ishere "crate"}+solution: |+ move;+ push;+robots:+ - name: base+ dir: east+ display:+ char: Ω+ attr: robot+ devices:+ - branch predictor+ - calculator+ - compass+ - dictionary+ - grabber+ - logger+ - net+ - scanner+ - treads+ - dozer blade+ - name: judge+ dir: north+ system: true+ display:+ char: j+ attr: robot+ invisible: true+entities:+ - name: crate+ display:+ attr: wood+ char: 'c'+ description:+ - Pushable crate+ properties: [known, pushable]+known: [water]+world:+ dsl: |+ {water}+ palette:+ 'Ω': [grass, erase, base]+ 'j': [stone, erase, judge]+ 'x': [grass, crate]+ upperleft: [0, 0]+ map: |+ Ωxxj
@@ -0,0 +1,86 @@+version: 1+name: Custom walkability+description: |+ The monkey can only walk on `tree`{=entity}s (and `banana`{=entity}s).+ The `path` command must fail until the path of `tree`{=entity}s is completed.++ NOTE: In order for the objectives to be evaluated properly for a "Win", they must be+ ordered strictly with "banana_access" coming before "placed_tree" in the+ list below.+objectives:+ - id: banana_access+ teaser: Banana access+ goal:+ - Give monkey access to `banana`{=entity}+ condition: |+ m <- robotnamed "monkey";+ as m {+ p <- path (inR 10) (inR "banana");+ return $ case p (\_. false) (\_. true);+ };+ - id: placed_tree+ teaser: Tree placed+ prerequisite:+ not: banana_access+ goal:+ - Tree must be placed+ condition: |+ x <- as base {has "tree"};+ return $ not x;+solution: |+ move;+ move;+ place "tree"+entities:+ - name: banana+ display:+ char: ')'+ attr: gold+ description:+ - Tasty treat for a monkey+ properties: [known, pickable]+robots:+ - name: base+ dir: east+ display:+ attr: robot+ devices:+ - logger+ - grabber+ - treads+ - dictionary+ - net+ inventory:+ - [1, tree]+ - name: monkey+ dir: south+ display:+ char: M+ attr: robot+ devices:+ - logger+ - grabber+ - treads+ - dictionary+ - net+ walkable:+ only:+ - tree+ - banana+known: [tree]+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, null, base]+ 'M': [grass, null, monkey]+ '.': [grass]+ 'T': [grass, tree]+ 'b': [grass, banana]+ upperleft: [0, 0]+ map: |+ ..M.+ ..T.+ B...+ ..T.+ ..b.
@@ -0,0 +1,101 @@+version: 1+name: Custom walkability - whitelist+description: |+ Exercise various scenarios of path cache invalidation.+objectives:+ - goal:+ - Get somewhere+ condition: |+ as base {ishere "platform"}+solution: |+ def goDir = \f. \result.+ let d = fst result in+ if (d == down) {return ()} {turn d; move; f;}+ end;++ def followRoute =+ nextDir <- path (inL ()) (inR "platform");+ case nextDir return $ goDir followRoute;+ end;++ followRoute;+entities:+ - name: platform+ display:+ char: 'P'+ attr: ice+ description:+ - Goal at the end of the trees+ properties: [known]+ - name: wayfinder+ display:+ char: 'w'+ description:+ - |+ Enables the `path` command:+ - |+ `path : (Unit + Int) -> ((Int * Int) + Text) -> Cmd (Unit + (Dir * Int))`+ - |+ Optionally supply a distance limit as the first argument, and+ supply either a location (`inL`) or an entity (`inR`) as the second argument.+ - |+ Example:+ - |+ `path (inL ()) (inR "tree");`+ - If a path exists, returns the direction to proceed along.+ properties: [known, pickable]+ capabilities: [path]+robots:+ - name: base+ dir: east+ display:+ attr: robot+ devices:+ - ADT calculator+ - branch predictor+ - comparator+ - compass+ - dictionary+ - grabber+ - logger+ - net+ - treads+ - wayfinder+ walkable:+ only:+ - tree+ - platform+ - name: sysbot+ dir: east+ system: true+ display:+ attr: robot+ invisible: false+ program: |+ move;+ t <- grab;+ move;+ place t;+ turn left;+ move;+ move;+ t2 <- grab;+ turn back;+ move;+known: [tree]+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, null, base]+ 'S': [grass, null, sysbot]+ '.': [grass]+ 'T': [grass, tree]+ 'P': [grass, platform]+ upperleft: [0, 0]+ map: |+ ............+ ......TTT...+ BTTTTTTTTP..+ ............+ .....ST.....
@@ -0,0 +1,56 @@+version: 1+name: Demo volume command+description: |+ Measure volume of enclosed space+creative: true+objectives:+ - goal:+ - |+ Make an enclosed volume of 14 cells+ condition: |+ as base {+ let targetVolume = 14 in+ vol <- volume targetVolume;+ return $case vol (\_. false) (\x. x == targetVolume);+ }+solution: |+ move;+ push;+ turn left;+ move;+ turn right;+ move;+ turn right;+ push;+robots:+ - name: base+ dir: east+ devices:+ - ADT calculator+ - treads+ - dozer blade+ - logger+ - branch predictor+ - comparator+entities:+ - name: monolith+ display:+ char: '@'+ description:+ - Pushable rock+ properties: [known, unwalkable, pickable]+known: [mountain]+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, null, base]+ '.': [grass]+ 'A': [stone, mountain]+ '@': [grass, monolith]+ upperleft: [-1, 1]+ map: |+ AAAAAAAAA+ A.......A+ AB.@....A+ AAAA.AAAA
@@ -0,0 +1,58 @@+version: 1+name: Demo custom terrain+description: |+ Colorful new terrain+creative: false+attrs:+ - name: beachsand+ bg: "#c2b280"+ - name: lava+ bg: "#dd7733"+ - name: lilac+ bg: "#a4a4bb"+terrains:+ - name: beach+ attr: beachsand+ description: |+ Shoreline covering, laborious to cross+ - name: lava+ attr: lava+ description: |+ Scorching, liquid rock+ - name: heather+ attr: lilac+ description: |+ Flowery ground cover+objectives:+ - goal:+ - |+ No entities should be here+ condition: |+ as base {+ isEmpty+ }+solution: |+ noop+robots:+ - name: base+ dir: east+known: []+world:+ dsl: |+ {grass}+ palette:+ 'B': [heather, null, base]+ '.': [heather]+ 'i': [ice]+ 'b': [beach]+ 'v': [lava]+ upperleft: [0, 0]+ map: |+ vvvvvvvv+ vvvvvvvv+ B.......+ ........+ iiiiiiii+ iiiiiiii+ bbbbbbbb+ bbbbbbbb
@@ -0,0 +1,94 @@+version: 1+name: Capability cost+description: |+ Consume inventory by exercising device capabilities+creative: false+seed: 0+objectives:+ - goal:+ - |+ Eliminate the `packing peanut`{=entity}s+ condition: |+ hasLighterFluid <- as base {+ has "lighter fluid";+ };++ if (not hasLighterFluid) {+ judge <- robotnamed "judge";+ as judge {+ maybePath <- path (inL ()) (inR "packing peanut");+ return $ case maybePath (\_. true) (\d. false);+ }+ } {+ return false;+ };+solution: |+ move;+ turn right;+ move;+ place "packing peanut";+ ignite down;+ move;+ move;+ ignite forward;+robots:+ - name: base+ dir: east+ devices:+ - treads+ - logger+ - Zippo+ - grabber+ inventory:+ - [2, lighter fluid]+ - [1, packing peanut]+ - name: judge+ dir: east+ system: true+entities:+ - name: lighter fluid+ display:+ char: 'f'+ description:+ - Fuel for a `Zippo`{=entity}+ properties: [known, pickable]+ - name: Zippo+ display:+ char: 'z'+ description:+ - Ignites things+ properties: [known, pickable]+ capabilities:+ - capability: ignite+ cost:+ - [1, "lighter fluid"]+ - name: packing peanut+ display:+ attr: snow+ char: 's'+ description:+ - Easy to drop, but impossible to pick up.+ - Highly combustible.+ properties: [known, combustible]+ combustion:+ ignition: 0.5+ duration: [10, 20]+ product: ash+known: [water, ash]+world:+ dsl: |+ {water}+ palette:+ 'B': [grass, erase, base]+ 'j': [grass, erase, judge]+ '.': [grass, erase]+ 'c': [grass, packing peanut]+ upperleft: [-1, 1]+ map: |+ ......+ Bcccc.+ .j....+ .cccc.+ ......+ .cccc.+ ......
@@ -0,0 +1,3 @@+nonoverlapping-structure-merge.yaml+root-map-expansion.yaml+structure-composition.yaml
@@ -0,0 +1,59 @@+version: 1+name: Expansion of a substructure to fit its placements+description: |+ Define two structures and place them on the map.+robots:+ - name: base+ loc: [4, -4]+ dir: east+known: [water, sand, tree]+world:+ palette:+ '.': [grass]+ upperleft: [-1, 1]+ structures:+ - name: vertical rectangle+ structure:+ palette:+ 'x': [blank, tree]+ map: |+ xx+ xx+ xx+ xx+ - name: horizontal rectangle+ structure:+ palette:+ 'x': [blank, sand]+ map: |+ xxxx+ xxxx+ - name: disjoint rectangles+ structure:+ palette:+ 'x': [blank, water]+ map: |+ xx+ xx+ placements:+ - src: vertical rectangle+ offset: [-7, 7]+ - src: horizontal rectangle+ offset: [7, -7]+ placements:+ - src: disjoint rectangles+ offset: [2, -2]+ map: |+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............+ ...............
@@ -0,0 +1,30 @@+version: 1+name: Non-overlapping merging with expansion+description: |+ Define two structures and place them on the map.++ Demonstrates automatic expansion of the root map grid.+robots:+ - name: base+ loc: [8, 0]+ dir: east+known: [tree, sand, water]+world:+ palette:+ '.': [grass]+ 'i': [ice]+ 'j': [dirt]+ upperleft: [3, 3]+ structures:+ - name: single tree+ structure:+ palette:+ 'x': [blank, tree]+ map: |+ x+ placements:+ - src: single tree+ offset: [-2, -4]+ map: |+ i.+ .j
@@ -0,0 +1,99 @@+version: 1+name: Various structure merging arrangements+description: |+ Define two structures and place them on the map.+robots:+ - name: base+ loc: [11, 0]+ dir: east+known: [water, sand]+world:+ palette:+ '.': [grass]+ upperleft: [-1, 1]+ structures:+ - name: vertical rectangle+ structure:+ palette:+ 'x': [blank, water]+ map: |+ xx+ xx+ xx+ xx+ - name: horizontal rectangle+ structure:+ palette:+ 'x': [blank, sand]+ map: |+ xxxx+ xxxx+ - name: combined rectangles blank base+ structure:+ palette:+ 'x': [blank]+ map: |+ xxxx+ xxxx+ xxxx+ xxxx+ placements:+ - src: vertical rectangle+ - src: horizontal rectangle+ - name: combined rectangles empty base+ structure:+ map: ""+ placements:+ - src: vertical rectangle+ - src: horizontal rectangle+ - name: combined rectangles single cell base+ structure:+ palette:+ 'x': [blank]+ map: |+ x+ placements:+ - src: vertical rectangle+ - src: horizontal rectangle+ - name: multi overlap+ structure:+ palette:+ 'x': [blank]+ map: |+ xxxx+ placements:+ - src: vertical rectangle+ offset: [1, 0]+ - src: horizontal rectangle+ offset: [0, -2]+ - src: vertical rectangle+ offset: [3, -2]+ - src: horizontal rectangle+ offset: [3, -4]+ - src: vertical rectangle+ offset: [5, -4]+ placements:+ - src: vertical rectangle+ offset: [1, -1]+ - src: horizontal rectangle+ offset: [1, -1]+ - src: multi overlap+ offset: [1, -6]+ - src: combined rectangles blank base+ offset: [6, -1]+ - src: combined rectangles empty base+ offset: [11, -1]+ - src: combined rectangles single cell base+ offset: [11, -6]+ map: |+ ................+ ................+ ................+ ................+ ................+ ................+ ................+ ................+ ................+ ................+ ................
@@ -5,3 +5,4 @@ 201-require-entities-def.yaml 533-reprogram-simple.yaml 533-reprogram.yaml+1664-require-system-robot-children.yaml
@@ -0,0 +1,51 @@+version: 1+name: Requirements of system-robot children+description: |+ Normally, system robots are not required to possess devices in order to use any particular command.+ However, a robot built by a system robot becomes subject to the requirement.+ This is a bug.++ In this scenario, the child robot cannot be built because the+ parent robot ("queenbee") does not possess a "beaglepuss" in its inventory.+objectives:+ - condition: |+ try {+ robotnamed "childbot";+ return true;+ } {+ return false;+ }+solution: |+ noop;+robots:+ - name: base+ dir: east+ - name: queenbee+ dir: east+ system: true+ display:+ invisible: false+ char: 'Q'+ inventory:+ - [1, solar panel]+ - [0, beaglepuss]+ program: |+ def createWorker =+ build {+ setname "childbot";+ appear "B" (inl ());+ };+ end;++ createWorker;+known: [water]+world:+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ 'Q': [grass, null, queenbee]+ upperleft: [-1, 1]+ map: |+ B..Q+ ....+ ....
@@ -18,8 +18,8 @@ build {require "boat"; move; move} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - 3D printer - logger
@@ -18,8 +18,8 @@ build {require "boat"; move; move} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - 3D printer@@ -46,7 +46,7 @@ attr: water char: ' ' description:- - An infinite ocean of water.- properties: [known, portable, growable, liquid]- growth: [0,0]+ - An infinite ocean of water.+ properties: [known, pickable, growable, liquid]+ growth: [0, 0] yields: water
@@ -17,8 +17,8 @@ build {require "boat"; move; require "boat"; move} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - 3D printer - logger
@@ -17,8 +17,8 @@ build { log "hi"; require 5 "rock"; mp; mp; mp; mp } robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - 3D printer - logger
@@ -15,8 +15,8 @@ build { require 5 "rock"; move; place "rock"; move; place "rock" } robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - 3D printer - logger
@@ -31,8 +31,8 @@ reprogram fred {require "boat"; require "metal drill"; move; move} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - 3D printer - logger
@@ -31,8 +31,8 @@ reprogram fred {require "boat"; require "metal drill"; move; require 3 "rock"; move; require 5 "rock"} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - 3D printer - logger
@@ -0,0 +1,1 @@+231-command-transformer-reqs.yaml
@@ -0,0 +1,36 @@+name: Foo+version: 1+description: |+ A function transforming a command correctly accumulates requirements.+creative: false+solution: |+ def pr = require 1 "rock"; move; place "rock" end+ def x4 = \c. c;c;c;c end+ build {x4 pr}+objectives:+ - goal:+ - Place four rocks+ condition: |+ judge <- robotNamed "judge";+ as judge {ishere "rock"}+robots:+ - name: base+ loc: [0, 0]+ dir: east+ devices:+ - 3D printer+ - solar panel+ inventory:+ - [4, rock]+ - [1, treads]+ - [1, grabber]+ - [1, solar panel]+ - [1, lambda]+ - name: judge+ loc: [4, 0]+ system: true+ display:+ invisible: true+world:+ dsl: |+ {grass}
@@ -21,7 +21,7 @@ } robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot@@ -72,56 +72,47 @@ attr: copper' char: 'A' description:- - A place in the mountains where raw copper ore can be mined.- As it is hidden inside a mountain, a tunnel needs to be- first drilled through, so that the vein becomes accessible.+ - A place in the mountains where raw copper ore can be mined. As it is hidden inside a mountain, a tunnel needs to be first drilled through, so that the vein becomes accessible. properties: [unwalkable]- - name: iron vein display: attr: iron' char: 'A' description:- - A place in the mountains where raw iron ore can be mined.- As it is hidden inside a mountain, a tunnel needs to be- first drilled through, so that the vein becomes accessible.+ - A place in the mountains where raw iron ore can be mined. As it is hidden inside a mountain, a tunnel needs to be first drilled through, so that the vein becomes accessible. properties: [unwalkable]- recipes: ## TOY DRILL - in:- - [1, copper vein]+ - [1, copper vein] out:- - [1, copper mine]- - [1, copper ore]+ - [1, copper mine]+ - [1, copper ore] required:- - [1, drill]+ - [1, drill] time: 42- - in:- - [1, iron vein]+ - [1, iron vein] out:- - [1, iron mine]- - [1, iron ore]+ - [1, iron mine]+ - [1, iron ore] required:- - [1, drill]+ - [1, drill] time: 64- ## METAL DRILL - in:- - [1, copper vein]+ - [1, copper vein] out:- - [1, copper mine]- - [1, copper ore]+ - [1, copper mine]+ - [1, copper ore] required:- - [1, metal drill]+ - [1, metal drill] time: 6- - in:- - [1, iron vein]+ - [1, iron vein] out:- - [1, iron mine]- - [1, iron ore]+ - [1, iron mine]+ - [1, iron ore] required:- - [1, metal drill]+ - [1, metal drill] time: 7
@@ -31,7 +31,7 @@ display: char: 'Ω' attr: robot- dir: [0,1]+ dir: north devices: - 3D printer - life support system
@@ -30,8 +30,8 @@ place "detonator"; robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - treads - logger
@@ -10,17 +10,17 @@ - condition: | t <- time; return (t == 2) goal:- - |- This is a dummy condition that just ensures the base has had- time to run the problematic `build` command. The scenario- *should* generate an error message; what we really care about is- whether the generated error message is correct, which is checked- in test/integration/Main.hs .+ - |+ This is a dummy condition that just ensures the base has had+ time to run the problematic `build` command. The scenario+ *should* generate an error message; what we really care about is+ whether the generated error message is correct, which is checked+ in test/integration/Main.hs . solution: | build {move; turn right; loc <- whereami} robots: - name: base- dir: [0,1]+ dir: north devices: - 3D printer - logger@@ -31,7 +31,7 @@ palette: 'Ω': [grass, null, base] '.': [grass]- upperleft: [0,1]+ upperleft: [0, 1] map: | . Ω
@@ -15,21 +15,20 @@ botAlive <- isAlive "bot"; return (baseAlive && not botAlive); } { return false; }- solution: | log "start"; wait 5; robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - treads - logger program: "move" - name: bot- loc: [0,-1]- dir: [1,0]+ loc: [0, -1]+ dir: east devices: - treads program: "move"
@@ -16,16 +16,16 @@ log "I will win next tick!"; place "lambda"; robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - grabber inventory: - [1, lambda] - name: sleeper- loc: [0,-1]- dir: [1,0]+ loc: [0, -1]+ dir: east devices: - logger - clock
@@ -38,16 +38,16 @@ forever {tryharvest} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - harvester inventory: - [1, lambda] - name: planter- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - grabber@@ -66,19 +66,19 @@ attr: plant char: 'W' description:- - A fast-growing weed.- properties: [known, portable, growable]- growth: [1,2]+ - A fast-growing weed.+ properties: [known, pickable, growable]+ growth: [1, 2] - name: Win display: attr: device char: 'W' description: - You win!- properties: [known, portable]+ properties: [known, pickable] world: palette: '.': [grass]- upperleft: [0,0]+ upperleft: [0, 0] map: | .
@@ -25,16 +25,16 @@ forever {tryharvest} robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - harvester inventory: - [1, lambda] - name: planter- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - grabber@@ -55,12 +55,12 @@ attr: plant char: 'W' description:- - A fast-growing weed.- properties: [known, portable, growable]- growth: [1,2]+ - A fast-growing weed.+ properties: [known, pickable, growable]+ growth: [1, 2] world: palette: '.': [grass]- upperleft: [0,0]+ upperleft: [0, 0] map: | .
@@ -18,8 +18,8 @@ move; harvest; move; grab; turn right; move; grab; grab; harvest; grab robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - treads - harvester
@@ -14,14 +14,14 @@ place "tree" robots: - name: base- loc: [5,0]- dir: [1,0]+ loc: [5, 0]+ dir: east devices: - treads - logger - grabber inventory:- - [1, tree]+ - [1, tree] world: palette: '.': [grass]
@@ -21,8 +21,8 @@ } robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - net@@ -59,14 +59,14 @@ attr: water char: 'G' description:- - A satellite navigation device.- properties: [known, portable]+ - A satellite navigation device.+ properties: [known, pickable] capabilities: [senseloc] - name: Tardis display: attr: water char: '█' description:- - Bigger on the inside.- properties: [known, portable]+ - Bigger on the inside.+ properties: [known, pickable] capabilities: [senseloc, teleport]
@@ -16,11 +16,11 @@ salvage robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east - name: fred- loc: [1,0]- dir: [0,0]+ loc: [1, 0]+ dir: [0, 0] inventory: - [1, rock] world:
@@ -3,7 +3,7 @@ description: Pick or drill lodestone and use it to flip bits. objectives: - goal:- - To create a drill bit, you will need to flip the available bit.+ - To create a drill bit, you will need to flip the available bit. condition: | try { as base {has "drill bit"};@@ -12,7 +12,7 @@ run "scenarios/Testing/562-lodestone.sw" robots: - name: base- dir: [1,0]+ dir: east display: char: Ω attr: robot@@ -73,36 +73,31 @@ attr: iron' char: 'A' description:- - A place in the mountains where raw iron ore can be mined.- As it is hidden inside a mountain, a tunnel needs to be- first drilled through, so that the vein becomes accessible.+ - A place in the mountains where raw iron ore can be mined. As it is hidden inside a mountain, a tunnel needs to be first drilled through, so that the vein becomes accessible. properties: [unwalkable]- - name: magnetic mine display: attr: iron' char: 'Å' description:- - A place in the mountains where raw iron ore can be mined.+ - A place in the mountains where raw iron ore can be mined. properties: [unwalkable]- recipes: ## TOY DRILL - in:- - [1, magnetic vein]+ - [1, magnetic vein] out:- - [1, magnetic mine]- - [1, lodestone]+ - [1, magnetic mine]+ - [1, lodestone] required:- - [1, drill]+ - [1, drill] time: 42- - in:- - [1, magnetic mine]+ - [1, magnetic mine] out:- - [1, magnetic mine]- - [1, iron ore]- - [1, lodestone]+ - [1, magnetic mine]+ - [1, iron ore]+ - [1, lodestone] required:- - [1, drill]+ - [1, drill] time: 42
@@ -18,8 +18,8 @@ swap "bitcoin"; swap "gold coin"; robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - scanner@@ -29,8 +29,8 @@ - [1, gold coin] - [1, bitcoin] - name: watcher- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east system: true devices: - logger
@@ -22,7 +22,7 @@ grab; robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot@@ -32,7 +32,7 @@ - grabber - treads - name: competitor- dir: [0, -1]+ dir: south display: char: b attr: robot@@ -48,7 +48,7 @@ turn back; move; - name: planter- dir: [1, 0]+ dir: east display: char: p attr: robot@@ -66,12 +66,11 @@ world: palette: 'Ω': [grass, null, base]- p : [grass, null, planter]- b : [grass, null, competitor]+ p: [grass, null, planter]+ b: [grass, null, competitor] '.': [grass]- 'T': [grass, tree] upperleft: [0, 0] map: |- ......b...- .p........- ......Ω...+ ......b...+ .p........+ ......Ω...
@@ -15,15 +15,15 @@ move; say "Fatal error: base was able to move into a boulder and not fail!" robots: - name: base- dir: [1,0]+ dir: east devices: ["treads", "logger"] - name: one- dir: [1,0]+ dir: east devices: ["treads", "logger"] program: | move; say "Fatal error: one was able to move into a boulder and not fail!" - name: two- dir: [1,0]+ dir: east system: true devices: ["logger"] program: |
@@ -16,20 +16,20 @@ move; say "Fatal error: base was able to move into water and not fail!" robots: - name: base- dir: [1,0]+ dir: east devices: ["treads", "logger"] - name: one- dir: [1,0]+ dir: east devices: ["treads", "logger"] program: | move; say "Fatal error: one was able to move into water and not fail or drown!" - name: two- dir: [1,0]+ dir: east devices: ["treads", "logger", "boat", "net"] program: | try {move} {say "Fatal error: two was unable to move into water even though it has a boat!"} - name: three- dir: [1,0]+ dir: east system: true devices: ["logger"] program: |
@@ -19,18 +19,18 @@ try {teleport self (3,0)} {teleport self (5,0)} robots: - name: base- dir: [0,0]+ dir: [0, 0] - name: one- dir: [1,0]+ dir: east - name: two- dir: [-1,0]+ dir: west - name: three- dir: [0,1]+ dir: north system: true program: | t <- robotNamed "four"; teleport t (3,0); teleport self (3,0) - name: four- dir: [0,-1]+ dir: south system: true world: palette:
@@ -48,17 +48,16 @@ ┌────┐--u~~U │....1..2../ └────┘--l~~L- robots: - name: base- dir: [1,0]- loc: [0,0]+ dir: east+ loc: [0, 0] devices: - treads - logger - name: check1- dir: [0,0]- loc: [3,0]+ dir: [0, 0]+ loc: [3, 0] system: true display: invisible: true@@ -73,8 +72,8 @@ ); create "Win" - name: check2- dir: [0,0]- loc: [6,0]+ dir: [0, 0]+ loc: [6, 0] system: true display: invisible: true@@ -89,8 +88,8 @@ ); create "Win" - name: check3- dir: [0,0]- loc: [9,0]+ dir: [0, 0]+ loc: [9, 0] system: true display: invisible: true@@ -105,11 +104,11 @@ ); create "Win" - name: horizon- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,horizontal wall]]+ inventory: [[1, horizontal wall]] program: | def until = \c. b <- c; if b {} {until c} end; n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);@@ -117,11 +116,11 @@ until (as c1 {has "Win"}); swap "horizontal wall" - name: vertice- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,vertical wall]]+ inventory: [[1, vertical wall]] program: | def until = \c. b <- c; if b {} {until c} end; n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);@@ -129,11 +128,11 @@ until (as c1 {has "Win"}); swap "vertical wall" - name: upright- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,upper right corner]]+ inventory: [[1, upper right corner]] program: | def until = \c. b <- c; if b {} {until c} end; n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);@@ -141,11 +140,11 @@ until (as c1 {has "Win"}); swap "upper right corner" - name: lowright- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,lower right corner]]+ inventory: [[1, lower right corner]] program: | def until = \c. b <- c; if b {} {until c} end; n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);@@ -153,11 +152,11 @@ until (as c1 {has "Win"}); swap "lower right corner" - name: upleft- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,upper left corner]]+ inventory: [[1, upper left corner]] program: | def until = \c. b <- c; if b {} {until c} end; n <- (s <- scan down; case s (\_. fail "Fatal error: missing room number!") return);@@ -165,51 +164,51 @@ until (as c1 {has "Win"}); swap "upper left corner" - name: upright0- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,down and horizontal wall]]+ inventory: [[1, down and horizontal wall]] program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check1"; until (as c1 {has "Win"}); swap "down and horizontal wall" - name: lowright0- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,up and horizontal wall]]+ inventory: [[1, up and horizontal wall]] program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check1"; until (as c1 {has "Win"}); swap "up and horizontal wall" - name: upright1- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,down and horizontal wall]]+ inventory: [[1, down and horizontal wall]] program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check2"; until (as c1 {has "Win"}); swap "down and horizontal wall" - name: lowright1- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true- inventory: [[1,up and horizontal wall]]+ inventory: [[1, up and horizontal wall]] program: | def until = \c. b <- c; if b {} {until c} end; c1 <- robotNamed "check2"; until (as c1 {has "Win"}); swap "up and horizontal wall" - name: gate1- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true@@ -219,7 +218,7 @@ until (as c1 {has "Win"}); grab - name: gate2- dir: [0,0]+ dir: [0, 0] system: true display: invisible: true
@@ -34,7 +34,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench - grabber
@@ -27,7 +27,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench inventory:
@@ -13,18 +13,17 @@ logic: or: - and:- - id: have_furnace- - not:- id: have_flower+ - id: have_furnace+ - not:+ id: have_flower - and:- - id: have_gear- - id: have_flower+ - id: have_gear+ - id: have_flower - id: have_furnace goal: - Make a "furnace". condition: | as base {has "furnace"};- optional: true - id: have_gear goal:@@ -45,7 +44,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench - grabber
@@ -33,7 +33,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench - grabber
@@ -23,14 +23,14 @@ char: 'w' description: - Enables `path` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [path] - name: atlas display: char: 'a' description: - Enables `waypoint` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [waypoint] - name: kudzu display:@@ -46,12 +46,12 @@ attr: easter_egg description: - A colorful egg laid by the rabbit- properties: [known, portable]+ properties: [known, pickable] growth: [5, 10] robots: - name: base loc: [0, 0]- dir: [1, 0]+ dir: east devices: - ADT calculator - atlas@@ -67,7 +67,7 @@ - wayfinder - name: gardener description: Periodically chops down the kudzu plant- dir: [1, 0]+ dir: east system: true devices: - ADT calculator@@ -83,7 +83,7 @@ program: | run "scenarios/Testing/836-pathfinding/_836-automatic-waypoint-navigation/gardener.sw" - name: rabbit- dir: [1, 0]+ dir: east loc: [2, -2] system: true devices:
@@ -20,11 +20,11 @@ char: 'w' description: - Enables `path` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [path] robots: - name: base- dir: [1,0]+ dir: east devices: - treads - logger@@ -38,7 +38,6 @@ '.': [grass] 'x': [stone, mountain] 'f': [grass, flower]- 'T': [grass, tree] upperleft: [0, 0] map: | xxxxx......
@@ -26,11 +26,11 @@ char: 'w' description: - Enables `path` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [path] robots: - name: base- dir: [1,0]+ dir: east devices: - treads - logger
@@ -15,7 +15,7 @@ move; robots: - name: base- dir: [1,0]+ dir: east devices: - treads - logger
@@ -16,7 +16,7 @@ move; robots: - name: base- dir: [1,0]+ dir: east devices: - treads - logger@@ -32,4 +32,3 @@ ....... ..B..f. .......-
@@ -19,11 +19,11 @@ char: 'w' description: - Enables `path` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [path] robots: - name: base- dir: [1,0]+ dir: east devices: - ADT calculator - branch predictor
@@ -16,11 +16,11 @@ char: 'w' description: - Enables `path` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [path] robots: - name: base- dir: [1,0]+ dir: east devices: - ADT calculator - branch predictor
@@ -16,11 +16,11 @@ char: 'w' description: - Enables `path` command- properties: [known, portable]+ properties: [known, pickable] capabilities: [path] robots: - name: base- dir: [1,0]+ dir: east devices: - ADT calculator - branch predictor
@@ -1,4 +1,5 @@-def goDir = \f. \d.+def goDir = \f. \r.+ let d = fst r in if (d == down) { eggHere <- ishere "egg"; if eggHere {grab; return ()} {};
@@ -1,4 +1,5 @@-def goDir = \f. \d.+def goDir = \f. \r.+ let d = fst r in if (d == down) { grab; return () } {
@@ -1,4 +1,5 @@-def goDir = \goalItem. \f. \d.+def goDir = \goalItem. \f. \r.+ let d = fst r in if (d == down) { grab; return () } {
@@ -1,4 +1,5 @@-def goDir = \f. \d.+def goDir = \f. \r.+ let d = fst r in if (d == down) { grab; return () } {
@@ -16,7 +16,7 @@ }; robots: - name: base- dir: [0, 1]+ dir: north devices: - treads - scanner
@@ -14,7 +14,7 @@ }; robots: - name: base- dir: [0, 1]+ dir: north devices: - treads - scanner
@@ -13,7 +13,7 @@ }; robots: - name: base- dir: [0, 1]+ dir: north devices: - treads - scanner
@@ -8,29 +8,41 @@ r0 <- robotNamed "other0"; b0 <- as r0 { has "boat" }; teleport self (0,0);- b1 <- meetAll (\b. \r. b0 <- as r {has "boat"}; return (b && b0)) true;+ def all : (rec l. Unit + a * l) -> (a -> Cmd Bool) -> Cmd Bool =+ \xs. \f. case xs+ (\_. return true)+ (\cons. b <- f (fst cons); if b {all (snd cons) f} {return false})+ end;+ rs <- meetAll;+ b1 <- all rs (\r. as r {has "boat"}); n2 <- as r0 { count "boat" }; return (b0 && b1 && (n2 == 2)) solution: | mr0 <- meet; case mr0 (\_. return ()) (\r0. give r0 "boat");- meetAll (\_. \r. give r "boat") ()+ def forM_ : (rec l. Unit + a * l) -> (a -> Cmd b) -> Cmd Unit =+ \xs. \f. case xs+ (\_. return ())+ (\cons. f (fst cons); forM_ (snd cons) f)+ end;+ rs <- meetAll;+ forM_ rs (\r. give r "boat") robots: - name: base- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east devices: - logger - antenna- - ADT calculator+ - hyperloop - grabber inventory: - [7, boat] - name: other0- loc: [0,0]- dir: [1,0]+ loc: [0, 0]+ dir: east - name: other- dir: [1,0]+ dir: east world: palette: '.': [grass]
@@ -12,7 +12,7 @@ h <- heading; turn east; move; move; turn right; move; move; turn h robots: - name: base- dir: [0,1]+ dir: north devices: - treads - compass
@@ -22,8 +22,8 @@ turn (if (snd loc < 0) {north} {south}); x (abs (snd loc)) move; robots: - name: base- dir: [0,1]- loc: [-5,5]+ dir: north+ loc: [-5, 5] devices: - clock - dictionary@@ -37,8 +37,8 @@ - branch predictor - logger - name: teleporter- dir: [0,1]- loc: [0,0]+ dir: north+ loc: [0, 0] system: true display: invisible: true@@ -62,4 +62,3 @@ ........... ........... ...........-
@@ -19,7 +19,7 @@ grab robots: - name: base- dir: [1,0]+ dir: east devices: - scanner - branch predictor@@ -36,8 +36,8 @@ attr: gold char: 'Y' description:- - A thing that everyone needs!- properties: [portable]+ - A thing that everyone needs!+ properties: [pickable] world: palette: '.': [grass]
@@ -9,8 +9,8 @@ mover <- robotNumbered 1; as mover { loc <- whereami; return $ loc == (0,1) } goal:- - |- Get a robot to (0,1)!+ - |+ Get a robot to (0,1)! solution: | build {move} entities:@@ -19,12 +19,12 @@ attr: device char: 'o' description:- - A non-traditional means of locomotion.- properties: [known, portable]+ - A non-traditional means of locomotion.+ properties: [known, pickable] capabilities: [move] robots: - name: base- dir: [0,1]+ dir: north devices: - 3D printer - logger@@ -35,7 +35,7 @@ palette: 'Ω': [grass, null, base] '.': [grass]- upperleft: [0,1]+ upperleft: [0, 1] map: | . Ω
@@ -16,8 +16,8 @@ build { turn right; move; move; move } robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω
@@ -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: east+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: |+ ........+ ........+ ........+ ........
@@ -15,18 +15,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east known: [tree] world: upperleft: [-1, 1]
@@ -15,18 +15,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east known: [tree] world: upperleft: [1, -1]
@@ -12,11 +12,11 @@ attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east known: [tree] world: upperleft: [1, -1]
@@ -15,18 +15,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor
@@ -15,18 +15,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor@@ -41,7 +41,7 @@ - strange loop - treads - name: judge- dir: [1, 0]+ dir: east system: true display: char: 'J'
@@ -15,18 +15,18 @@ attr: portal_in char: "o" description:- - Portal entrance+ - Portal entrance properties: [known] - name: telepad exit display: attr: portal_out char: "o" description:- - Portal exit+ - Portal exit properties: [known] robots: - name: base- dir: [1, 0]+ dir: east devices: - ADT calculator - branch predictor@@ -41,7 +41,7 @@ - strange loop - treads - name: judge- dir: [1, 0]+ dir: east system: true display: char: 'J'
@@ -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: east+ devices:+ - treads+structures:+ - name: red_jewel+ recognize: [east]+ 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......+ .......+ .......
@@ -0,0 +1,19 @@+version: 1+name: |+ Entity attribute validity+description: |+ This should be rejected by the parser.+entities:+ - name: scooter+ display:+ char: 'M'+ attr: 'foobar'+ description:+ - My scooter+robots: []+world:+ palette:+ 'x': [grass, null, base]+ upperleft: [0, 0]+ map: |+ x
@@ -0,0 +1,18 @@+version: 1+name: |+ Display character width+description: |+ Characters that are too wide mess up the world rendering.+entities:+ - name: ladder+ display:+ char: '且'+ description:+ - My ladder+robots: []+world:+ palette:+ 'x': [grass, null, base]+ upperleft: [0, 0]+ map: |+ x
@@ -0,0 +1,29 @@+version: 1+name: Structure recognizer - redundant symmetries+description: |+ Prevent orientations from being supplied+ for recognition when they are redundant by+ rotational symmetry+creative: false+robots:+ - name: base+ dir: east+structures:+ - name: domino+ recognize: [east, north, west]+ structure:+ mask: '.'+ palette:+ 'r': [stone, tree]+ map: |+ r+ r+known: [tree]+world:+ name: root+ palette:+ '.': [grass]+ 'B': [grass, null, base]+ upperleft: [0, 0]+ map: |+ B
@@ -0,0 +1,27 @@+version: 1+name: Custom terrain - invalid attribute+description: |+ Colorful new terrain+creative: false+attrs:+ - name: lava+ bg: "#dd7733"+terrains:+ - name: lava+ attr: baklava+ description: |+ Scorching, liquid rock+robots:+ - name: base+ dir: east+known: []+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, null, base]+ '.': [lava]+ upperleft: [0, 0]+ map: |+ B.+ ..
@@ -0,0 +1,27 @@+version: 1+name: Custom terrain - invalid terrain reference+description: |+ Colorful new terrain+creative: false+attrs:+ - name: lava+ bg: "#dd7733"+terrains:+ - name: lava+ attr: lava+ description: |+ Scorching, liquid rock+robots:+ - name: base+ dir: east+known: []+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, null, base]+ '.': [liver]+ upperleft: [0, 0]+ map: |+ B.+ ..
@@ -0,0 +1,39 @@+version: 1+name: Capability cost - bad entity reference+description: |+ Capability cost recipe for 'ignite' in `Zippo`{=entity}+ references a non-existent entity+creative: false+robots:+ - name: base+ dir: east+ devices:+ - Zippo+entities:+ - name: heavier fluid+ display:+ char: 'f'+ description:+ - Fuel for a Zippo+ properties: [known, pickable]+ - name: Zippo+ display:+ char: 'z'+ description:+ - Ignites things+ properties: [known, pickable]+ capabilities:+ - capability: ignite+ cost:+ - [1, "lighter fluid"]+known: []+world:+ dsl: |+ {grass}+ palette:+ 'B': [grass, null, base]+ '.': [grass]+ upperleft: [-1, 1]+ map: |+ ..+ B.
@@ -0,0 +1,16 @@+version: 1+name: Robot location in nonexistent named subworld+description: |+ Robot specifies an explicit "planar" location, which uses+ the "default" subworld name. However, since the root subworld+ has been given a name, we object that the subworld specified by+ the robot doesn't exist.+robots:+ - name: base+ loc: [0, 0]+world:+ name: mySubworld+ palette:+ '.': [grass]+ map: |-+ .
@@ -0,0 +1,12 @@+version: 1+name: Enforce rectangular maps+description: |+ Enforce map area is rectangular.+robots: []+world:+ palette:+ '.': [grass]+ upperleft: [0, 0]+ map: |+ ..+ ...
@@ -0,0 +1,13 @@+version: 1+name: Enforce palette usage+description: |+ Every entry in the palette must be used by the world map.+robots: []+world:+ palette:+ '.': [grass]+ 'd': [dirt]+ upperleft: [0, 0]+ map: |+ ..+ ..
@@ -23,7 +23,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench inventory:
@@ -22,7 +22,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench - grabber
@@ -17,7 +17,7 @@ display: char: 'Ω' attr: robot- dir: [0, 1]+ dir: north devices: - workbench inventory:
@@ -4,29 +4,9 @@ Introduction to the backstory of Swarm. objectives: - goal:- - In a shockingly original turn of events, you have crash landed- on an alien planet! It's not clear how you'll ever get home,- but since you're here, you might as well explore a bit. Your- sensors indicate that the atmosphere is highly toxic, so- you'll have to stay inside your robotic base, with its- built-in life support system. However, you are stocked with- all the materials you need to build robots to explore- for you!- - To start, you only have some very basic- devices which can give your robots abilities like moving, turning,- grabbing things, and interpreting very simple imperative- programs. As you use your robots to gather resources, you will- be able to construct better devices, which in turn allow you to- construct robots with upgraded abilities and programming- language features, which in turn allow you to program more- sophisticated robots which in turn will... you get the- idea.- - To prepare you, this simulator will walk you through a series of hands-on- exercises that introduce you to the way robots work and the programming- language you will use to control them. Note that your progress through- the tutorials will be saved automatically. You can return to- the menu at any time to jump around between tutorials or pick- up again where you left off.+ - In a shockingly original turn of events, you have crash landed on an alien planet! It's not clear how you'll ever get home, but since you're here, you might as well explore a bit. Your sensors indicate that the atmosphere is highly toxic, so you'll have to stay inside your robotic base, with its built-in life support system. However, you are stocked with all the materials you need to build robots to explore for you!+ - To start, you only have some very basic devices which can give your robots abilities like moving, turning, grabbing things, and interpreting very simple imperative programs. As you use your robots to gather resources, you will be able to construct better devices, which in turn allow you to construct robots with upgraded abilities and programming language features, which in turn allow you to program more sophisticated robots which in turn will... you get the idea.+ - To prepare you, this simulator will walk you through a series of hands-on exercises that introduce you to the way robots work and the programming language you will use to control them. Note that your progress through the tutorials will be saved automatically. You can return to the menu at any time to jump around between tutorials or pick up again where you left off. - | When you're ready for your first challenge, we will try the `say` command. Close this dialog with **Esc** or **Ctrl+G**, and type at the prompt:@@ -55,15 +35,15 @@ ``` - | To open the full goal text again, you can hit **Ctrl+G**.- properties: [known, portable]+ properties: [known, pickable] robots: - name: base system: true display: char: 'Ω' attr: robot- dir: [1,0]- loc: [0,0]+ dir: east+ loc: [0, 0] inventory: - [1, READY] devices:@@ -72,8 +52,8 @@ system: true display: invisible: true- loc: [0,0]- dir: [0,0]+ loc: [0, 0]+ dir: [0, 0] inventory: - [0, READY] devices:
@@ -29,13 +29,13 @@ - | Every command returns a value. However, some simple commands, like `move`, do not have any meaningful- value to return. Swarm has a special type, `unit`{=type}, with only one value,+ value to return. Swarm has a special type, `Unit`{=type}, with only one value, called `()`. Since there is only one possible value of type- `unit`{=type}, returning it does not convey any information.- Thus, the type of `move` is `cmd unit`{=type}.+ `Unit`{=type}, returning it does not convey any information.+ Thus, the type of `move` is `Cmd Unit`{=type}. - | Other commands do return a nontrivial value after executing.- For example, `grab` has type `cmd text`{=type}, and returns the name of the+ For example, `grab` has type `Cmd Text`{=type}, and returns the name of the grabbed entity as a text value. - | To use the result of a command later, you need _bind notation_, which@@ -80,10 +80,10 @@ char: 'H' description: - The Unspeakable One- properties: [portable]+ properties: [pickable] robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot
@@ -7,13 +7,9 @@ # objectives: - goal:- - Now that you know basic commands, it is time to- build robots to do the work for you.- You will start in a base ('Ω') that does not move (at least not yet).+ - Now that you know basic commands, it is time to build robots to do the work for you. You will start in a base ('Ω') that does not move (at least not yet). - Let's start by building a gardener robot to perform a simple task.- - You can `build` a robot with `build {COMMANDS}`{=snippet},- where in place of `COMMANDS`{=snippet} you write the sequence- of commands for the robot to execute (separated by semicolons).+ - You can `build` a robot with `build {COMMANDS}`{=snippet}, where in place of `COMMANDS`{=snippet} you write the sequence of commands for the robot to execute (separated by semicolons). - | Build a robot to harvest the `flower`{=entity} and place it next to the `water`{=entity}.@@ -35,7 +31,7 @@ build {turn right; move; move; harvest; turn right; move; place "flower"} robots: - name: base- dir: [0,1]+ dir: north heavy: true display: char: Ω
@@ -13,9 +13,9 @@ to sweep over the entire 4x4 square and pick up a `very small rock`{=entity} any time you detect one. - |- The `ishere` command, with type `text -> cmd bool`{=type}, can be used+ The `ishere` command, with type `Text -> Cmd Bool`{=type}, can be used for detecting the presence of a specific item such as a `very small rock`{=entity}.- What we need is a way to take the `bool`{=type} output from `ishere`+ What we need is a way to take the `Bool`{=type} output from `ishere` and use it to decide whether to `grab` a rock or not. (Trying to execute `grab` in a cell without anything to grab will throw an exception, causing the robot to crash.)@@ -25,7 +25,7 @@ it is simply a built-in function of type - | ```- if : bool -> {a} -> {a} -> a+ if : Bool -> {a} -> {a} -> a ``` - | It takes a boolean expression and then returns either the first or second subsequent@@ -37,20 +37,20 @@ is called. Delayed expressions, on the other hand, are not evaluated until needed. In this case, we want to make sure that only the correct branch is evaluated. To write a value- of type, say, `{int}`{=type}, we just surround a value of type `int`{=type}+ of type, say, `{Int}`{=type}, we just surround a value of type `Int`{=type} in curly braces, like `{3}`. This is why arguments to `build` must also be in curly braces: the type of `build`- is `{cmd a} -> cmd robot`{=type}.+ is `{Cmd a} -> Cmd Actor`{=type}. - |- **TIP:** Note that `if` requires a `bool`{=type}, not a `cmd bool`{=type}! So you cannot directly say+ **TIP:** Note that `if` requires a `Bool`{=type}, not a `Cmd Bool`{=type}! So you cannot directly say `if (ishere "very small rock") {...} {...}`{=snippet}. Instead you can write `b <- ishere "very small rock"; if b {...} {...}`{=snippet}. You might enjoy writing your own function of- type `cmd bool -> {cmd a} -> {cmd a} -> cmd a`{=type} to encapsulate this pattern.+ type `Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a`{=type} to encapsulate this pattern. - | **TIP:** the two branches of an `if` must have the same type. In particular, `if ... {grab} {}`{=snippet} is not- allowed, because `{grab}` has type `{cmd text}`{=type} whereas `{}` has type `{cmd unit}`{=type}.+ allowed, because `{grab}` has type `{Cmd Text}`{=type} whereas `{}`{=snippet} has type `{Cmd Unit}`{=type}. In this case `{grab; return ()}` has the right type. condition: | try {@@ -71,7 +71,7 @@ robots: - name: base heavy: true- dir: [0,1]+ dir: north display: char: Ω attr: robot@@ -96,7 +96,7 @@ invisible: true description: - A small rock. It is so small, it is practically invisible.- properties: [portable]+ properties: [pickable] world: palette: 'Ω': [grass, null, base]
@@ -8,13 +8,9 @@ # objectives: - goal:- - Robots can use the `make` command to make things, as long as- they have a `workbench`{=entity} and the proper ingredients. For- example, `make "circuit"` will make a `circuit`{=entity}.- - Your base has a few `tree`{=entity}s in its inventory. Select them to see the- available recipes.- - Your goal is to make a `branch predictor`{=entity}, so you will have to make- some `branch`{=entity}es first.+ - Robots can use the `make` command to make things, as long as they have a `workbench`{=entity} and the proper ingredients. For example, `make "circuit"` will make a `circuit`{=entity}.+ - Your base has a few `tree`{=entity}s in its inventory. Select them to see the available recipes.+ - Your goal is to make a `branch predictor`{=entity}, so you will have to make some `branch`{=entity}es first. - | **NOTE:** when used after opening quotes in the REPL, the Tab key can cycle through possible completions of a name. E.g., type:@@ -31,7 +27,7 @@ display: attr: robot char: 'Ω'- dir: [1,0]+ dir: east devices: - workbench - logger
@@ -15,17 +15,23 @@ end; // At the beginning all robots can be given Win.-def allOK: actor -> bool = \rob.+def allOK: Actor -> Bool = \rob. true end; myLoc <- whereami; +def foldM : (rec l. Unit + a * l) -> b -> (b -> a -> Cmd b) -> Cmd b =+ \xs. \b. \f. case xs+ (\_. return b)+ (\cons. b' <- f b (fst cons); foldM (snd cons) b' f)+end+ // Try to give a robot a Win, filtering out those that were already given a Win. // The robot will also receive instructions, so it **must have a logger!**-def tryGive: text -> (actor -> bool) -> cmd (actor -> bool) = \msg.- // (b -> actor -> cmd b) -> b -> cmd b- meetAll $ \f.\rob.+def tryGive: Text -> (Actor -> Bool) -> Cmd (Actor -> Bool) = \msg. \ok.+ rs <- meetAll;+ foldM rs ok $ \f.\rob. if (not $ f rob) { log $ "skipping the robot " ++ format rob ++ "because it already has a Win"; return f@@ -45,7 +51,6 @@ log $ "the robot " ++ format rob ++ "is missing a logger!"; return f; };- } } end;@@ -56,8 +61,12 @@ log "Hi, I am secret"; iterate allOK (tryGive- $ "Send a robot to `salvage` me and come back to `give base \"Win\"`.\n"- ++ "When the rescue robot stands where I am and executes `salvage`,\n"- ++ "all my inventory and logs will go to it, including the \"Win\".\n"- ++ "Once you have brought the \"Win\" to your base, you will win!"+ $ "Send a robot to `salvage` me and come back to\n"+ ++ "`give base \"Win\". When the rescue robot stands\n"+ ++ "where I am and executes `salvage`, all my inventory\n"+ ++ "and logs will go to it, including the \"Win\". Once you\n"+ ++ "have brought the \"Win\" to your base, you will win!\n\n"+ ++ "NOTE: if you are still viewing me when I am salvaged,\n"+ ++ "you will be in for a surprise! If this happens just\n"+ ++ "type `view base` to return to viewing your base." )
@@ -4,8 +4,7 @@ Learn how to view built robots and debug them. objectives: - goal:- - Before you send your robots far away from the `base` you need to learn how- to figure out what went wrong with them if they crash.+ - Before you send your robots far away from the `base` you need to learn how to figure out what went wrong with them if they crash. - | In this challenge, you should start by sending a robot to walk four steps straight east into the mountain,@@ -35,7 +34,7 @@ char: 'W' description: - If you have this, you win!- properties: [known, portable]+ properties: [known, pickable] solution: | crasher <- build { turn east; move; move; move; log "bye"; move@@ -47,7 +46,7 @@ }; robots: - name: base- dir: [0,1]+ dir: north heavy: true display: char: Ω
@@ -4,21 +4,16 @@ Learn how to define new commands. objectives: - goal:- - Your goal is to build a robot to fetch the `flower`{=entity} growing in the- upper right and bring it back to you; you win the challenge when the base- has a `flower`{=entity} in its inventory.+ - Your goal is to build a robot to fetch the `flower`{=entity} growing in the upper right and bring it back to you; you win the challenge when the base has a `flower`{=entity} in its inventory. - | However, it would be extremely tedious to simply type out all the individual `move` and `turn` commands required. Your base has a `dictionary`{=entity} device that can be used to define new commands. For example: - | ```- def m4 : cmd unit = move; move; move; move end+ def m4 : Cmd Unit = move; move; move; move end ```- - defines a new command `m4`{=snippet}, with type `cmd unit`{=type}, as four consecutive `move` commands.- With judicious- use of new definitions, it should be possible to complete this challenge- in just a few lines of code.+ - defines a new command `m4`{=snippet}, with type `Cmd Unit`{=type}, as four consecutive `move` commands. With judicious use of new definitions, it should be possible to complete this challenge in just a few lines of code. - | **TIP:** your base is at coordinates `(0,0)`, and the `flower`{=entity} is at `(16,4)`, which you can confirm by clicking in the world map panel. When you click on a cell,@@ -52,7 +47,7 @@ } robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot
@@ -4,14 +4,8 @@ Learn how to equip devices and gain new capabilities. objectives: - goal:- - You know how to `grab` things lying around, so you are ready to get- an upgrade!- By equipping devices, you learn new capabilities which allow you to- perform more complex commands.- - Before you start building new robots in the later tutorials, you need- to gain the `build` capability.- Try typing `build {}` - you should get an error telling you that you- need to equip a `3D printer`{=entity}.+ - You know how to `grab` things lying around, so you are ready to get an upgrade! By equipping devices, you learn new capabilities which allow you to perform more complex commands.+ - Before you start building new robots in the later tutorials, you need to gain the `build` capability. Try typing `build {}` - you should get an error telling you that you need to equip a `3D printer`{=entity}. - | Fortunately, there is a `3D printer`{=entity} lying nearby. Go `grab` it, then `equip` it with `equip "3D printer"`.@@ -30,7 +24,7 @@ turn south; move; grab; equip "3D printer"; build {}; robots: - name: base- dir: [1,0]+ dir: east devices: - logger - treads
@@ -5,13 +5,13 @@ def tL = turn left end; def tB = turn back end; def forever = \c. c ; forever c end;-def ifC : cmd bool -> {cmd a} -> {cmd a} -> cmd a = \test. \then. \else.+def ifC : Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a = \test. \then. \else. b <- test; if b then else end;-def while : cmd bool -> {cmd a} -> cmd unit = \test. \body.+def while : Cmd Bool -> {Cmd a} -> Cmd Unit = \test. \body. ifC test {force body ; while test body} {} end;-def giveall : actor -> text -> cmd unit = \r. \thing.+def giveall : Actor -> Text -> Cmd Unit = \r. \thing. while (has thing) {give r thing} end; def x4 = \c. c; c; c; c end;@@ -19,13 +19,13 @@ def x12 = \c. x4 (c;c;c) end; def m12 = x12 move end; def next_row = tB; m12; tL; move; tL end;-def plant_field : text -> cmd unit = \thing.+def plant_field : Text -> Cmd Unit = \thing. x4 ( x12 (move; place thing; harvest); next_row ) end;-def harvest_field : text -> cmd unit = \thing.+def harvest_field : Text -> Cmd Unit = \thing. x4 ( x12 (move; ifC (ishere thing) {harvest; return ()} {}); next_row
@@ -38,19 +38,11 @@ } } { return false } - goal:- - Congratulations! You have completed the most difficult simulated exercise and- are ready to begin exploring the new planet in earnest. Of course there- is much more remaining to explore in the world, and many additional programming- language features to unlock.+ - Congratulations! You have completed the most difficult simulated exercise and are ready to begin exploring the new planet in earnest. Of course there is much more remaining to explore in the world, and many additional programming language features to unlock. - | To finally complete this tutorial, there is only one thing left for you to do: use one of your lambdas to make some delicious `curry`{=entity}.- - Afterwards, you will return to the menu where you can select- "Classic game" for the complete game experience. Or, play a- "Creative game" if you just want to play around with- programming robots, without any constraints or need to collect- resources. You could also choose to redo some tutorial scenarios, or- explore the other challenge scenarios listed in the menu.+ - Afterwards, you will return to the menu where you can select "Classic game" for the complete game experience. Or, play a "Creative game" if you just want to play around with programming robots, without any constraints or need to collect resources. You could also choose to redo some tutorial scenarios, or explore the other challenge scenarios listed in the menu. - Now go forth and build your swarm! condition: | try {as base {has "curry"}} {return false}@@ -63,8 +55,8 @@ display: char: 'Ω' attr: robot- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north devices: - 3D printer - dictionary
@@ -9,9 +9,7 @@ command. This command takes two arguments: the target robot, and the name of the item to give. The target robot is often the special `base` robot, but could be any robot.- - In this scenario, you will need to collect the items scattered- around your `base`, by `build`ing one or more robots to- collect them and then `give` them to you.+ - In this scenario, you will need to collect the items scattered around your `base`, by `build`ing one or more robots to collect them and then `give` them to you. condition: | as base { bd <- has "board";@@ -34,7 +32,7 @@ } robots: - name: base- dir: [0,1]+ dir: north heavy: true display: char: Ω
@@ -4,19 +4,15 @@ Learn how to interact with the world by grabbing entities. objectives: - goal:- - Previously you learned how to make new things (like a `branch predictor`{=entity}) from ingredients.- Now you will learn how to obtain the ingredients you need.+ - Previously you learned how to make new things (like a `branch predictor`{=entity}) from ingredients. Now you will learn how to obtain the ingredients you need. - There are some `tree`{=entity}s ahead of your robot; `move` to each one and `grab` it.- - You can learn more by reading about the grabber device in your- inventory. Remember, if the description does not fit in the- lower left info box, you can either hit **Enter** to pop out the- description, or focus the info box in order to scroll.+ - You can learn more by reading about the grabber device in your inventory. Remember, if the description does not fit in the lower left info box, you can either hit **Enter** to pop out the description, or focus the info box in order to scroll. condition: | try { t <- as base {count "tree"}; return (t >= 6); } { return false }-solution:+solution: | move; move; grab; move; grab;@@ -26,7 +22,7 @@ move; grab; robots: - name: base- dir: [1,0]+ dir: east devices: - treads - grabber
@@ -4,8 +4,7 @@ Learn how to define functions. objectives: - goal:- - Your goal in this challenge is to send a robot to grab the- `flower`{=entity} in the lower right (you don't need to bring it back).+ - Your goal in this challenge is to send a robot to grab the `flower`{=entity} in the lower right (you don't need to bring it back). - | The path looks complex, but if you study it, you will see that it has a lot of structure. In particular, there are many parts of@@ -17,11 +16,9 @@ one more than `x`{=snippet}. As another example: - | ```- def x4 : cmd unit -> cmd unit = \c. c; c; c; c end+ def x4 : Cmd Unit -> Cmd Unit = \c. c; c; c; c end ```- - That is, `x4`{=snippet} is defined as the function which takes a command,- called `c`{=snippet}, as input, and returns the command- `c; c; c; c`{=snippet} which consists of executing `c`{=snippet} four times.+ - That is, `x4`{=snippet} is defined as the function which takes a command, called `c`{=snippet}, as input, and returns the command `c; c; c; c`{=snippet} which consists of executing `c`{=snippet} four times. condition: | try { teleport self (32,-16);@@ -42,7 +39,7 @@ } robots: - name: base- dir: [0,1]+ dir: north display: char: Ω attr: robot@@ -71,7 +68,7 @@ '┘': [stone, lower right corner] '─': [stone, horizontal wall] '│': [stone, vertical wall]- upperleft: [-1,1]+ upperleft: [-1, 1] map: | ┌─────────────────────────────────┐ │.......@.......@.......@.......@@│@@ -92,5 +89,3 @@ │@@@@.@.@@@@@.@.@@@@@.@.@@@@@.@.@@│ │Ω....@.......@.......@.......@..*│ └─────────────────────────────────┘--
@@ -6,13 +6,10 @@ - id: move_to_first_flower teaser: Get the flower goal:- - Robots can use the `move` command to move forward one unit- in the direction they are currently facing.- - To complete this challenge, move your robot two spaces to the right,- to the coordinates `(2,0)` marked with the purple `flower`{=entity}.+ - Robots can use the `move` command to move forward one unit in the direction they are currently facing.+ - To complete this challenge, move your robot two spaces to the right, to the coordinates `(2,0)` marked with the purple `flower`{=entity}. - Note that you can chain commands with semicolon, `;`{=snippet}.- - You can open this popup window at any time to remind yourself of the goal- using **Ctrl+G**.+ - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | r <- robotNamed "check1"; loc <- as r {has "Win"};@@ -26,12 +23,9 @@ ``` move; move ```- - To reuse that command without having to retype it press the upward- arrow on your keyboard. This will allow you to select previous commands.- - Ahead of you is a six steps long corridor. Move to its end, i.e. the- coordinates `(8,0)` marked with the second purple `flower`{=entity}.- - You can open this popup window at any time to remind yourself of the goal- using **Ctrl+G**.+ - To reuse that command without having to retype it press the upward arrow on your keyboard. This will allow you to select previous commands.+ - Ahead of you is a six steps long corridor. Move to its end, i.e. the coordinates `(8,0)` marked with the second purple `flower`{=entity}.+ - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | r <- robotNamed "check2"; loc <- as r {has "Win"};@@ -39,37 +33,25 @@ - id: move_northeast_corner teaser: To northeast corner goal:- - Well done! In addition to `move`, you can use the `turn` command- to turn your robot, for example, `turn right` or `turn east`.- - Switch to the inventory view in the upper left (by clicking on it or typing **Alt+E**)- and select the `treads`{=entity} device to read about the details.- If the bottom-left info panel is not big enough to read the- whole thing, you can hit **Enter** on the `treads`{=entity} device to pop- out the description, or you can focus the info panel (with **Alt+T** or- by clicking) and scroll it with arrow keys or **PgUp**/**PgDown**.- When you're done reading, you can come back to the REPL prompt- by clicking on it or typing **Alt+R**.- - Afterwards, move your robot to the coordinates `(8,4)` in the northeast corner- marked with two flowers.+ - Well done! In addition to `move`, you can use the `turn` command to turn your robot, for example, `turn right` or `turn east`.+ - Switch to the inventory view in the upper left (by clicking on it or typing **Alt+E**) and select the `treads`{=entity} device to read about the details. If the bottom-left info panel is not big enough to read the whole thing, you can hit **Enter** on the `treads`{=entity} device to pop out the description, or you can focus the info panel (with **Alt+T** or by clicking) and scroll it with arrow keys or **PgUp**/**PgDown**. When you're done reading, you can come back to the REPL prompt by clicking on it or typing **Alt+R**.+ - Afterwards, move your robot to the coordinates `(8,4)` in the northeast corner marked with two flowers. - | Remember, you can chain commands with `;`{=snippet}, for example: - | ``` move;move;move;move ```- - You can open this popup window at any time to remind yourself of the goal- using **Ctrl+G**.+ - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | r <- robotNamed "check3"; loc <- as r {has "Win"}; prerequisite: move_along_corridor - goal: - Good job! You are now ready to move and turn on your own.- - To complete this challenge, move your robot to the northeast corner,- to the coordinates `(8,8)` marked with one `flower`{=entity}.+ - To complete this challenge, move your robot to the northeast corner, to the coordinates `(8,8)` marked with one `flower`{=entity}. - Remember you can press the upward arrow on your keyboard to select previous commands.- - You can open this popup window at any time to remind yourself of the goal- using **Ctrl+G**.+ - You can open this popup window at any time to remind yourself of the goal using **Ctrl+G**. condition: | r <- robotNamed "check4"; loc <- as r {has "Win"};@@ -143,19 +125,17 @@ ┌───┐--d22c │..*1....X| └───┘-----b- # Font inspiration and a nicely visible separator: #-# ███████ ██ ██ █████ ██████ ███ ███ -# ██ ██ ██ ██ ██ ██ ██ ████ ████ -# ███████ ██ █ ██ ███████ ██████ ██ ████ ██ -# ██ ██ ███ ██ ██ ██ ██ ██ ██ ██ ██ -# ███████ ███ ███ ██ ██ ██ ██ ██ ██ -+# ███████ ██ ██ █████ ██████ ███ ███+# ██ ██ ██ ██ ██ ██ ██ ████ ████+# ███████ ██ █ ██ ███████ ██████ ██ ████ ██+# ██ ██ ███ ██ ██ ██ ██ ██ ██ ██ ██+# ███████ ███ ███ ██ ██ ██ ██ ██ ██ robots: - name: base- dir: [1,0]- loc: [0,0]+ dir: east+ loc: [0, 0] devices: - treads - logger@@ -164,7 +144,7 @@ ## OBJECTIVES ## ################# - name: check1- loc: [2,0]+ loc: [2, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end;@@ -177,7 +157,7 @@ ); create "Win" - name: check2- loc: [8,0]+ loc: [8, 0] system: true program: | def until = \c. b <- c; if b {} {until c} end;@@ -190,7 +170,7 @@ ); create "Win" - name: check3- loc: [8,4]+ loc: [8, 4] system: true program: | def until = \c. b <- c; if b {} {until c} end;@@ -203,7 +183,7 @@ ); create "Win" - name: check4- loc: [8,8]+ loc: [8, 8] system: true program: | def until = \c. b <- c; if b {} {until c} end;
@@ -9,14 +9,9 @@ # objectives: - goal:- - Previously you learned how to plunder a plentiful forest for wood.- Now you will learn how to plant trees to obtain as much wood as you need.- - There is a fast-growing tree (called `spruce`{=entity}) ahead of you. You could `grab`- it as before, but you now have a new device called a `harvester`{=entity}.- If you `harvest` a tree rather than `grab` it, a new tree will grow in its- place after some time.- - You can also place items from your inventory on the ground- below you using the `place` command.+ - Previously you learned how to plunder a plentiful forest for wood. Now you will learn how to plant trees to obtain as much wood as you need.+ - There is a fast-growing tree (called `spruce`{=entity}) ahead of you. You could `grab` it as before, but you now have a new device called a `harvester`{=entity}. If you `harvest` a tree rather than `grab` it, a new tree will grow in its place after some time.+ - You can also place items from your inventory on the ground below you using the `place` command. - | Using these commands in conjunction, you can plant new growable entities by placing and then harvesting them. For example, to plant a new `spruce`{=entity} seed@@ -24,8 +19,7 @@ ``` place "spruce"; harvest ```- - Your goal is to collect 6 `spruce`{=entity} trees. You can speed this up- by planting more trees.+ - Your goal is to collect 6 `spruce`{=entity} trees. You can speed this up by planting more trees. - | **TIP:** You can get a sneak peak at a feature we will explain later and type: ```@@ -45,13 +39,13 @@ attr: plant char: 'T' description:- - |- A tall, living entity made of a tough cellular material called "wood".- They regrow after being harvested and are an important raw ingredient used- in making many different devices.- - |- This one seems to grow a little faster.- properties: [portable, growable]+ - |+ A tall, living entity made of a tough cellular material called "wood".+ They regrow after being harvested and are an important raw ingredient used+ in making many different devices.+ - |+ This one seems to grow a little faster.+ properties: [pickable, growable] growth: [100, 120] solution: | def t = move; place "spruce"; harvest; end;@@ -67,7 +61,7 @@ turn back; h; h; h; h; h; h; robots: - name: base- dir: [1,0]+ dir: east devices: - treads - grabber
@@ -4,23 +4,10 @@ Learn how to require additional devices that would otherwise not be equipped. objectives: - goal:- - The `build` command automatically equips devices on the newly- built robot that it knows- will be required. For example, if you `build {move}`, some `treads`{=entity}- will automatically be equipped on the new robot since it needs- them to `move`. (To see what the `build` command will equip,- you can type `requirements <e>`{=snippet} where `<e>`{=snippet} is any expression.)- - However, sometimes you need a device but `build` can't tell that- you need it. In this case, you can use the special `require`{=snippet}- command to require a particular device. For example, if you- `build {require "3D printer"; move}`, a `3D printer`{=entity} will be- equipped on the new robot (in addition to `treads`{=entity}) even though it does not execute any- commands that use one.- - Your goal is to pick a flower on the other side of the river and- bring it back to your base. You win when the base has a- `periwinkle`{=entity} flower in its inventory.- - "Hint: robots will drown in the `water`{=entity} unless they have a `boat`{=entity} device- equipped!"+ - The `build` command automatically equips devices on the newly built robot that it knows will be required. For example, if you `build {move}`, some `treads`{=entity} will automatically be equipped on the new robot since it needs them to `move`. (To see what the `build` command will equip, you can type `requirements <e>`{=snippet} where `<e>`{=snippet} is any expression.)+ - However, sometimes you need a device but `build` can't tell that you need it. In this case, you can use the special `require`{=snippet} command to require a particular device. For example, if you `build {require "3D printer"; move}`, a `3D printer`{=entity} will be equipped on the new robot (in addition to `treads`{=entity}) even though it does not execute any commands that use one.+ - Your goal is to pick a flower on the other side of the river and bring it back to your base. You win when the base has a `periwinkle`{=entity} flower in its inventory.+ - "Hint: robots will drown in the `water`{=entity} unless they have a `boat`{=entity} device equipped!" condition: | try { as base {has "periwinkle"}@@ -31,8 +18,8 @@ attr: flower char: '*' description:- - A flower.- properties: [known, infinite, portable]+ - A flower.+ properties: [known, infinite, pickable] solution: | def m5 = move; move; move; move; move end; build {@@ -42,7 +29,7 @@ robots: - name: base heavy: true- dir: [0,1]+ dir: north display: char: Ω attr: robot
@@ -4,16 +4,9 @@ Learn how to require inventory when building robots. objectives: - goal:- - In the previous tutorial challenge, you learned how to use- `require`{=snippet} to require specific devices to be equipped.- Sometimes, instead of requiring equipped devices, you require- supplies in your inventory. In this case, you can write- `require <int> <name>`{=snippet} to require a certain number of copies of- a certain entity to be placed in your inventory.- - For example, `build {require 10 "flower"; move; move}` would- build a robot with 10 `flower`{=entity}s in its inventory.- - Your goal in this challenge is to cover the entire 4x4 gray area- with `rock`{=entity}s!+ - In the previous tutorial challenge, you learned how to use `require`{=snippet} to require specific devices to be equipped. Sometimes, instead of requiring equipped devices, you require supplies in your inventory. In this case, you can write `require <int> <name>`{=snippet} to require a certain number of copies of a certain entity to be placed in your inventory.+ - For example, `build {require 10 "flower"; move; move}` would build a robot with 10 `flower`{=entity}s in its inventory.+ - Your goal in this challenge is to cover the entire 4x4 gray area with `rock`{=entity}s! - | Remember that you can define commands to simplify your task, for example: ```@@ -45,7 +38,7 @@ robots: - name: base heavy: true- dir: [0,1]+ dir: north display: char: Ω attr: robot
@@ -4,14 +4,9 @@ Learn how to send robots to safely scan your surroundings. objectives: - goal:- - When you land on an alien planet, all the entities in the- world will be unfamiliar to you, but you can learn what they are using- the `scan` command, enabled by a `scanner`{=entity} device.- - Send one or more robots to move next to some of the unknown entities (marked as "?"),- scan them (with something like `scan forward` or `scan north`), and then return- to the base and execute `upload base`.- - For more information about the `scan` and `upload` commands, read- the description of the `scanner`{=entity} in your inventory.+ - When you land on an alien planet, all the entities in the world will be unfamiliar to you, but you can learn what they are using the `scan` command, enabled by a `scanner`{=entity} device.+ - Send one or more robots to move next to some of the unknown entities (marked as "?"), scan them (with something like `scan forward` or `scan north`), and then return to the base and execute `upload base`.+ - For more information about the `scan` and `upload` commands, read the description of the `scanner`{=entity} in your inventory. condition: | try { bm <- as base {knows "mountain"};@@ -30,7 +25,7 @@ } robots: - name: base- dir: [0,1]+ dir: north heavy: true display: char: Ω
@@ -7,7 +7,7 @@ - | Let's see what happens when you enter something that does not type check. Try typing `turn 1`{=snippet} at the REPL prompt. Clearly this is nonsense, and- the expression will be highlighted in red. To see what the error is, hit **Enter**.+ part of the expression will be highlighted in red. To see what the error is, hit **Enter**. The REPL will print out a type error. - "Some other type errors for you to try:" - |@@ -16,13 +16,8 @@ `place tree`{=snippet} (without double quotes around `tree`{=snippet}) - | `move move`{=snippet}- - The last expression might give the most confusing error.- Obviously we are just missing a `;`{=snippet} separating the two `move`- commands. However, without the semicolon, it looks like- `move` is a function being applied to an argument, but of course- `move` is not a function.- - Once you are done experimenting, execute `place "Win"` to finish this challenge and- move on to the next.+ - The last expression might give the most confusing error. Obviously we are just missing a `;`{=snippet} separating the two `move` commands. However, without the semicolon, it looks like `move` is a function being applied to an argument, but of course `move` is not a function.+ - Once you are done experimenting, execute `place "Win"` to finish this challenge and move on to the next. condition: | try { w <- as base {has "Win"};@@ -35,12 +30,12 @@ char: 'W' description: - Do `place "Win"` once you are done with this challenge.- properties: [known, portable]+ properties: [known, pickable] solution: | place "Win" robots: - name: base- dir: [1,0]+ dir: east devices: - treads - compass
@@ -4,19 +4,10 @@ Learn about the Swarm type system. objectives: - goal:- - The Swarm programming language has a strong static type system. That is,- every expression in the language has a type, and all the types must match up- properly before a program can be executed.- - To see the type of an expression, enter the expression at the- REPL prompt (you do not need to execute it). If the expression type checks,- its type will be displayed in gray text at the top right of the window.- - For example, if you try typing `move`, you can see that it has- type `cmd unit`{=type}, which means that `move` is a command which- returns a value of the `unit`{=type} type (the only value of- type `unit`{=type} is called `()`).- - As another example, you can see that `turn` has type `dir -> cmd unit`{=type},- meaning that `turn` is a function which takes a direction as input- and results in a command.+ - The Swarm programming language has a strong static type system. That is, every expression in the language has a type, and all the types must match up properly before a program can be executed.+ - To see the type of an expression, enter the expression at the REPL prompt (you do not need to execute it). If the expression type checks, its type will be displayed in gray text at the top right of the window.+ - For example, if you try typing `move`, you can see that it has type `Cmd Unit`{=type}, which means that `move` is a command which returns a value of the `Unit`{=type} type (the only value of type `Unit`{=type} is called `()`).+ - As another example, you can see that `turn` has type `Dir -> Cmd Unit`{=type}, meaning that `turn` is a function which takes a direction as input and results in a command. - "Here are a few more expressions for you to try (feel free to try others as well):" - | `north`@@ -30,8 +21,7 @@ `3` - | `"tree"`- - Once you are done experimenting, execute `place "Win"` to finish this challenge and- move on to the next.+ - Once you are done experimenting, execute `place "Win"` to finish this challenge and move on to the next. condition: | try { w <- as base {has "Win"};@@ -44,13 +34,12 @@ char: 'W' description: - Do `place "Win"` once you are done with this challenge.- properties: [known, portable]+ properties: [known, pickable] solution: | place "Win"- robots: - name: base- dir: [1,0]+ dir: east devices: - treads - compass
@@ -11,11 +11,11 @@ def mg = m; grab end -def get_3_trees : cmd unit =+def get_3_trees : Cmd Unit = tB; m; mg; mg; mg; tB; m4 end -def make_harvester : cmd unit =+def make_harvester : Cmd Unit = make "log"; make "log"; make "log"; make "board"; make "board"; make "board"; make "box";@@ -23,11 +23,11 @@ make "harvester" end -def get_lambda : cmd unit =+def get_lambda : Cmd Unit = m10; tR; m9; harvest; tB; m9; tL; m10 end -def solution : cmd unit =+def solution : Cmd Unit = build {get_3_trees}; wait 16; salvage; make_harvester; build {get_lambda}; wait 50; salvage
@@ -6,23 +6,10 @@ - id: get_trees teaser: Get 3 trees goal:- - You're ready to graduate to something a bit more complex! This- multi-step tutorial will walk you through a few of the first- steps you might take in exploring the new planet, using many- of the commands and techniques you have learned in the- previous tutorial challenges.- - You can see that your base starts out with some key devices- equipped and some basic supplies for building robots. To- build more advanced devices and produce more robots,- you'll need to explore, gather resources, and set up some- automated production pipelines.- - At this point you may want to create an external `.sw`{=path} file- with useful definitions you create. You can then load it- via the `run` command. See- https://github.com/swarm-game/swarm/tree/main/editors- for help configuring your editor with support for swarm-lang.- - Your first task is to collect three or more `tree`{=entity}s. You can- remind yourself of the available commands using **F4**.+ - You're ready to graduate to something a bit more complex! This multi-step tutorial will walk you through a few of the first steps you might take in exploring the new planet, using many of the commands and techniques you have learned in the previous tutorial challenges.+ - You can see that your base starts out with some key devices equipped and some basic supplies for building robots. To build more advanced devices and produce more robots, you'll need to explore, gather resources, and set up some automated production pipelines.+ - At this point you may want to create an external `.sw`{=path} file with useful definitions you create. You can then load it via the `run` command. See https://github.com/swarm-game/swarm/tree/main/editors for help configuring your editor with support for swarm-lang.+ - Your first task is to collect three or more `tree`{=entity}s. You can remind yourself of the available commands using **F4**. condition: | try { n <- as base {count "tree"};@@ -31,28 +18,15 @@ - id: get_harvester teaser: Make a harvester goal:- - Nice work! Now, use the `tree`{=entity}s to make a `harvester`{=entity} device.- This will require several intermediate products; try making- various things, and take a look at your available recipes (**F3**)- and at the recipes listed for items in your inventory. Of course,- you may end up needing some additional trees.+ - Nice work! Now, use the `tree`{=entity}s to make a `harvester`{=entity} device. This will require several intermediate products; try making various things, and take a look at your available recipes (**F3**) and at the recipes listed for items in your inventory. Of course, you may end up needing some additional trees. condition: | try { as base {has "harvester"} } {return false} prerequisite: get_trees - goal:- - Now that you have a `harvester`{=entity}, you can use `harvest` instead of `grab`- whenever you pick up a growing item (check for the word "growing" at the- top of the item description), to leave behind a seed that will regrow.- - "**TIP:** since you only have a single harvester device for now, whenever you- send out a robot to harvest something, try programming it to come back- to the base when it is done. Then, execute `salvage` to get the harvester- back, so you can reuse it in another robot later."- - One of the next things you will probably want is a `lambda`{=entity}, so you can- define and use parameterized commands. Scan some things and use- the process of elimination to find one. Since lambdas regrow,- once you find one, try getting it with `harvest`.- - "**TIP:** remember that you can click on cells in the world to see their- coordinates."+ - Now that you have a `harvester`{=entity}, you can use `harvest` instead of `grab` whenever you pick up a growing item (check for the word "growing" at the top of the item description), to leave behind a seed that will regrow.+ - "**TIP:** since you only have a single harvester device for now, whenever you send out a robot to harvest something, try programming it to come back to the base when it is done. Then, execute `salvage` to get the harvester back, so you can reuse it in another robot later."+ - One of the next things you will probably want is a `lambda`{=entity}, so you can define and use parameterized commands. Scan some things and use the process of elimination to find one. Since lambdas regrow, once you find one, try getting it with `harvest`.+ - "**TIP:** remember that you can click on cells in the world to see their coordinates." condition: | try { as base {has "lambda"} } {return false} prerequisite: get_harvester@@ -63,8 +37,8 @@ display: char: 'Ω' attr: robot- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north devices: - 3D printer - dictionary
@@ -1,4 +1,4 @@-def forever : cmd unit -> cmd unit = \c. c ; forever c end+def forever : Cmd Unit -> Cmd Unit = \c. c ; forever c end /** Teleports to a new location to execute a function then returns to the original location before
@@ -14,7 +14,7 @@ end; // modulus function (%)-def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end @@ -28,9 +28,9 @@ Decide where to initially teleport to based on the initial coords. */ def init :- [xMin : int, xMax : int, yMin : int, yMax : int]- -> [yWest : int, yEast : int, xSouth : int, xNorth : int]- -> cmd (bool * int) = \extents. \lanes.+ [xMin : Int, xMax : Int, yMin : Int, yMax : Int]+ -> [yWest : Int, yEast : Int, xSouth : Int, xNorth : Int]+ -> Cmd (Bool * Int) = \extents. \lanes. let topCorner = (-18, 30) in absloc <- whereami; let loc = sumTuples absloc $ mapTuple (\x. -x) topCorner in@@ -68,9 +68,9 @@ end; def getCanMove :- [xWest : int, xEast : int, ySouth : int, yNorth : int]- -> bool- -> cmd bool+ [xWest : Int, xEast : Int, ySouth : Int, yNorth : Int]+ -> Bool+ -> Cmd Bool = \stoplines. \hasGreenLight. d <- heading;@@ -95,7 +95,7 @@ return $ hasGreenLight || not (atStopLine || neighborIsStopped); end; -def doTunnelWrap : [xMin : int, xMax : int, yMin : int, yMax : int] -> cmd bool = \extents.+def doTunnelWrap : [xMin : Int, xMax : Int, yMin : Int, yMax : Int] -> Cmd Bool = \extents. myloc <- whereami; didWrap <- if (fst myloc < extents.xMin) { teleport self (extents.xMax, snd myloc);@@ -116,10 +116,10 @@ end; def moveWithWrap :- [xWest : int, xEast : int, ySouth : int, yNorth : int]- -> [xMin : int, xMax : int, yMin : int, yMax : int] // extents- -> bool- -> cmd (bool * bool)+ [xWest : Int, xEast : Int, ySouth : Int, yNorth : Int]+ -> [xMin : Int, xMax : Int, yMin : Int, yMax : Int] // extents+ -> Bool+ -> Cmd (Bool * Bool) = \stoplines. \extents. \isLongitudinal. hasGreenLight <- isGreenLight isLongitudinal;@@ -141,9 +141,9 @@ end; def getNewDelayState :- bool- -> [moveDelay : int, transitionCountdown : int]- -> [moveDelay : int, transitionCountdown : int]+ Bool+ -> [moveDelay : Int, transitionCountdown : Int]+ -> [moveDelay : Int, transitionCountdown : Int] = \canGo. \delayState. if (not canGo) { // reset to max delay and pause the countdown at max@@ -165,12 +165,12 @@ Then we continually decrease the delay by 1, until reaching no delay. */ def advance :- int- -> bool- -> [xWest : int, xEast : int, ySouth : int, yNorth : int]- -> [xMin : int, xMax : int, yMin : int, yMax : int]- -> [moveDelay : int, transitionCountdown : int]- -> cmd unit+ Int+ -> Bool+ -> [xWest : Int, xEast : Int, ySouth : Int, yNorth : Int]+ -> [xMin : Int, xMax : Int, yMin : Int, yMax : Int]+ -> [moveDelay : Int, transitionCountdown : Int]+ -> Cmd Unit = \idx. \isLongitudinal. \stoplines. \extents. \delayState. wait delayState.moveDelay;
@@ -8,7 +8,7 @@ display: char: Ω attr: robot- dir: [1, 0]+ dir: east loc: [10, 3] devices: - logger@@ -18,7 +18,7 @@ system: true display: invisible: false- dir: [1, 0]+ dir: east devices: - lodestone inventory:@@ -29,7 +29,7 @@ system: true display: invisible: true- dir: [0, 1]+ dir: north loc: [24, 9] devices: - lodestone@@ -43,60 +43,47 @@ '.': [grass] 'd': [grass, null, drone] structures:- - name: road segment- structure:- palette:- 'S':- - stone- 'w':- - ice- '█':- - stone- - sand- map: |- SSSSSS- SSSSSS- ███SSS- SSSSSS- SSSSSS- wwwwww- - name: tunnel- structure:- mask: '.'- palette:- '@': [stone, boulder]- 'b': [blank]- map: |- ..@@@@..- .@bbbb@.- @@bbbb@@- @bbbbbb@- - name: intersection- structure:- palette:- 'S':- - stone- 'w':- - ice- '█':- - stone- - sand- map: |- SSSSSS- SSSSSS- SSSSSS- SSSSSS- SSSSSS- SSSSSS+ - name: road segment+ structure:+ palette:+ 'S':+ - stone+ 'w':+ - ice+ '█':+ - stone+ - sand+ map: |+ SSSSSS+ SSSSSS+ ███SSS+ SSSSSS+ SSSSSS+ wwwwww+ - name: tunnel+ structure:+ mask: '.'+ palette:+ '@': [stone, boulder]+ 'b': [blank]+ map: |+ ..@@@@..+ .@bbbb@.+ @@bbbb@@+ @bbbbbb@+ - name: intersection+ structure:+ palette:+ 'S':+ - stone+ map: |+ SSSSSS+ SSSSSS+ SSSSSS+ SSSSSS+ SSSSSS+ SSSSSS placements:- - src: tunnel- offset: [3, -21]- orient:- up: west- - src: tunnel- offset: [71, -21]- orient:- up: east - src: road segment offset: [6, -22] orient:@@ -161,9 +148,17 @@ orient: up: west flip: true+ - src: tunnel+ offset: [3, -21]+ orient:+ up: west+ - src: tunnel+ offset: [71, -21]+ orient:+ up: east upperleft:- - -18- - 30+ - -18+ - 30 map: | dddddddddd.................................................................... dddddddd......................................................................
@@ -0,0 +1,4 @@+clearing.yaml+rorschach.yaml+stretch.yaml+translate.yaml
@@ -0,0 +1,22 @@+version: 1+name: Clearing+description: |+ The base is in a clearing in the forest: the area within a certain+ radius of the base is completely clear of trees; then there are+ random trees at increasing density up to another radius; outside of+ the outer radius there are only trees.+creative: true+robots:+ - name: base+ display:+ char: Ω+ loc: [0, 0]+ dir: north+world:+ dsl: |+ overlay+ [ {dirt}+ , mask ((x*x + 4*y*y) >= (6*6) && (x*x + 4*y*y) <= (30*30))+ (let h = hash % 24 in if (36 + h*h) <= (x*x + 4*y*y) then {tree,dirt} else {dirt} )+ , mask ((x*x + 4*y*y) > (30*30)) {tree, dirt}+ ]
@@ -0,0 +1,21 @@+version: 1+name: Rorschach+description: |+ A world with both horizontal and vertical reflection symmetry,+ created with `imap`{=snippet}.+creative: true+robots:+ - name: base+ dir: north+ loc: [0, 0]+known: [tree]+world:+ dsl: |+ let trees = if (hash % 4 == 0) then {tree, dirt} else {stone}+ in+ overlay+ [ mask (x >= 0 && y >= 0) trees+ , mask (x >= 0 && y < 0) (imap x (-y) trees)+ , mask (x < 0 && y >= 0) (imap (-x) y trees)+ , mask (x < 0 && y < 0) (imap (-x) (-y) trees)+ ]
@@ -0,0 +1,16 @@+version: 1+name: Stretch+description: |+ A world created by stretching a random pattern of trees, with the+ amount of stretching determined by the distance from the origin.+creative: true+robots:+ - name: base+ dir: north+ loc: [0, 0]+known: [tree]+world:+ dsl: |+ let trees = if (hash % 4 == 0) then {tree, dirt} else {stone}+ in+ imap (if (y == 0) then 0 else (x/abs(y))) (if (abs x <= 1) then 0 else (y/abs(x/2))) trees
@@ -0,0 +1,24 @@+version: 1+name: Translate+description: |+ An illustration of how to use `imap`{=snippet} to translate. A basic patch is+ created and then overlaid at various translations. Note that since+ `imap`{=snippet} works by mapping a function over the coordinates, translation+ is "backwards": for example, `imap (x+4)`{=snippet} translates 4 units to the+ *left*.+creative: true+robots:+ - name: base+ dir: north+ loc: [0, 0]+known: [rock]+world:+ dsl: |+ let patch = mask (abs(x) <= 4 && abs(y) <= 4) (if ((x + y) % 2 == 0) then {rock, dirt} else {dirt})+ in+ overlay+ [ patch+ , imap (x+6) (y+3) patch+ , imap (x-10) (y-7) patch+ , imap (x-14) (y+5) patch+ ]
@@ -4,8 +4,8 @@ creative: true robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω
@@ -3,8 +3,8 @@ description: The classic open-world, resource-gathering version of the game. You start with a few basic supplies and have to program robots to explore and collect resources. robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω
@@ -1,12 +1,11 @@ version: 1 name: Creative game-description: No constraints! Do whatever you want, create any items you- want out of thin air, build robots to your heart's content.+description: No constraints! Do whatever you want, create any items you want out of thin air, build robots to your heart's content. creative: true robots: - name: base- loc: [0,0]- dir: [0,1]+ loc: [0, 0]+ dir: north heavy: true display: char: Ω
@@ -0,0 +1,16 @@+- name: stone+ attr: stone+ description: |+ Solid, impenetrable material+- name: dirt+ attr: dirt+ description: |+ Soil amenable to plant growth+- name: grass+ attr: grass+ description: |+ Soft, verdant ground+- name: ice+ attr: ice+ description: |+ Cold, solid, and slippery.
binary file changed (absent → 138 bytes)
@@ -0,0 +1,43 @@+structures:+ - name: checker pair+ structure:+ palette:+ 't': true+ 'f': false+ map: |+ ttttffff+ ttttffff+ ttttffff+ ttttffff+ - name: checker quad+ structure:+ map: ""+ placements:+ - src: checker pair+ offset: [0, 0]+ - src: checker pair+ offset: [0, -4]+ orient:+ up: south+ - name: checker octo+ structure:+ map: ""+ placements:+ - src: checker quad+ offset: [0, 0]+ - src: checker quad+ offset: [8, 0]+ - src: checker quad+ offset: [0, -8]+ - src: checker quad+ offset: [8, -8]+placements:+ - src: checker octo+ offset: [0, 0]+ - src: checker octo+ offset: [16, 0]+ - src: checker octo+ offset: [0, -16]+ - src: checker octo+ offset: [16, -16]+map: ""
binary file changed (absent → 158 bytes)
@@ -0,0 +1,59 @@+structures:+ - name: cross+ structure:+ structures:+ - name: beam+ structure:+ palette:+ 't': true+ 'f': false+ map: |+ ttt+ ttt+ ttt+ ttt+ ttt+ ttt+ fff+ fff+ fff+ placements:+ - src: beam+ offset: [0, 3]+ - src: beam+ offset: [-3, -3]+ orient:+ up: east+ map: ""+ - name: disc+ structure:+ mask: '.'+ palette:+ 't': true+ map: |+ ..tttt..+ .tttttt.+ ttt..ttt+ tt....tt+ tt....tt+ ttt..ttt+ .tttttt.+ ..tttt..+placements:+ - src: cross+ offset: [0, -15]+ - src: cross+ offset: [0, 0]+ orient:+ up: east+ - src: cross+ offset: [15, 0]+ orient:+ up: south+ - src: cross+ offset: [15, -15]+ orient:+ up: west+ - src: disc+ offset: [8, -8]+map: ""
@@ -89,6 +89,7 @@ [ {grass} , mask (hash % 20 == 10) {grass, cotton} , mask (hash % 20 == 0) {grass, flower}+ , mask (hash % 1000 == 1) {grass, tea plant} ] ) , mask (small && soft && artificial)
@@ -0,0 +1,127 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<!-- Generated by graphviz version 2.43.0 (0)+ -->+<!-- Title: plan Pages: 1 -->+<svg width="278pt" height="476pt"+ viewBox="0.00 0.00 277.50 476.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 472)">+<title>plan</title>+<polygon fill="white" stroke="transparent" points="-4,4 -4,-472 273.5,-472 273.5,4 -4,4"/>+<!-- swarm -->+<g id="node1" class="node">+<title>swarm</title>+<path fill="none" stroke="brown" stroke-width="2" d="M168,-36C168,-36 127,-36 127,-36 121,-36 115,-30 115,-24 115,-24 115,-12 115,-12 115,-6 121,0 127,0 127,0 168,0 168,0 174,0 180,-6 180,-12 180,-12 180,-24 180,-24 180,-30 174,-36 168,-36"/>+<text text-anchor="middle" x="147.5" y="-14.3" font-family="Times,serif" font-size="14.00">swarm</text>+</g>+<!-- swarm-web -->+<g id="node2" class="node">+<title>swarm-web</title>+<path fill="none" stroke="gray" stroke-width="2" d="M184.5,-108C184.5,-108 110.5,-108 110.5,-108 104.5,-108 98.5,-102 98.5,-96 98.5,-96 98.5,-84 98.5,-84 98.5,-78 104.5,-72 110.5,-72 110.5,-72 184.5,-72 184.5,-72 190.5,-72 196.5,-78 196.5,-84 196.5,-84 196.5,-96 196.5,-96 196.5,-102 190.5,-108 184.5,-108"/>+<text text-anchor="middle" x="147.5" y="-86.3" font-family="Times,serif" font-size="14.00">swarm-web</text>+</g>+<!-- swarm->swarm-web -->+<g id="edge1" class="edge">+<title>swarm->swarm-web</title>+<path fill="none" stroke="brown" d="M147.5,-36.3C147.5,-44.02 147.5,-53.29 147.5,-61.89"/>+<polygon fill="brown" stroke="brown" points="144,-61.9 147.5,-71.9 151,-61.9 144,-61.9"/>+</g>+<!-- swarm-doc -->+<g id="node3" class="node">+<title>swarm-doc</title>+<path fill="none" stroke="gray" stroke-width="2" d="M127.5,-180C127.5,-180 57.5,-180 57.5,-180 51.5,-180 45.5,-174 45.5,-168 45.5,-168 45.5,-156 45.5,-156 45.5,-150 51.5,-144 57.5,-144 57.5,-144 127.5,-144 127.5,-144 133.5,-144 139.5,-150 139.5,-156 139.5,-156 139.5,-168 139.5,-168 139.5,-174 133.5,-180 127.5,-180"/>+<text text-anchor="middle" x="92.5" y="-158.3" font-family="Times,serif" font-size="14.00">swarm-doc</text>+</g>+<!-- swarm-web->swarm-doc -->+<g id="edge2" class="edge">+<title>swarm-web->swarm-doc</title>+<path fill="none" stroke="gray" d="M133.9,-108.3C127.38,-116.61 119.43,-126.72 112.25,-135.86"/>+<polygon fill="gray" stroke="gray" points="109.37,-133.87 105.94,-143.9 114.87,-138.19 109.37,-133.87"/>+</g>+<!-- swarm-tui -->+<g id="node4" class="node">+<title>swarm-tui</title>+<path fill="none" stroke="gray" stroke-width="2" d="M235,-180C235,-180 170,-180 170,-180 164,-180 158,-174 158,-168 158,-168 158,-156 158,-156 158,-150 164,-144 170,-144 170,-144 235,-144 235,-144 241,-144 247,-150 247,-156 247,-156 247,-168 247,-168 247,-174 241,-180 235,-180"/>+<text text-anchor="middle" x="202.5" y="-158.3" font-family="Times,serif" font-size="14.00">swarm-tui</text>+</g>+<!-- swarm-web->swarm-tui -->+<g id="edge3" class="edge">+<title>swarm-web->swarm-tui</title>+<path fill="none" stroke="gray" d="M161.1,-108.3C167.62,-116.61 175.57,-126.72 182.75,-135.86"/>+<polygon fill="gray" stroke="gray" points="180.13,-138.19 189.06,-143.9 185.63,-133.87 180.13,-138.19"/>+</g>+<!-- swarm-engine -->+<g id="node5" class="node">+<title>swarm-engine</title>+<path fill="none" stroke="gray" stroke-width="2" d="M194,-252C194,-252 101,-252 101,-252 95,-252 89,-246 89,-240 89,-240 89,-228 89,-228 89,-222 95,-216 101,-216 101,-216 194,-216 194,-216 200,-216 206,-222 206,-228 206,-228 206,-240 206,-240 206,-246 200,-252 194,-252"/>+<text text-anchor="middle" x="147.5" y="-230.3" font-family="Times,serif" font-size="14.00">swarm-engine</text>+</g>+<!-- swarm-doc->swarm-engine -->+<g id="edge4" class="edge">+<title>swarm-doc->swarm-engine</title>+<path fill="none" stroke="gray" d="M106.1,-180.3C112.62,-188.61 120.57,-198.72 127.75,-207.86"/>+<polygon fill="gray" stroke="gray" points="125.13,-210.19 134.06,-215.9 130.63,-205.87 125.13,-210.19"/>+</g>+<!-- swarm-tui->swarm-engine -->+<g id="edge5" class="edge">+<title>swarm-tui->swarm-engine</title>+<path fill="none" stroke="gray" d="M188.9,-180.3C182.38,-188.61 174.43,-198.72 167.25,-207.86"/>+<polygon fill="gray" stroke="gray" points="164.37,-205.87 160.94,-215.9 169.87,-210.19 164.37,-205.87"/>+</g>+<!-- swarm-scenario -->+<g id="node6" class="node">+<title>swarm-scenario</title>+<path fill="none" stroke="gray" stroke-width="2" d="M200,-324C200,-324 95,-324 95,-324 89,-324 83,-318 83,-312 83,-312 83,-300 83,-300 83,-294 89,-288 95,-288 95,-288 200,-288 200,-288 206,-288 212,-294 212,-300 212,-300 212,-312 212,-312 212,-318 206,-324 200,-324"/>+<text text-anchor="middle" x="147.5" y="-302.3" font-family="Times,serif" font-size="14.00">swarm-scenario</text>+</g>+<!-- swarm-engine->swarm-scenario -->+<g id="edge6" class="edge">+<title>swarm-engine->swarm-scenario</title>+<path fill="none" stroke="gray" d="M147.5,-252.3C147.5,-260.02 147.5,-269.29 147.5,-277.89"/>+<polygon fill="gray" stroke="gray" points="144,-277.9 147.5,-287.9 151,-277.9 144,-277.9"/>+</g>+<!-- swarm-topography -->+<g id="node7" class="node">+<title>swarm-topography</title>+<path fill="none" stroke="gray" stroke-width="2" d="M139,-396C139,-396 12,-396 12,-396 6,-396 0,-390 0,-384 0,-384 0,-372 0,-372 0,-366 6,-360 12,-360 12,-360 139,-360 139,-360 145,-360 151,-366 151,-372 151,-372 151,-384 151,-384 151,-390 145,-396 139,-396"/>+<text text-anchor="middle" x="75.5" y="-374.3" font-family="Times,serif" font-size="14.00">swarm-topography</text>+</g>+<!-- swarm-scenario->swarm-topography -->+<g id="edge7" class="edge">+<title>swarm-scenario->swarm-topography</title>+<path fill="none" stroke="gray" d="M129.7,-324.3C120.9,-332.86 110.12,-343.34 100.5,-352.7"/>+<polygon fill="gray" stroke="gray" points="97.82,-350.42 93.09,-359.9 102.7,-355.43 97.82,-350.42"/>+</g>+<!-- swarm-lang -->+<g id="node8" class="node">+<title>swarm-lang</title>+<path fill="none" stroke="gray" stroke-width="2" d="M257.5,-396C257.5,-396 181.5,-396 181.5,-396 175.5,-396 169.5,-390 169.5,-384 169.5,-384 169.5,-372 169.5,-372 169.5,-366 175.5,-360 181.5,-360 181.5,-360 257.5,-360 257.5,-360 263.5,-360 269.5,-366 269.5,-372 269.5,-372 269.5,-384 269.5,-384 269.5,-390 263.5,-396 257.5,-396"/>+<text text-anchor="middle" x="219.5" y="-374.3" font-family="Times,serif" font-size="14.00">swarm-lang</text>+</g>+<!-- swarm-scenario->swarm-lang -->+<g id="edge8" class="edge">+<title>swarm-scenario->swarm-lang</title>+<path fill="none" stroke="gray" d="M165.3,-324.3C174.1,-332.86 184.88,-343.34 194.5,-352.7"/>+<polygon fill="gray" stroke="gray" points="192.3,-355.43 201.91,-359.9 197.18,-350.42 192.3,-355.43"/>+</g>+<!-- swarm-util -->+<g id="node9" class="node">+<title>swarm-util</title>+<path fill="none" stroke="gray" stroke-width="2" d="M182,-468C182,-468 113,-468 113,-468 107,-468 101,-462 101,-456 101,-456 101,-444 101,-444 101,-438 107,-432 113,-432 113,-432 182,-432 182,-432 188,-432 194,-438 194,-444 194,-444 194,-456 194,-456 194,-462 188,-468 182,-468"/>+<text text-anchor="middle" x="147.5" y="-446.3" font-family="Times,serif" font-size="14.00">swarm-util</text>+</g>+<!-- swarm-topography->swarm-util -->+<g id="edge9" class="edge">+<title>swarm-topography->swarm-util</title>+<path fill="none" stroke="gray" d="M93.3,-396.3C102.1,-404.86 112.88,-415.34 122.5,-424.7"/>+<polygon fill="gray" stroke="gray" points="120.3,-427.43 129.91,-431.9 125.18,-422.42 120.3,-427.43"/>+</g>+<!-- swarm-lang->swarm-util -->+<g id="edge10" class="edge">+<title>swarm-lang->swarm-util</title>+<path fill="none" stroke="gray" d="M201.7,-396.3C192.9,-404.86 182.12,-415.34 172.5,-424.7"/>+<polygon fill="gray" stroke="gray" points="169.82,-422.42 165.09,-431.9 174.7,-427.43 169.82,-422.42"/>+</g>+</g>+</svg>
@@ -7,145 +7,190 @@ ;; ;; This file is not part of GNU Emacs. ;;+;;; Commentary:+;; This package provides major mode for the Swarm programming language.+;;+;; ;;; Code: (require 'lsp-mode) -(defvar swarm-mode-syntax-table nil "Syntax table for `swarm-mode'.")+(defvar swarm-mode-syntax-table+ (let ((synTable (make-syntax-table)))+ ;; C++ style comments ("// ..." and "/* ... */")+ (modify-syntax-entry ?\/ ". 124b" synTable)+ (modify-syntax-entry ?* ". 23" synTable)+ (modify-syntax-entry ?\n "> b" synTable)+ synTable)+ "Syntax table for `swarm-mode'.") -(setq swarm-mode-syntax-table- (let ( (synTable (make-syntax-table)))+(defvar swarm-mode-operators-regexp+ (regexp-opt+ '(+ "-"+ "=="+ "!="+ "<"+ ">"+ "<="+ ">="+ "||"+ "&&"+ "+"+ "-"+ "*"+ "/"+ "^"+ "++"+ "$"+ ":"+ )+ t)+ "Regexp that recognizes operators for swarm language.") - ;; C++ style comments ("// ..." and "/* ... */")- (modify-syntax-entry ?\/ ". 124" synTable)- (modify-syntax-entry ?* ". 23b" synTable)- (modify-syntax-entry ?\n "> " synTable)+(defvar swarm-mode-commands-regexp+ (concat+ "\\b"+ (regexp-opt+ '(+ "noop"+ "wait"+ "selfdestruct"+ "move"+ "backup"+ "volume"+ "path"+ "push"+ "stride"+ "turn"+ "grab"+ "harvest"+ "sow"+ "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"+ "floorplan"+ "hastag"+ "tagmembers"+ "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"+ "east"+ "north"+ "west"+ "south"+ "down"+ "forward"+ "left"+ "back"+ "right"+ )+ t)+ "\\b")+ "Regexp that recognizes commands for swarm.") - synTable))+(defvar swarm-mode-builtins-regexp+ (concat+ "\\b"+ (regexp-opt+ '(+ "self"+ "parent"+ "base"+ "if"+ "inl"+ "inr"+ "case"+ "fst"+ "snd"+ "force"+ "undefined"+ "fail"+ "not"+ "format"+ "chars"+ "split"+ "charat"+ "tochar"+ "key"+ )+ t)+ "\\b" )+ "Regexp that recognizes builtin for swarm language.") -(setq swarm-font-lock-keywords- (let* (- ;; Generate the current keywords with:- ;; cabal run swarm:swarm -- generate editors --emacs- (x-keywords '("def" "end" "let" "in" "require"))- (x-builtins '(- "self"- "parent"- "base"- "if"- "inl"- "inr"- "case"- "fst"- "snd"- "force"- "undefined"- "fail"- "not"- "format"- "chars"- "split"- "charat"- "tochar"- "key"- ))- (x-commands '(- "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"- "east"- "north"- "west"- "south"- "down"- "forward"- "left"- "back"- "right"- ))- (x-types '("int" "text" "dir" "bool" "cmd" "void" "unit" "actor"))+(defvar swarm-mode-types-regexp+ "\\b[A-Z][a-zA-Z_]*\\b"+ "Regexp that recognizes types (all uppercase strings are supposed to be types) in swarm language.") - (x-keywords-regexp (regexp-opt x-keywords 'words))- (x-builtins-regexp (regexp-opt x-builtins 'words))- (x-commands-regexp (regexp-opt x-commands 'words))- (x-types-regexp (regexp-opt x-types 'words)))+(defvar swarm-mode-keywords-regexp+ (concat "\\b" (regexp-opt '("def" "tydef" "rec" "end" "let" "in" "require") t) "\\b")+ "Regexp that recognizes keywords in swarm language.") - `(- (,x-keywords-regexp . 'font-lock-keyword-face)- (,x-builtins-regexp . 'font-lock-builtin-face)- (,x-types-regexp . 'font-lock-type-face)- (,x-commands-regexp . 'font-lock-constant-face)- ("[a-z_][a-z0-9_]*" . 'font-lock-function-name-face)- )))+(defvar swarm-font-lock-keywords+ `((,swarm-mode-types-regexp . 'font-lock-type-face)+ (,swarm-mode-keywords-regexp . 'font-lock-keyword-face)+ (,swarm-mode-builtins-regexp . 'font-lock-builtin-face)+ (,swarm-mode-commands-regexp . 'font-lock-constant-face)+ (,swarm-mode-operators-regexp . 'font-lock-variable-name-face))) +;;;###autoload (define-derived-mode swarm-mode prog-mode "Swarm Lang Mode"- (setq font-lock-defaults '((swarm-font-lock-keywords) nil t nil))+ "Major mode for editing Swarm language files."+ (setq font-lock-defaults '((swarm-font-lock-keywords))) (set-syntax-table swarm-mode-syntax-table)) +;;;###autoload (add-to-list 'auto-mode-alist '("\\.sw\\'" . swarm-mode)) (with-eval-after-load 'lsp-mode
@@ -1,14 +1,14 @@-syn keyword Keyword def end let in require+syn keyword Keyword def tydef rec 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 volume path push stride turn grab harvest sow 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 floorplan hastag tagmembers 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+syn match Type "\<[A-Z][a-zA-Z_]*\>"+syn match Operators "[-=!<>|&+*/^$:]" syn match Comment "//.*$" syn region MultilineComment start="/\*" end="\*/" syn match Brackets "[\[\]\(\)\{\}]"-syn match Colon ":" syn match String "\".*\"" syn match Number "\<[-]\=\d\+\>" @@ -19,6 +19,6 @@ hi def link Comment Comment hi def link MultilineComment Comment hi def link Brackets Keyword-hi def link Colon Keyword-hi def link String String +hi def link Operators Keyword+hi def link String String hi def link Number Number
@@ -1,111 +0,0 @@-{- "$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json",- "name": "swarm",- "patterns": [- {"include": "#keywords"},- {"include": "#comments"},- {"include": "#strings"},- {"include": "#variables"},- {"include": "#constants"}- ],- "repository": {- "keywords": {- "patterns": [- {- "name": "keyword.control.dictionary.def",- "begin": "def\\s+(\\w+)\\s*(:((\\s*(cmd|dir|string|int|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=",- "end": "end",- "beginCaptures": {- "1": {"name": "entity.name.function"},- "3": {"name": "entity.name.type"}- },- "patterns": [- {"include": "#keywords"},- {"include": "#comments"},- {"include": "#strings"},- {"include": "#variables"},- {"include": "#constants"}- ]- },- {- "name": "keyword.control.dictionary.let",- "begin": "\\s*let\\s+(\\w+)\\s*(:((\\s*(cmd|dir|text|int|void|unit|actor|\\(|\\)|\\{|\\}|(\\*|\\+|->)|[a-z]\\w*|forall ([a-z]\\w*\\s*)+.)\\s*)+))?=",- "end": "\\s*in\\b",- "beginCaptures": {- "1": {"name": "entity.name.function"},- "3": {"name": "entity.name.type"}- },- "patterns": [- {"include": "#keywords"},- {"include": "#comments"},- {"include": "#strings"},- {"include": "#variables"},- {"include": "#constants"}- ]- },- {- "name": "keyword.control.require",- "match": "require"- },- {- "name": "keyword.operator",- "match": "-|==|!=|<|>|<=|>=|\\|\\||&&|\\+|-|\\*|/(?![/|*])|\\^|\\+\\+|\\$"- },- {- "name": "keyword.operator.lambda",- "match": "\\\\(\\w+)\\.",- "captures": { "1": {"name": "variable.other"} }- },- {- "name": "keyword.other",- "match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|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"- }- ]- },- "comments": {- "patterns": [- {- "name": "comment.line.double-slash",- "begin": "//",- "end": "\n"- },- {- "name":"comment.block",- "begin": "\/[*]",- "end": "[*](\/)"- }- ]- },- "strings":{- "patterns": [- {- "name":"string.quoted.double",- "begin": "\"",- "end": "\""- }- ]- },- "variables":{- "patterns": [- {- "name": "variable.language.dir",- "match": "\\b(?i)(east|north|west|south|down|forward|left|back|right|)\\b"- },- {- "name": "variable.parameter",- "match": "\\b(?i)([a-z]\\w*)\\b"- }- ]- },- "constants": {- "patterns": [- {- "name": "constant.numeric",- "match": "([0-9]+|0b[01]+|0o[0-8]+|0x\\x+)"- }- ]- }-- },- "scopeName": "source.swarm"-}
@@ -0,0 +1,201 @@+######################################################+# #+# Syntax highlighting TextMate grammar for Swarm #+# #+######################################################+# Read the DEVELOPING.md file for how to test this.+#+# WARNING: A SINGLE TYPO CAN BREAK THE WHOLE THING!!!+#+# Always run the snapshot test to see if half of the+# syntax is not suddenly missing and you should be OK.+$schema: https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json+name: swarm+scopeName: source.swarm+patterns:+ - include: '#expression'+repository:+ # ============================================================================+ # This group is recursively reused and is the root if Swarm language+ expression:+ # WARNING: patterns are ordered, but the named groups in repository are NOT+ patterns:+ - include: '#keywords'+ - include: '#comments'+ - include: '#definitions'+ - include: '#strings'+ - include: '#constants'+ - include: '#variables' # must go AFTER keywords and definitions+ - include: '#parens'+ # ============================================================================+ keywords:+ patterns:+ - include: '#keyword'+ - include: '#require'+ - include: '#operator'+ - include: '#lambda'+ - include: '#chain'+ - include: '#in'+ - include: '#end'+ repository:+ # ---------------------------------------------+ # GENERATED PATTERN: Functions and commands+ # Get new version with:+ # cabal run swarm:swarm-docs -- editors --code+ # ---------------------------------------------+ keyword:+ name: keyword.other+ match: >-+ \b(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|volume|path|push|stride|turn|grab|harvest|sow|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|floorplan|hastag|tagmembers|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+ require:+ name: keyword.control.require+ match: \b(require)\b+ lambda:+ name: keyword.operator.lambda+ match: \\(\w+)\.+ captures:+ '1':+ name: variable.other+ chain:+ name: keyword.operator.chain+ match: ;+ # ---------------------------------------------+ # GENERATED PATTERN: Operators+ # Get new version with:+ # cabal run swarm:swarm-docs -- editors --code+ # ---------------------------------------------+ operator:+ name: keyword.operator+ match: '-|==|!=|<|>|<=|>=|\|\||&&|\+|-|\*|/(?![/|*])|\^|\+\+|\$|:'+ in:+ name: keyword.control.dictionary.let.in+ match: \b(in)\b+ end:+ name: keyword.control.dictionary.def.end+ match: \b(end)\b+ # ============================================================================+ variables:+ patterns:+ # ---------------------------------------------+ # GENERATED PATTERN: Directions+ # Get new version with:+ # cabal run swarm:swarm-docs -- editors --code+ # ---------------------------------------------+ - name: variable.language.dir+ match: \b(east|north|west|south|down|forward|left|back|right)\b+ - name: variable.parameter+ match: \b([a-z]\w*)\b+ parens:+ patterns:+ - include: '#paren'+ - include: '#brace'+ repository:+ paren:+ begin: \(+ end: \)+ beginCaptures:+ '0':+ name: punctuation.paren.open+ endCaptures:+ '0':+ name: punctuation.paren.close+ name: expression.group+ patterns:+ - include: '#expression'+ brace:+ begin: \{+ end: \}+ beginCaptures:+ '0':+ name: punctuation.braces.open+ endCaptures:+ '0':+ name: punctuation.braces.close+ name: expression.group+ patterns:+ - include: '#expression'+ # ============================================================================+ comments:+ patterns:+ - include: '#line'+ - include: '#block'+ repository:+ line:+ name: comment.line.double-slash+ begin: //+ end: $\n?+ block:+ name: comment.block+ begin: /[*]+ end: '[*](/)'+ # ============================================================================+ strings:+ patterns:+ - name: string.quoted.double+ begin: '"'+ end: '"'+ patterns:+ - name: constant.character.escape.sequence.swarm+ match: \\(?:["$\\/bfnrt])+ # ============================================================================+ constants:+ patterns:+ - name: constant.numeric+ match: ([0-9]+|0b[01]+|0o[0-8]+|0x\x+)+ # ============================================================================+ definitions:+ patterns:+ - include: '#tydef'+ - include: '#defeq'+ - include: '#leteq'+ repository:+ tydef:+ name: keyword.control.dictionary.tydef+ begin: \b(tydef)\s+([^=]+)\s*(=)+ end: \b(end)\b+ beginCaptures:+ '1':+ name: keyword.control.dictionary.tydef.start+ '2':+ name: entity.name.type+ '3':+ name: keyword.control.dictionary.tydef.assignment+ endCaptures:+ '1':+ name: keyword.control.dictionary.tydef.end+ patterns:+ - include: '#types'+ defeq:+ name: keyword.control.dictionary.def+ begin: \b(def)\s+(\w+)\s*(:)?+ end: '='+ beginCaptures:+ '2':+ name: entity.name.function+ '3':+ name: keyword.control.dictionary.def.annotation+ endCaptures:+ '0':+ name: keyword.control.dictionary.def.assignment+ patterns:+ - include: '#types'+ leteq:+ name: keyword.control.dictionary.let+ begin: \b(let)\s+(\w+)\s*(:)?+ end: '='+ beginCaptures:+ '2':+ name: entity.name.function+ '3':+ name: keyword.control.dictionary.let.annotation+ endCaptures:+ '0':+ name: keyword.control.dictionary.let.assignment+ patterns:+ - include: '#types'+ # ============================================================================+ # Types are not part of #expression and are used only in #definition+ types:+ patterns:+ - name: entity.name.type+ match: \b(forall|rec|[A-Z]\w*|[a-z]\w*)\b|\(|\)|\{|\}|(\*|\+|->)|\.
@@ -2,24 +2,24 @@ // search, with robots spawning more robots. Fun, though not very practical // in classic mode. -def repeat : int -> cmd unit -> cmd unit = \n.\c.+def repeat : Int -> Cmd Unit -> Cmd Unit = \n.\c. if (n == 0) {} {c ; repeat (n-1) c} end;-def while : cmd bool -> cmd unit -> cmd unit = \test.\c.+def while : Cmd Bool -> Cmd Unit -> Cmd Unit = \test.\c. b <- test; if b {c ; while test c} {} end;-def getX : cmd int =+def getX : Cmd Int = pos <- whereami; return (fst pos); end;-def getY : cmd int =+def getY : Cmd Int = pos <- whereami; return (snd pos); end;-def gotoX : int -> cmd unit = \tgt.+def gotoX : Int -> Cmd Unit = \tgt. cur <- getX; if (cur == tgt) {}@@ -30,7 +30,7 @@ gotoX tgt } end;-def gotoY : int -> cmd unit = \tgt.+def gotoY : Int -> Cmd Unit = \tgt. cur <- getY; if (cur == tgt) {}@@ -41,8 +41,8 @@ gotoY tgt } end;-def goto : int -> int -> cmd unit = \x. \y. gotoX x; gotoY y; gotoX x; gotoY y end;-def spawnfwd : {cmd unit} -> cmd unit = \c.+def goto : Int -> Int -> Cmd Unit = \x. \y. gotoX x; gotoY y; gotoX x; gotoY y end;+def spawnfwd : {Cmd Unit} -> Cmd Unit = \c. try { move; b <- isHere "tree";@@ -53,7 +53,7 @@ move } { turn back } end;-def clear : cmd unit =+def clear : Cmd Unit = grab; repeat 4 ( spawnfwd {clear};@@ -63,4 +63,4 @@ give base "tree"; selfdestruct; end;-def start : cmd actor = build {turn west; repeat 7 move; clear} end+def start : Cmd Actor = build {turn west; repeat 7 move; clear} end
@@ -1,10 +1,10 @@ // A "cat" that wanders around randomly. Shows off use of the // 'random' command. -let forever : cmd unit -> cmd unit = \c. c ; forever c in-let repeat : int -> cmd unit -> cmd unit =+let forever : Cmd Unit -> Cmd Unit = \c. c ; forever c in+let repeat : Int -> Cmd Unit -> Cmd Unit = \n. \c. if (n == 0) {} {c ; repeat (n-1) c} in-let randdir : cmd dir =+let randdir : Cmd Dir = d <- random 4; return ( if (d == 0) {north}
@@ -1,8 +1,8 @@-def ifC : forall a. cmd bool -> {cmd a} -> {cmd a} -> cmd a =+def ifC : forall a. Cmd Bool -> {Cmd a} -> {Cmd a} -> Cmd a = \test. \thn. \els. b <- test; if b thn els end // Recursive DFS to harvest a contiguous forest-def dfs : cmd unit =+def dfs : Cmd Unit = ifC (ishere "tree") { grab; turn west;
@@ -1,10 +1,10 @@ // Defining simple recursive functions. -def repeat : int -> cmd unit -> cmd unit = \n.\c.+def repeat : Int -> Cmd Unit -> Cmd Unit = \n.\c. if (n == 0) {} {c ; repeat (n-1) c} end -def fact : int -> int = \n:int.+def fact : Int -> Int = \n:Int. if (n == 0) {1} {n * fact (n-1)}
@@ -26,10 +26,10 @@ // // It is the callers responsibility to make sure a program using this // "type" is type safe. Notably 2 == [0] != [] == 0 but [] !! x == 0.-// +// // TODO: once #153 is resolved, add types to definitions //-// type listI = int+// type ListI = Int /*******************************************************************/ /* LAYOUT */@@ -39,16 +39,16 @@ // chunks each prefixed by 1bit that marks if the byte is last in // the header (0=YES). -/* EXAMPLE - [short_x,long_y] - concretly e.g. [42, 2^(2^7)] +/* EXAMPLE - [short_x,long_y] - concretly e.g. [42, 2^(2^7)] 0 < len short_x < 2^7-2^7 < len long_y < 2^14 +2^7 < len long_y < 2^14 cons short_x $ cons long_y $ nil vvvvvvvvvvvv vvvvvvvvvvvvvvvvvvvvvvvvv vvv 0|len x|x | 1|len y%2^7|0|len y/2^7|y | 0 ^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^- head tail + head tail */ /*******************************************************************/@@ -56,31 +56,31 @@ /*******************************************************************/ // bitlength of a number (shifting by one)-def naive_len : int -> int = \i.+def naive_len : Int -> Int = \i. if (i == 0) {0} {1 + naive_len (i/2)} end // modulus function (%)-def mod : int -> int -> int = \i.\m.+def mod : Int -> Int -> Int = \i.\m. i - m * (i / m) end // f X Y = Y * 2^(-X)-def shiftL : int -> int -> int = \s.\i.+def shiftL : Int -> Int -> Int = \s.\i. i / 2^s end // f X Y = Y * 2^(X)-def shiftR : int -> int -> int = \s.\i.+def shiftR : Int -> Int -> Int = \s.\i. i * 2^s end // shift by (8bit) bytes-def shiftLH : int -> int -> int = \s. shiftL (s*8) end-def shiftRH : int -> int -> int = \s. shiftR (s*8) end+def shiftLH : Int -> Int -> Int = \s. shiftL (s*8) end+def shiftRH : Int -> Int -> Int = \s. shiftR (s*8) end // bitlength of a number (shifting by 64)-def len : int -> int = \i.+def len : Int -> Int = \i. let next = i / 2^64 in if (next == 0) {naive_len i} {64 + len next} end@@ -89,11 +89,11 @@ /* helper functions */ /*******************************************************************/ -def getLenPart : int -> int = \i. mod (i/2) (2^7) end-def setLenPart : int -> int = \i. 2 * (mod i (2^7)) end+def getLenPart : Int -> Int = \i. mod (i/2) (2^7) end+def setLenPart : Int -> Int = \i. 2 * (mod i (2^7)) end // Split length into 7-bit parts and prefix all but last with 1-def to1numA : int -> int * int = \i.+def to1numA : Int -> Int * Int = \i. let nextPart = shiftL 7 i in if (nextPart == 0) { ((2 * i), 1) } /* last part */@@ -107,7 +107,7 @@ // Get bitlength of the first number in the list // and also the list starting at the number itself //-// getLenA : listI -> int * int+// getLenA : ListI -> Int * Int def getLenA = \xs. let isEnd = 0 == mod xs 2 in let l = getLenPart xs in@@ -123,7 +123,7 @@ /* LIST FUNCTIONS */ /*******************************************************************/ -// headTail : listI -> {int} * {listI} +// headTail : ListI -> {Int} * {ListI} def headTail = \xs. let sign = mod xs 2 in let ns = xs / 2 in@@ -135,21 +135,21 @@ ) end -// head : listI -> int-def head : int -> int = \xs.+// head : ListI -> Int+def head : Int -> Int = \xs. force $ fst $ headTail xs end -// tail : listI -> listI +// tail : ListI -> ListI def tail = \xs. force $ snd $ headTail xs end -// nil : listI+// nil : ListI def nil = 0 end // Add non-negative number to beginning of list (cons adds the sign)-// consP : nat -> listI -> int+// consP : nat -> ListI -> Int def consP = \x.\xs. if (x == 0) { 2 /* header says one bit length */ + shiftR (8+1) xs}@@ -160,7 +160,7 @@ end // Add integer to the beginning of the list-// consP : int -> listI -> listI+// consP : Int -> ListI -> ListI def cons = \x.\xs. if (x >= 0) { 2 * consP x xs }@@ -172,19 +172,19 @@ /* MORE LIST FUNCTIONS */ /*******************************************************************/ -// index : int -> listI -> int+// index : Int -> ListI -> Int def index = \i.\xs. if (i <= 0) {head xs} {index (i-1) (tail xs)} end -def for : int -> int -> (int -> cmd a) -> cmd unit = \s.\e.\act.+def for : Int -> Int -> (Int -> Cmd a) -> Cmd Unit = \s.\e.\act. if (s == e) {} {act s; for (s+1) e act} end -// for_each_i : int -> listI int -> (int * int -> cmd a) -> cmd unit+// for_each_i : Int -> ListI Int -> (Int * Int -> Cmd a) -> Cmd Unit def for_each_i = \i.\xs.\act. if (xs == nil) {} { let ht = headTail xs@@ -192,7 +192,7 @@ } end -// for_each : listI int -> (int -> cmd a) -> cmd unit+// for_each : ListI Int -> (Int -> Cmd a) -> Cmd Unit def for_each = \xs.\act. for_each_i 0 xs (\i. act) end@@ -226,19 +226,19 @@ assert (ln1 == 517) "[-1] ~ 517"; assert (head ln1 == -1) "head [-1] == -1"; assert (tail ln1 == nil) "tail [-1] == []";- + log "check [42]"; let l42 = cons 42 nil in assert (l42 == 21528) "[42] ~ 21528"; assert (head l42 == 42) "head [42] == 42"; assert (tail l42 == nil) "tail [42] == []";- + log "check [499672]"; let l499672 = cons 499672 nil in assert (l499672 == 255832140) "[499672] ~ 255832140"; assert (head l499672 == 499672) "head [499672] == 499672"; assert (tail l499672 == nil) "tail [499672] == []";- + log "check [1,0]"; let l1_0 = cons 1 l0 in assert (l1_0 == 4612) "[1,0] ~ 4612";@@ -304,7 +304,7 @@ let lbiggest = cons bigger lbig in assert (head lbiggest == bigger) "head [bigger,big] == bigger"; assert (tail lbiggest == lbig) "tail [bigger,big] == [big]";- + log "OK - ALL TEST PASSED"; end
@@ -0,0 +1,9 @@+tydef Maybe a = Unit + a end++def just : a -> Maybe a = inr end++def nothing : Maybe a = inl () end++def positive : Int -> Maybe Int = \x.+ if (x > 0) {just x} {nothing}+end
@@ -5,16 +5,16 @@ if (a == fst p) {snd p} {k a} end -def nil : a -> cmd unit = \a. return () end+def nil : a -> Cmd Unit = \a. return () end // The delay around the first argument is necessary to prevent // infinite recursion-def handlerB : {key -> cmd unit} -> key -> cmd unit = \hA. \k.+def handlerB : {Key -> Cmd Unit} -> Key -> Cmd Unit = \hA. \k. cons (key "b", move) nil k; installKeyHandler "" (force hA) end // Typing 'a' then 'b' in sequence will cause the robot to move.-def handlerA : key -> cmd unit =+def handlerA : Key -> Cmd Unit = cons (key "a", installKeyHandler "" (handlerB {handlerA})) nil end
@@ -0,0 +1,5 @@+tydef D = rec d. d -> d end++def selfApp : D -> D = \x. x x end++def omega : D = selfApp selfApp end
@@ -2,11 +2,11 @@ if (a == fst p) {snd p} {k a} end -def nil : a -> cmd unit = \a. return () end+def nil : a -> Cmd Unit = \a. return () end // Suitable to use as e.g. // installKeyHandler "(S-)←↓↑→ [Del] [g]rab [h]arvest [d]rill [s]can [b]locked [u]pload" pilot-def pilot : key -> cmd unit =+def pilot : Key -> Cmd Unit = cons (key "Up", move) $ cons (key "Down", turn back) $ cons (key "Left", turn left) $
@@ -0,0 +1,107 @@+// 'rec t. F(t)' creates a recursive type which is the solution of t = F(t).+// For example 'rec l. Unit + Int * l' is the type l such that l = Unit + Int * l,+// that is, arbitrary-length finite lists of Int.+//+// Recursive types are equal up to alpha-renaming, so e.g.+// (rec l. Unit + Int * l) = (rec q. Unit + Int * q)++////////////////////////////////////////////////////////////+// Lists+////////////////////////////////////////////////////////////++tydef List a = rec l. Unit + a * l end++def nil : List a = inl () end+def cons : a -> List a -> List a = \x. \l. inr (x, l) end++def foldr : (a -> b -> b) -> b -> List a -> b = \f. \z. \xs.+ case xs+ (\_. z)+ (\c. f (fst c) (foldr f z (snd c)))+end++def map : (a -> b) -> List a -> List b = \f.+ foldr (\y. cons (f y)) nil+end++def append : List a -> List a -> List a = \xs. \ys.+ foldr cons ys xs+end++def concat : List (List a) -> List a = foldr append nil end++def sum : List Int -> Int =+ foldr (\x. \y. x + y) 0+end++def twentySeven = sum (cons 12 (cons 5 (cons 3 (cons 7 nil)))) end++// Note that if a function returns e.g. (rec t. Unit + (Int * Int) * t),+// that is the *same type* as List (Int * Int), so we can use any List+// functions on the output.++def someFun : Int -> (rec t. Unit + (Int * Int) * t) = \x. inr ((x, x), inl ()) end++def doSomethingWithSomeFun : List (Int * Int) =+ (cons (2,3) (cons (4,7) (someFun 5)))+end++////////////////////////////////////////////////////////////+// Binary trees with a at internal nodes and b at leaves+////////////////////////////////////////////////////////////++tydef BTree a b = rec bt. b + bt * a * bt end++def leaf : b -> BTree a b = inl end++def branch : BTree a b -> a -> BTree a b -> BTree a b =+ \l. \a. \r. inr (l, a, r)+end++def foldBTree : (b -> c) -> (c -> a -> c -> c) -> BTree a b -> c =+ \lf. \br. \t.+ case t+ lf+ // fst p, fst (snd p), snd (snd p) is annoying; see #1893+ (\p. br (foldBTree lf br (fst p)) (fst (snd p)) (foldBTree lf br (snd (snd p))))+end++def max : Int -> Int -> Int = \a. \b. if (a > b) {a} {b} end++def height : BTree a b -> Int =+ foldBTree (\_. 0) (\l. \_. \r. 1 + max l r)+end++////////////////////////////////////////////////////////////+// Rose trees+////////////////////////////////////////////////////////////++// It would be better to reuse the definition of List+// and define Rose a = rec r. a * List r,+// but we do it this way just to show off nested rec+tydef Rose a = rec r. a * (rec l. Unit + r * l) end++def foldRose : (a -> List b -> b) -> Rose a -> b = \f. \r.+ f (fst r) (map (foldRose f) (snd r))+end++def flatten : Rose a -> List a =+ foldRose (\a. \ts. cons a (concat ts))+end++////////////////////////////////////////////////////////////+// Equirecursive types+////////////////////////////////////////////////////////////++// Swarm has equirecursive types, which means a recursive type is+// *equal to* its unfolding. This has some interesting consequences+// including the fact that types are equal if their infinite unfoldings+// would be equal.++// For example, U1 and U2 below are the same, and the Swarm+// typechecker can tell:++tydef U1 = rec u1. Unit + u1 end+tydef U2 = rec u2. Unit + Unit + u2 end++def u : U1 -> U2 = \u. u end
@@ -1,9 +1,9 @@-def forever : {cmd unit} -> cmd unit =+def forever : {Cmd Unit} -> Cmd Unit = \c. force c ; forever c end // Wander randomly forever.-def wander : cmd unit =+def wander : Cmd Unit = forever { b <- random 2; turn (if (b == 0) {left} {right});
@@ -1,139 +0,0 @@--- This file is a temporary copy of the code from fused-effects, with--- https://github.com/fused-effects/fused-effects/issues/449 fixed--- (the fixed line of code is marked with a comment below). We should--- keep this only until the above issue is fixed upstream.-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- | A carrier for 'Accum' effects.--- This carrier performs its append operations strictly and thus avoids the space leaks inherent in lazy writer monads.--- These appends are left-associative; as such, @[]@ is a poor choice of monoid for computations that entail many calls to 'tell'.--- The [Seq](http://hackage.haskell.org/package/containersdocs/Data-Sequence.html) or [DList](http://hackage.haskell.org/package/dlist) monoids may be a superior choice.------ @since 1.1.2.0-module Control.Carrier.Accum.FixedStrict (- -- * Accum carrier- runAccum,- execAccum,- evalAccum,- AccumC (AccumC),-- -- * Accum effect- module Control.Effect.Accum,-) where--import Control.Algebra-import Control.Applicative (Alternative (..))-import Control.Effect.Accum-import Control.Monad (MonadPlus (..))-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class---- | Run an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result.------ @--- 'runAccum' w0 ('pure' a) = 'pure' (w0, a)--- @--- @--- 'runAccum' w0 ('add' w) = 'pure' (w0 <> w, ())--- @--- @--- 'runAccum' w0 ('add' w >> 'look') = 'pure' (w0 <> w, w0 <> w)--- @------ @since 1.1.2.0-runAccum :: w -> AccumC w m a -> m (w, a)-runAccum = flip runAccumC-{-# INLINE runAccum #-}---- | Run a 'Accum' effect (typically with a 'Monoid'al log),--- producing the final log and discarding the result value.------ @--- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w--- @------ @since 1.1.2.0-execAccum :: (Functor m) => w -> AccumC w m a -> m w-execAccum w = fmap fst . runAccum w-{-# INLINE execAccum #-}---- | Run a 'Accum' effect (typically with a 'Monoid'al log),--- producing the result value and discarding the final log.------ @--- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w--- @------ @since 1.1.2.0-evalAccum :: (Functor m) => w -> AccumC w m a -> m a-evalAccum w = fmap snd . runAccum w-{-# INLINE evalAccum #-}---- | @since 1.1.2.0-newtype AccumC w m a = AccumC {runAccumC :: w -> m (w, a)}--instance Monoid w => MonadTrans (AccumC w) where- lift ma = AccumC $ \_ -> (mempty,) <$> ma- {-# INLINE lift #-}--instance Functor m => Functor (AccumC w m) where- fmap f ma = AccumC $ fmap (fmap f) . runAccumC ma- {-# INLINE fmap #-}--instance (Monad m, Monoid w) => Applicative (AccumC w m) where- pure a = AccumC $ const $ pure (mempty, a)- {-# INLINE pure #-}-- mf <*> ma = AccumC $ \w -> do- (w', f) <- runAccumC mf w- (w'', a) <- runAccumC ma $ mappend w w'- return (mappend w' w'', f a)- {-# INLINE (<*>) #-}--instance (Alternative m, Monad m, Monoid w) => Alternative (AccumC w m) where- empty = lift empty- {-# INLINE empty #-}-- ma1 <|> ma2 = AccumC $ \w -> runAccumC ma1 w <|> runAccumC ma2 w- {-# INLINE (<|>) #-}--instance (Monad m, Monoid w) => Monad (AccumC w m) where- ma >>= f = AccumC $ \w -> do- (w', a) <- runAccumC ma w- (w'', b) <- runAccumC (f a) $ mappend w w'- return (mappend w' w'', b)- {-# INLINE (>>=) #-}--instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where- mzero = lift mzero- {-# INLINE mzero #-}-- ma1 `mplus` ma2 = AccumC $ \w -> runAccumC ma1 w `mplus` runAccumC ma2 w- {-# INLINE mplus #-}--instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where- fail = AccumC . const . Fail.fail- {-# INLINE fail #-}--instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where- mfix ma = AccumC $ \w -> mfix $ flip runAccumC w . ma . snd- {-# INLINE mfix #-}--instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where- liftIO = lift . liftIO- {-# INLINE liftIO #-}--instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where- alg hdl sig ctx = AccumC $ \w -> case sig of- L accum -> case accum of- Add w' -> pure (w', ctx)- Look -> pure (mempty, w <$ ctx)- R other -> thread (uncurry runAccum ~<~ hdl) other (mempty, ctx) -- THIS IS THE FIXED LINE- {-# INLINE alg #-}
@@ -1,60 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Simplification logic for boolean expressions that is not--- provided in the 'boolexpr' package.-module Data.BoolExpr.Simplify (- cannotBeTrue,- replace,-) where--import Data.BoolExpr-import Data.List qualified as L-import Data.Map (Map)-import Data.Map qualified as M-import Data.Set qualified as S---- | Used only by "hasContradiction".--- Note that the Booleans returned in this tuple are not actually used--- as conditions, and therefore their semantic convention (e.g. associating--- True = Positive and False = Negative) is irrelevant.--- Rather, they are collected into sets--- to determine whether both True and False exist for a key.-extractConstFromSigned :: Signed a -> (a, Bool)-extractConstFromSigned v = case v of- Negative x -> (x, False)- Positive x -> (x, True)--hasContradiction :: Ord a => Conj (Signed a) -> Bool-hasContradiction (Conj items) =- not- . M.null- . M.filter ((> 1) . S.size)- . M.fromListWith (<>)- $ fmap (fmap S.singleton . extractConstFromSigned) items--simplifyDNF :: Ord a => DNF a -> DNF a-simplifyDNF (DNF (Disj disjunctions)) =- DNF $ Disj $ L.filter (not . hasContradiction) disjunctions--isAlwaysFalse :: Ord a => DNF a -> Bool-isAlwaysFalse (DNF (Disj disjunctions)) = L.null disjunctions--cannotBeTrue :: Ord a => BoolExpr a -> Bool-cannotBeTrue = isAlwaysFalse . simplifyDNF . boolTreeToDNF--replace :: Ord a => Map a Bool -> BoolExpr a -> BoolExpr a-replace f (BAnd a b) = BAnd (replace f a) (replace f b)-replace f (BOr a b) = BOr (replace f a) (replace f b)-replace f (BNot t) = BNot (replace f t)-replace _ BTrue = BTrue-replace _ BFalse = BFalse-replace m c@(BConst x) = case M.lookup varname m of- Nothing -> c- Just val ->- if txform val- then BTrue- else BFalse- where- (varname, isPositive) = extractConstFromSigned x- txform = if isPositive then id else not
@@ -1,140 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Main entry point for the Swarm application.-module Swarm.App where--import Brick-import Brick.BChan-import Control.Carrier.Lift (runM)-import Control.Carrier.Throw.Either (runThrow)-import Control.Concurrent (forkIO, threadDelay)-import Control.Lens (view, (%~), (&), (?~))-import Control.Monad (forever, void, when)-import Control.Monad.IO.Class (liftIO)-import Data.IORef (newIORef, writeIORef)-import Data.Text qualified as T-import Data.Text.IO qualified as T-import Graphics.Vty qualified as V-import Swarm.Game.Failure (SystemFailure)-import Swarm.Language.Pretty (prettyText)-import Swarm.Log (LogSource (SystemLog), Severity (..))-import Swarm.ReadableIORef (mkReadonly)-import Swarm.TUI.Controller-import Swarm.TUI.Model-import Swarm.TUI.Model.StateUpdate-import Swarm.TUI.Model.UI (uiAttrMap)-import Swarm.TUI.View-import Swarm.Version (getNewerReleaseVersion)-import Swarm.Web-import System.IO (stderr)--type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState ()---- | The configuration of the Swarm app which we pass to the @brick@--- library.-app :: EventHandler -> App AppState AppEvent Name-app eventHandler =- App- { appDraw = drawUI- , appChooseCursor = chooseCursor- , appHandleEvent = eventHandler- , appStartEvent = enablePasteMode- , appAttrMap = view $ uiState . uiAttrMap- }---- | The main @IO@ computation which initializes the state, sets up--- some communication channels, and runs the UI.-appMain :: AppOpts -> IO ()-appMain opts = do- res <- runM . runThrow $ initAppState opts- case res of- Left err -> T.hPutStrLn stderr (prettyText @SystemFailure err)- Right s -> do- -- Send Frame events as at a reasonable rate for 30 fps. The- -- game is responsible for figuring out how many steps to take- -- each frame to achieve the desired speed, regardless of the- -- frame rate. Note that if the game cannot keep up with 30- -- fps, it's not a problem: the channel will fill up and this- -- thread will block. So the force of the threadDelay is just- -- to set a *maximum* possible frame rate.- --- -- 5 is the size of the bounded channel; when it gets that big,- -- any writes to it will block. Probably 1 would work fine,- -- though it seems like it could be good to have a bit of buffer- -- just so the app never has to wait for the thread to wake up- -- and do another write.-- chan <- newBChan 5- _ <- forkIO $- forever $ do- threadDelay 33_333 -- cap maximum framerate at 30 FPS- writeBChan chan Frame-- _ <- forkIO $ do- upRel <- getNewerReleaseVersion (repoGitInfo opts)- writeBChan chan (UpstreamVersion upRel)-- -- Start the web service with a reference to the game state.- -- NOTE: This reference should be considered read-only by- -- the web service; the game alone shall host the canonical state.- appStateRef <- newIORef s- eport <-- Swarm.Web.startWebThread- (userWebPort opts)- (mkReadonly appStateRef)- chan-- let logP p = logEvent SystemLog Info "Web API" ("started on :" <> T.pack (show p))- let logE e = logEvent SystemLog Error "Web API" (T.pack e)- let s' =- s- & runtimeState- %~ case eport of- Right p -> (webPort ?~ p) . (eventLog %~ logP p)- Left e -> eventLog %~ logE e-- -- Update the reference for every event- let eventHandler e = do- curSt <- get- liftIO $ writeIORef appStateRef curSt- handleEvent e-- -- Setup virtual terminal- let buildVty = V.mkVty $ V.defaultConfig {V.colorMode = colorMode opts}- initialVty <- buildVty- V.setMode (V.outputIface initialVty) V.Mouse True-- -- Run the app.- void $ customMain initialVty buildVty (Just chan) (app eventHandler) s'---- | A demo program to run the web service directly, without the terminal application.--- This is useful to live update the code using @ghcid -W --test "Swarm.App.demoWeb"@.-demoWeb :: IO ()-demoWeb = do- let demoPort = 8080- res <-- runM . runThrow $ initAppState (defaultAppOpts {userScenario = demoScenario})- case res of- Left err -> T.putStrLn (prettyText @SystemFailure err)- Right s -> do- appStateRef <- newIORef s- chan <- newBChan 5- webMain- Nothing- demoPort- (mkReadonly appStateRef)- chan- where- demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml"---- | If available for the terminal emulator, enable bracketed paste mode.-enablePasteMode :: EventM n s ()-enablePasteMode = do- vty <- getVtyHandle- let output = V.outputIface vty- when (V.supportsMode output V.BracketedPaste) $- liftIO $- V.setMode output V.BracketedPaste True
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Constants used throughout the UI and game.-module Swarm.Constant where--import Data.Text (Text)---- * Website constants---- $convention--- By convention, all URL constants include trailing slashes--- when applicable.---- | The URL for the Swarm repository.-swarmRepoUrl :: Text-swarmRepoUrl = "https://github.com/swarm-game/swarm/"---- | The URL for the Swarm wiki.-wikiUrl :: Text-wikiUrl = swarmRepoUrl <> "wiki/"---- | The URL for the Swarm commands cheat sheet.-wikiCheatSheet :: Text-wikiCheatSheet = wikiUrl <> "Commands-Cheat-Sheet"
@@ -1,597 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Auto-generation of various forms of documentation.-module Swarm.Doc.Gen (- -- ** Main document generation function + types- generateDocs,- GenerateDocs (..),- EditorType (..),- SheetType (..),- loadStandaloneScenario,-- -- ** Formatted keyword lists- keywordsCommands,- keywordsDirections,- operatorNames,- builtinFunctionList,-- -- ** Wiki pages- PageAddress (..),-) where--import Control.Effect.Lift-import Control.Effect.Throw (Throw, throwError)-import Control.Lens (view, (^.))-import Control.Lens.Combinators (to)-import Control.Monad (zipWithM, zipWithM_)-import Data.Containers.ListUtils (nubOrd)-import Data.Foldable (find, toList)-import Data.List (transpose)-import Data.Map.Lazy (Map, (!))-import Data.Map.Lazy qualified as Map-import Data.Maybe (fromMaybe, isJust, listToMaybe)-import Data.Set (Set)-import Data.Set qualified as Set-import Data.Text (Text, unpack)-import Data.Text qualified as T-import Data.Text.IO qualified as T-import Data.Tuple (swap)-import Swarm.Doc.Pedagogy-import Swarm.Doc.Schema.Render-import Swarm.Doc.Util-import Swarm.Game.Display (displayChar)-import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)-import Swarm.Game.Entity qualified as E-import Swarm.Game.Failure (SystemFailure (CustomFailure))-import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight)-import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory)-import Swarm.Game.Scenario (Scenario, loadStandaloneScenario, scenarioRobots)-import Swarm.Game.World.Gen (extractEntities)-import Swarm.Game.World.Typecheck (Some (..), TTerm)-import Swarm.Language.Capability (Capability)-import Swarm.Language.Capability qualified as Capability-import Swarm.Language.Key (specialKeyNames)-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Syntax (Const (..))-import Swarm.Language.Syntax qualified as Syntax-import Swarm.Language.Text.Markdown as Markdown (docToMark)-import Swarm.Language.Typecheck (inferConst)-import Swarm.Util (both, listEnums, quote)-import Swarm.Util.Effect (simpleErrorHandle)-import Swarm.Web (swarmApiMarkdown)-import Text.Dot (Dot, NodeId, (.->.))-import Text.Dot qualified as Dot---- ============================================================================--- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR--- ============================================================================------ These are the exported functions used by the executable.------ -------------------------------------------------------------------------------- | An enumeration of the kinds of documentation we can generate.-data GenerateDocs where- -- | Entity dependencies by recipes.- RecipeGraph :: GenerateDocs- -- | Keyword lists for editors.- EditorKeywords :: Maybe EditorType -> GenerateDocs- -- | List of special key names recognized by 'Swarm.Language.Syntax.Key' command- SpecialKeyNames :: GenerateDocs- -- | Cheat sheets for inclusion on the Swarm wiki.- CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs- -- | List command introductions by tutorial- TutorialCoverage :: GenerateDocs- -- | Web API endpoints- WebAPIEndpoints :: GenerateDocs- deriving (Eq, Show)---- | An enumeration of the editors supported by Swarm (currently,--- Emacs and VS Code).-data EditorType = Emacs | VSCode | Vim- deriving (Eq, Show, Enum, Bounded)---- | An enumeration of the kinds of cheat sheets we can produce.-data SheetType = Entities | Commands | Capabilities | Recipes | Scenario- deriving (Eq, Show, Enum, Bounded)---- | A configuration record holding the URLs of the various cheat--- sheets, to facilitate cross-linking.-data PageAddress = PageAddress- { entityAddress :: Text- , commandsAddress :: Text- , capabilityAddress :: Text- , recipesAddress :: Text- }- deriving (Eq, Show)---- | Generate the requested kind of documentation to stdout.-generateDocs :: GenerateDocs -> IO ()-generateDocs = \case- RecipeGraph -> generateRecipe >>= putStrLn- EditorKeywords e ->- case e of- Just et -> generateEditorKeywords et- Nothing -> do- putStrLn "All editor completions:"- let editorGen et = do- putStrLn $ replicate 40 '-'- putStrLn $ "-- " <> show et- putStrLn $ replicate 40 '-'- generateEditorKeywords et- mapM_ editorGen listEnums- SpecialKeyNames -> generateSpecialKeyNames- CheatSheet address s -> case s of- Nothing -> error "Not implemented for all Wikis"- Just st -> case st of- Commands -> T.putStrLn commandsPage- Capabilities -> simpleErrorHandle $ do- entities <- loadEntities- sendIO $ T.putStrLn $ capabilityPage address entities- Entities -> simpleErrorHandle $ do- entities <- loadEntities- sendIO $ T.putStrLn $ entitiesPage address (Map.elems $ entitiesByName entities)- Recipes -> simpleErrorHandle $ do- entities <- loadEntities- recipes <- loadRecipes entities- sendIO $ T.putStrLn $ recipePage address recipes- Scenario -> genScenarioSchemaDocs- TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack- WebAPIEndpoints -> putStrLn swarmApiMarkdown---- ------------------------------------------------------------------------------- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED--- -------------------------------------------------------------------------------- | Generate a list of keywords in the format expected by one of the--- supported editors.-generateEditorKeywords :: EditorType -> IO ()-generateEditorKeywords = \case- Emacs -> do- putStrLn "(x-builtins '("- T.putStr $ builtinFunctionList Emacs- putStrLn "))\n(x-commands '("- T.putStr $ keywordsCommands Emacs- T.putStr $ keywordsDirections Emacs- putStrLn "))"- VSCode -> do- putStrLn "Functions and commands:"- T.putStrLn $ builtinFunctionList VSCode <> "|" <> keywordsCommands VSCode- putStrLn "\nDirections:"- T.putStrLn $ keywordsDirections VSCode- putStrLn "\nOperators:"- T.putStrLn operatorNames- Vim -> do- putStr "syn keyword Builtins "- T.putStr $ builtinFunctionList Vim- putStr "\nsyn keyword Command "- T.putStr $ keywordsCommands Vim- putStr "\nsyn keyword Direction "- T.putStrLn $ keywordsDirections Vim--commands :: [Const]-commands = filter Syntax.isCmd Syntax.allConst--operators :: [Const]-operators = filter Syntax.isOperator Syntax.allConst--builtinFunctions :: [Const]-builtinFunctions = filter Syntax.isBuiltinFunction Syntax.allConst--builtinFunctionList :: EditorType -> Text-builtinFunctionList e = editorList e $ map constSyntax builtinFunctions--editorList :: EditorType -> [Text] -> Text-editorList = \case- Emacs -> T.unlines . map ((" " <>) . quote)- VSCode -> T.intercalate "|"- Vim -> T.intercalate " "--constSyntax :: Const -> Text-constSyntax = Syntax.syntax . Syntax.constInfo---- | Get formatted list of basic functions/commands.-keywordsCommands :: EditorType -> Text-keywordsCommands e = editorList e $ map constSyntax commands---- | Get formatted list of directions.-keywordsDirections :: EditorType -> Text-keywordsDirections e = editorList e $ map Syntax.directionSyntax Syntax.allDirs---- | A list of the names of all the operators in the language.-operatorNames :: Text-operatorNames = T.intercalate "|" $ map (escape . constSyntax) operators- where- special :: String- special = "*+$[]|^"- slashNotComment = \case- '/' -> "/(?![/|*])"- c -> T.singleton c- escape = T.concatMap (\c -> if c `elem` special then T.snoc "\\\\" c else slashNotComment c)---- ------------------------------------------------------------------------------- GENERATE SPECIAL KEY NAMES--- ------------------------------------------------------------------------------generateSpecialKeyNames :: IO ()-generateSpecialKeyNames =- T.putStr . T.unlines . Set.toList $ specialKeyNames---- ------------------------------------------------------------------------------- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE--- ------------------------------------------------------------------------------escapeTable :: Text -> Text-escapeTable = T.concatMap (\c -> if c == '|' then T.snoc "\\" c else T.singleton c)--separatingLine :: [Int] -> Text-separatingLine ws = T.cons '|' . T.concat $ map (flip T.snoc '|' . flip T.replicate "-" . (2 +)) ws--listToRow :: [Int] -> [Text] -> Text-listToRow mw xs = wrap '|' . T.intercalate "|" $ zipWith format mw xs- where- format w x = wrap ' ' x <> T.replicate (w - T.length x) " "--maxWidths :: [[Text]] -> [Int]-maxWidths = map (maximum . map T.length) . transpose---- ------------ COMMANDS--- -----------commandHeader :: [Text]-commandHeader = ["Syntax", "Type", "Capability", "Description"]--commandToList :: Const -> [Text]-commandToList c =- map- escapeTable- [ addLink ("#" <> tshow c) . codeQuote $ constSyntax c- , codeQuote . prettyText $ inferConst c- , maybe "" Capability.capabilityName $ Capability.constCaps c- , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c- ]--constTable :: [Const] -> Text-constTable cs = T.unlines $ header <> map (listToRow mw) commandRows- where- mw = maxWidths (commandHeader : commandRows)- commandRows = map commandToList cs- header = [listToRow mw commandHeader, separatingLine mw]--commandToSection :: Const -> Text-commandToSection c =- T.unlines $- [ "## " <> T.pack (show c)- , ""- , "- syntax: " <> codeQuote (constSyntax c)- , "- type: " <> (codeQuote . prettyText $ inferConst c)- , maybe "" (("- required capabilities: " <>) . Capability.capabilityName) $ Capability.constCaps c- , ""- , Syntax.briefDoc . Syntax.constDoc $ Syntax.constInfo c- ]- <> let l = Syntax.longDoc . Syntax.constDoc $ Syntax.constInfo c- in if T.null l then [] else ["", l]--commandsPage :: Text-commandsPage =- T.intercalate "\n\n" $- [ "# Commands"- , constTable commands- , "# Builtin functions"- , "These functions are evaluated immediately once they have enough arguments."- , constTable builtinFunctions- , "# Operators"- , constTable operators- , "# Detailed descriptions"- ]- <> map commandToSection (commands <> builtinFunctions <> operators)---- ---------------- CAPABILITIES--- ---------------capabilityHeader :: [Text]-capabilityHeader = ["Name", "Commands", "Entities"]--capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text]-capabilityRow PageAddress {..} em cap =- map- escapeTable- [ Capability.capabilityName cap- , T.intercalate ", " (linkCommand <$> cs)- , T.intercalate ", " (linkEntity . view entityName <$> es)- ]- where- linkEntity t =- if T.null entityAddress- then t- else addLink (entityAddress <> "#" <> T.replace " " "-" t) t- linkCommand c =- ( if T.null commandsAddress- then id- else addLink (commandsAddress <> "#" <> tshow c)- )- . codeQuote- $ constSyntax c-- cs = [c | c <- Syntax.allConst, let mcap = Capability.constCaps c, isJust $ find (== cap) mcap]- es = fromMaybe [] $ E.entitiesByCap em Map.!? cap--capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text-capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRows- where- mw = maxWidths (capabilityHeader : capabilityRows)- capabilityRows = map (capabilityRow a em) cs- header = [listToRow mw capabilityHeader, separatingLine mw]--capabilityPage :: PageAddress -> EntityMap -> Text-capabilityPage a em = capabilityTable a em listEnums---- ------------ Entities--- -----------entityHeader :: [Text]-entityHeader = ["?", "Name", "Capabilities", "Properties*", "Portable"]--entityToList :: Entity -> [Text]-entityToList e =- map- escapeTable- [ codeQuote . T.singleton $ e ^. entityDisplay . to displayChar- , addLink ("#" <> linkID) $ view entityName e- , T.intercalate ", " $ Capability.capabilityName <$> Set.toList (view E.entityCapabilities e)- , T.intercalate ", " . map tshow . filter (/= E.Portable) $ toList props- , if E.Portable `elem` props- then ":heavy_check_mark:"- else ":negative_squared_cross_mark:"- ]- where- props = view E.entityProperties e- linkID = T.replace " " "-" $ view entityName e--entityTable :: [Entity] -> Text-entityTable es = T.unlines $ header <> map (listToRow mw) entityRows- where- mw = maxWidths (entityHeader : entityRows)- entityRows = map entityToList es- header = [listToRow mw entityHeader, separatingLine mw]--entityToSection :: Entity -> Text-entityToSection e =- T.unlines $- [ "## " <> view E.entityName e- , ""- , " - Char: " <> (codeQuote . T.singleton $ e ^. entityDisplay . to displayChar)- ]- <> [" - Properties: " <> T.intercalate ", " (map tshow $ toList props) | not $ null props]- <> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps]- <> ["\n"]- <> [Markdown.docToMark $ view E.entityDescription e]- where- props = view E.entityProperties e- caps = Set.toList $ view E.entityCapabilities e--entitiesPage :: PageAddress -> [Entity] -> Text-entitiesPage _a es =- T.intercalate "\n\n" $- [ "# Entities"- , "This is a quick-overview table of entities - click the name for detailed description."- , "*) As a note, most entities have the Portable property, so we show it in a separate column."- , entityTable es- ]- <> map entityToSection es---- ---------------- RECIPES--- ---------------recipeHeader :: [Text]-recipeHeader = ["In", "Out", "Required", "Time", "Weight"]--recipeRow :: PageAddress -> Recipe Entity -> [Text]-recipeRow PageAddress {..} r =- map- escapeTable- [ T.intercalate ", " (map formatCE $ view recipeInputs r)- , T.intercalate ", " (map formatCE $ view recipeOutputs r)- , T.intercalate ", " (map formatCE $ view recipeCatalysts r)- , tshow $ view recipeTime r- , tshow $ view recipeWeight r- ]- where- formatCE (c, e) = T.unwords [tshow c, linkEntity $ view entityName e]- linkEntity t =- if T.null entityAddress- then t- else addLink (entityAddress <> "#" <> T.replace " " "-" t) t--recipeTable :: PageAddress -> [Recipe Entity] -> Text-recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows- where- mw = maxWidths (recipeHeader : recipeRows)- recipeRows = map (recipeRow a) rs- header = [listToRow mw recipeHeader, separatingLine mw]--recipePage :: PageAddress -> [Recipe Entity] -> Text-recipePage = recipeTable--getBaseRobot :: Has (Throw SystemFailure) sig m => Scenario -> m Robot-getBaseRobot s = case listToMaybe $ view scenarioRobots s of- Just r -> pure $ instantiateRobot 0 r- Nothing -> throwError $ CustomFailure "Scenario contains no robots"---- ------------------------------------------------------------------------------- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES--- ------------------------------------------------------------------------------generateRecipe :: IO String-generateRecipe = simpleErrorHandle $ do- (classic, (worlds, entities, recipes)) <- loadStandaloneScenario "data/scenarios/classic.yaml"- baseRobot <- getBaseRobot classic- return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes--recipesToDot :: Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()-recipesToDot baseRobot classicTerm emap recipes = do- Dot.attribute ("rankdir", "LR")- Dot.attribute ("ranksep", "2")- world <- diamond "World"- base <- diamond "Base"- -- --------------------------------------------------------------------------- -- add nodes with for all the known entities- let enames' = toList . Map.keysSet . entitiesByName $ emap- enames = filter (`Set.notMember` ignoredEntities) enames'- ebmap <- Map.fromList . zip enames <$> mapM (box . unpack) enames- -- --------------------------------------------------------------------------- -- getters for the NodeId based on entity name or the whole entity- let safeGetEntity m e = fromMaybe (error $ unpack e <> " is not an entity!?") $ m Map.!? e- getE = safeGetEntity ebmap- nid = getE . view entityName- -- --------------------------------------------------------------------------- -- Get the starting inventories, entities present in the world and compute- -- how hard each entity is to get - see 'recipeLevels'.- let devs = startingDevices baseRobot- inv = startingInventory baseRobot- worldEntities = case classicTerm of Some _ t -> extractEntities t- levels = recipeLevels recipes (Set.unions [worldEntities, devs])- -- --------------------------------------------------------------------------- -- Base inventory- (_bc, ()) <- Dot.cluster $ do- Dot.attribute ("style", "filled")- Dot.attribute ("color", "lightgrey")- mapM_ ((base ---<>) . nid) devs- mapM_ ((base .->.) . nid . fst) $ Map.toList inv- -- --------------------------------------------------------------------------- -- World entities- (_wc, ()) <- Dot.cluster $ do- Dot.attribute ("style", "filled")- Dot.attribute ("color", "forestgreen")- mapM_ (uncurry (Dot..->.) . (world,) . getE . view entityName) (toList worldEntities)- -- --------------------------------------------------------------------------- let -- put a hidden node above and below entities and connect them by hidden edges- wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)- wrapBelowAbove ns = do- b <- hiddenNode- t <- hiddenNode- let ns' = map nid $ toList ns- mapM_ (b .~>.) ns'- mapM_ (.~>. t) ns'- return (b, t)- -- put set of entities in nice- subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)- subLevel i ns = fmap snd . Dot.cluster $ do- Dot.attribute ("style", "filled")- Dot.attribute ("color", "khaki")- bt <- wrapBelowAbove ns- Dot.attribute ("rank", "sink")- -- the normal label for cluster would be cover by lines- _bigLabel <-- Dot.node- [ ("shape", "plain")- , ("label", "Bottom Label")- , ("fontsize", "20pt")- , ("label", "Level #" <> show i)- ]- return bt- -- --------------------------------------------------------------------------- -- order entities into clusters based on how "far" they are from- -- what is available at the start - see 'recipeLevels'.- bottom <- wrapBelowAbove worldEntities- ls <- zipWithM subLevel [1 ..] (drop 1 levels)- let invisibleLine = zipWithM_ (.~>.)- tls <- mapM (const hiddenNode) levels- bls <- mapM (const hiddenNode) levels- invisibleLine tls bls- invisibleLine bls (drop 1 tls)- let sameBelowAbove (b1, t1) (b2, t2) = Dot.same [b1, b2] >> Dot.same [t1, t2]- zipWithM_ sameBelowAbove (bottom : ls) (zip bls tls)- -- --------------------------------------------------------------------------- -- add node for the world and draw a line to each entity found in the wild- -- finally draw recipes- let recipeInOut r = [(snd i, snd o) | i <- r ^. recipeInputs, o <- r ^. recipeOutputs]- recipeReqOut r = [(snd q, snd o) | q <- r ^. recipeCatalysts, o <- r ^. recipeOutputs]- recipesToPairs f rs = both nid <$> nubOrd (concatMap f rs)- mapM_ (uncurry (.->.)) (recipesToPairs recipeInOut recipes)- mapM_ (uncurry (---<>)) (recipesToPairs recipeReqOut recipes)---- ------------------------------------------------------------------------------- RECIPE LEVELS--- -------------------------------------------------------------------------------- | Order entities in sets depending on how soon it is possible to obtain them.------ So:--- * Level 0 - starting entities (for example those obtainable in the world)--- * Level N+1 - everything possible to make (or drill) from Level N------ This is almost a BFS, but the requirement is that the set of entities--- required for recipe is subset of the entities known in Level N.------ If we ever depend on some graph library, this could be rewritten--- as some BFS-like algorithm with added recipe nodes, but you would--- need to enforce the condition that recipes need ALL incoming edges.-recipeLevels :: [Recipe Entity] -> Set Entity -> [Set Entity]-recipeLevels recipes start = levels- where- recipeParts r = ((r ^. recipeInputs) <> (r ^. recipeCatalysts), r ^. recipeOutputs)- m :: [(Set Entity, Set Entity)]- m = map (both (Set.fromList . map snd) . recipeParts) recipes- levels :: [Set Entity]- levels = reverse $ go [start] start- where- isKnown known (i, _o) = null $ i Set.\\ known- nextLevel known = Set.unions . map snd $ filter (isKnown known) m- go ls known =- let n = nextLevel known Set.\\ known- in if null n- then ls- else go (n : ls) (Set.union n known)--startingDevices :: Robot -> Set Entity-startingDevices = Set.fromList . map snd . E.elems . view equippedDevices--startingInventory :: Robot -> Map Entity Int-startingInventory = Map.fromList . map swap . E.elems . view robotInventory---- | Ignore utility entities that are just used for tutorials and challenges.-ignoredEntities :: Set Text-ignoredEntities =- Set.fromList- [ "upper left corner"- , "upper right corner"- , "lower left corner"- , "lower right corner"- , "horizontal wall"- , "vertical wall"- ]---- ------------------------------------------------------------------------------- GRAPHVIZ HELPERS--- ------------------------------------------------------------------------------customNode :: [(String, String)] -> String -> Dot NodeId-customNode attrs label = Dot.node $ [("style", "filled"), ("label", label)] <> attrs--box, diamond :: String -> Dot NodeId-box = customNode [("shape", "box")]-diamond = customNode [("shape", "diamond")]---- | Hidden node - used for layout.-hiddenNode :: Dot NodeId-hiddenNode = Dot.node [("style", "invis")]---- | Hidden edge - used for layout.-(.~>.) :: NodeId -> NodeId -> Dot ()-i .~>. j = Dot.edge i j [("style", "invis")]---- | Edge for recipe requirements and outputs.-(---<>) :: NodeId -> NodeId -> Dot ()-e1 ---<> e2 = Dot.edge e1 e2 attrs- where- attrs = [("arrowhead", "diamond"), ("color", "blue")]
@@ -1,248 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Assess pedagogical soundness of the tutorials.------ Approach:------ 1. Obtain a list of all of the tutorial scenarios, in order--- 2. Search their \"solution\" code for `commands`--- 3. "fold" over the tutorial list, noting which tutorial was first to introduce each command-module Swarm.Doc.Pedagogy (- renderTutorialProgression,- generateIntroductionsSequence,- CoverageInfo (..),- TutorialInfo (..),-) where--import Control.Lens (universe, view, (^.))-import Control.Monad (guard)-import Data.List (foldl', intercalate, sort, sortOn)-import Data.List.Extra (zipFrom)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (mapMaybe)-import Data.Sequence (Seq)-import Data.Set (Set)-import Data.Set qualified as S-import Data.Text (Text)-import Data.Text qualified as T-import Swarm.Constant-import Swarm.Game.Entity (loadEntities)-import Swarm.Game.Failure (SystemFailure)-import Swarm.Game.Scenario (Scenario, scenarioDescription, scenarioName, scenarioObjectives, scenarioSolution)-import Swarm.Game.Scenario.Objective (objectiveGoal)-import Swarm.Game.ScenarioInfo (ScenarioCollection, ScenarioInfoPair, flatten, loadScenarios, scenarioCollectionToList, scenarioPath)-import Swarm.Game.World.Load (loadWorlds)-import Swarm.Language.Module (Module (..))-import Swarm.Language.Pipeline (ProcessedTerm (..))-import Swarm.Language.Syntax-import Swarm.Language.Text.Markdown (docToText, findCode)-import Swarm.Language.Types (Polytype)-import Swarm.TUI.Controller (getTutorials)-import Swarm.Util.Effect (ignoreWarnings, simpleErrorHandle)---- * Constants--commandsWikiAnchorPrefix :: Text-commandsWikiAnchorPrefix = wikiCheatSheet <> "#"---- * Types---- | Tutorials augmented by the set of--- commands that they introduce.--- Generated by folding over all of the--- tutorials in sequence.-data CoverageInfo = CoverageInfo- { tutInfo :: TutorialInfo- , novelSolutionCommands :: Map Const [SrcLoc]- }---- | Tutorial scenarios with the set of commands--- introduced in their solution and descriptions--- having been extracted-data TutorialInfo = TutorialInfo- { scenarioPair :: ScenarioInfoPair- , tutIndex :: Int- , solutionCommands :: Map Const [SrcLoc]- , descriptionCommands :: Set Const- }---- | A private type used by the fold-data CommandAccum = CommandAccum- { _encounteredCmds :: Set Const- , tuts :: [CoverageInfo]- }---- * Functions---- | Extract commands from both goal descriptions and solution code.-extractCommandUsages :: Int -> ScenarioInfoPair -> TutorialInfo-extractCommandUsages idx siPair@(s, _si) =- TutorialInfo siPair idx solnCommands $ getDescCommands s- where- solnCommands = getCommands maybeSoln- maybeSoln = view scenarioSolution s---- | Obtain the set of all commands mentioned by--- name in the tutorial's goal descriptions.-getDescCommands :: Scenario -> Set Const-getDescCommands s = S.fromList $ concatMap filterConst allCode- where- goalTextParagraphs = view objectiveGoal <$> view scenarioObjectives s- allCode = concatMap findCode goalTextParagraphs- filterConst :: Syntax -> [Const]- filterConst sx = mapMaybe toConst $ universe (sx ^. sTerm)- toConst :: Term -> Maybe Const- toConst = \case- TConst c -> Just c- _ -> Nothing--isConsidered :: Const -> Bool-isConsidered c = isUserFunc c && c `S.notMember` ignoredCommands- where- ignoredCommands = S.fromList [Run, Return, Noop, Force]---- | Extract the command names from the source code of the solution.------ NOTE: `noop` gets automatically inserted for an empty `build {}` command--- at parse time, so we explicitly ignore the `noop` in the case that--- the player did not write it explicitly in their code.------ Also, the code from `run` is not parsed transitively yet.-getCommands :: Maybe ProcessedTerm -> Map Const [SrcLoc]-getCommands Nothing = mempty-getCommands (Just (ProcessedTerm (Module stx _) _ _)) =- M.fromListWith (<>) $ mapMaybe isCommand nodelist- where- nodelist :: [Syntax' Polytype]- nodelist = universe stx- isCommand (Syntax' sloc t _) = case t of- TConst c -> guard (isConsidered c) >> Just (c, [sloc])- _ -> Nothing---- | "fold" over the tutorials in sequence to determine which--- commands are novel to each tutorial's solution.-computeCommandIntroductions :: [(Int, ScenarioInfoPair)] -> [CoverageInfo]-computeCommandIntroductions =- reverse . tuts . foldl' f initial- where- initial = CommandAccum mempty mempty-- f :: CommandAccum -> (Int, ScenarioInfoPair) -> CommandAccum- f (CommandAccum encounteredPreviously xs) (idx, siPair) =- CommandAccum updatedEncountered $ CoverageInfo usages novelCommands : xs- where- usages = extractCommandUsages idx siPair- usedCmdsForTutorial = solutionCommands usages-- updatedEncountered = encounteredPreviously `S.union` M.keysSet usedCmdsForTutorial- novelCommands = M.withoutKeys usedCmdsForTutorial encounteredPreviously---- | Extract the tutorials from the complete scenario collection--- and derive their command coverage info.-generateIntroductionsSequence :: ScenarioCollection -> [CoverageInfo]-generateIntroductionsSequence =- computeCommandIntroductions . zipFrom 0 . getTuts- where- getTuts =- concatMap flatten- . scenarioCollectionToList- . getTutorials---- * Rendering functions---- | Helper for standalone rendering.--- For unit tests, can instead access the scenarios via the GameState.-loadScenarioCollection :: IO ScenarioCollection-loadScenarioCollection = simpleErrorHandle $ do- entities <- loadEntities- -- Note we ignore any warnings generated by 'loadWorlds' and- -- 'loadScenarios' below. Any warnings will be caught when loading- -- all the scenarios via the usual code path; we do not need to do- -- anything with them here while simply rendering pedagogy info.- worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities- ignoreWarnings @(Seq SystemFailure) $ loadScenarios entities worlds--renderUsagesMarkdown :: CoverageInfo -> Text-renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) =- T.unlines bodySections- where- bodySections = firstLine : otherLines- otherLines =- intercalate- [""]- [ pure . surround "`" . T.pack $ view scenarioPath si- , pure . surround "*" . T.strip . docToText $ view scenarioDescription s- , renderSection "Introduced in solution" . renderCmdList $ M.keysSet novelCmds- , renderSection "Referenced in description" $ renderCmdList dCmds- ]- surround x y = x <> y <> x-- renderSection title content =- ["### " <> title] <> content-- firstLine =- T.unwords- [ "##"- , renderTutorialTitle idx s- ]--renderTutorialTitle :: (Show a) => a -> Scenario -> Text-renderTutorialTitle idx s =- T.unwords- [ T.pack $ show idx <> ":"- , view scenarioName s- ]--linkifyCommand :: Text -> Text-linkifyCommand c = "[" <> c <> "](" <> commandsWikiAnchorPrefix <> c <> ")"--renderList :: [Text] -> [Text]-renderList items =- if null items- then pure "(none)"- else map ("* " <>) items--cmdSetToSortedText :: Set Const -> [Text]-cmdSetToSortedText = sort . map (T.pack . show) . S.toList--renderCmdList :: Set Const -> [Text]-renderCmdList = renderList . map linkifyCommand . cmdSetToSortedText---- | Generate a document which lists all the tutorial scenarios,--- highlighting for each one which commands are introduced for the--- first time in the canonical solution, and which commands are--- referenced in the tutorial description.-renderTutorialProgression :: IO Text-renderTutorialProgression =- processAndRender <$> loadScenarioCollection- where- processAndRender ss =- T.unlines allLines- where- introSection =- "# Command introductions by tutorial"- : "This document indicates which tutorials introduce various commands and keywords."- : ""- : "All used:"- : renderFullCmdList allUsed-- render (cmd, tut) =- T.unwords- [ linkifyCommand cmd- , "(" <> renderTutorialTitle (tutIndex tut) (fst $ scenarioPair tut) <> ")"- ]- renderFullCmdList = renderList . map render . sortOn fst- infos = generateIntroductionsSequence ss- allLines = introSection <> map renderUsagesMarkdown infos- allUsed = concatMap mkTuplesForTutorial infos-- mkTuplesForTutorial tut =- map (\x -> (T.pack $ show x, tutIdxScenario)) $- M.keys $- novelSolutionCommands tut- where- tutIdxScenario = tutInfo tut
@@ -1,42 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Graph-based heuristics for arranging the--- order of sections in the schema docs-module Swarm.Doc.Schema.Arrangement (sortAndPruneSchemas) where--import Data.Graph-import Data.Set qualified as Set-import Swarm.Doc.Schema.Parse-import Swarm.Doc.Schema.Refined-import Swarm.Doc.Schema.SchemaType---- | Sort the schemas in topological order.------ Only includes schema files that are reachable from--- the root schema--- (i.e. exclude @entities.json@ and @recipes.json@,--- which are used independently to validate @entities.yaml@--- and @recipes.yaml@).-sortAndPruneSchemas ::- SchemaIdReference ->- [SchemaData] ->- [SchemaData]-sortAndPruneSchemas rootSchemaKey schemas =- reverse . flattenSCCs . stronglyConnComp $ reachableEdges- where- rawEdgeList = map getNodeEdgesEntry schemas- (graph, _nodeFromVertex, vertexFromKey) = graphFromEdges rawEdgeList- reachableVertices = Set.fromList $ maybe [] (reachable graph) $ vertexFromKey rootSchemaKey-- reachableEdges = filter f rawEdgeList- f (_, k, _) = maybe False (`Set.member` reachableVertices) . vertexFromKey $ k--getNodeEdgesEntry ::- SchemaData ->- (SchemaData, SchemaIdReference, [SchemaIdReference])-getNodeEdgesEntry sd@(SchemaData fp schem _) =- ( sd- , fromFilePath fp- , Set.toList $ extractReferences $ content schem- )
@@ -1,52 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ There are no modern, comprehensive JSON Schema parsing--- libraries in Haskell, as explained in--- <this post https://dev.to/sshine/a-review-of-json-schema-libraries-for-haskell-321>.------ Therefore, a bespoke parser for a small subset of JSON Schema is implemented here,--- simply for rendering Markdown documentation from Swarm's schema.-module Swarm.Doc.Schema.Parse where--import Control.Applicative ((<|>))-import Data.Aeson-import Data.Map (Map)-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Swarm.Doc.Schema.Refined-import Text.Pandoc---- | Includes everything needed to--- render the schema to markdown-data SchemaData = SchemaData- { schemaPath :: FilePath- , schemaContent :: ToplevelSchema- , markdownFooters :: [Pandoc]- }--data Members- = ObjectProperties (Map Text SwarmSchema)- | ListMembers (ItemDescription SwarmSchema)- deriving (Eq, Ord, Show)--data ToplevelSchema = ToplevelSchema- { title :: Text- , description :: Maybe Pandoc- , content :: SwarmSchema- , members :: Maybe Members- , footerPaths :: [FilePath]- }- deriving (Eq, Ord, Show)--instance FromJSON ToplevelSchema where- parseJSON x = do- rawSchema :: rawSchema <- parseJSON x- swarmSchema <- toSwarmSchema rawSchema-- theTitle <- maybe (fail "Schema requires a title") return $ _title rawSchema- let theFooters = fromMaybe [] $ _footers rawSchema- maybeMembers =- ObjectProperties <$> properties swarmSchema- <|> ListMembers <$> itemsDescription swarmSchema- return $ ToplevelSchema theTitle (objectDescription swarmSchema) swarmSchema maybeMembers theFooters
@@ -1,145 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Refined JSON schema after converting--- all JSON Value types to their specific sum types-module Swarm.Doc.Schema.Refined where--import Control.Applicative ((<|>))-import Data.Aeson-import Data.List.Extra (replace)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (fromMaybe, mapMaybe)-import Data.Set (Set)-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import GHC.Generics (Generic)-import Swarm.Doc.Schema.SchemaType-import System.FilePath (takeBaseName)-import Text.Pandoc-import Text.Pandoc.Builder---- * Basic--schemaJsonOptions :: Options-schemaJsonOptions =- defaultOptions- { fieldLabelModifier = replace "S" "$" . drop 1 -- drops leading underscore- }---- | A single record that encompasses all possible objects--- in a JSON schema. All fields are optional.-data SchemaRaw = SchemaRaw- { _description :: Maybe Text- , _default :: Maybe Value- , _title :: Maybe Text- , _type :: Maybe (SingleOrList Text)- , _name :: Maybe Text- , _properties :: Maybe (Map Text SwarmSchema)- , _items :: Maybe (ItemDescription SwarmSchema)- , _examples :: Maybe [Value]- , _Sref :: Maybe Text- , _oneOf :: Maybe [SchemaRaw]- , _footers :: Maybe [FilePath]- , _additionalProperties :: Maybe Bool- }- deriving (Eq, Ord, Show, Generic)--instance FromJSON SchemaRaw where- parseJSON = genericParseJSON schemaJsonOptions--extractSchemaType :: SchemaRaw -> Maybe SchemaType-extractSchemaType rawSchema =- mkReference <$> _Sref rawSchema- <|> getTypeFromItems- <|> Simple <$> _type rawSchema- <|> Alternatives . mapMaybe extractSchemaType <$> _oneOf rawSchema- where- mkReference = Reference . SchemaIdReference . T.pack . takeBaseName . T.unpack-- getTypeFromItems :: Maybe SchemaType- getTypeFromItems = do- itemsThing <- _items rawSchema- case itemsThing of- ItemList _ -> Nothing- ItemType x -> Just $ ListOf $ schemaType x---- * Refined--data ItemDescription a- = ItemList [a]- | ItemType a- deriving (Eq, Ord, Show)--instance (FromJSON a) => FromJSON (ItemDescription a) where- parseJSON x =- ItemList <$> parseJSON x- <|> ItemType <$> parseJSON x--getSchemaReferences :: SchemaType -> [SchemaIdReference]-getSchemaReferences = \case- Simple _ -> []- Alternatives xs -> concatMap getSchemaReferences xs- Reference x -> pure x- ListOf x -> getSchemaReferences x---- | A subset of all JSON schemas, conforming to internal Swarm conventions.------ Conveniently, this extra representation layer--- is able to enforce (via 'toSwarmSchema') that all "object"--- definitions in the schema contain the @"additionalProperties": true@ attribute.-data SwarmSchema = SwarmSchema- { schemaType :: SchemaType- , defaultValue :: Maybe Value- , objectDescription :: Maybe Pandoc- , properties :: Maybe (Map Text SwarmSchema)- , itemsDescription :: Maybe (ItemDescription SwarmSchema)- , examples :: [Value]- }- deriving (Eq, Ord, Show)--instance FromJSON SwarmSchema where- parseJSON x = do- rawSchema :: rawSchema <- parseJSON x- toSwarmSchema rawSchema--getMarkdown :: MonadFail m => Text -> m Pandoc-getMarkdown desc = case runPure (readMarkdown def desc) of- Right d -> return d- Left err -> fail $ T.unpack $ renderError err--toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema-toSwarmSchema rawSchema = do- theType <- maybe (fail "Unspecified sub-schema type") return maybeType- markdownDescription <- mapM getMarkdown $ _description rawSchema-- if null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema))- then return ()- else fail "All objects must specify '\"additionalProperties\": true'"-- return- SwarmSchema- { schemaType = theType- , defaultValue = _default rawSchema- , objectDescription = markdownDescription <|> doc . plain . text <$> _name rawSchema- , examples = fromMaybe [] $ _examples rawSchema- , properties = _properties rawSchema- , itemsDescription = _items rawSchema- }- where- maybeType = extractSchemaType rawSchema---- * Utilities---- | Recursively extract references to other schemas-extractReferences :: SwarmSchema -> Set SchemaIdReference-extractReferences s = thisRefList <> otherRefLists- where- thisRefList = Set.fromList . getSchemaReferences $ schemaType s-- otherSchemas = maybe [] M.elems $ properties s- otherRefLists = Set.unions $ map extractReferences otherSchemas
@@ -1,194 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Render a markdown document fragment--- from the Scenario JSON schema files.-module Swarm.Doc.Schema.Render where--import Control.Arrow (left, (&&&))-import Control.Monad.Except (runExceptT)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (except)-import Data.Aeson-import Data.List (intersperse)-import Data.Map (Map)-import Data.Map.Strict qualified as M-import Data.Maybe (fromMaybe)-import Data.Scientific (FPFormat (..), Scientific, formatScientific)-import Data.Text qualified as T-import Data.Text.IO qualified as TIO-import Data.Vector qualified as V-import Swarm.Doc.Schema.Arrangement-import Swarm.Doc.Schema.Parse-import Swarm.Doc.Schema.Refined-import Swarm.Doc.Schema.SchemaType-import Swarm.Doc.Util-import Swarm.Util (applyWhen, brackets, quote, showT)-import System.Directory (listDirectory)-import System.FilePath (splitExtension, (<.>), (</>))-import Text.Pandoc-import Text.Pandoc.Builder-import Text.Pandoc.Walk (query)--scenariosDir :: FilePath-scenariosDir = "data/scenarios"--docFragmentsDir :: FilePath-docFragmentsDir = scenariosDir </> "doc-fragments"--schemasDir :: FilePath-schemasDir = "data/schema"--schemaExtension :: String-schemaExtension = ".json"--propertyColumnHeadings :: [T.Text]-propertyColumnHeadings =- [ "Key"- , "Default?"- , "Type"- , "Description"- ]--listColumnHeadings :: [T.Text]-listColumnHeadings =- [ "Index"- , "Type"- , "Description"- ]--makeTitleMap :: [SchemaData] -> Map SchemaIdReference T.Text-makeTitleMap = M.fromList . map (fromFilePath . schemaPath &&& title . schemaContent)--makePandocTable :: Map SchemaIdReference T.Text -> SchemaData -> Pandoc-makePandocTable titleMap (SchemaData _ (ToplevelSchema theTitle theDescription _schema theMembers _) parsedFooters) =- setTitle (text "JSON Schema for Scenarios") $- doc (header 3 (text theTitle))- <> fromMaybe mempty theDescription- <> maybe mempty mkTable theMembers- <> mconcat parsedFooters- where- renderItems someStuff = case someStuff of- ItemType x -> plain $ text "List of " <> listToText titleMap (schemaType x)- ItemList xs ->- makePropsTable False listColumnHeadings titleMap- . M.fromList- $ zip (map tshow [0 :: Int ..]) xs-- mkTable x = doc $ case x of- ObjectProperties props -> makePropsTable True propertyColumnHeadings titleMap props- ListMembers someStuff -> renderItems someStuff--genPropsRow :: Bool -> Map SchemaIdReference T.Text -> (T.Text, SwarmSchema) -> [Blocks]-genPropsRow includeDefaultColumn titleMap (k, x) =- firstColumn : applyWhen includeDefaultColumn (defaultColumn :) tailColumns- where- firstColumn = plain $ code k- defaultColumn = maybe mempty (plain . code . renderValue) $ defaultValue x- tailColumns =- [ plain . listToText titleMap $ schemaType x- , fromList $ maybe [] (query id) $ objectDescription x- ]--makePropsTable ::- Bool ->- [T.Text] ->- Map SchemaIdReference T.Text ->- Map T.Text SwarmSchema ->- Blocks-makePropsTable includeDefaultColumn headingsList titleMap =- simpleTable headerRow . map (genPropsRow includeDefaultColumn titleMap) . M.toList- where- headerRow = map (plain . text) headingsList--type FileStemAndExtension = (FilePath, String)--recombineExtension :: FileStemAndExtension -> FilePath-recombineExtension (filenameStem, fileExtension) =- filenameStem <.> fileExtension--genMarkdown :: [SchemaData] -> Either T.Text T.Text-genMarkdown schemaThings =- left renderError $- runPure $- writeMarkdown (def {writerExtensions = extensionsFromList [Ext_pipe_tables]}) pd- where- titleMap = makeTitleMap schemaThings- pd =- mconcat $- map (makePandocTable titleMap) $- sortAndPruneSchemas (fromFilePath "scenario") schemaThings--parseSchemaFile :: FileStemAndExtension -> IO (Either T.Text ToplevelSchema)-parseSchemaFile stemAndExtension =- left (prependPath . T.pack) <$> eitherDecodeFileStrict fullPath- where- prependPath = ((T.unwords ["in", quote (T.pack filename)] <> ": ") <>)- filename = recombineExtension stemAndExtension- fullPath = schemasDir </> filename--loadFooterContent :: (FilePath, ToplevelSchema) -> IO SchemaData-loadFooterContent (fp, schem) = do- xs <- mapM (TIO.readFile . (scenariosDir </>)) $ footerPaths schem- parsedFooters <- mapM getMarkdown xs- return $- SchemaData- fp- schem- parsedFooters--genScenarioSchemaDocs :: IO ()-genScenarioSchemaDocs = do- dirContents <- listDirectory schemasDir- let inputFiles = filter ((== schemaExtension) . snd) $ map splitExtension dirContents- xs <- mapM (sequenceA . (recombineExtension &&& parseSchemaFile)) inputFiles-- result <- runExceptT $ do- schemaTuples <- except $ traverse sequenceA xs- things <- liftIO $ mapM loadFooterContent schemaTuples- myMarkdown <- except $ genMarkdown things- docHeader <- liftIO $ TIO.readFile "data/scenarios/doc-fragments/header.md"- liftIO . writeFile (docFragmentsDir </> "SCHEMA.md") . T.unpack $ docHeader <> myMarkdown-- case result of- Left e -> print $ unwords ["Failed:", T.unpack e]- Right _ -> return ()--renderValue :: Value -> T.Text-renderValue = \case- Object obj -> showT obj- Array arr -> brackets . T.intercalate ", " . map renderValue $ V.toList arr- String t -> quote t- Number num -> T.pack $ formatNumberCompact num- Bool b -> showT b- Null -> "null"--fragmentHref :: Map SchemaIdReference T.Text -> SchemaIdReference -> T.Text-fragmentHref titleMap r@(SchemaIdReference ref) =- T.cons '#' . T.toLower . T.replace " " "-" $ x- where- x = M.findWithDefault ref r titleMap--listToText :: Map SchemaIdReference T.Text -> SchemaType -> Inlines-listToText titleMap = \case- Simple xs -> renderAlternatives $ map code $ getList xs- Alternatives xs -> renderAlternatives $ map (listToText titleMap) xs- Reference r@(SchemaIdReference x) -> schemaLink r x- ListOf x -> listToText titleMap x <> text " list"- where- renderAlternatives = mconcat . intersperse (text " or ")- schemaLink r = link (fragmentHref titleMap r) "Link to object properties" . text---- |--- Strips trailing zeros and decimal point from a floating-point number--- when possible.------ Obtained from here: https://stackoverflow.com/a/35980995/105137-formatNumberCompact :: Scientific -> String-formatNumberCompact v- | v == 0 = "0"- | abs v < 1e-5 || abs v > 1e10 = formatScientific Exponent Nothing v- | v - fromIntegral (floor v :: Integer) == 0 = formatScientific Fixed (Just 0) v- | otherwise = formatScientific Generic Nothing v
@@ -1,38 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Representation of the "type" of a schema.-module Swarm.Doc.Schema.SchemaType where--import Control.Applicative ((<|>))-import Data.Aeson-import Data.Text (Text)-import Data.Text qualified as T-import System.FilePath (takeBaseName)--newtype SingleOrList a = SingleOrList- { getList :: [a]- }- deriving (Eq, Ord, Show)--instance (FromJSON a) => FromJSON (SingleOrList a) where- parseJSON x =- fmap SingleOrList $- pure <$> parseJSON x <|> parseJSON x--data SchemaType- = -- | A basic built-in type- Simple (SingleOrList Text)- | -- | Any one of multiple possible schema types- Alternatives [SchemaType]- | -- | A reference to a schema defined elsewhere- Reference SchemaIdReference- | -- | Members of a list, all of the given schema type- ListOf SchemaType- deriving (Eq, Ord, Show)--newtype SchemaIdReference = SchemaIdReference Text- deriving (Eq, Ord, Show)--fromFilePath :: FilePath -> SchemaIdReference-fromFilePath = SchemaIdReference . T.pack . takeBaseName
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Utilities for generating doc markup-module Swarm.Doc.Util where--import Data.Text (Text)-import Data.Text qualified as T--wrap :: Char -> Text -> Text-wrap c = T.cons c . flip T.snoc c--codeQuote :: Text -> Text-codeQuote = wrap '`'--addLink :: Text -> Text -> Text-addLink l t = T.concat ["[", t, "](", l, ")"]--tshow :: (Show a) => a -> Text-tshow = T.pack . show
@@ -1,61 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Metadata about achievements that the player has obtained.-module Swarm.Game.Achievement.Attainment (- Attainment (..),- achievement,- maybeScenarioPath,- obtainedAt,-) where--import Control.Lens hiding (from, (<.>))-import Data.Aeson (- Options (..),- defaultOptions,- genericParseJSON,- genericToJSON,- )-import Data.Function (on)-import Data.Time (ZonedTime, zonedTimeToUTC)-import Data.Yaml as Y-import GHC.Generics (Generic)-import Swarm.Game.Achievement.Definitions---- | A record holding an achievement along with some metadata to--- record the time at which the achievement was obtained, and the--- scenario in which it was achieved.-data Attainment = Attainment- { _achievement :: CategorizedAchievement- -- ^ The achievement.- , _maybeScenarioPath :: Maybe FilePath- -- ^ From which scenario was it obtained?- , _obtainedAt :: ZonedTime- -- ^ What time was it obtained?- }- deriving (Generic)--makeLenses ''Attainment--instance Eq Attainment where- (==) = (==) `on` _achievement--instance Ord Attainment where- compare = compare `on` (zonedTimeToUTC . _obtainedAt)--instance Semigroup Attainment where- (<>) = min--instance FromJSON Attainment where- parseJSON = genericParseJSON achievementJsonOptions--instance ToJSON Attainment where- toJSON = genericToJSON achievementJsonOptions--achievementJsonOptions :: Options-achievementJsonOptions =- defaultOptions- { fieldLabelModifier = drop 1 -- drops leading underscore- }
@@ -1,120 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Definitions of all possible achievements.-module Swarm.Game.Achievement.Definitions (- -- * Achievements- CategorizedAchievement (..),- GlobalAchievement (..),- GameplayAchievement (..),- listAchievements,-- -- * Achievement info- ExpectedEffort (..),- Quotation (..),- FlavorText (..),- AchievementInfo (..),-) where--import Data.Aeson-import Data.Text (Text)-import GHC.Generics (Generic)-import Swarm.Language.Syntax (Syntax)-import Swarm.Language.Text.Markdown (Document)-import Swarm.Util---- | How hard do we expect the achievement to be?-data ExpectedEffort- = Trivial- | Easy- | Moderate- | Gruelling- deriving (Eq, Ord, Show, Bounded, Enum, Generic, FromJSON, ToJSON)---- | A quotation to spice up the description of an achievement.-data Quotation = Quotation- { attribution :: Text- , content :: Text- }- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | Flavor text to spice up the description of an achievement, either--- freeform text or a quotation.-data FlavorText- = Freeform (Document Syntax)- | FTQuotation Quotation- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | Information about an achievement. See--- "Swarm.Game.Achievement.Description" for a mapping from--- achievements to an corresponding 'AchievementInfo' record.-data AchievementInfo = AchievementInfo- { title :: Text- -- ^ Guidelines:- --- -- * prefer puns, pop culture references, etc.- -- * should be a phrase in Title Case.- -- * For achievements that are "obfuscated", this can be- -- a vague "clue" as to what the attainment entails.- , humorousElaboration :: Maybe FlavorText- -- ^ Explain the reference, e.g. in the form of a full quote- -- from a movie, or something you might find- -- in a fortune cookie- , attainmentProcess :: Document Syntax- -- ^ Precisely what must be done to obtain this achievement.- , effort :: ExpectedEffort- -- ^ How hard the achievement is expected to be.- , isObfuscated :: Bool- -- ^ Hides the attainment process until after the achievement is attained.- -- Best when the title + elaboration constitute a good clue.- }- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | An achievement, categorized as either global or gameplay.-data CategorizedAchievement- = GlobalAchievement GlobalAchievement- | GameplayAchievement GameplayAchievement- deriving (Eq, Ord, Show, Generic)--categorizedAchievementJsonOptions :: Options-categorizedAchievementJsonOptions =- defaultOptions- { sumEncoding = UntaggedValue- }--instance ToJSON CategorizedAchievement where- toJSON = genericToJSON categorizedAchievementJsonOptions--instance FromJSON CategorizedAchievement where- parseJSON = genericParseJSON categorizedAchievementJsonOptions---- | Achievements that entail some aggregate of actions across--- scenarios, or are independent of any particular scenario.-data GlobalAchievement- = CompletedSingleTutorial- | CompletedAllTutorials- | LookedAtAboutScreen- deriving (Eq, Ord, Show, Bounded, Enum, Generic)--instance FromJSON GlobalAchievement-instance ToJSON GlobalAchievement---- | Achievements obtained while playing a single scenario.-data GameplayAchievement- = CraftedBitcoin- | RobotIntoWater- | AttemptSelfDestructBase- | DestroyedBase- | LoseScenario- | GetDisoriented- | SwapSame- deriving (Eq, Ord, Show, Bounded, Enum, Generic)--instance FromJSON GameplayAchievement-instance ToJSON GameplayAchievement---- | List of all possible achievements.-listAchievements :: [CategorizedAchievement]-listAchievements =- map GlobalAchievement listEnums- <> map GameplayAchievement listEnums
@@ -1,97 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Flavor text about all defined achievements.-module Swarm.Game.Achievement.Description where--import Swarm.Game.Achievement.Definitions---- | Function mapping each 'CategorizedAchievement' to an appropriate--- 'AchievementInfo' record. This function must be updated whenever--- a new type of achievement is added.-describe :: CategorizedAchievement -> AchievementInfo-describe = \case- GlobalAchievement CompletedSingleTutorial ->- AchievementInfo- "Welcome Freshmen"- (Just $ Freeform "School is in session!")- "Complete one of the tutorials."- Easy- False- GlobalAchievement CompletedAllTutorials ->- AchievementInfo- "Autodidact"- ( Just $- FTQuotation $- Quotation- "Terry Pratchet"- "I didn't go to university... But I have sympathy for those who did."- )- "Complete all of the tutorials."- Moderate- False- GlobalAchievement LookedAtAboutScreen ->- AchievementInfo- "About time!"- Nothing- "View the About screen."- Trivial- True- GameplayAchievement CraftedBitcoin ->- -- Bitcoin is the deepest level of the recipes- -- hierarchy.- AchievementInfo- "Master of Your Craft"- Nothing- "Make a Bitcoin"- Moderate- True- GameplayAchievement RobotIntoWater ->- AchievementInfo- "Watery Grave"- (Just $ Freeform "This little robot thinks he's a submarine.")- "Destroy a robot by sending it into the water."- Easy- True- GameplayAchievement AttemptSelfDestructBase ->- AchievementInfo- "Call of the Void"- (Just $ Freeform "What does that big red button do?")- "Attempt to self-destruct your base."- Easy- True- GameplayAchievement DestroyedBase ->- AchievementInfo- "That Could Have Gone Better"- (Just $ Freeform "Boom.")- "Actually destroy your base."- Moderate- True- GameplayAchievement LoseScenario ->- AchievementInfo- "Silver Lining"- (Just $ Freeform "Here's your consolation prize.")- "Lose at a scenario."- Easy- True- GameplayAchievement GetDisoriented ->- AchievementInfo- "Playing Ostrich"- ( Just $- FTQuotation $- Quotation- "Lil Jon"- "Fire up that loud / Another round of shots / Turn down for what?"- )- "`turn down` without a compass. Congratulations, you are \"disoriented\". How are you supposed to move now?"- Easy- True- GameplayAchievement SwapSame ->- AchievementInfo- "Fair Trade"- (Just $ Freeform "The *Law of Equivalent Exchange*... taken literally.")- "`swap` an item for itself."- Easy- True
@@ -1,64 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Load/save logic for achievements.--- Each achievement is saved to its own file to better--- support forward-compatibility.-module Swarm.Game.Achievement.Persistence where--import Control.Arrow (left)-import Control.Effect.Accum-import Control.Effect.Lift-import Control.Monad (forM_)-import Data.Sequence (Seq)-import Data.Yaml qualified as Y-import Swarm.Game.Achievement.Attainment-import Swarm.Game.Achievement.Definitions-import Swarm.Game.Failure-import Swarm.Game.ResourceLoading (getSwarmXdgDataSubdir)-import Swarm.Util.Effect (forMW)-import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)-import System.FilePath ((</>))---- | Get a path to the directory where achievement records are--- stored. If the argument is set to @True@, create the directory if--- it does not exist.-getSwarmAchievementsPath :: Bool -> IO FilePath-getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement"---- | Load saved info about achievements from XDG data directory.--- Returns a list of attained achievements.-loadAchievementsInfo ::- (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>- m [Attainment]-loadAchievementsInfo = do- savedAchievementsPath <- sendIO $ getSwarmAchievementsPath False- doesParentExist <- sendIO $ doesDirectoryExist savedAchievementsPath- if doesParentExist- then do- contents <- sendIO $ listDirectory savedAchievementsPath- forMW contents $ \p -> do- let fullPath = savedAchievementsPath </> p- isFile <- sendIO $ doesFileExist fullPath- if isFile- then do- eitherDecodedFile <- sendIO (Y.decodeFileEither fullPath)- return $ left (AssetNotLoaded Achievement p . CanNotParseYaml) eitherDecodedFile- else return . Left $ AssetNotLoaded Achievement p (EntryNot File)- else do- return []---- | Save info about achievements to XDG data directory.-saveAchievementsInfo ::- [Attainment] ->- IO ()-saveAchievementsInfo attainmentList = do- savedAchievementsPath <- getSwarmAchievementsPath True- forM_ attainmentList $ \x -> do- let achievementName = case _achievement x of- GlobalAchievement y -> show y- GameplayAchievement y -> show y- fullPath = savedAchievementsPath </> achievementName- Y.encodeFile fullPath x
@@ -1,429 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ The Swarm interpreter uses a technique known as a--- <https://matt.might.net/articles/cesk-machines/ CESK machine> (if--- you want to read up on them, you may want to start by reading about--- <https://matt.might.net/articles/cek-machines/ CEK machines>--- first). Execution happens simply by iterating a step function,--- sending one state of the CESK machine to the next. In addition to--- being relatively efficient, this means we can easily run a bunch of--- robots synchronously, in parallel, without resorting to any threads--- (by stepping their machines in a round-robin fashion); pause and--- single-step the game; save and resume, and so on.------ Essentially, a CESK machine state has four components:------ - The __C__ontrol is the thing we are currently focused on:--- either a 'Term' to evaluate, or a 'Value' that we have--- just finished evaluating.--- - The __E__nvironment ('Env') is a mapping from variables that might--- occur free in the Control to their values.--- - The __S__tore ('Store') is a mapping from abstract integer--- /locations/ to values. We use it to store delayed (lazy) values,--- so they will be computed at most once.--- - The __K__ontinuation ('Cont') is a stack of 'Frame's,--- representing the evaluation context, /i.e./ what we are supposed--- to do after we finish with the currently focused thing. When we--- reduce the currently focused term to a value, the top frame on--- the stack tells us how to proceed.------ You can think of a CESK machine as a defunctionalization of a--- recursive big-step interpreter, where we explicitly keep track of--- the call stack and the environments that would be in effect at--- various places in the recursion. One could probably even derive--- this mechanically, by writing a recursive big-step interpreter,--- then converting it to CPS, then defunctionalizing the--- continuations.------ The slightly confusing thing about CESK machines is how we--- have to pass around environments everywhere. Basically,--- anywhere there can be unevaluated terms containing free--- variables (in values, in continuation stack frames, ...), we--- have to store the proper environment alongside so that when--- we eventually get around to evaluating it, we will be able to--- pull out the environment to use.-module Swarm.Game.CESK (- -- * Frames and continuations- Frame (..),- Cont,-- -- ** Wrappers for creating delayed change of state- WorldUpdate (..),- RobotUpdate (..),-- -- * Store- Store,- Addr,- emptyStore,- MemCell (..),- allocate,- lookupStore,- setStore,-- -- * CESK machine states- CESK (..),-- -- ** Construction- initMachine,- initMachine',- cancel,- resetBlackholes,-- -- ** Extracting information- finalValue,- TickNumber (..),- addTicks,-) where--import Control.Lens ((^.))-import Control.Lens.Combinators (pattern Empty)-import Data.Aeson (FromJSON, ToJSON)-import Data.Int (Int64)-import Data.IntMap.Strict (IntMap)-import Data.IntMap.Strict qualified as IM-import GHC.Generics (Generic)-import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>))-import Swarm.Game.Entity (Count, Entity)-import Swarm.Game.Exception-import Swarm.Game.World (WorldUpdate (..))-import Swarm.Language.Context-import Swarm.Language.Module-import Swarm.Language.Pipeline-import Swarm.Language.Pretty-import Swarm.Language.Requirement (ReqCtx)-import Swarm.Language.Syntax-import Swarm.Language.Types-import Swarm.Language.Value as V-import Swarm.Util.WindowedCounter (Offsettable (..))---- | A newtype representing a count of ticks (typically since the--- start of a game).-newtype TickNumber = TickNumber {getTickNumber :: Int64}- deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON)---- | Add an offset to a 'TickNumber'.-addTicks :: Int -> TickNumber -> TickNumber-addTicks i (TickNumber n) = TickNumber $ n + fromIntegral i--instance Offsettable TickNumber where- offsetBy = addTicks--instance Pretty TickNumber where- pretty (TickNumber i) = pretty i----------------------------------------------------------------- Frames and continuations----------------------------------------------------------------- | A frame is a single component of a continuation stack, explaining--- what to do next after we finish evaluating the currently focused--- term.-data Frame- = -- | We were evaluating the first component of a pair; next, we- -- should evaluate the second component which was saved in this- -- frame (and push a 'FFst' frame on the stack to save the first component).- FSnd Term Env- | -- | We were evaluating the second component of a pair; when done,- -- we should combine it with the value of the first component saved- -- in this frame to construct a fully evaluated pair.- FFst Value- | -- | @FArg t e@ says that we were evaluating the left-hand side of- -- an application, so the next thing we should do is evaluate the- -- term @t@ (the right-hand side, /i.e./ argument of the- -- application) in environment @e@. We will also push an 'FApp'- -- frame on the stack.- FArg Term Env- | -- | @FApp v@ says that we were evaluating the right-hand side of- -- an application; once we are done, we should pass the resulting- -- value as an argument to @v@.- FApp Value- | -- | @FLet x t2 e@ says that we were evaluating a term @t1@ in an- -- expression of the form @let x = t1 in t2@, that is, we were- -- evaluating the definition of @x@; the next thing we should do- -- is evaluate @t2@ in the environment @e@ extended with a binding- -- for @x@.- FLet Var Term Env- | -- | We are executing inside a 'Try' block. If an exception is- -- raised, we will execute the stored term (the "catch" block).- FTry Value- | -- | We were executing a command; next we should take any- -- environment it returned and union it with this one to produce- -- the result of a bind expression.- FUnionEnv Env- | -- | We were executing a command that might have definitions; next- -- we should take the resulting 'Env' and add it to the robot's- -- 'Swarm.Game.Robot.robotEnv', along with adding this accompanying 'Ctx' and- -- 'ReqCtx' to the robot's 'Swarm.Game.Robot.robotCtx'.- FLoadEnv TCtx ReqCtx- | -- | We were executing a definition; next we should take the resulting value- -- and return a context binding the variable to the value.- FDef Var- | -- | An @FExec@ frame means the focused value is a command, which- -- we should now execute.- FExec- | -- | We are in the process of executing the first component of a- -- bind; once done, we should also execute the second component- -- in the given environment (extended by binding the variable,- -- if there is one, to the output of the first command).- FBind (Maybe Var) Term Env- | -- | Discard any environment generated as the result of executing- -- a command.- FDiscardEnv- | -- | Apply specific updates to the world and current robot.- --- -- The 'Const' is used to track the original command for error messages.- FImmediate Const [WorldUpdate Entity] [RobotUpdate]- | -- | Update the memory cell at a certain location with the computed value.- FUpdate Addr- | -- | Signal that we are done with an atomic computation.- FFinishAtomic- | -- | We are in the middle of running a computation for all the- -- nearby robots. We have the function to run, and the list of- -- robot IDs to run it on.- FMeetAll Value [Int]- | -- | We are in the middle of evaluating a record: some fields have- -- already been evaluated; we are focusing on evaluating one- -- field; and some fields have yet to be evaluated.- FRcd Env [(Var, Value)] Var [(Var, Maybe Term)]- | -- | We are in the middle of evaluating a record field projection.- FProj Var- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | A continuation is just a stack of frames.-type Cont = [Frame]----------------------------------------------------------------- Store---------------------------------------------------------------type Addr = Int---- | 'Store' represents a store, /i.e./ memory, indexing integer--- locations to 'MemCell's.-data Store = Store {next :: Addr, mu :: IntMap MemCell}- deriving (Show, Eq, Generic, FromJSON, ToJSON)---- | A memory cell can be in one of three states.-data MemCell- = -- | A cell starts out life as an unevaluated term together with- -- its environment.- E Term Env- | -- | When the cell is 'Force'd, it is set to a 'Blackhole' while- -- being evaluated. If it is ever referenced again while still- -- a 'Blackhole', that means it depends on itself in a way that- -- would trigger an infinite loop, and we can signal an error.- -- (Of course, we- -- <http://www.lel.ed.ac.uk/~gpullum/loopsnoop.html cannot- -- detect /all/ infinite loops this way>.)- --- -- A 'Blackhole' saves the original 'Term' and 'Env' that are- -- being evaluated; if Ctrl-C is used to cancel a computation- -- while we are in the middle of evaluating a cell, the- -- 'Blackhole' can be reset to 'E'.- Blackhole Term Env- | -- | Once evaluation is complete, we cache the final 'Value' in- -- the 'MemCell', so that subsequent lookups can just use it- -- without recomputing anything.- V Value- deriving (Show, Eq, Generic, FromJSON, ToJSON)--emptyStore :: Store-emptyStore = Store 0 IM.empty---- | Allocate a new memory cell containing an unevaluated expression--- with the current environment. Return the index of the allocated--- cell.-allocate :: Env -> Term -> Store -> (Addr, Store)-allocate e t (Store n m) = (n, Store (n + 1) (IM.insert n (E t e) m))---- | Look up the cell at a given index.-lookupStore :: Addr -> Store -> Maybe MemCell-lookupStore n = IM.lookup n . mu---- | Set the cell at a given index.-setStore :: Addr -> MemCell -> Store -> Store-setStore n c (Store nxt m) = Store nxt (IM.insert n c m)----------------------------------------------------------------- CESK machine----------------------------------------------------------------- | The overall state of a CESK machine, which can actually be one of--- four kinds of states. The CESK machine is named after the first--- kind of state, and it would probably be possible to inline a--- bunch of things and get rid of the second state, but I find it--- much more natural and elegant this way. Most tutorial--- presentations of CEK/CESK machines only have one kind of state, but--- then again, most tutorial presentations only deal with the bare--- lambda calculus, so one can tell whether a term is a value just--- by seeing whether it is syntactically a lambda. I learned this--- approach from Harper's Practical Foundations of Programming--- Languages.-data CESK- = -- | When we are on our way "in/down" into a term, we have a- -- currently focused term to evaluate in the environment, a store,- -- and a continuation. In this mode we generally pattern-match on the- -- 'Term' to decide what to do next.- In Term Env Store Cont- | -- | Once we finish evaluating a term, we end up with a 'Value'- -- and we switch into "out" mode, bringing the value back up- -- out of the depths to the context that was expecting it. In- -- this mode we generally pattern-match on the 'Cont' to decide- -- what to do next.- --- -- Note that there is no 'Env', because we don't have anything- -- with variables to evaluate at the moment, and we maintain the- -- invariant that any unevaluated terms buried inside a 'Value'- -- or 'Cont' must carry along their environment with them.- Out Value Store Cont- | -- | An exception has been raised. Keep unwinding the- -- continuation stack (until finding an enclosing 'Try' in the- -- case of a command failure or a user-generated exception, or- -- until the stack is empty in the case of a fatal exception).- Up Exn Store Cont- | -- | The machine is waiting for the game to reach a certain time- -- to resume its execution.- Waiting TickNumber CESK- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | Is the CESK machine in a final (finished) state? If so, extract--- the final value and store.-finalValue :: CESK -> Maybe (Value, Store)-{-# INLINE finalValue #-}-finalValue (Out v s []) = Just (v, s)-finalValue _ = Nothing---- | Initialize a machine state with a starting term along with its--- type; the term will be executed or just evaluated depending on--- whether it has a command type or not.-initMachine :: ProcessedTerm -> Env -> Store -> CESK-initMachine t e s = initMachine' t e s []---- | Like 'initMachine', but also take an explicit starting continuation.-initMachine' :: ProcessedTerm -> Env -> Store -> Cont -> CESK-initMachine' (ProcessedTerm (Module t' ctx) _ reqCtx) e s k =- case t' ^. sType of- -- If the starting term has a command type...- Forall _ (TyCmd _) ->- case ctx of- -- ...but doesn't contain any definitions, just create a machine- -- that will evaluate it and then execute it.- Empty -> In t e s (FExec : k)- -- Or, if it does contain definitions, then load the resulting- -- context after executing it.- _ -> In t e s (FExec : FLoadEnv ctx reqCtx : k)- -- Otherwise, for a term with a non-command type, just- -- create a machine to evaluate it.- _ -> In t e s k- where- -- Erase all type and SrcLoc annotations from the term before- -- putting it in the machine state, since those are irrelevant at- -- runtime.- t = eraseS t'---- | Cancel the currently running computation.-cancel :: CESK -> CESK-cancel cesk = Out VUnit s' []- where- s' = resetBlackholes $ getStore cesk- getStore (In _ _ s _) = s- getStore (Out _ s _) = s- getStore (Up _ s _) = s- getStore (Waiting _ c) = getStore c---- | Reset any 'Blackhole's in the 'Store'. We need to use this any--- time a running computation is interrupted, either by an exception--- or by a Ctrl+C.-resetBlackholes :: Store -> Store-resetBlackholes (Store n m) = Store n (IM.map resetBlackhole m)- where- resetBlackhole (Blackhole t e) = E t e- resetBlackhole c = c----------------------------------------------------------------- Pretty printing CESK machine states---------------------------------------------------------------instance PrettyPrec CESK where- prettyPrec _ (In c _ _ k) = prettyCont k (11, "▶" <> ppr c <> "◀")- prettyPrec _ (Out v _ k) = prettyCont k (11, "◀" <> ppr (valueToTerm v) <> "▶")- prettyPrec _ (Up e _ k) = prettyCont k (11, "!" <> (pretty (formatExn mempty e) <> "!"))- prettyPrec _ (Waiting t cesk) = "🕑" <> pretty t <> "(" <> ppr cesk <> ")"---- | Take a continuation, and the pretty-printed expression which is--- the focus of the continuation (i.e. the expression whose value--- will be given to the continuation) along with its top-level--- precedence, and pretty-print the whole thing.------ As much as possible, we try to print to look like an *expression*--- with a currently focused part, that is, we print the continuation--- from the inside out instead of as a list of frames. This makes--- it much more intuitive to read.-prettyCont :: Cont -> (Int, Doc ann) -> Doc ann-prettyCont [] (_, inner) = inner-prettyCont (f : k) inner = prettyCont k (prettyFrame f inner)---- | Pretty-print a single continuation frame, given its already--- pretty-printed focus. In particular, given a frame and its--- "inside" (i.e. the expression or other frames being focused on,--- whose value will eventually be passed to this frame), with the--- precedence of the inside's top-level construct, return a--- pretty-printed version of the entire frame along with its--- top-level precedence.-prettyFrame :: Frame -> (Int, Doc ann) -> (Int, Doc ann)-prettyFrame (FSnd t _) (_, inner) = (11, "(" <> inner <> "," <+> ppr t <> ")")-prettyFrame (FFst v) (_, inner) = (11, "(" <> ppr (valueToTerm v) <> "," <+> inner <> ")")-prettyFrame (FArg t _) (p, inner) = (10, pparens (p < 10) inner <+> prettyPrec 11 t)-prettyFrame (FApp v) (p, inner) = (10, prettyPrec 10 (valueToTerm v) <+> pparens (p < 11) inner)-prettyFrame (FLet x t _) (_, inner) = (11, hsep ["let", pretty x, "=", inner, "in", ppr t])-prettyFrame (FTry v) (p, inner) = (10, "try" <+> pparens (p < 11) inner <+> prettyPrec 11 (valueToTerm v))-prettyFrame (FUnionEnv _) inner = prettyPrefix "∪·" inner-prettyFrame (FLoadEnv _ _) inner = prettyPrefix "L·" inner-prettyFrame (FDef x) (_, inner) = (11, "def" <+> pretty x <+> "=" <+> inner <+> "end")-prettyFrame FExec inner = prettyPrefix "E·" inner-prettyFrame (FBind Nothing t _) (p, inner) = (0, pparens (p < 1) inner <+> ";" <+> ppr t)-prettyFrame (FBind (Just x) t _) (p, inner) = (0, hsep [pretty x, "<-", pparens (p < 1) inner, ";", ppr t])-prettyFrame FDiscardEnv inner = prettyPrefix "D·" inner-prettyFrame (FImmediate c _worldUpds _robotUpds) inner = prettyPrefix ("I[" <> ppr c <> "]·") inner-prettyFrame (FUpdate addr) inner = prettyPrefix ("S@" <> pretty addr) inner-prettyFrame FFinishAtomic inner = prettyPrefix "A·" inner-prettyFrame (FMeetAll _ _) inner = prettyPrefix "M·" inner-prettyFrame (FRcd _ done foc rest) (_, inner) = (11, encloseSep "[" "]" ", " (pDone ++ [pFoc] ++ pRest))- where- pDone = map (\(x, v) -> pretty x <+> "=" <+> ppr (valueToTerm v)) (reverse done)- pFoc = pretty foc <+> "=" <+> inner- pRest = map pprEq rest- pprEq (x, Nothing) = pretty x- pprEq (x, Just t) = pretty x <+> "=" <+> ppr t-prettyFrame (FProj x) (p, inner) = (11, pparens (p < 11) inner <> "." <> pretty x)---- | Pretty-print a special "prefix application" frame, i.e. a frame--- formatted like @X· inner@. Unlike typical applications, these--- associate to the *right*, so that we can print something like @X·--- Y· Z· inner@ with no parens.-prettyPrefix :: Doc ann -> (Int, Doc ann) -> (Int, Doc ann)-prettyPrefix pre (p, inner) = (11, pre <+> pparens (p < 11) inner)------------------------------------------------------------------- Runtime robot update------------------------------------------------------------------- | Enumeration of robot updates. This type is used for changes by--- /e.g./ the @drill@ command which must be carried out at a later--- tick. Using a first-order representation (as opposed to /e.g./--- just a @Robot -> Robot@ function) allows us to serialize and--- inspect the updates.------ Note that this can not be in 'Swarm.Game.Robot' as it would create--- a cyclic dependency.-data RobotUpdate- = -- | Add copies of an entity to the robot's inventory.- AddEntity Count Entity- | -- | Make the robot learn about an entity.- LearnEntity Entity- deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
@@ -1,203 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- Orphan Hashable instances needed to derive Hashable Display---- |--- SPDX-License-Identifier: BSD-3-Clause------ Utilities for describing how to display in-game entities in the TUI.-module Swarm.Game.Display (- -- * The display record- Priority,- Attribute (..),- Display,-- -- ** Fields- defaultChar,- orientationMap,- curOrientation,- displayAttr,- displayPriority,- invisible,-- -- ** Rendering- displayChar,- hidden,-- -- ** Construction- defaultTerrainDisplay,- defaultEntityDisplay,- defaultRobotDisplay,-) where--import Control.Lens hiding (Const, from, (.=))-import Data.Hashable (Hashable)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (fromMaybe, isJust)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml-import GHC.Generics (Generic)-import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..))-import Swarm.Util (maxOn)-import Swarm.Util.Lens (makeLensesNoSigs)-import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)---- | Display priority. Entities with higher priority will be drawn on--- top of entities with lower priority.-type Priority = Int---- | An internal attribute name.-data Attribute = ADefault | ARobot | AEntity | AWorld Text | ATerrain Text- deriving (Eq, Ord, Show, Generic, Hashable)--terrainPrefix :: Text-terrainPrefix = "terrain_"--instance FromJSON Attribute where- parseJSON =- withText "attribute" $- pure . \case- "robot" -> ARobot- "entity" -> AEntity- "default" -> ADefault- t | terrainPrefix `T.isPrefixOf` t -> ATerrain $ T.drop (T.length terrainPrefix) t- w -> AWorld w--instance ToJSON Attribute where- toJSON = \case- ADefault -> String "default"- ARobot -> String "robot"- AEntity -> String "entity"- AWorld w -> String w- ATerrain t -> String $ terrainPrefix <> t---- | A record explaining how to display an entity in the TUI.-data Display = Display- { _defaultChar :: Char- , _orientationMap :: Map AbsoluteDir Char- , _curOrientation :: Maybe Direction- , _displayAttr :: Attribute- , _displayPriority :: Priority- , _invisible :: Bool- }- deriving (Eq, Ord, Show, Generic, Hashable)--instance Semigroup Display where- d1 <> d2- | _invisible d1 = d2- | _invisible d2 = d1- | otherwise = maxOn _displayPriority d1 d2--makeLensesNoSigs ''Display---- | The default character to use for display.-defaultChar :: Lens' Display Char---- | For robots or other entities that have an orientation, this map--- optionally associates different display characters with--- different orientations. If an orientation is not in the map,--- the 'defaultChar' will be used.-orientationMap :: Lens' Display (Map AbsoluteDir Char)---- | The display caches the current orientation of the entity, so we--- know which character to use from the orientation map.-curOrientation :: Lens' Display (Maybe Direction)---- | The attribute to use for display.-displayAttr :: Lens' Display Attribute---- | This entity's display priority. Higher priorities are drawn--- on top of lower.-displayPriority :: Lens' Display Priority---- | Whether the entity is currently invisible.-invisible :: Lens' Display Bool--instance FromJSON Display where- parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ')--instance FromJSONE Display Display where- parseJSONE = withObjectE "Display" $ \v -> do- defD <- getE- mc <- liftE $ v .:? "char"- let c = fromMaybe (defD ^. defaultChar) mc- let dOM = if isJust mc then mempty else defD ^. orientationMap- liftE $- Display c- <$> v .:? "orientationMap" .!= dOM- <*> v .:? "curOrientation" .!= (defD ^. curOrientation)- <*> (v .:? "attr") .!= (defD ^. displayAttr)- <*> v .:? "priority" .!= (defD ^. displayPriority)- <*> v .:? "invisible" .!= (defD ^. invisible)--instance ToJSON Display where- toJSON d =- object $- [ "char" .= (d ^. defaultChar)- , "attr" .= (d ^. displayAttr)- , "priority" .= (d ^. displayPriority)- ]- ++ ["orientationMap" .= (d ^. orientationMap) | not (M.null (d ^. orientationMap))]- ++ ["invisible" .= (d ^. invisible) | d ^. invisible]---- | Look up the character that should be used for a display.-displayChar :: Display -> Char-displayChar disp = fromMaybe (disp ^. defaultChar) $ do- DAbsolute d <- disp ^. curOrientation- M.lookup d (disp ^. orientationMap)---- | Modify a display to use a @?@ character for entities that are--- hidden/unknown.-hidden :: Display -> Display-hidden = (defaultChar .~ '?') . (curOrientation .~ Nothing)---- | The default way to display some terrain using the given character--- and attribute, with priority 0.-defaultTerrainDisplay :: Char -> Attribute -> Display-defaultTerrainDisplay c attr =- defaultEntityDisplay c- & displayPriority .~ 0- & displayAttr .~ attr---- | Construct a default display for an entity that uses only a single--- display character, the default entity attribute, and priority 1.-defaultEntityDisplay :: Char -> Display-defaultEntityDisplay c =- Display- { _defaultChar = c- , _orientationMap = M.empty- , _curOrientation = Nothing- , _displayAttr = AEntity- , _displayPriority = 1- , _invisible = False- }---- | Construct a default robot display for a given orientation, with--- display characters @"X^>v<"@, the default robot attribute, and--- priority 10.------ Note that the 'defaultChar' is used for direction 'DDown'--- and is overridden for the special base robot.-defaultRobotDisplay :: Display-defaultRobotDisplay =- Display- { _defaultChar = 'X'- , _orientationMap =- M.fromList- [ (DEast, '>')- , (DWest, '<')- , (DSouth, 'v')- , (DNorth, '^')- ]- , _curOrientation = Nothing- , _displayAttr = ARobot- , _displayPriority = 10- , _invisible = False- }--instance Monoid Display where- mempty = defaultEntityDisplay ' ' & invisible .~ True
@@ -1,713 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ An 'Entity' represents an object that exists in the world. Each--- entity has a way to be displayed, some metadata such as a name and--- description, some properties, and possibly an inventory of other--- entities.------ This module also defines the 'Inventory' type, since the two types--- are mutually recursive (an inventory contains entities, which can--- have inventories).-module Swarm.Game.Entity (- -- * Entity properties- EntityName,- EntityProperty (..),- GrowthTime (..),- defaultGrowthTime,- Combustibility (..),- defaultCombustibility,-- -- * Entities- Entity,- mkEntity,-- -- ** Fields- -- $lenses- entityDisplay,- entityName,- entityPlural,- entityNameFor,- entityDescription,- entityOrientation,- entityGrowth,- entityCombustion,- entityYields,- entityProperties,- hasProperty,- entityCapabilities,- entityInventory,- entityHash,-- -- ** Entity map- EntityMap (..),- buildEntityMap,- loadEntities,- lookupEntityName,- deviceForCap,-- -- * Inventories- Inventory,- Count,-- -- ** Construction- empty,- singleton,- fromList,- fromElems,-- -- ** Lookup- lookup,- lookupByName,- countByName,- contains,- contains0plus,- elems,- isSubsetOf,- isEmpty,- inventoryCapabilities,- extantElemsWithCapability,- entitiesByCapability,-- -- ** Modification- insert,- insertCount,- delete,- deleteCount,- deleteAll,- union,- difference,-) where--import Control.Algebra (Has)-import Control.Arrow ((&&&))-import Control.Carrier.Throw.Either (liftEither)-import Control.Effect.Lift (Lift, sendIO)-import Control.Effect.Throw (Throw, throwError)-import Control.Lens (Getter, Lens', lens, to, view, (^.))-import Control.Monad ((<=<))-import Data.Bifunctor (first)-import Data.Char (toLower)-import Data.Function (on)-import Data.Hashable-import Data.IntMap (IntMap)-import Data.IntMap qualified as IM-import Data.IntSet (IntSet)-import Data.IntSet qualified as IS-import Data.List (foldl')-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (fromMaybe, isJust, listToMaybe)-import Data.Set (Set)-import Data.Set qualified as Set (fromList, member, toList, unions)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml-import GHC.Generics (Generic)-import Swarm.Game.Display-import Swarm.Game.Failure-import Swarm.Game.Location-import Swarm.Game.ResourceLoading (getDataFileNameSafe)-import Swarm.Language.Capability-import Swarm.Language.Syntax (Syntax)-import Swarm.Language.Text.Markdown (Document, docToText)-import Swarm.Util (binTuples, failT, findDup, plural, (?))-import Swarm.Util.Effect (withThrow)-import Swarm.Util.Yaml-import Text.Read (readMaybe)-import Witch-import Prelude hiding (lookup)----------------------------------------------------------------- Properties----------------------------------------------------------------- | A type representing entity names, currently a synonym for 'Text'.--- In the future it is conceivable that it might become more complex.-type EntityName = Text---- | Various properties that an entity can have, which affect how--- robots can interact with it.-data EntityProperty- = -- | Robots can't move onto a cell containing this entity.- Unwalkable- | -- | Robots can pick this up (via 'Swarm.Language.Syntax.Grab' or 'Swarm.Language.Syntax.Harvest').- Portable- | -- | Obstructs the view of robots that attempt to "scout"- Opaque- | -- | Regrows from a seed after it is harvested.- Growable- | -- | Can burn when ignited (either via 'Swarm.Language.Syntax.Ignite' or by- -- an adjacent burning entity).- Combustible- | -- | Regenerates infinitely when grabbed or harvested.- Infinite- | -- | Robots drown if they walk on this without a boat.- Liquid- | -- | Robots automatically know what this is without having to scan it.- Known- deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable)--instance ToJSON EntityProperty where- toJSON = String . from . map toLower . show--instance FromJSON EntityProperty where- parseJSON = withText "EntityProperty" tryRead- where- tryRead :: Text -> Parser EntityProperty- tryRead t = case readMaybe . from . T.toTitle $ t of- Just c -> return c- Nothing -> failT ["Unknown entity property", t]---- | How long an entity takes to regrow. This represents the minimum--- and maximum amount of time taken by one growth stage (there are--- two stages). The actual time for each stage will be chosen--- uniformly at random between these two values.-newtype GrowthTime = GrowthTime (Integer, Integer)- deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON)---- | The default growth time (100, 200) for a growable entity with no--- growth time specification.-defaultGrowthTime :: GrowthTime-defaultGrowthTime = GrowthTime (100, 200)---- | Properties of combustion.-data Combustibility = Combustibility- { ignition :: Double- -- ^ Rate of ignition by a neighbor, per tick.- -- If this rate is denoted \(\lambda\), the probability of- -- ignition over a period of \(t\) ticks is \(1 - e^{-\lambda t}\).- -- See <https://math.stackexchange.com/a/1243629>.- , duration :: (Integer, Integer)- -- ^ min and max tick counts for combustion to persist- , product :: Maybe EntityName- -- ^ what entity, if any, is left over after combustion- }- deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON)---- | The default combustion specification for a combustible entity--- with no combustion specification:------ * ignition rate 0.5--- * duration (100, 200)--- * product @ash@-defaultCombustibility :: Combustibility-defaultCombustibility = Combustibility 0.5 (100, 200) (Just "ash")----------------------------------------------------------------- Entity----------------------------------------------------------------- | A record to hold information about an entity.------ The constructor for 'Entity' is intentionally not exported. To--- construct one manually, use the 'mkEntity' function.------ There are two main constraints on the way entities are stored:------ 1. We want to be able to easily modify an entity in one--- particular cell of the world (for example, painting one--- tree red).--- 2. In an inventory, we want to store identical entities only--- once, along with a count.------ We could get (2) nicely by storing only names of entities, and--- having a global lookup table from names to entity records.--- However, storing names instead of actual entity records in the--- world makes (1) more complex: every time we modify an entity we--- would have to generate a fresh name for the modified entity and--- add it to the global entity table. This approach is also--- annoying because it means we can't just uses lenses to drill down--- into the properties of an entity in the world or in an inventory,--- but have to do an intermediate lookup in the global (mutable!)--- entity table.------ On the other hand, if we just store entity records everywhere,--- checking them for equality becomes expensive. Having an--- inventory be a map with entities themselves as keys sounds awful.------ The solution we adopt here is that every @Entity@ record carries--- along a hash value of all the other fields. We just assume that--- these hashes are unique (a collision is of course possible but--- extremely unlikely). Entities can be efficiently compared just--- by looking at their hashes; they can be stored in a map using--- hash values as keys; and we provide lenses which automatically--- recompute the hash value when modifying a field of an entity--- record. Note also that world storage is still efficient, too:--- thanks to referential transparency, in practice most of the--- entities stored in the world that are the same will literally--- just be stored as pointers to the same shared record.-data Entity = Entity- { _entityHash :: Int- -- ^ A hash value computed from the other fields- , _entityDisplay :: Display- -- ^ The way this entity should be displayed on the world map.- , _entityName :: EntityName- -- ^ The name of the entity, used /e.g./ in an inventory display.- , _entityPlural :: Maybe Text- -- ^ The plural of the entity name, in case it is irregular. If- -- this field is @Nothing@, default pluralization heuristics- -- will be used (see 'plural').- , _entityDescription :: Document Syntax- -- ^ A longer-form description. Each 'Text' value is one- -- paragraph.- , _entityOrientation :: Maybe Heading- -- ^ The entity's orientation (if it has one). For example, when- -- a robot moves, it moves in the direction of its orientation.- , _entityGrowth :: Maybe GrowthTime- -- ^ If this entity grows, how long does it take?- , _entityCombustion :: Maybe Combustibility- -- ^ If this entity is combustible, how spreadable is it?- , _entityYields :: Maybe Text- -- ^ The name of a different entity obtained when this entity is- -- grabbed.- , _entityProperties :: Set EntityProperty- -- ^ Properties of the entity.- , _entityCapabilities :: Set Capability- -- ^ Capabilities provided by this entity.- , _entityInventory :: Inventory- -- ^ Inventory of other entities held by this entity.- }- -- Note that an entity does not have a location, because the- -- location of an entity is implicit in the way it is stored (by- -- location).-- deriving (Show, Generic)---- | The @Hashable@ instance for @Entity@ ignores the cached hash--- value and simply combines the other fields.-instance Hashable Entity where- hashWithSalt s (Entity _ disp nm pl descr orient grow combust yld props caps inv) =- s- `hashWithSalt` disp- `hashWithSalt` nm- `hashWithSalt` pl- `hashWithSalt` docToText descr- `hashWithSalt` orient- `hashWithSalt` grow- `hashWithSalt` combust- `hashWithSalt` yld- `hashWithSalt` props- `hashWithSalt` caps- `hashWithSalt` inv---- | Entities are compared by hash for efficiency.-instance Eq Entity where- (==) = (==) `on` _entityHash---- | Entities are compared by hash for efficiency.-instance Ord Entity where- compare = compare `on` _entityHash---- | Recompute an entity's hash value.-rehashEntity :: Entity -> Entity-rehashEntity e = e {_entityHash = hash e}---- | Create an entity with no orientation, an empty inventory,--- providing no capabilities (automatically filling in the hash--- value).-mkEntity ::- -- | Display- Display ->- -- | Entity name- Text ->- -- | Entity description- Document Syntax ->- -- | Properties- [EntityProperty] ->- -- | Capabilities- [Capability] ->- Entity-mkEntity disp nm descr props caps =- rehashEntity $- Entity- 0- disp- nm- Nothing- descr- Nothing- Nothing- Nothing- Nothing- (Set.fromList props)- (Set.fromList caps)- empty----------------------------------------------------------------- Entity map----------------------------------------------------------------- | An 'EntityMap' is a data structure containing all the loaded--- entities, allowing them to be looked up either by name or by what--- capabilities they provide (if any).-data EntityMap = EntityMap- { entitiesByName :: Map Text Entity- , entitiesByCap :: Map Capability [Entity]- }- deriving (Eq, Show, Generic, FromJSON, ToJSON)--instance Semigroup EntityMap where- EntityMap n1 c1 <> EntityMap n2 c2 = EntityMap (n1 <> n2) (M.unionWith (<>) c1 c2)--instance Monoid EntityMap where- mempty = EntityMap M.empty M.empty- mappend = (<>)---- | Find an entity with the given name.-lookupEntityName :: Text -> EntityMap -> Maybe Entity-lookupEntityName nm = M.lookup nm . entitiesByName---- | Find all entities which are devices that provide the given--- capability.-deviceForCap :: Capability -> EntityMap -> [Entity]-deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap---- | Build an 'EntityMap' from a list of entities. The idea is that--- this will be called once at startup, when loading the entities--- from a file; see 'loadEntities'.-buildEntityMap :: Has (Throw LoadingFailure) sig m => [Entity] -> m EntityMap-buildEntityMap es = do- case findDup (map fst namedEntities) of- Nothing -> return ()- Just duped -> throwError $ Duplicate Entities duped- return $- EntityMap- { entitiesByName = M.fromList namedEntities- , entitiesByCap = M.fromListWith (<>) . concatMap (\e -> map (,[e]) (Set.toList $ e ^. entityCapabilities)) $ es- }- where- namedEntities = map (view entityName &&& id) es----------------------------------------------------------------- Serialization---------------------------------------------------------------instance FromJSON Entity where- parseJSON = withObject "Entity" $ \v ->- rehashEntity- <$> ( Entity 0- <$> v .: "display"- <*> v .: "name"- <*> v .:? "plural"- <*> (v .: "description")- <*> v .:? "orientation"- <*> v .:? "growth"- <*> v .:? "combustion"- <*> v .:? "yields"- <*> v .:? "properties" .!= mempty- <*> v .:? "capabilities" .!= mempty- <*> pure empty- )---- | If we have access to an 'EntityMap', we can parse the name of an--- 'Entity' as a string and look it up in the map.-instance FromJSONE EntityMap Entity where- parseJSONE = withTextE "entity name" $ \name ->- E $ \em -> case lookupEntityName name em of- Nothing -> failT ["Unknown entity:", name]- Just e -> return e--instance ToJSON Entity where- toJSON e =- object $- [ "display" .= (e ^. entityDisplay)- , "name" .= (e ^. entityName)- , "description" .= (e ^. entityDescription)- ]- ++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)]- ++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)]- ++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)]- ++ ["yields" .= (e ^. entityYields) | isJust (e ^. entityYields)]- ++ ["properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties]- ++ ["capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities]---- | Load entities from a data file called @entities.yaml@, producing--- either an 'EntityMap' or a parse error.-loadEntities ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- m EntityMap-loadEntities = do- let entityFile = "entities.yaml"- entityFailure = AssetNotLoaded (Data Entities) entityFile- fileName <- getDataFileNameSafe Entities entityFile- decoded <-- withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $- decodeFileEither fileName- withThrow entityFailure $ buildEntityMap decoded----------------------------------------------------------------- Entity lenses----------------------------------------------------------------- $lenses--- Our own custom lenses which properly recompute the cached hash--- value each time something gets updated. See--- https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/--- for the approach used here.---- | Make a lens for Entity that recomputes the hash after setting.-hashedLens :: (Entity -> a) -> (Entity -> a -> Entity) -> Lens' Entity a-hashedLens get set = lens get (\e a -> rehashEntity $ set e a)---- | Get the hash of an entity. Note that this is a getter, not a--- lens; the "Swarm.Game.Entity" module carefully maintains some--- internal invariants ensuring that hashes work properly, and by--- golly, no one else is going to mess that up.-entityHash :: Getter Entity Int-entityHash = to _entityHash---- | The 'Display' explaining how to draw this entity in the world display.-entityDisplay :: Lens' Entity Display-entityDisplay = hashedLens _entityDisplay (\e x -> e {_entityDisplay = x})---- | The name of the entity.-entityName :: Lens' Entity EntityName-entityName = hashedLens _entityName (\e x -> e {_entityName = x})---- | The irregular plural version of the entity's name, if there is--- one.-entityPlural :: Lens' Entity (Maybe Text)-entityPlural = hashedLens _entityPlural (\e x -> e {_entityPlural = x})---- | Get a version of the entity's name appropriate to the--- number---the singular name for 1, and a plural name for any other--- number. The plural name is obtained either by looking it up if--- irregular, or by applying standard heuristics otherwise.-entityNameFor :: Int -> Getter Entity Text-entityNameFor 1 = entityName-entityNameFor _ = to $ \e ->- case e ^. entityPlural of- Just pl -> pl- Nothing -> plural (e ^. entityName)---- | A longer, free-form description of the entity. Each 'Text' value--- represents a paragraph.-entityDescription :: Lens' Entity (Document Syntax)-entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x})---- | The direction this entity is facing (if it has one).-entityOrientation :: Lens' Entity (Maybe Heading)-entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x})---- | How long this entity takes to grow, if it regrows.-entityGrowth :: Lens' Entity (Maybe GrowthTime)-entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x})---- | Susceptibility to and duration of combustion-entityCombustion :: Lens' Entity (Maybe Combustibility)-entityCombustion = hashedLens _entityCombustion (\e x -> e {_entityCombustion = x})---- | The name of a different entity yielded when this entity is--- grabbed, if any.-entityYields :: Lens' Entity (Maybe Text)-entityYields = hashedLens _entityYields (\e x -> e {_entityYields = x})---- | The properties enjoyed by this entity.-entityProperties :: Lens' Entity (Set EntityProperty)-entityProperties = hashedLens _entityProperties (\e x -> e {_entityProperties = x})---- | Test whether an entity has a certain property.-hasProperty :: Entity -> EntityProperty -> Bool-hasProperty e p = p `elem` (e ^. entityProperties)---- | The capabilities this entity provides when equipped.-entityCapabilities :: Lens' Entity (Set Capability)-entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x})---- | The inventory of other entities carried by this entity.-entityInventory :: Lens' Entity Inventory-entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x})----------------------------------------------------------------- Inventory----------------------------------------------------------------- | A convenient synonym to remind us when an 'Int' is supposed to--- represent /how many/ of something we have.-type Count = Int---- | An inventory is really just a bag/multiset of entities. That is,--- it contains some entities, along with the number of times each--- occurs. Entities can be looked up directly, or by name.-data Inventory = Inventory- { -- Main map- counts :: IntMap (Count, Entity)- , -- Mirrors the main map; just caching the ability to look up by- -- name.- byName :: Map Text IntSet- , -- Cached hash of the inventory, using a homomorphic hashing scheme- -- (see https://github.com/swarm-game/swarm/issues/229).- --- -- Invariant: equal to Sum_{(k,e) \in counts} (k+1) * (e ^. entityHash).- -- The k+1 is so the hash distinguishes between having a 0 count of something- -- and not having it as a key in the map at all.- inventoryHash :: Int- }- deriving (Show, Generic, FromJSON, ToJSON)--instance Hashable Inventory where- -- Just return cached hash value.- hash = inventoryHash- hashWithSalt s = hashWithSalt s . inventoryHash---- | Inventories are compared by hash for efficiency.-instance Eq Inventory where- (==) = (==) `on` hash---- | Look up an entity in an inventory, returning the number of copies--- contained.-lookup :: Entity -> Inventory -> Count-lookup e (Inventory cs _ _) = maybe 0 fst $ IM.lookup (e ^. entityHash) cs---- | Look up an entity by name in an inventory, returning a list of--- matching entities. Note, if this returns some entities, it does--- /not/ mean we necessarily have any in our inventory! It just--- means we /know about/ them. If you want to know whether you have--- any, use 'lookup' and see whether the resulting 'Count' is--- positive, or just use 'countByName' in the first place.-lookupByName :: Text -> Inventory -> [Entity]-lookupByName name (Inventory cs byN _) =- maybe [] (map (snd . (cs IM.!)) . IS.elems) (M.lookup (T.toLower name) byN)---- | Look up an entity by name and see how many there are in the--- inventory. If there are multiple entities with the same name, it--- just picks the first one returned from 'lookupByName'.-countByName :: Text -> Inventory -> Count-countByName name inv =- maybe 0 (`lookup` inv) (listToMaybe (lookupByName name inv))---- | The empty inventory.-empty :: Inventory-empty = Inventory IM.empty M.empty 0---- | Create an inventory containing one entity.-singleton :: Entity -> Inventory-singleton = flip insert empty---- | Insert an entity into an inventory. If the inventory already--- contains this entity, then only its count will be incremented.-insert :: Entity -> Inventory -> Inventory-insert = insertCount 1---- | Create an inventory from a list of entities.-fromList :: [Entity] -> Inventory-fromList = foldl' (flip insert) empty---- | Create an inventory from a list of entities and their counts.-fromElems :: [(Count, Entity)] -> Inventory-fromElems = foldl' (flip (uncurry insertCount)) empty---- | Insert a certain number of copies of an entity into an inventory.--- If the inventory already contains this entity, then only its--- count will be incremented.-insertCount :: Count -> Entity -> Inventory -> Inventory-insertCount k e (Inventory cs byN h) =- Inventory- (IM.insertWith (\(m, _) (n, _) -> (m + n, e)) (e ^. entityHash) (k, e) cs)- (M.insertWith IS.union (T.toLower $ e ^. entityName) (IS.singleton (e ^. entityHash)) byN)- (h + (k + extra) * (e ^. entityHash)) -- homomorphic hashing- where- -- Include the hash of an entity once just for "knowing about" it;- -- then include the hash once per actual copy of the entity. In- -- other words, having k copies of e in the inventory contributes- -- (k+1)*(e ^. entityHash) to the inventory hash. The reason for- -- doing this is so that the inventory hash changes even when we- -- insert 0 copies of something, since having 0 copies of something- -- is different than not having it as a key at all; having 0 copies- -- signals that we at least "know about" the entity.- extra = if (e ^. entityHash) `IM.member` cs then 0 else 1---- | Check whether an inventory contains at least one of a given entity.-contains :: Inventory -> Entity -> Bool-contains inv e = lookup e inv > 0---- | Check whether an inventory has an entry for the given entity,--- even if there are 0 copies. In particular this is used to--- indicate whether a robot "knows about" an entity.-contains0plus :: Entity -> Inventory -> Bool-contains0plus e = isJust . IM.lookup (e ^. entityHash) . counts---- | Check if the first inventory is a subset of the second.--- Note that entities with a count of 0 are ignored.-isSubsetOf :: Inventory -> Inventory -> Bool-isSubsetOf inv1 inv2 = all (\(n, e) -> lookup e inv2 >= n) (elems inv1)---- | Check whether an inventory is empty, meaning that it contains 0--- total entities (although it may still /know about/ some entities, that--- is, have them as keys with a count of 0).-isEmpty :: Inventory -> Bool-isEmpty = all ((== 0) . fst) . elems---- | Compute the set of capabilities provided by the devices in an inventory.-inventoryCapabilities :: Inventory -> Set Capability-inventoryCapabilities = Set.unions . map (^. entityCapabilities) . nonzeroEntities---- | List elements that have at least one copy in the inventory.-nonzeroEntities :: Inventory -> [Entity]-nonzeroEntities = map snd . filter ((> 0) . fst) . elems---- | List elements that possess a given Capability and--- exist with nonzero count in the inventory.-extantElemsWithCapability :: Capability -> Inventory -> [Entity]-extantElemsWithCapability cap =- filter (Set.member cap . (^. entityCapabilities)) . nonzeroEntities---- | Groups entities by the capabilities they offer.-entitiesByCapability :: Inventory -> Map Capability (NE.NonEmpty Entity)-entitiesByCapability inv =- binTuples entityCapabilityPairs- where- getCaps = Set.toList . (^. entityCapabilities)- entityCapabilityPairs = concatMap ((\e -> map (,e) $ getCaps e) . snd) $ elems inv---- | Delete a single copy of a certain entity from an inventory.-delete :: Entity -> Inventory -> Inventory-delete = deleteCount 1---- | Delete a specified number of copies of an entity from an inventory.-deleteCount :: Count -> Entity -> Inventory -> Inventory-deleteCount k e (Inventory cs byN h) = Inventory cs' byN h'- where- m = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0- cs' = IM.adjust removeCount (e ^. entityHash) cs- h' = h - min k m * (e ^. entityHash)-- removeCount :: (Count, a) -> (Count, a)- removeCount (n, a) = (max 0 (n - k), a)---- | Delete all copies of a certain entity from an inventory.-deleteAll :: Entity -> Inventory -> Inventory-deleteAll e (Inventory cs byN h) =- Inventory- (IM.adjust (first (const 0)) (e ^. entityHash) cs)- byN- (h - n * (e ^. entityHash))- where- n = (fst <$> IM.lookup (e ^. entityHash) cs) ? 0---- | Get the entities in an inventory and their associated counts.-elems :: Inventory -> [(Count, Entity)]-elems (Inventory cs _ _) = IM.elems cs---- | Union two inventories.-union :: Inventory -> Inventory -> Inventory-union (Inventory cs1 byN1 h1) (Inventory cs2 byN2 h2) =- Inventory- (IM.unionWith (\(c1, e) (c2, _) -> (c1 + c2, e)) cs1 cs2)- (M.unionWith IS.union byN1 byN2)- (h1 + h2 - common)- where- -- Need to subtract off the sum of the hashes in common, because- -- of the way each entity with count k contributes (k+1) times its- -- hash. So if the two inventories share an entity e, just adding their- -- hashes would mean e now contributes (k+2) times its hash.- common = IS.foldl' (+) 0 $ IM.keysSet cs1 `IS.intersection` IM.keysSet cs2---- | Subtract the second inventory from the first.-difference :: Inventory -> Inventory -> Inventory-difference inv1 = foldl' (flip (uncurry deleteCount)) inv1 . elems
@@ -1,187 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Runtime exceptions for the Swarm language interpreter.-module Swarm.Game.Exception (- Exn (..),- IncapableFix (..),- formatExn,-- -- * Helper functions- formatIncapable,- formatIncapableFix,-) where--import Control.Lens ((^.))-import Data.Aeson (FromJSON, ToJSON)-import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.Map qualified as M-import Data.Set qualified as S-import Data.Text (Text)-import Data.Text qualified as T-import GHC.Generics (Generic)-import Swarm.Constant-import Swarm.Game.Achievement.Definitions-import Swarm.Game.Entity (EntityMap, deviceForCap, entityName)-import Swarm.Language.Capability (Capability (CGod), capabilityName)-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Requirement (Requirements (..))-import Swarm.Language.Syntax (Const, Term)-import Swarm.Util-import Witch (from)---- --------------------------------------------------------------------- SETUP FOR DOCTEST---- $setup--- >>> :set -XOverloadedStrings--- >>> import Control.Lens--- >>> import Data.Text (unpack)--- >>> import Swarm.Language.Syntax--- >>> import Swarm.Language.Capability--- >>> import Swarm.Game.Entity--- >>> import Swarm.Game.Display--- >>> import qualified Swarm.Language.Requirement as R---- ---------------------------------------------------------------------- | Suggested way to fix things when a robot does not meet the--- requirements to run a command.-data IncapableFix- = -- | 'Swarm.Language.Syntax.Equip' the missing device on yourself/target- FixByEquip- | -- | Add the missing device to your inventory- FixByObtain- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | The type of exceptions that can be thrown by robot programs.-data Exn- = -- | Something went very wrong. This is a bug in Swarm and cannot- -- be caught by a @try@ block (but at least it will not crash- -- the entire UI).- Fatal Text- | -- | An infinite loop was detected via a blackhole. This cannot- -- be caught by a @try@ block.- InfiniteLoop- | -- | A robot tried to do something for which it does not have some- -- of the required capabilities. This cannot be caught by a- -- @try@ block. Also contains the missing requirements, the- -- term that caused the problem, and a suggestion for how to fix- -- things.- Incapable IncapableFix Requirements Term- | -- | A command failed in some "normal" way (/e.g./ a 'Swarm.Language.Syntax.Move'- -- command could not move, or a 'Swarm.Language.Syntax.Grab' command found nothing to- -- grab, /etc./). Can be caught by a @try@ block.- CmdFailed Const Text (Maybe GameplayAchievement)- | -- | The user program explicitly called 'Swarm.Language.Syntax.Undefined' or 'Swarm.Language.Syntax.Fail'. Can- -- be caught by a @try@ block.- User Text- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | Pretty-print an exception for displaying to the player.-formatExn :: EntityMap -> Exn -> Text-formatExn em = \case- Fatal t ->- T.unlines- [ "Fatal error: " <> t- , "Please report this as a bug at"- , "<" <> swarmRepoUrl <> "issues/new>."- ]- InfiniteLoop -> "Infinite loop detected!"- (CmdFailed c t _) -> T.concat [prettyText c, ": ", t]- (User t) -> "Player exception: " <> t- (Incapable f caps tm) -> formatIncapable em f caps tm---- --------------------------------------------------------------------- INCAPABLE HELPERS--- ---------------------------------------------------------------------- | Pretty-print an 'IncapableFix': either "equip" or "obtain".-formatIncapableFix :: IncapableFix -> Text-formatIncapableFix = \case- FixByEquip -> "equip"- FixByObtain -> "obtain"---- | Pretty print the incapable exception with an actionable suggestion--- on how to fix it.------ >>> import Data.Either (fromRight)--- >>> import Control.Carrier.Throw.Either (runThrow)--- >>> import Control.Algebra (run)--- >>> import Swarm.Game.Failure (LoadingFailure)--- >>> :set -XTypeApplications--- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty [CAppear]--- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty [CAppear]--- >>> m = fromRight mempty . run . runThrow @LoadingFailure $ buildEntityMap [w,r]--- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByEquip cs t------ >>> incapableError (R.singletonCap CGod) (TConst As)--- Thou shalt not utter such blasphemy:--- 'as'--- If God in troth thou wantest to play, try thou a Creative game.------ >>> incapableError (R.singletonCap CAppear) (TConst Appear)--- You do not have the devices required for:--- 'appear'--- Please equip:--- - the one ring or magic wand------ >>> incapableError (R.singletonCap CRandom) (TConst Random)--- Missing the random capability for:--- 'random'--- but no device yet provides it. See--- https://github.com/swarm-game/swarm/issues/26------ >>> incapableError (R.singletonInv 3 "tree") (TConst Noop)--- You are missing required inventory for:--- 'noop'--- Please obtain:--- - tree (3)-formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text-formatIncapable em f (Requirements caps _ inv) tm- | CGod `S.member` caps =- unlinesExText $- "Thou shalt not utter such blasphemy:"- :| [ squote $ prettyText tm- , "If God in troth thou wantest to play, try thou a Creative game."- ]- | not (null capsNone) =- unlinesExText $- "Missing the " <> capMsg <> " for:"- :| [ squote $ prettyText tm- , "but no device yet provides it. See"- , swarmRepoUrl <> "issues/26"- ]- | not (S.null caps) =- unlinesExText- ( "You do not have the devices required for:"- :| squote (prettyText tm)- : "Please " <> formatIncapableFix f <> ":"- : (("- " <>) . formatDevices <$> filter (not . null) deviceSets)- )- | otherwise =- unlinesExText- ( "You are missing required inventory for:"- :| squote (prettyText tm)- : "Please obtain:"- : (("- " <>) . formatEntity <$> M.assocs inv)- )- where- capList = S.toList caps- deviceSets = map (`deviceForCap` em) capList- devicePerCap = zip capList deviceSets- -- capabilities not provided by any device- capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap- capMsg = case capsNone of- [ca] -> ca <> " capability"- cas -> "capabilities " <> T.intercalate ", " cas- formatDevices = T.intercalate " or " . map (^. entityName)- formatEntity (e, 1) = e- formatEntity (e, n) = e <> " (" <> from (show n) <> ")"---- | Exceptions that span multiple lines should be indented.-unlinesExText :: NonEmpty Text -> Text-unlinesExText (t :| ts) = T.unlines $ (t :) $ map (" " <>) ts
@@ -1,141 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ A data type to represent system failures (as distinct from robot--- program failures).------ These failures are often not fatal and serve--- to create common infrastructure for logging.-module Swarm.Game.Failure (- SystemFailure (..),- AssetData (..),- Asset (..),- Entry (..),- LoadingFailure (..),- OrderFileWarning (..),-) where--import Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty qualified as NE-import Data.Text (Text)-import Data.Text qualified as T-import Data.Void-import Data.Yaml (ParseException, prettyPrintParseException)-import Prettyprinter (Pretty (pretty), nest, squotes, vcat, (<+>))-import Swarm.Language.Pretty-import Swarm.Util (showLowT)-import Text.Megaparsec (ParseErrorBundle, errorBundlePretty)-import Witch (into)----------------------------------------------------------------- Failure descriptions---- | Enumeration of various assets we can attempt to load.-data AssetData = AppAsset | NameGeneration | Entities | Recipes | Worlds | Scenarios | Script- deriving (Eq, Show)---- | Overarching enumeration of various assets we can attempt to load.-data Asset = Achievement | Data AssetData | History | Save- deriving (Eq, Show)---- | Enumeration type to distinguish between directories and files.-data Entry = Directory | File- deriving (Eq, Show)---- | An error that occurred while attempting to load some kind of asset.-data LoadingFailure- = DoesNotExist Entry- | EntryNot Entry- | CanNotParseYaml ParseException- | CanNotParseMegaparsec (ParseErrorBundle Text Void)- | DoesNotTypecheck Text -- See Note [Typechecking errors]- | Duplicate AssetData Text- | CustomMessage Text- deriving (Show)---- ~~~~ Note [Pretty-printing typechecking errors]------ It would make sense to store a CheckErr in DoesNotTypecheck;--- however, Swarm.Game.Failure is imported in lots of places, and--- CheckErr can contain high-level things like TTerms etc., so it--- would lead to an import cycle. Instead, we choose to just--- pretty-print typechecking errors before storing them here.---- | A warning that arose while processing an @00-ORDER.txt@ file.-data OrderFileWarning- = NoOrderFile- | MissingFiles (NonEmpty FilePath)- | DanglingFiles (NonEmpty FilePath)- deriving (Eq, Show)---- | An enumeration of various types of failures (errors or warnings)--- that can occur.-data SystemFailure- = AssetNotLoaded Asset FilePath LoadingFailure- | ScenarioNotFound FilePath- | OrderFileWarning FilePath OrderFileWarning- | CustomFailure Text- deriving (Show)----------------------------------------------------------------- Pretty-printing--instance PrettyPrec AssetData where- prettyPrec _ = \case- NameGeneration -> "name generation data"- AppAsset -> "data assets"- d -> pretty (showLowT d)--instance PrettyPrec Asset where- prettyPrec _ = \case- Data ad -> ppr ad- a -> pretty (showLowT a)--instance PrettyPrec Entry where- prettyPrec _ = prettyShowLow--instance PrettyPrec LoadingFailure where- prettyPrec _ = \case- DoesNotExist e -> "The" <+> ppr e <+> "is missing!"- EntryNot e -> "The entry is not a" <+> ppr e <> "!"- CanNotParseYaml p ->- nest 2 . vcat $- "Parse failure:"- : map pretty (T.lines (into @Text (prettyPrintParseException p)))- CanNotParseMegaparsec p ->- nest 2 . vcat $- "Parse failure:"- : map pretty (T.lines (into @Text (errorBundlePretty p)))- DoesNotTypecheck t ->- nest 2 . vcat $- "Parse failure:"- : map pretty (T.lines t)- Duplicate thing duped -> "Duplicate" <+> ppr thing <> ":" <+> squotes (pretty duped)- CustomMessage m -> pretty m--instance PrettyPrec OrderFileWarning where- prettyPrec _ = \case- NoOrderFile -> "File not found; using alphabetical order"- MissingFiles missing ->- ppr . BulletList "Files not listed will be ignored:" $- map (into @Text) (NE.toList missing)- DanglingFiles dangling ->- ppr . BulletList "Some listed files do not exist:" $- map (into @Text) (NE.toList dangling)--instance PrettyPrec SystemFailure where- prettyPrec _ = \case- AssetNotLoaded a fp l ->- nest 2 . vcat $- [ "Failed to acquire" <+> ppr a <+> "from path" <+> squotes (pretty fp) <> ":"- , ppr l- ]- ScenarioNotFound s -> "Scenario not found:" <+> pretty s- OrderFileWarning orderFile w ->- nest 2 . vcat $- [ "Warning: while processing" <+> pretty orderFile <> ":"- , ppr w- ]- CustomFailure m -> pretty m
@@ -1,236 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- Orphan JSON instances for Location and Heading---- |--- SPDX-License-Identifier: BSD-3-Clause------ Locations and headings.-module Swarm.Game.Location (- Location,- pattern Location,-- -- ** Heading and Direction functions- Heading,- applyTurn,- relativeTo,- toDirection,- toAbsDirection,- nearestDirection,- fromDirection,- isCardinal,- north,- south,- east,- west,-- -- ** Utility functions- manhattan,- euclidean,- getElemsInArea,-- -- ** Re-exports for convenience- Affine (..),- Point (..),- origin,-) where--import Control.Arrow ((&&&))-import Data.Aeson (FromJSONKey, ToJSONKey)-import Data.Function (on, (&))-import Data.Int (Int32)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON))-import Linear (Additive (..), V2 (..), negated, norm, perp, unangle)-import Linear.Affine (Affine (..), Point (..), origin)-import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal)-import Swarm.Util qualified as Util---- $setup--- >>> import qualified Data.Map as Map--- >>> import Linear--- >>> import Swarm.Language.Direction---- | A t'Location' is a pair of @(x,y)@ coordinates, both up to 32 bits.--- The positive x-axis points east and the positive y-axis points--- north. These are the coordinates that are shown to players.------ See also the 'Swarm.Game.World.Coords' type defined in "Swarm.Game.World", which--- use a (row, column) format instead, which is more convenient for--- internal use. The "Swarm.Game.World" module also defines--- conversions between t'Location' and 'Swarm.Game.World.Coords'.-type Location = Point V2 Int32---- | A convenient way to pattern-match on t'Location' values.-pattern Location :: Int32 -> Int32 -> Location-pattern Location x y = P (V2 x y)--{-# COMPLETE Location #-}--instance FromJSON Location where- parseJSON = fmap P . parseJSON--instance ToJSON Location where- toJSON (P v) = toJSON v---- | A @Heading@ is a 2D vector, with 32-bit coordinates.------ t'Location' and 'Heading' are both represented using types from--- the @linear@ package, so they can be manipulated using a large--- number of operators from that package. For example:------ * Two headings can be added with '^+^'.--- * The difference between two t'Location's is a 'Heading' (via '.-.').--- * A t'Location' plus a 'Heading' is another t'Location' (via 'Linear.Affine..^+').-type Heading = V2 Int32--deriving instance ToJSON (V2 Int32)-deriving instance FromJSON (V2 Int32)--deriving instance FromJSONKey (V2 Int32)-deriving instance ToJSONKey (V2 Int32)--toHeading :: AbsoluteDir -> Heading-toHeading = \case- DNorth -> north- DSouth -> south- DEast -> east- DWest -> west---- | The cardinal direction north = @V2 0 1@.-north :: Heading-north = V2 0 1---- | The cardinal direction south = @V2 0 (-1)@.-south :: Heading-south = V2 0 (-1)---- | The cardinal direction east = @V2 1 0@.-east :: Heading-east = V2 1 0---- | The cardinal direction west = @V2 (-1) 0@.-west :: Heading-west = V2 (-1) 0---- | The direction for viewing the current cell = @V2 0 0@.-down :: Heading-down = zero---- | The 'applyTurn' function gives the meaning of each 'Direction' by--- turning relative to the given heading or by turning to an absolute--- heading.------ >>> applyTurn (DRelative (DPlanar DLeft)) (V2 5 3)--- V2 (-3) 5--- >>> applyTurn (DAbsolute DWest) (V2 5 3)--- V2 (-1) 0-applyTurn :: Direction -> Heading -> Heading-applyTurn d = case d of- DRelative e -> case e of- DPlanar DLeft -> perp- DPlanar DRight -> negated . perp- DPlanar DBack -> negated- DPlanar DForward -> id- DDown -> const down- DAbsolute e -> const $ toHeading e---- | Mapping from heading to their corresponding cardinal directions.--- Only absolute directions are mapped.-cardinalDirs :: M.Map Heading AbsoluteDir-cardinalDirs =- M.fromList $ map (toHeading &&& id) Util.listEnums---- | Possibly convert a heading into a 'Direction'---that is, if the--- vector happens to be a unit vector in one of the cardinal--- directions.------ >>> toDirection (V2 0 (-1))--- Just (DAbsolute DSouth)--- >>> toDirection (V2 3 7)--- Nothing-toDirection :: Heading -> Maybe Direction-toDirection = fmap DAbsolute . toAbsDirection---- | Like 'toDirection', but preserve the type guarantee of an absolute direction-toAbsDirection :: Heading -> Maybe AbsoluteDir-toAbsDirection v = M.lookup v cardinalDirs---- | Return the 'PlanarRelativeDir' which would result in turning to--- the first (target) direction from the second (reference) direction.------ >>> DWest `relativeTo` DSouth--- DRight--- >>> DWest `relativeTo` DWest--- DForward-relativeTo :: AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir-relativeTo targetDir referenceDir =- toEnum indexDiff- where- enumCount = length (Util.listEnums :: [AbsoluteDir])- indexDiff = ((-) `on` fromEnum) targetDir referenceDir `mod` enumCount---- | Compute the absolute direction nearest to a given 'Heading'.------ Logic adapted from <https://gamedev.stackexchange.com/questions/49290/#comment213403_49300>.-nearestDirection :: Heading -> AbsoluteDir-nearestDirection coord =- Util.indexWrapNonEmpty orderedDirs index- where- angle :: Double- angle = unangle (fmap fromIntegral coord) / (2 * pi)-- index :: Int- index = round $ fromIntegral (length orderedDirs) * angle- orderedDirs = Util.listEnumsNonempty---- | Convert a 'Direction' into a corresponding 'Heading'. Note that--- this only does something reasonable for 'DNorth', 'DSouth', 'DEast',--- and 'DWest'---other 'Direction's return the zero vector.-fromDirection :: Direction -> Heading-fromDirection = \case- DAbsolute x -> toHeading x- _ -> zero---- | Manhattan distance between world locations.-manhattan :: Location -> Location -> Int32-manhattan (Location x1 y1) (Location x2 y2) = abs (x1 - x2) + abs (y1 - y2)---- | Euclidean distance between world locations.-euclidean :: Location -> Location -> Double-euclidean p1 p2 = norm (fromIntegral <$> (p2 .-. p1))---- | Get elements that are within a certain manhattan distance from location.------ >>> v2s i = [(p, manhattan origin p) | x <- [-i..i], y <- [-i..i], let p = Location x y]--- >>> v2s 0--- [(P (V2 0 0),0)]--- >>> map (\i -> length (getElemsInArea origin i (Map.fromList $ v2s i))) [0..8]--- [1,5,13,25,41,61,85,113,145]------ The last test is the sequence "Centered square numbers":--- https://oeis.org/A001844-getElemsInArea :: Location -> Int32 -> Map Location e -> [e]-getElemsInArea o@(Location x y) d m = M.elems sm'- where- -- to be more efficient we basically split on first coordinate- -- (which is logarithmic) and then we have to linearly filter- -- the second coordinate to get a square - this is how it looks:- -- ▲▲▲▲- -- ││││ the arrows mark points that are greater then A- -- ││s│ and lesser then B- -- │sssB (2,1)- -- ssoss <-- o=(x=0,y=0) with d=2- -- (-2,-1) Asss│- -- │s││ the point o and all s are in manhattan- -- ││││ distance 2 from point o- -- ▼▼▼▼- sm =- m- & M.split (Location (x - d) (y - 1)) -- A- & snd -- A<- & M.split (Location (x + d) (y + 1)) -- B- & fst -- B>- sm' = M.filterWithKey (const . (<= d) . manhattan o) sm
@@ -1,267 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ A recipe represents some kind of process for transforming--- some input entities into some output entities.------ Recipes support a number of different game mechanics, including:------ * crafting--- * mining--- * randomized "loot boxes"--- * unlocking doors------ == Synchronous vs Async--- Recipes can be completed either within the same tick--- as execution is started, or execution may span--- multiple ticks. It is possible for the execution--- of multi-tick recipes to be interrupted in one way or--- another, in which case the recipe fails without producing--- the "outputs".-module Swarm.Game.Recipe (- -- * Ingredient lists and recipes- IngredientList,- Recipe (..),-- -- ** Fields- recipeInputs,- recipeOutputs,- recipeCatalysts,- recipeTime,- recipeWeight,-- -- * Loading recipes- loadRecipes,- outRecipeMap,- inRecipeMap,- catRecipeMap,-- -- * Looking up recipes- MissingIngredient (..),- MissingType (..),- knowsIngredientsFor,- recipesFor,- make,- make',-) where--import Control.Algebra (Has)-import Control.Arrow (left)-import Control.Effect.Lift (Lift, sendIO)-import Control.Effect.Throw (Throw, liftEither)-import Control.Lens hiding (from, (.=))-import Control.Monad ((<=<))-import Data.Bifunctor (second)-import Data.Either.Validation-import Data.IntMap (IntMap)-import Data.IntMap qualified as IM-import Data.List (foldl')-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml-import GHC.Generics (Generic)-import Swarm.Game.Entity as E-import Swarm.Game.Failure-import Swarm.Game.ResourceLoading (getDataFileNameSafe)-import Swarm.Util.Effect (withThrow)-import Swarm.Util.Lens (makeLensesNoSigs)-import Swarm.Util.Yaml-import Witch---- | An ingredient list is a list of entities with multiplicity. It--- is polymorphic in the entity type so that we can use either--- entity names when serializing, or actual entity objects while the--- game is running.-type IngredientList e = [(Count, e)]---- | A recipe represents some kind of process where inputs are--- transformed into outputs.-data Recipe e = Recipe- { _recipeInputs :: IngredientList e- , _recipeOutputs :: IngredientList e- , _recipeCatalysts :: IngredientList e- , _recipeTime :: Integer- , _recipeWeight :: Integer- }- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)--deriving instance ToJSON (Recipe Entity)-deriving instance FromJSON (Recipe Entity)--makeLensesNoSigs ''Recipe---- | The inputs to a recipe.-recipeInputs :: Lens' (Recipe e) (IngredientList e)---- | The outputs from a recipe.-recipeOutputs :: Lens' (Recipe e) (IngredientList e)---- | The time required to finish a recipe.-recipeTime :: Lens' (Recipe e) Integer---- | Other entities which the recipe requires you to have, but which--- are not consumed by the recipe (e.g. a @\"furnace\"@).-recipeCatalysts :: Lens' (Recipe e) (IngredientList e)---- | How this recipe is weighted against other recipes. Any time--- there are multiple valid recipes that fit certain criteria, one--- of the recipes will be randomly chosen with probability--- proportional to its weight.-recipeWeight :: Lens' (Recipe e) Integer----------------------------------------------------------------- Serializing---------------------------------------------------------------instance ToJSON (Recipe Text) where- toJSON (Recipe ins outs cats time weight) =- object $- [ "in" .= ins- , "out" .= outs- ]- ++ ["required" .= cats | not (null cats)]- ++ ["time" .= time | time /= 1]- ++ ["weight" .= weight | weight /= 1]--instance FromJSON (Recipe Text) where- parseJSON = withObject "Recipe" $ \v ->- Recipe- <$> v- .: "in"- <*> v- .: "out"- <*> v- .:? "required"- .!= []- <*> v- .:? "time"- .!= 1- <*> v- .:? "weight"- .!= 1---- | Given an 'EntityMap', turn a list of recipes containing /names/--- of entities into a list of recipes containing actual 'Entity'--- records; or.-resolveRecipes :: EntityMap -> [Recipe Text] -> Validation [Text] [Recipe Entity]-resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lookupEntityName t em))--instance FromJSONE EntityMap (Recipe Entity) where- parseJSONE v = do- rt <- liftE $ parseJSON @(Recipe Text) v- em <- getE- let erEnt :: Validation [Text] (Recipe Entity)- erEnt = traverse (\t -> maybe (Failure [t]) Success (lookupEntityName t em)) rt- case validationToEither erEnt of- Right rEnt -> return rEnt- Left err -> fail . from @Text . T.unlines $ err---- | Given an already loaded 'EntityMap', try to load a list of--- recipes from the data file @recipes.yaml@.-loadRecipes ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- EntityMap ->- m [Recipe Entity]-loadRecipes em = do- fileName <- getDataFileNameSafe Recipes f- textRecipes <-- withThrow (AssetNotLoaded (Data Recipes) fileName . CanNotParseYaml)- . (liftEither <=< sendIO)- $ decodeFileEither @[Recipe Text] fileName- withThrow (AssetNotLoaded (Data Recipes) fileName . CustomMessage)- . liftEither- . left (T.append "Unknown entities in recipe(s): " . T.intercalate ", ")- . validationToEither- $ resolveRecipes em textRecipes- where- f = "recipes.yaml"------------------------------------------------------------------ | Build a map of recipes either by inputs or outputs.-buildRecipeMap ::- Getter (Recipe Entity) (IngredientList Entity) ->- [Recipe Entity] ->- IntMap [Recipe Entity]-buildRecipeMap select recipeList =- IM.fromListWith (++) (map (second (: [])) (concatMap mk recipeList))- where- mk r = [(e ^. entityHash, r) | (_, e) <- r ^. select]---- | Build a map of recipes indexed by output ingredients.-outRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]-outRecipeMap = buildRecipeMap recipeOutputs---- | Build a map of recipes indexed by input ingredients.-inRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]-inRecipeMap = buildRecipeMap recipeInputs---- | Build a map of recipes indexed by catalysts.-catRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]-catRecipeMap = buildRecipeMap recipeCatalysts---- | Get a list of all the recipes for the given entity. Look up an--- entity in either an 'inRecipeMap' or 'outRecipeMap' depending on--- whether you want to know recipes that consume or produce the--- given entity, respectively.-recipesFor :: IntMap [Recipe Entity] -> Entity -> [Recipe Entity]-recipesFor rm e = fromMaybe [] $ IM.lookup (e ^. entityHash) rm---- | Record information about something missing from a recipe.-data MissingIngredient = MissingIngredient MissingType Count Entity- deriving (Show, Eq)---- | What kind of thing is missing?-data MissingType = MissingInput | MissingCatalyst- deriving (Show, Eq)---- | Figure out which ingredients (if any) are lacking from an--- inventory to be able to carry out the recipe. Catalysts are not--- consumed and so can be used even when equipped.-missingIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> [MissingIngredient]-missingIngredientsFor (inv, ins) (Recipe inps _ cats _ _) =- mkMissing MissingInput (findLacking inv inps)- <> mkMissing MissingCatalyst (findLacking ins (findLacking inv cats))- where- mkMissing k = map (uncurry (MissingIngredient k))- findLacking inven = filter ((> 0) . fst) . map (countNeeded inven)- countNeeded inven (need, entity) = (need - E.lookup entity inven, entity)---- | Figure out if a recipe is available, /i.e./ if we at least know--- about all the ingredients. Note it does not matter whether we have--- enough of the ingredients.-knowsIngredientsFor :: (Inventory, Inventory) -> Recipe Entity -> Bool-knowsIngredientsFor (inv, ins) recipe =- knowsAll inv (recipe ^. recipeInputs) && knowsAll ins (recipe ^. recipeCatalysts)- where- knowsAll xs = all (E.contains xs . snd)---- | Try to make a recipe, deleting the recipe's inputs from the--- inventory. Return either a description of which items are--- lacking, if the inventory does not contain sufficient inputs,--- or an inventory without inputs and function adding outputs if--- it was successful.-make ::- -- | The robot's inventory and equipped devices- (Inventory, Inventory) ->- -- | The recipe we are trying to make- Recipe Entity ->- Either- [MissingIngredient]- (Inventory, IngredientList Entity, Recipe Entity)-make invs r = finish <$> make' invs r- where- finish (invTaken, out) = (invTaken, out, r)---- | Try to make a recipe, but do not insert it yet.-make' :: (Inventory, Inventory) -> Recipe Entity -> Either [MissingIngredient] (Inventory, IngredientList Entity)-make' invs@(inv, _) r =- case missingIngredientsFor invs r of- [] ->- let removed = foldl' (flip (uncurry deleteCount)) inv (r ^. recipeInputs)- in Right (removed, r ^. recipeOutputs)- missing -> Left missing
@@ -1,152 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Various utilities related to loading game data files.-module Swarm.Game.ResourceLoading where--import Control.Algebra (Has)-import Control.Effect.Lift (Lift, sendIO)-import Control.Effect.Throw (Throw, liftEither, throwError)-import Control.Exception (catch)-import Control.Exception.Base (IOException)-import Control.Monad (forM, when, (<=<))-import Data.Array (Array, listArray)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (mapMaybe)-import Data.Text (Text)-import Data.Text qualified as T-import Paths_swarm (getDataDir)-import Swarm.Game.Failure-import Swarm.Util-import System.Directory (- XdgDirectory (XdgData),- createDirectoryIfMissing,- doesDirectoryExist,- doesFileExist,- getXdgDirectory,- listDirectory,- )-import System.FilePath-import Witch---- | Read-only lists of adjectives and words for use in building random robot names-data NameGenerator = NameGenerator- { adjList :: Array Int Text- , nameList :: Array Int Text- }---- | Get subdirectory from swarm data directory.------ This will first look in Cabal generated path and then--- try a @data@ directory in 'XdgData' path.------ The idea is that when installing with Cabal/Stack the first--- is preferred, but when the players install a binary they--- need to extract the `data` archive to the XDG directory.-getDataDirSafe ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- AssetData ->- FilePath ->- m FilePath-getDataDirSafe asset p = do- d <- (`appDir` p) <$> sendIO getDataDir- de <- sendIO $ doesDirectoryExist d- if de- then return d- else do- xd <- (`appDir` p) <$> sendIO (getSwarmXdgDataSubdir False "data")- xde <- sendIO $ doesDirectoryExist xd- if xde then return xd else throwError $ AssetNotLoaded (Data asset) xd $ DoesNotExist Directory- where- appDir r = \case- "" -> r- "." -> r- d -> r </> d---- | Get file from swarm data directory.------ See the note in 'getDataDirSafe'.-getDataFileNameSafe ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- AssetData ->- FilePath ->- m FilePath-getDataFileNameSafe asset name = do- d <- getDataDirSafe asset "."- let fp = d </> name- fe <- sendIO $ doesFileExist fp- if fe- then return fp- else throwError $ AssetNotLoaded (Data asset) fp $ DoesNotExist File---- | Get a nice message suggesting to download @data@ directory to 'XdgData'.-dataNotFound :: FilePath -> IO LoadingFailure-dataNotFound f = do- d <- getSwarmXdgDataSubdir False ""- let squotes = squote . T.pack- return $- CustomMessage $- T.unlines- [ "Could not find the data: " <> squotes f- , "Try downloading the Swarm 'data' directory to: " <> squotes (d </> "data")- ]---- | Get path to swarm data, optionally creating necessary--- directories. This could fail if user has bad permissions--- on his own @$HOME@ or @$XDG_DATA_HOME@ which is unlikely.-getSwarmXdgDataSubdir :: Bool -> FilePath -> IO FilePath-getSwarmXdgDataSubdir createDirs subDir = do- swarmData <- (</> subDir) <$> getXdgDirectory XdgData "swarm"- when createDirs (createDirectoryIfMissing True swarmData)- pure swarmData--getSwarmXdgDataFile :: Bool -> FilePath -> IO FilePath-getSwarmXdgDataFile createDirs filepath = do- let (subDir, file) = splitFileName filepath- d <- getSwarmXdgDataSubdir createDirs subDir- return $ d </> file---- | Get path to swarm saves, optionally creating necessary--- directories.-getSwarmSavePath :: Bool -> IO FilePath-getSwarmSavePath createDirs = getSwarmXdgDataSubdir createDirs "saves"---- | Get path to swarm history, optionally creating necessary--- directories.-getSwarmHistoryPath :: Bool -> IO FilePath-getSwarmHistoryPath createDirs = getSwarmXdgDataFile createDirs "history"---- | Read all the @.txt@ files in the @data/@ directory.-readAppData ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- m (Map Text Text)-readAppData = do- d <- getDataDirSafe AppAsset "."- dirMembers :: [FilePath] <-- (liftEither <=< sendIO) $- (pure <$> listDirectory d) `catch` \(e :: IOException) ->- return . Left . AssetNotLoaded (Data AppAsset) d . CustomMessage . T.pack $ show e- let fs = filter ((== ".txt") . takeExtension) dirMembers-- filesList <- sendIO $ forM fs (\f -> (into @Text (dropExtension f),) <$> readFileMayT (d </> f))- return $ M.fromList . mapMaybe sequenceA $ filesList--initNameGenerator :: Has (Throw SystemFailure) sig m => Map Text Text -> m NameGenerator-initNameGenerator appDataMap = do- adjs <- getDataLines "adjectives"- names <- getDataLines "names"- return $- NameGenerator- { adjList = makeArr adjs- , nameList = makeArr names- }- where- makeArr xs = listArray (0, length xs - 1) xs- getDataLines f = case M.lookup f appDataMap of- Nothing ->- throwError $- AssetNotLoaded (Data NameGeneration) (into @FilePath f <.> "txt") (DoesNotExist File)- Just content -> return . drop 1 . T.lines $ content
@@ -1,656 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ A data type to represent robots.-module Swarm.Game.Robot (- -- * Robots data-- -- * Robots- RobotPhase (..),- RID,- RobotR,- Robot,- TRobot,-- -- ** Runtime robot update- RobotUpdate (..),-- -- * Robot context- RobotContext,- defTypes,- defReqs,- defVals,- defStore,- emptyRobotContext,-- -- ** Lenses- robotEntity,- robotName,- trobotName,- unwalkableEntities,- robotCreatedAt,- robotDisplay,- robotLocation,- unsafeSetRobotLocation,- trobotLocation,- robotOrientation,- robotInventory,- equippedDevices,- robotLog,- robotLogUpdated,- inventoryHash,- robotCapabilities,- robotContext,- trobotContext,- robotID,- robotParentID,- robotHeavy,- machine,- systemRobot,- selfDestruct,- runningAtomic,- activityCounts,- tickStepBudget,- tangibleCommandCount,- commandsHistogram,- lifetimeStepCount,- activityWindow,-- -- ** Creation & instantiation- mkRobot,- instantiateRobot,-- -- ** Query- robotKnows,- isActive,- wantsToStep,- waitingUntil,- getResult,-- -- ** Constants- hearingDistance,-) where--import Control.Lens hiding (Const, contains)-import Data.Aeson qualified as Ae (FromJSON, Key, KeyValue, ToJSON (..), object, (.=))-import Data.Hashable (hashWithSalt)-import Data.Kind qualified-import Data.Map (Map)-import Data.Maybe (catMaybes, fromMaybe, isNothing)-import Data.Sequence (Seq)-import Data.Sequence qualified as Seq-import Data.Set (Set)-import Data.Text (Text)-import Data.Yaml ((.!=), (.:), (.:?))-import GHC.Generics (Generic)-import Linear-import Servant.Docs (ToSample)-import Servant.Docs qualified as SD-import Swarm.Game.CESK-import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible)-import Swarm.Game.Entity hiding (empty)-import Swarm.Game.Location (Heading, Location, toDirection)-import Swarm.Game.Universe-import Swarm.Language.Capability (Capability)-import Swarm.Language.Context qualified as Ctx-import Swarm.Language.Pipeline.QQ (tmQ)-import Swarm.Language.Requirement (ReqCtx)-import Swarm.Language.Syntax (Const, Syntax)-import Swarm.Language.Text.Markdown (Document)-import Swarm.Language.Typed (Typed (..))-import Swarm.Language.Types (TCtx)-import Swarm.Language.Value as V-import Swarm.Log-import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs)-import Swarm.Util.WindowedCounter-import Swarm.Util.Yaml-import System.Clock (TimeSpec)---- | A record that stores the information--- for all definitions stored in a 'Robot'-data RobotContext = RobotContext- { _defTypes :: TCtx- -- ^ Map definition names to their types.- , _defReqs :: ReqCtx- -- ^ Map definition names to the capabilities- -- required to evaluate/execute them.- , _defVals :: Env- -- ^ Map definition names to their values. Note that since- -- definitions are delayed, the values will just consist of- -- 'VRef's pointing into the store.- , _defStore :: Store- -- ^ A store containing memory cells allocated to hold- -- definitions.- }- deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON)--makeLenses ''RobotContext--emptyRobotContext :: RobotContext-emptyRobotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore--type instance Index RobotContext = Ctx.Var-type instance IxValue RobotContext = Typed Value--instance Ixed RobotContext-instance At RobotContext where- at name = lens getter setter- where- getter ctx =- do- typ <- Ctx.lookup name (ctx ^. defTypes)- val <- Ctx.lookup name (ctx ^. defVals)- req <- Ctx.lookup name (ctx ^. defReqs)- return $ Typed val typ req- setter ctx Nothing =- ctx- & defTypes %~ Ctx.delete name- & defVals %~ Ctx.delete name- & defReqs %~ Ctx.delete name- setter ctx (Just (Typed val typ req)) =- ctx- & defTypes %~ Ctx.addBinding name typ- & defVals %~ Ctx.addBinding name val- & defReqs %~ Ctx.addBinding name req---- | A unique identifier for a robot.-type RID = Int---- | The phase of a robot description record.-data RobotPhase- = -- | The robot record has just been read in from a scenario- -- description; it represents a /template/ that may later be- -- instantiated as one or more concrete robots.- TemplateRobot- | -- | The robot record represents a concrete robot in the world.- ConcreteRobot--data ActivityCounts = ActivityCounts- { _tickStepBudget :: Int- , _tangibleCommandCount :: Int- , _commandsHistogram :: Map Const Int- , _lifetimeStepCount :: Int- , _activityWindow :: WindowedCounter TickNumber- }- deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON)--emptyActivityCount :: ActivityCounts-emptyActivityCount =- ActivityCounts- { _tickStepBudget = 0- , _tangibleCommandCount = 0- , _commandsHistogram = mempty- , _lifetimeStepCount = 0- , -- NOTE: This value was chosen experimentally.- -- TODO(#1341): Make this dynamic based on game speed.- _activityWindow = mkWindow 64- }--makeLensesNoSigs ''ActivityCounts---- | A counter that is decremented upon each step of the robot within the--- CESK machine. Initially set to 'Swarm.Game.State.robotStepsPerTick'--- at each new tick.------ The need for 'tickStepBudget' is a bit technical, and I hope I can--- eventually find a different, better way to accomplish it.--- Ideally, we would want each robot to execute a single--- /command/ at every game tick, so that /e.g./ two robots--- executing @move;move;move@ and @repeat 3 move@ (given a--- suitable definition of @repeat@) will move in lockstep.--- However, the second robot actually has to do more computation--- than the first (it has to look up the definition of @repeat@,--- reduce its application to the number 3, etc.), so its CESK--- machine will take more steps. It won't do to simply let each--- robot run until executing a command---because robot programs--- can involve arbitrary recursion, it is very easy to write a--- program that evaluates forever without ever executing a--- command, which in this scenario would completely freeze the--- UI. (It also wouldn't help to ensure all programs are--- terminating---it would still be possible to effectively do--- the same thing by making a program that takes a very, very--- long time to terminate.) So instead, we allocate each robot--- a certain maximum number of computation steps per tick--- (defined in 'Swarm.Game.Step.evalStepsPerTick'), and it--- suspends computation when it either executes a command or--- reaches the maximum number of steps, whichever comes first.------ It seems like this really isn't something the robot should be--- keeping track of itself, but that seemed the most technically--- convenient way to do it at the time. The robot needs some--- way to signal when it has executed a command, which it--- currently does by setting tickStepBudget to zero. However, that--- has the disadvantage that when tickStepBudget becomes zero, we--- can't tell whether that happened because the robot ran out of--- steps, or because it executed a command and set it to zero--- manually.------ Perhaps instead, each robot should keep a counter saying how--- many commands it has executed. The loop stepping the robot--- can tell when the counter increments.-tickStepBudget :: Lens' ActivityCounts Int---- | Total number of tangible commands executed over robot's lifetime-tangibleCommandCount :: Lens' ActivityCounts Int---- | Histogram of commands executed over robot's lifetime-commandsHistogram :: Lens' ActivityCounts (Map Const Int)---- | Total number of CESK steps executed over robot's lifetime.--- This could be thought of as "CPU cycles" consumed, and is labeled--- as "cycles" in the F2 dialog in the UI.-lifetimeStepCount :: Lens' ActivityCounts Int---- | Sliding window over a span of ticks indicating ratio of activity-activityWindow :: Lens' ActivityCounts (WindowedCounter TickNumber)---- | With a robot template, we may or may not have a location. With a--- concrete robot we must have a location.-type family RobotLocation (phase :: RobotPhase) :: Data.Kind.Type where- RobotLocation 'TemplateRobot = Maybe (Cosmic Location)- RobotLocation 'ConcreteRobot = Cosmic Location---- | Robot templates have no ID; concrete robots definitely do.-type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where- RobotID 'TemplateRobot = ()- RobotID 'ConcreteRobot = RID---- | A value of type 'RobotR' is a record representing the state of a--- single robot. The @f@ parameter is for tracking whether or not--- the robot has been assigned a unique ID.-data RobotR (phase :: RobotPhase) = RobotR- { _robotEntity :: Entity- , _equippedDevices :: Inventory- , _robotCapabilities :: Set Capability- -- ^ A cached view of the capabilities this robot has.- -- Automatically generated from '_equippedDevices'.- , _robotLog :: Seq LogEntry- , _robotLogUpdated :: Bool- , _robotLocation :: RobotLocation phase- , _robotContext :: RobotContext- , _robotID :: RobotID phase- , _robotParentID :: Maybe RID- , _robotHeavy :: Bool- , _machine :: CESK- , _systemRobot :: Bool- , _selfDestruct :: Bool- , _activityCounts :: ActivityCounts- , _runningAtomic :: Bool- , _unwalkableEntities :: Set EntityName- , _robotCreatedAt :: TimeSpec- }- deriving (Generic)--deriving instance (Show (RobotLocation phase), Show (RobotID phase)) => Show (RobotR phase)-deriving instance (Eq (RobotLocation phase), Eq (RobotID phase)) => Eq (RobotR phase)---- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/--- for the approach used here with lenses.--makeLensesExcluding ['_robotCapabilities, '_equippedDevices, '_robotLog] ''RobotR---- | A template robot, i.e. a template robot record without a unique ID number,--- and possibly without a location.-type TRobot = RobotR 'TemplateRobot---- | A concrete robot, with a unique ID number and a specific location.-type Robot = RobotR 'ConcreteRobot--instance ToSample Robot where- toSamples _ = SD.singleSample sampleBase- where- sampleBase :: Robot- sampleBase =- mkRobot- 0- Nothing- "base"- "The starting robot."- defaultCosmicLocation- zero- defaultRobotDisplay- (initMachine [tmQ| move |] mempty emptyStore)- []- []- False- False- mempty- 0---- In theory we could make all these lenses over (RobotR phase), but--- that leads to lots of type ambiguity problems later. In practice--- we only need lenses for Robots.---- | Robots are not entities, but they have almost all the--- characteristics of one (or perhaps we could think of robots as--- very special sorts of entities), so for convenience each robot--- carries an 'Entity' record to store all the information it has in--- common with any 'Entity'.------ Note there are various lenses provided for convenience that--- directly reference fields inside this record; for example, one--- can use 'robotName' instead of writing @'robotEntity'--- . 'entityName'@.-robotEntity :: Lens' (RobotR phase) Entity---- | Entities that the robot cannot move onto-unwalkableEntities :: Lens' Robot (Set EntityName)---- | The creation date of the robot.-robotCreatedAt :: Lens' Robot TimeSpec---- robotName and trobotName could be generalized to--- @robotName' :: Lens' (RobotR phase) Text@.--- However, type inference does not work--- very well with the polymorphic version, so we export both--- monomorphic versions instead.---- | The name of a robot.-robotName :: Lens' Robot Text-robotName = robotEntity . entityName---- | The name of a robot template.-trobotName :: Lens' TRobot Text-trobotName = robotEntity . entityName---- | The 'Display' of a robot. This is a special lens that--- automatically sets the 'curOrientation' to the orientation of the--- robot every time you do a @get@ operation. Technically this does--- not satisfy the lens laws---in particular, the get/put law does--- not hold. But we should think of the 'curOrientation' as being--- simply a cache of the displayed entity's direction.-robotDisplay :: Lens' Robot Display-robotDisplay = lens getDisplay setDisplay- where- getDisplay r =- (r ^. robotEntity . entityDisplay)- & curOrientation .~ ((r ^. robotOrientation) >>= toDirection)- setDisplay r d = r & robotEntity . entityDisplay .~ d---- | The robot's current location, represented as @(x,y)@. This is only--- a getter, since when changing a robot's location we must remember--- to update the 'Swarm.Game.State.robotsByLocation' map as well. You can use the--- 'Swarm.Game.Step.updateRobotLocation' function for this purpose.-robotLocation :: Getter Robot (Cosmic Location)---- | Set a robot's location. This is unsafe and should never be--- called directly except by the 'Swarm.Game.Step.updateRobotLocation' function.--- The reason is that we need to make sure the 'Swarm.Game.State.robotsByLocation'--- map stays in sync.-unsafeSetRobotLocation :: Cosmic Location -> Robot -> Robot-unsafeSetRobotLocation loc r = r {_robotLocation = loc}---- | A template robot's location. Unlike 'robotLocation', this is a--- lens, since when dealing with robot templates there is as yet no--- 'Swarm.Game.State.robotsByLocation' map to keep up-to-date.-trobotLocation :: Lens' TRobot (Maybe (Cosmic Location))-trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l})---- | Which way the robot is currently facing.-robotOrientation :: Lens' Robot (Maybe Heading)-robotOrientation = robotEntity . entityOrientation---- | The robot's inventory.-robotInventory :: Lens' Robot Inventory-robotInventory = robotEntity . entityInventory---- | The robot's context.-robotContext :: Lens' Robot RobotContext---- | The robot's context.-trobotContext :: Lens' TRobot RobotContext-trobotContext = lens _robotContext (\r c -> r {_robotContext = c})---- | The (unique) ID number of the robot. This is only a Getter since--- the robot ID is immutable.-robotID :: Getter Robot RID---- | Instantiate a robot template to make it into a concrete robot, by--- providing a robot ID. Concrete robots also require a location;--- if the robot template didn't have a location already, just set--- the location to (0,0) by default. If you want a different location,--- set it via 'trobotLocation' before calling 'instantiateRobot'.-instantiateRobot :: RID -> TRobot -> Robot-instantiateRobot i r =- r- { _robotID = i- , _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r- }---- | The ID number of the robot's parent, that is, the robot that--- built (or most recently reprogrammed) this robot, if there is--- one.-robotParentID :: Lens' Robot (Maybe RID)---- | Is this robot extra heavy (thus requiring tank treads to move)?-robotHeavy :: Lens' Robot Bool---- | A separate inventory for equipped devices, which provide the--- robot with certain capabilities.------ Note that every time the inventory of equipped devices is--- modified, this lens recomputes a cached set of the capabilities--- the equipped devices provide, to speed up subsequent lookups to--- see whether the robot has a certain capability (see 'robotCapabilities')-equippedDevices :: Lens' Robot Inventory-equippedDevices = lens _equippedDevices setEquipped- where- setEquipped r inst =- r- { _equippedDevices = inst- , _robotCapabilities = inventoryCapabilities inst- }---- | The robot's own private message log, most recent message last.--- Messages can be added both by explicit use of the 'Swarm.Language.Syntax.Log' command,--- and by uncaught exceptions. Stored as a 'Seq' so that--- we can efficiently add to the end and also process from beginning--- to end. Note that updating via this lens will also set the--- 'robotLogUpdated'.-robotLog :: Lens' Robot (Seq LogEntry)-robotLog = lens _robotLog setLog- where- setLog r newLog =- r- { _robotLog = newLog- , -- Flag the log as updated if (1) if already was, or (2) the new- -- log is a different length than the old. (This would not- -- catch updates that merely modify an entry, but we don't want- -- to have to compare the entire logs, and we only ever append- -- to logs anyway.)- _robotLogUpdated =- _robotLogUpdated r || Seq.length (_robotLog r) /= Seq.length newLog- }---- | Has the 'robotLog' been updated since the last time it was--- viewed?-robotLogUpdated :: Lens' Robot Bool---- | A hash of a robot's entity record and equipped devices, to--- facilitate quickly deciding whether we need to redraw the robot--- info panel.-inventoryHash :: Getter Robot Int-inventoryHash = to (\r -> 17 `hashWithSalt` (r ^. (robotEntity . entityHash)) `hashWithSalt` (r ^. equippedDevices))---- | Does a robot know of an entity's existence?-robotKnows :: Robot -> Entity -> Bool-robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. equippedDevices)---- | Get the set of capabilities this robot possesses. This is only a--- getter, not a lens, because it is automatically generated from--- the 'equippedDevices'. The only way to change a robot's--- capabilities is to modify its 'equippedDevices'.-robotCapabilities :: Getter Robot (Set Capability)-robotCapabilities = to _robotCapabilities---- | The robot's current CEK machine state.-machine :: Lens' Robot CESK---- | Is this robot a "system robot"? System robots are generated by--- the system (as opposed to created by the user) and are not--- subject to the usual capability restrictions.-systemRobot :: Lens' Robot Bool---- | Does this robot wish to self destruct?-selfDestruct :: Lens' Robot Bool---- | Diagnostic and operational tracking of CESK steps or other activity-activityCounts :: Lens' Robot ActivityCounts---- | Is the robot currently running an atomic block?-runningAtomic :: Lens' Robot Bool---- | A general function for creating robots.-mkRobot ::- -- | ID number of the robot.- RobotID phase ->- -- | ID number of the robot's parent, if it has one.- Maybe Int ->- -- | Name of the robot.- Text ->- -- | Description of the robot.- Document Syntax ->- -- | Initial location.- RobotLocation phase ->- -- | Initial heading/direction.- Heading ->- -- | Robot display.- Display ->- -- | Initial CESK machine.- CESK ->- -- | Equipped devices.- [Entity] ->- -- | Initial inventory.- [(Count, Entity)] ->- -- | Should this be a system robot?- Bool ->- -- | Is this robot heavy?- Bool ->- -- | Unwalkable entities- Set EntityName ->- -- | Creation date- TimeSpec ->- RobotR phase-mkRobot rid pid name descr loc dir disp m devs inv sys heavy unwalkables ts =- RobotR- { _robotEntity =- mkEntity disp name descr [] []- & entityOrientation ?~ dir- & entityInventory .~ fromElems inv- , _equippedDevices = inst- , _robotCapabilities = inventoryCapabilities inst- , _robotLog = Seq.empty- , _robotLogUpdated = False- , _robotLocation = loc- , _robotContext = emptyRobotContext- , _robotID = rid- , _robotParentID = pid- , _robotHeavy = heavy- , _robotCreatedAt = ts- , _machine = m- , _systemRobot = sys- , _selfDestruct = False- , _activityCounts = emptyActivityCount- , _runningAtomic = False- , _unwalkableEntities = unwalkables- }- where- inst = fromList devs---- | We can parse a robot from a YAML file if we have access to an--- 'EntityMap' in which we can look up the names of entities.-instance FromJSONE EntityMap TRobot where- parseJSONE = withObjectE "robot" $ \v -> do- -- Note we can't generate a unique ID here since we don't have- -- access to a 'State GameState' effect; a unique ID will be- -- filled in later when adding the robot to the world.- sys <- liftE $ v .:? "system" .!= False- let defDisplay = defaultRobotDisplay & invisible .~ sys-- mkRobot () Nothing- <$> liftE (v .: "name")- <*> liftE (v .:? "description" .!= mempty)- <*> liftE (v .:? "loc")- <*> liftE (v .:? "dir" .!= zero)- <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay)- <*> liftE (mkMachine <$> (v .:? "program"))- <*> v ..:? "devices" ..!= []- <*> v ..:? "inventory" ..!= []- <*> pure sys- <*> liftE (v .:? "heavy" .!= False)- <*> liftE (v .:? "unwalkable" ..!= mempty)- <*> pure 0- where- mkMachine Nothing = Out VUnit emptyStore []- mkMachine (Just pt) = initMachine pt mempty emptyStore--(.=?) :: (Ae.KeyValue a, Ae.ToJSON v, Eq v) => Ae.Key -> v -> v -> Maybe a-(.=?) n v defaultVal = if defaultVal /= v then Just $ n Ae..= v else Nothing--(.==) :: (Ae.KeyValue a, Ae.ToJSON v) => Ae.Key -> v -> Maybe a-(.==) n v = Just $ n Ae..= v--instance Ae.ToJSON Robot where- toJSON r =- Ae.object $- catMaybes- [ "id" .== (r ^. robotID)- , "name" .== (r ^. robotEntity . entityDisplay)- , "description" .=? (r ^. robotEntity . entityDescription) $ mempty- , "loc" .== (r ^. robotLocation)- , "dir" .=? (r ^. robotEntity . entityOrientation) $ zero- , "display" .=? (r ^. robotDisplay) $ (defaultRobotDisplay & invisible .~ sys)- , "program" .== (r ^. machine)- , "devices" .=? (map (^. _2 . entityName) . elems $ r ^. equippedDevices) $ []- , "inventory" .=? (map (_2 %~ view entityName) . elems $ r ^. robotInventory) $ []- , "system" .=? sys $ False- , "heavy" .=? (r ^. robotHeavy) $ False- , "log" .=? (r ^. robotLog) $ mempty- , -- debug- "capabilities" .=? (r ^. robotCapabilities) $ mempty- , "logUpdated" .=? (r ^. robotLogUpdated) $ False- , "context" .=? (r ^. robotContext) $ emptyRobotContext- , "parent" .=? (r ^. robotParentID) $ Nothing- , "createdAt" .=? (r ^. robotCreatedAt) $ 0- , "selfDestruct" .=? (r ^. selfDestruct) $ False- , "activity" .=? (r ^. activityCounts) $ emptyActivityCount- , "runningAtomic" .=? (r ^. runningAtomic) $ False- ]- where- sys = r ^. systemRobot---- | Is the robot actively in the middle of a computation?-isActive :: Robot -> Bool-{-# INLINE isActive #-}-isActive = isNothing . getResult---- | "Active" robots include robots that are waiting; 'wantsToStep' is--- true if the robot actually wants to take another step right now--- (this is a /subset/ of active robots).-wantsToStep :: TickNumber -> Robot -> Bool-wantsToStep now robot- | not (isActive robot) = False- | otherwise = maybe True (now >=) (waitingUntil robot)---- | The time until which the robot is waiting, if any.-waitingUntil :: Robot -> Maybe TickNumber-waitingUntil robot =- case _machine robot of- Waiting time _ -> Just time- _ -> Nothing---- | Get the result of the robot's computation if it is finished.-getResult :: Robot -> Maybe (Value, Store)-{-# INLINE getResult #-}-getResult = finalValue . view machine--hearingDistance :: (Num i) => i-hearingDistance = 32
@@ -1,305 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Scenarios are standalone worlds with specific starting and winning--- conditions, which can be used both for building interactive--- tutorials and for standalone puzzles and scenarios.-module Swarm.Game.Scenario (- -- * WorldDescription- PCell (..),- Cell,- PWorldDescription (..),- WorldDescription,- IndexedTRobot,-- -- * Scenario- Scenario (..),-- -- ** Fields- scenarioVersion,- scenarioName,- scenarioAuthor,- scenarioDescription,- scenarioCreative,- scenarioSeed,- scenarioAttrs,- scenarioEntities,- scenarioRecipes,- scenarioKnown,- scenarioWorlds,- scenarioNavigation,- scenarioRobots,- scenarioObjectives,- scenarioSolution,- scenarioStepsPerTick,-- -- * Loading from disk- loadScenario,- loadScenarioFile,- getScenarioPath,- loadStandaloneScenario,-) where--import Control.Arrow ((&&&))-import Control.Carrier.Throw.Either (runThrow)-import Control.Effect.Lift (Lift, sendIO)-import Control.Effect.Throw-import Control.Lens hiding (from, (.=), (<.>))-import Control.Monad (filterM, unless, (<=<))-import Data.Aeson-import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.List.NonEmpty qualified as NE-import Data.Map qualified as M-import Data.Maybe (catMaybes, isNothing, listToMaybe)-import Data.Sequence (Seq)-import Data.Text (Text)-import Data.Text qualified as T-import Swarm.Game.Entity-import Swarm.Game.Failure-import Swarm.Game.Location-import Swarm.Game.Recipe-import Swarm.Game.ResourceLoading (getDataFileNameSafe)-import Swarm.Game.Robot (TRobot)-import Swarm.Game.Scenario.Objective-import Swarm.Game.Scenario.Objective.Validation-import Swarm.Game.Scenario.RobotLookup-import Swarm.Game.Scenario.Style-import Swarm.Game.Scenario.Topography.Cell-import Swarm.Game.Scenario.Topography.Navigation.Portal-import Swarm.Game.Scenario.Topography.Structure qualified as Structure-import Swarm.Game.Scenario.Topography.WorldDescription-import Swarm.Game.Universe-import Swarm.Game.World.Load (loadWorlds)-import Swarm.Game.World.Typecheck (WorldMap)-import Swarm.Language.Pipeline (ProcessedTerm)-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Syntax (Syntax)-import Swarm.Language.Text.Markdown (Document)-import Swarm.Util (binTuples, failT)-import Swarm.Util.Effect (ignoreWarnings, throwToMaybe, withThrow)-import Swarm.Util.Lens (makeLensesNoSigs)-import Swarm.Util.Yaml-import System.Directory (doesFileExist)-import System.FilePath ((<.>), (</>))----------------------------------------------------------------- Scenario----------------------------------------------------------------- | A 'Scenario' contains all the information to describe a--- scenario.-data Scenario = Scenario- { _scenarioVersion :: Int- , _scenarioName :: Text- , _scenarioAuthor :: Maybe Text- , _scenarioDescription :: Document Syntax- , _scenarioCreative :: Bool- , _scenarioSeed :: Maybe Int- , _scenarioAttrs :: [CustomAttr]- , _scenarioEntities :: EntityMap- , _scenarioRecipes :: [Recipe Entity]- , _scenarioKnown :: [Text]- , _scenarioWorlds :: NonEmpty WorldDescription- , _scenarioNavigation :: Navigation (M.Map SubworldName) Location- , _scenarioRobots :: [TRobot]- , _scenarioObjectives :: [Objective]- , _scenarioSolution :: Maybe ProcessedTerm- , _scenarioStepsPerTick :: Maybe Int- }- deriving (Show)--makeLensesNoSigs ''Scenario--instance FromJSONE (EntityMap, WorldMap) Scenario where- parseJSONE = withObjectE "scenario" $ \v -> do- -- parse custom entities- emRaw <- liftE (v .:? "entities" .!= [])- em <- case run . runThrow $ buildEntityMap emRaw of- Right x -> return x- Left x -> failT [prettyText @LoadingFailure x]-- -- Save the passed in WorldMap for later- worldMap <- snd <$> getE-- -- Get rid of WorldMap from context locally, and combine EntityMap- -- with any custom entities parsed above- localE fst $ withE em $ do- -- parse 'known' entity names and make sure they exist- known <- liftE (v .:? "known" .!= [])- em' <- getE- case filter (isNothing . (`lookupEntityName` em')) known of- [] -> return ()- unk -> failT ["Unknown entities in 'known' list:", T.intercalate ", " unk]-- -- parse robots and build RobotMap- rs <- v ..: "robots"- let rsMap = buildRobotMap rs-- rootLevelSharedStructures :: Structure.InheritedStructureDefs <-- localE (,rsMap) $- v ..:? "structures" ..!= []-- allWorlds <- localE (worldMap,rootLevelSharedStructures,,rsMap) $ do- rootWorld <- v ..: "world"- subworlds <- v ..:? "subworlds" ..!= []- return $ rootWorld :| subworlds-- let worldsByName = binTuples $ NE.toList $ NE.map (worldName &&& id) allWorlds- dupedNames = M.keys $ M.filter ((> 1) . length) worldsByName- unless (null dupedNames) $- failT- [ "Subworld names are not unique:"- , T.intercalate ", " $ map renderWorldName dupedNames- ]-- let mergedWaypoints =- M.fromList $- map (worldName &&& runIdentity . waypoints . navigation) $- NE.toList allWorlds-- mergedPortals <-- validatePortals- . Navigation mergedWaypoints- . M.unions- . map (portals . navigation)- $ NE.toList allWorlds-- let mergedNavigation = Navigation mergedWaypoints mergedPortals-- Scenario- <$> liftE (v .: "version")- <*> liftE (v .: "name")- <*> liftE (v .:? "author")- <*> liftE (v .:? "description" .!= "")- <*> liftE (v .:? "creative" .!= False)- <*> liftE (v .:? "seed")- <*> liftE (v .:? "attrs" .!= [])- <*> pure em- <*> v ..:? "recipes" ..!= []- <*> pure known- <*> pure allWorlds- <*> pure mergedNavigation- <*> pure rs- <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)- <*> liftE (v .:? "solution")- <*> liftE (v .:? "stepsPerTick")------------------------------------------------------- Lenses---- | The version number of the scenario schema. Currently, this--- should always be 1, but it is ignored. In the future, this may--- be used to convert older formats to newer ones, or simply to--- print a nice error message when we can't read an older format.-scenarioVersion :: Lens' Scenario Int---- | The name of the scenario.-scenarioName :: Lens' Scenario Text---- | The author of the scenario.-scenarioAuthor :: Lens' Scenario (Maybe Text)---- | A high-level description of the scenario, shown /e.g./ in the--- menu.-scenarioDescription :: Lens' Scenario (Document Syntax)---- | Whether the scenario should start in creative mode.-scenarioCreative :: Lens' Scenario Bool---- | The seed used for the random number generator. If @Nothing@, use--- a random seed / prompt the user for the seed.-scenarioSeed :: Lens' Scenario (Maybe Int)---- | Custom attributes defined in the scenario.-scenarioAttrs :: Lens' Scenario [CustomAttr]---- | Any custom entities used for this scenario.-scenarioEntities :: Lens' Scenario EntityMap---- | Any custom recipes used in this scenario.-scenarioRecipes :: Lens' Scenario [Recipe Entity]---- | List of entities that should be considered "known", so robots do--- not have to scan them.-scenarioKnown :: Lens' Scenario [Text]---- | The subworlds of the scenario.--- The "root" subworld shall always be at the head of the list, by construction.-scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription)---- | Waypoints and inter-world portals-scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location)---- | The starting robots for the scenario. Note this should--- include the base.-scenarioRobots :: Lens' Scenario [TRobot]---- | A sequence of objectives for the scenario (if any).-scenarioObjectives :: Lens' Scenario [Objective]---- | An optional solution of the scenario, expressed as a--- program of type @cmd a@. This is useful for automated--- testing of the win condition.-scenarioSolution :: Lens' Scenario (Maybe ProcessedTerm)---- | Optionally, specify the maximum number of steps each robot may--- take during a single tick.-scenarioStepsPerTick :: Lens' Scenario (Maybe Int)---------------------------------------------------------------- Loading scenarios---------------------------------------------------------------getScenarioPath ::- (Has (Lift IO) sig m) =>- FilePath ->- m (Maybe FilePath)-getScenarioPath scenario = do- libScenario <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" </> scenario- libScenarioExt <- throwToMaybe @SystemFailure $ getDataFileNameSafe Scenarios $ "scenarios" </> scenario <.> "yaml"- let candidates = catMaybes [Just scenario, libScenarioExt, libScenario]- listToMaybe <$> sendIO (filterM doesFileExist candidates)---- | Load a scenario with a given name from disk, given an entity map--- to use. This function is used if a specific scenario is--- requested on the command line.-loadScenario ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- FilePath ->- EntityMap ->- WorldMap ->- m (Scenario, FilePath)-loadScenario scenario em worldMap = do- mfileName <- getScenarioPath scenario- fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName- (,fileName) <$> loadScenarioFile em worldMap fileName---- | Load a scenario from a file.-loadScenarioFile ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- EntityMap ->- WorldMap ->- FilePath ->- m Scenario-loadScenarioFile em worldMap fileName =- (withThrow adaptError . (liftEither <=< sendIO)) $- decodeFileEitherE (em, worldMap) fileName- where- adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml--loadStandaloneScenario ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- FilePath ->- m (Scenario, (WorldMap, EntityMap, [Recipe Entity]))-loadStandaloneScenario fp = do- entities <- loadEntities- recipes <- loadRecipes entities- worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities- scene <- fst <$> loadScenario fp entities worlds- return (scene, (worlds, entities, recipes))
@@ -1,209 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.Objective where--import Control.Applicative ((<|>))-import Control.Lens hiding (from, (<.>))-import Data.Aeson-import Data.Set qualified as Set-import Data.Text (Text)-import GHC.Generics (Generic)-import Servant.Docs (ToSample)-import Servant.Docs qualified as SD-import Swarm.Game.Achievement.Definitions-import Swarm.Game.Scenario.Objective.Logic as L-import Swarm.Language.Pipeline (ProcessedTerm)-import Swarm.Language.Syntax (Syntax)-import Swarm.Language.Text.Markdown qualified as Markdown-import Swarm.Util.Lens (makeLensesNoSigs)----------------------------------------------------------------- Scenario objectives---------------------------------------------------------------data PrerequisiteConfig = PrerequisiteConfig- { previewable :: Bool- -- ^ Typically, only the currently "active" objectives are- -- displayed to the user in the Goals dialog. An objective- -- is "active" if all of its prerequisites are met.- --- -- However, some objectives may be "high-level", in that they may- -- explain the broader intention behind potentially multiple- -- prerequisites.- --- -- Set this option to 'True' to display this goal in the "upcoming" section even- -- if the objective has currently unmet prerequisites.- , logic :: Prerequisite ObjectiveLabel- -- ^ Boolean expression of dependencies upon other objectives. Variables in this expression- -- are the "id"s of other objectives, and become "true" if the corresponding objective is completed.- -- The "condition" of the objective at hand shall not be evaluated until its- -- prerequisite expression evaluates as 'True'.- --- -- Note that the achievement of these objective dependencies is- -- persistent; once achieved, they still count even if their "condition"- -- might not still hold. The condition is never re-evaluated once true.- }- deriving (Eq, Show, Generic, ToJSON)--instance FromJSON PrerequisiteConfig where- -- Parsing JSON/YAML 'PrerequisiteConfig' has a shorthand option- -- in which the boolean expression can be written directly,- -- bypassing the "logic" key.- -- Furthermore, an "Id" in a boolean expressions can be written- -- as a bare string without needing the "id" key.- parseJSON val = preLogic val <|> preObject val- where- preObject = withObject "prerequisite" $ \v ->- PrerequisiteConfig- <$> (v .:? "previewable" .!= False)- <*> v .: "logic"- preLogic = fmap (PrerequisiteConfig False) . parseJSON---- | An objective is a condition to be achieved by a player in a--- scenario.-data Objective = Objective- { _objectiveGoal :: Markdown.Document Syntax- , _objectiveTeaser :: Maybe Text- , _objectiveCondition :: ProcessedTerm- , _objectiveId :: Maybe ObjectiveLabel- , _objectiveOptional :: Bool- , _objectivePrerequisite :: Maybe PrerequisiteConfig- , _objectiveHidden :: Bool- , _objectiveAchievement :: Maybe AchievementInfo- }- deriving (Eq, Show, Generic, ToJSON)--makeLensesNoSigs ''Objective--instance ToSample Objective where- toSamples _ = SD.noSamples---- | An explanation of the goal of the objective, shown to the player--- during play. It is represented as a list of paragraphs.-objectiveGoal :: Lens' Objective (Markdown.Document Syntax)---- | A very short (3-5 words) description of the goal for--- displaying on the left side of the Objectives modal.-objectiveTeaser :: Lens' Objective (Maybe Text)---- | A winning condition for the objective, expressed as a--- program of type @cmd bool@. By default, this program will be--- run to completion every tick (the usual limits on the number--- of CESK steps per tick do not apply).-objectiveCondition :: Lens' Objective ProcessedTerm---- | Optional name by which this objective may be referenced--- as a prerequisite for other objectives.-objectiveId :: Lens' Objective (Maybe Text)---- | Indicates whether the objective is not required in order--- to "win" the scenario. Useful for (potentially hidden) achievements.--- If the field is not supplied, it defaults to False (i.e. the--- objective is mandatory to "win").-objectiveOptional :: Lens' Objective Bool---- | Dependencies upon other objectives-objectivePrerequisite :: Lens' Objective (Maybe PrerequisiteConfig)---- | Whether the goal is displayed in the UI before completion.--- The goal will always be revealed after it is completed.------ This attribute often goes along with an Achievement.-objectiveHidden :: Lens' Objective Bool---- | An optional achievement that is to be registered globally--- when this objective is completed.-objectiveAchievement :: Lens' Objective (Maybe AchievementInfo)--instance FromJSON Objective where- parseJSON = withObject "objective" $ \v ->- Objective- <$> (v .:? "goal" .!= mempty)- <*> (v .:? "teaser")- <*> (v .: "condition")- <*> (v .:? "id")- <*> (v .:? "optional" .!= False)- <*> (v .:? "prerequisite")- <*> (v .:? "hidden" .!= False)- <*> (v .:? "achievement")--data CompletionBuckets = CompletionBuckets- { incomplete :: [Objective]- , completed :: [Objective]- , unwinnable :: [Objective]- }- deriving (Show, Generic, FromJSON, ToJSON)---- | TODO: #1044 Could also add an "ObjectiveFailed" constructor...-newtype Announcement- = ObjectiveCompleted Objective- deriving (Show, Generic, ToJSON)--data ObjectiveCompletion = ObjectiveCompletion- { completionBuckets :: CompletionBuckets- -- ^ This is the authoritative "completion status"- -- for all objectives.- -- Note that there is a separate Set to store the- -- completion status of prerequisite objectives, which- -- must be carefully kept in sync with this.- -- Those prerequisite objectives are required to have- -- labels, but other objectives are not.- -- Therefore only prerequisites exist in the completion- -- map keyed by label.- , completedIDs :: Set.Set ObjectiveLabel- }- deriving (Show, Generic, FromJSON, ToJSON)---- | Concatenates all incomplete and completed objectives.-listAllObjectives :: CompletionBuckets -> [Objective]-listAllObjectives (CompletionBuckets x y z) = x <> y <> z--addCompleted :: Objective -> ObjectiveCompletion -> ObjectiveCompletion-addCompleted obj (ObjectiveCompletion buckets cmplIds) =- ObjectiveCompletion newBuckets newCmplById- where- newBuckets =- buckets- { completed = obj : completed buckets- }- newCmplById = case _objectiveId obj of- Nothing -> cmplIds- Just lbl -> Set.insert lbl cmplIds--addUnwinnable :: Objective -> ObjectiveCompletion -> ObjectiveCompletion-addUnwinnable obj (ObjectiveCompletion buckets cmplIds) =- ObjectiveCompletion newBuckets cmplIds- where- newBuckets =- buckets- { unwinnable = obj : unwinnable buckets- }--setIncomplete ::- ([Objective] -> [Objective]) ->- ObjectiveCompletion ->- ObjectiveCompletion-setIncomplete f (ObjectiveCompletion buckets cmplIds) =- ObjectiveCompletion newBuckets cmplIds- where- newBuckets =- buckets- { incomplete = f $ incomplete buckets- }--addIncomplete :: Objective -> ObjectiveCompletion -> ObjectiveCompletion-addIncomplete obj = setIncomplete (obj :)---- | Returns the "ObjectiveCompletion" with the "incomplete" goals--- extracted to a separate tuple member.--- This is intended as input to a "fold".-extractIncomplete :: ObjectiveCompletion -> (ObjectiveCompletion, [Objective])-extractIncomplete oc =- (withoutIncomplete, incompleteGoals)- where- incompleteGoals = incomplete $ completionBuckets oc- withoutIncomplete = setIncomplete (const []) oc
@@ -1,152 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Utilities for performing graph analysis on Objective prerequisites-module Swarm.Game.Scenario.Objective.Graph where--import Control.Arrow ((&&&))-import Data.Aeson-import Data.BoolExpr (Signed (Positive))-import Data.BoolExpr qualified as BE-import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp)-import Data.Map (Map)-import Data.Map.Strict qualified as M-import Data.Maybe (mapMaybe)-import Data.Set qualified as Set-import Data.Text qualified as T-import Data.Tuple (swap)-import GHC.Generics (Generic)-import Servant.Docs (ToSample)-import Servant.Docs qualified as SD-import Swarm.Game.Scenario.Objective-import Swarm.Game.Scenario.Objective.Logic as L-import Swarm.Game.Scenario.Objective.WinCheck---- | This is only needed for constructing a Graph,--- which requires all nodes to have a key.-data ObjectiveId- = Label (Signed ObjectiveLabel)- | -- | for unlabeled objectives- Ordinal Int- deriving (Eq, Ord, Show, Generic, ToJSON)--data GraphInfo = GraphInfo- { actualGraph :: Graph- , isAcyclic :: Bool- , sccInfo :: [SCC Objective]- , nodeIDs :: [ObjectiveId]- }- deriving (Show, Generic, ToJSON)--instance ToJSON (SCC Objective) where- toJSON = String . T.pack . show--instance ToJSON Graph where- toJSON = String . T.pack . show--instance ToSample GraphInfo where- toSamples _ = SD.noSamples--getConstFromSigned :: BE.Signed a -> a-getConstFromSigned = \case- BE.Positive x -> x- BE.Negative x -> x---- | Collect all of the constants that have a negation.--- This is necessary for enumerating all of the distinct--- nodes when constructing a Graph, as we treat a constant--- and its negation as distinct nodes.-getNegatedIds :: [Objective] -> Map ObjectiveLabel Objective-getNegatedIds objs =- M.fromList $ mapMaybe f allConstants- where- objectivesById = getObjectivesById objs-- allPrereqExpressions = mapMaybe _objectivePrerequisite objs- allConstants =- mapMaybe onlyNegative- . Set.toList- . Set.unions- . map (getDistinctConstants . logic)- $ allPrereqExpressions-- f = sequenceA . \x -> (x, M.lookup x objectivesById)-- onlyNegative = \case- BE.Negative x -> Just x- _ -> Nothing--getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective-getObjectivesById objs =- M.fromList $- map swap $- mapMaybe (sequenceA . (id &&& _objectiveId)) objs---- | Uses the textual labels for those objectives that--- have them, and assigns arbitrary integer IDs for--- the remaining.------ Only necessary for constructing a "Graph".-assignIds :: [Objective] -> Map ObjectiveId Objective-assignIds objs =- unlabeledObjsMap <> labeledObjsMap- where- objectivesById = getObjectivesById objs-- labeledObjsMap = M.mapKeys (Label . Positive) objectivesById-- unlabeledObjs = filter (null . _objectiveId) objs- unlabeledObjsMap = M.fromList $ zipWith (\x y -> (Ordinal x, y)) [0 ..] unlabeledObjs--type Edges = [(Objective, ObjectiveId, [ObjectiveId])]---- | NOTE: Based strictly on the goal labels, the graph could--- potentially contain a cycle, if there exist--- mutually-exclusive goals. That is, if goal A depends on the NOT--- of "goal B". Goal B could then also depend on "NOT Goal A" (re-enforcing the--- mutual-exclusivity), or it could mandate a completion order, e.g.:--- Goal A and Goal B are simultaneously available to pursue. However, if the--- player completes Goal B first, then it closes off the option to complete--- Goal A. However, if Goal A is completed first, then the user is also allowed--- to complete Goal B.------ To avoid a "cycle" in this circumstance, "A" needs to exist as a distinct node--- from "NOT A" in the graph.-makeGraph :: Edges -> Graph-makeGraph edges =- myGraph- where- (myGraph, _, _) = graphFromEdges edges--makeGraphEdges :: [Objective] -> Edges-makeGraphEdges objectives =- rootTuples <> negatedTuples- where- rootTuples = map f $ M.toList $ assignIds objectives- negatedTuples = map gg $ M.toList $ getNegatedIds objectives- gg (k, v) = (v, Label $ BE.Negative k, [])-- f (k, v) = (v, k, maybe [] (map Label . g) $ _objectivePrerequisite v)- g = Set.toList . getDistinctConstants . logic--isAcyclicGraph :: [SCC Objective] -> Bool-isAcyclicGraph =- all isAcyclicVertex- where- isAcyclicVertex = \case- AcyclicSCC _ -> True- _ -> False--makeGraphInfo :: ObjectiveCompletion -> GraphInfo-makeGraphInfo oc =- GraphInfo- (makeGraph edges)- (isAcyclicGraph connectedComponents)- connectedComponents- (M.keys $ assignIds objs)- where- edges = makeGraphEdges objs- connectedComponents = stronglyConnComp edges- objs = listAllObjectives $ completionBuckets oc
@@ -1,49 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ A model for defining boolean expressions for Objective prerequisites.------ This model is intended to be user-facing in the .yaml files, and is--- distinct from that in 'Data.BoolExpr'.-module Swarm.Game.Scenario.Objective.Logic where--import Control.Applicative ((<|>))-import Data.Aeson-import Data.BoolExpr-import Data.Char (toLower)-import Data.List.NonEmpty (NonEmpty)-import Data.Text (Text)-import GHC.Generics (Generic)--type ObjectiveLabel = Text---- | In contrast with the "BoolExpr" type,--- "And" and "Or" can have /one or more/ children--- instead of /exactly two/.-data Prerequisite a- = And (NonEmpty (Prerequisite a))- | Or (NonEmpty (Prerequisite a))- | Not (Prerequisite a)- | Id a- deriving (Eq, Show, Generic, Functor, Foldable)--prerequisiteOptions :: Options-prerequisiteOptions =- defaultOptions- { sumEncoding = ObjectWithSingleField- , constructorTagModifier = map toLower- }--instance ToJSON (Prerequisite ObjectiveLabel) where- toJSON = genericToJSON prerequisiteOptions--instance FromJSON (Prerequisite ObjectiveLabel) where- parseJSON x = preString x <|> genericParseJSON prerequisiteOptions x- where- preString = withText "prerequisite" $ pure . Id--toBoolExpr :: Prerequisite a -> BoolExpr a-toBoolExpr (And xs) = foldr1 BAnd (fmap toBoolExpr xs)-toBoolExpr (Or xs) = foldr1 BOr (fmap toBoolExpr xs)-toBoolExpr (Not x) = BNot $ toBoolExpr x-toBoolExpr (Id x) = BConst $ pure x
@@ -1,51 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Validity checking for 'Objective' prerequisites-module Swarm.Game.Scenario.Objective.Validation where--import Control.Monad (unless)-import Data.Foldable (for_, toList)-import Data.Graph (stronglyConnComp)-import Data.Maybe (mapMaybe)-import Data.Set qualified as Set-import Data.Text qualified as T-import Swarm.Game.Scenario.Objective-import Swarm.Game.Scenario.Objective.Graph-import Swarm.Util (failT, quote)---- | Performs monadic validation before returning--- the "pure" construction of a wrapper record.--- This validation entails:------ 1. Ensuring that all goal references utilized in prerequisites--- actually exist--- 2. Ensuring that the graph of dependencies is acyclic.-validateObjectives ::- MonadFail m =>- [Objective] ->- m [Objective]-validateObjectives objectives = do- for_ objectives $ \x -> case _objectivePrerequisite x of- Just p ->- unless (null remaining) $- failT- [ "Reference to undefined objective(s)"- , T.intercalate ", " (map quote $ Set.toList remaining) <> "."- , "Defined are:"- , T.intercalate ", " (map quote $ Set.toList allIds)- ]- where- refs = Set.fromList $ toList $ logic p- remaining = Set.difference refs allIds- Nothing -> return ()-- unless (isAcyclicGraph connectedComponents) $- failT ["There are dependency cycles in the prerequisites."]-- return objectives- where- connectedComponents = stronglyConnComp $ makeGraphEdges objectives- allIds = Set.fromList $ mapMaybe _objectiveId objectives
@@ -1,96 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Utilities to check whether conditions are met for a game win/loss.-module Swarm.Game.Scenario.Objective.WinCheck where--import Data.Aeson-import Data.BoolExpr qualified as BE-import Data.BoolExpr.Simplify qualified as Simplify-import Data.List (partition)-import Data.Map qualified as M-import Data.Set (Set)-import Data.Set qualified as Set-import GHC.Generics (Generic)-import Servant.Docs (ToSample)-import Servant.Docs qualified as SD-import Swarm.Game.Scenario.Objective-import Swarm.Game.Scenario.Objective.Logic as L---- | We have "won" if all of the "unwinnable" or remaining "incomplete" objectives are "optional".-didWin :: ObjectiveCompletion -> Bool-didWin oc = all _objectiveOptional $ incomplete buckets <> unwinnable buckets- where- buckets = completionBuckets oc---- | We have "lost" if any of the "unwinnable" objectives not "optional".-didLose :: ObjectiveCompletion -> Bool-didLose oc = not $ all _objectiveOptional $ unwinnable buckets- where- buckets = completionBuckets oc--isPrereqsSatisfied :: ObjectiveCompletion -> Objective -> Bool-isPrereqsSatisfied completions =- maybe True f . _objectivePrerequisite- where- f = BE.evalBoolExpr getTruth . L.toBoolExpr . logic-- getTruth :: ObjectiveLabel -> Bool- getTruth label = Set.member label $ completedIDs completions--isUnwinnablePrereq :: Set ObjectiveLabel -> Prerequisite ObjectiveLabel -> Bool-isUnwinnablePrereq completedObjectives =- Simplify.cannotBeTrue . Simplify.replace boolMap . L.toBoolExpr- where- boolMap =- M.fromList $- map (,True) $- Set.toList completedObjectives--isUnwinnable :: ObjectiveCompletion -> Objective -> Bool-isUnwinnable completions obj =- maybe False (isUnwinnablePrereq (completedIDs completions) . logic) $ _objectivePrerequisite obj---- | The first element of the returned tuple consists of "active" objectives,--- the second element "inactive".-partitionActiveObjectives :: ObjectiveCompletion -> ([Objective], [Objective])-partitionActiveObjectives oc =- partition (isPrereqsSatisfied oc) $- incomplete $- completionBuckets oc--getActiveObjectives :: ObjectiveCompletion -> [Objective]-getActiveObjectives =- fst . partitionActiveObjectives--deriving instance Generic (BE.Signed ObjectiveLabel)-deriving instance ToJSON (BE.Signed ObjectiveLabel)---- | For debugging only (via Web API)-data PrereqSatisfaction = PrereqSatisfaction- { objective :: Objective- , deps :: Set (BE.Signed ObjectiveLabel)- , prereqsSatisfied :: Bool- }- deriving (Generic, ToJSON)--instance ToSample PrereqSatisfaction where- toSamples _ = SD.noSamples---- | Used only by the web interface for debugging-getSatisfaction :: ObjectiveCompletion -> [PrereqSatisfaction]-getSatisfaction oc =- map f $- listAllObjectives $- completionBuckets oc- where- f y =- PrereqSatisfaction- y- (maybe mempty (getDistinctConstants . logic) $ _objectivePrerequisite y)- (isPrereqsSatisfied oc y)--getDistinctConstants :: (Ord a) => Prerequisite a -> Set (BE.Signed a)-getDistinctConstants = Set.fromList . BE.constants . toBoolExpr
@@ -1,60 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.RobotLookup where--import Control.Lens hiding (from, (<.>))-import Data.Aeson (FromJSON)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Text (Text)-import Data.Text qualified as T-import GHC.Generics (Generic)-import Swarm.Game.Entity-import Swarm.Game.Robot (TRobot, trobotName)-import Swarm.Util (failT, quote)-import Swarm.Util.Yaml----------------------------------------------------------------- Robot map---------------------------------------------------------------newtype RobotName = RobotName Text- deriving (Show, Eq, Ord, Generic, FromJSON)---- | A robot template paired with its definition's index within--- the Scenario file-type IndexedTRobot = (Int, TRobot)---- | A map from names to robots, used to look up robots in scenario--- descriptions.-type RobotMap = Map RobotName IndexedTRobot---- | Create a 'RobotMap' from a list of robot templates.-buildRobotMap :: [TRobot] -> RobotMap-buildRobotMap rs = M.fromList $ zipWith (\x y -> (RobotName $ view trobotName y, (x, y))) [0 ..] rs----------------------------------------------------------------- Lookup utilities----------------------------------------------------------------- | Look up a thing by name, throwing a parse error if it is not--- found.-getThing :: Show k => Text -> (k -> m -> Maybe a) -> k -> ParserE m a-getThing thing lkup name = do- m <- getE- case lkup name m of- Nothing -> failT ["Unknown", thing, "name:", quote $ T.pack $ show name]- Just a -> return a---- | Look up an entity by name in an 'EntityMap', throwing a parse--- error if it is not found.-getEntity :: Text -> ParserE EntityMap Entity-getEntity = getThing "entity" lookupEntityName---- | Look up a robot by name in a 'RobotMap', throwing a parse error--- if it is not found.-getRobot :: RobotName -> ParserE RobotMap IndexedTRobot-getRobot = getThing "robot" M.lookup
@@ -1,164 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wno-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Types and records for updating and retrieving--- the best scores for a scenario.-module Swarm.Game.Scenario.Scoring.Best where--import Control.Arrow ((&&&))-import Control.Lens hiding (from, (<.>))-import Data.Aeson (- genericParseJSON,- genericToEncoding,- genericToJSON,- )-import Data.Function (on)-import Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (mapMaybe)-import Data.Text (Text)-import Data.Time (ZonedTime, zonedTimeToUTC)-import Data.Yaml as Y-import GHC.Generics (Generic)-import Swarm.Game.Scenario.Scoring.CodeSize-import Swarm.Game.Scenario.Scoring.ConcreteMetrics-import Swarm.Game.Scenario.Scoring.GenericMetrics-import Swarm.Util.Lens (makeLensesNoSigs)---- * Some orphan ZonedTime instances--instance Eq ZonedTime where- (==) = (==) `on` zonedTimeToUTC--instance Ord ZonedTime where- (<=) = (<=) `on` zonedTimeToUTC---- * High scores by various criteria--data BestByCriteria- = BestByTime- | BestByTicks- | BestByCharCount- | BestByAstSize- deriving (Eq, Ord, Bounded, Enum, Show)--describeCriteria :: BestByCriteria -> Text-describeCriteria = \case- BestByTime -> "time"- BestByTicks -> "ticks"- BestByCharCount -> "char count"- BestByAstSize -> "AST size"--data ProgressStats = ProgressStats- { _scenarioStarted :: ZonedTime- -- ^ Time when the scenario was started including time zone.- , _scenarioAttemptMetrics :: AttemptMetrics- }- deriving (Eq, Ord, Show, Read, Generic)--makeLenses ''ProgressStats--instance FromJSON ProgressStats where- parseJSON = genericParseJSON scenarioOptions--instance ToJSON ProgressStats where- toEncoding = genericToEncoding scenarioOptions- toJSON = genericToJSON scenarioOptions--type ProgressMetric = Metric ProgressStats---- * High scores by various criteria--data BestRecords = BestRecords- { _scenarioBestByTime :: ProgressMetric- , _scenarioBestByTicks :: ProgressMetric- , _scenarioBestByCharCount :: ProgressMetric- , _scenarioBestByAstSize :: ProgressMetric- }- deriving (Eq, Ord, Read, Generic)--instance Show BestRecords where- show (BestRecords a b c d) =- unlines $- map- angleBracket- [ show a- , show b- , show c- , show d- ]- where- angleBracket :: String -> String- angleBracket x = "<" <> x <> ">"--emptyBest :: ZonedTime -> BestRecords-emptyBest t = BestRecords x x x x- where- x = Metric Attempted $ ProgressStats t emptyAttemptMetric--updateBest :: ProgressMetric -> BestRecords -> BestRecords-updateBest newPlayMetric (BestRecords oldA oldB oldC oldD) =- BestRecords- (bestTime oldA scenarioElapsed)- (bestTime oldB scenarioElapsedTicks)- (bestSize oldC sourceTextLength)- (bestSize oldD astSize)- where- f x y = chooseBetter y newPlayMetric x- bestTime x y = f x (Just . view (scenarioAttemptMetrics . scenarioDurationMetrics . y))- bestSize x y = f x (fmap y . view (scenarioAttemptMetrics . scenarioCodeMetrics))--makeLensesNoSigs ''BestRecords---- | The best status of the scenario, measured in real world time.-scenarioBestByTime :: Lens' BestRecords ProgressMetric---- | The best status of the scenario, measured in game ticks.-scenarioBestByTicks :: Lens' BestRecords ProgressMetric---- | The best code size of the scenario, measured in character count.-scenarioBestByCharCount :: Lens' BestRecords ProgressMetric---- | The best code size of the scenario, measured in AST size.-scenarioBestByAstSize :: Lens' BestRecords ProgressMetric--instance FromJSON BestRecords where- parseJSON = genericParseJSON scenarioOptions--instance ToJSON BestRecords where- toEncoding = genericToEncoding scenarioOptions- toJSON = genericToJSON scenarioOptions---- | Uses the start time of the play-attempt to de-dupe--- records that are from the same game. The start time should--- be sufficient to uniquely identify a game.-getBestGroups ::- BestRecords ->- [(Metric ProgressStats, NonEmpty BestByCriteria)]-getBestGroups =- rearrangeTuples . M.toList . bestToMap- where- groupByStartTime = NE.groupAllWith $ view scenarioStarted . getMetric . snd- rearrangeTuples = map (snd . NE.head &&& NE.map fst) . groupByStartTime-- bestToMap :: BestRecords -> Map BestByCriteria ProgressMetric- bestToMap (BestRecords t1 t2 s1 s2) =- M.fromList $ durationElements <> mapMaybe (traverse ensurePresent) codeSizeElements- where- durationElements =- [ (BestByTime, t1)- , (BestByTicks, t2)- ]- codeSizeElements =- [ (BestByCharCount, s1)- , (BestByAstSize, s2)- ]-- ensurePresent x =- (getMetric x ^. scenarioAttemptMetrics . scenarioCodeMetrics) >> Just x
@@ -1,35 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Types and utilities to compute code size--- in terms of textual length and AST nodes.-module Swarm.Game.Scenario.Scoring.CodeSize where--import Control.Monad (guard)-import Data.Aeson-import GHC.Generics (Generic)-import Swarm.Language.Module-import Swarm.Language.Pipeline-import Swarm.Language.Syntax--data CodeSizeDeterminators = CodeSizeDeterminators- { initialCode :: Maybe ProcessedTerm- , hasUsedREPL :: Bool- }- deriving (Show)--data ScenarioCodeMetrics = ScenarioCodeMetrics- { sourceTextLength :: Int- , astSize :: Int- }- deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)--codeSizeFromDeterminator :: CodeSizeDeterminators -> Maybe ScenarioCodeMetrics-codeSizeFromDeterminator (CodeSizeDeterminators maybeInitialCode usedRepl) = do- guard $ not usedRepl- ProcessedTerm (Module s@(Syntax' srcLoc _ _) _) _ _ <- maybeInitialCode- return $ ScenarioCodeMetrics (charCount srcLoc) (measureAstSize s)- where- charCount :: SrcLoc -> Int- charCount NoLoc = 0- charCount (SrcLoc start end) = end - start
@@ -1,60 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Data types and instances for specific scoring methods-module Swarm.Game.Scenario.Scoring.ConcreteMetrics where--import Control.Lens hiding (from, (<.>))-import Data.Aeson-import Data.Char (toLower)-import Data.Time (NominalDiffTime)-import GHC.Generics (Generic)-import Swarm.Game.CESK (TickNumber (..))-import Swarm.Game.Scenario.Scoring.CodeSize--scenarioOptions :: Options-scenarioOptions =- defaultOptions- { fieldLabelModifier = map toLower . drop (length ("_scenario" :: String))- }--data DurationMetrics = DurationMetrics- { _scenarioElapsed :: NominalDiffTime- -- ^ Time elapsed until winning the scenario.- , _scenarioElapsedTicks :: TickNumber- -- ^ Ticks elapsed until winning the scenario.- }- deriving (Eq, Ord, Show, Read, Generic)--makeLenses ''DurationMetrics--emptyDurationMetric :: DurationMetrics-emptyDurationMetric = DurationMetrics 0 $ TickNumber 0--instance FromJSON DurationMetrics where- parseJSON = genericParseJSON scenarioOptions--instance ToJSON DurationMetrics where- toEncoding = genericToEncoding scenarioOptions- toJSON = genericToJSON scenarioOptions--data AttemptMetrics = AttemptMetrics- { _scenarioDurationMetrics :: DurationMetrics- , _scenarioCodeMetrics :: Maybe ScenarioCodeMetrics- -- ^ Size of the user's program.- }- deriving (Eq, Ord, Show, Read, Generic)--emptyAttemptMetric :: AttemptMetrics-emptyAttemptMetric = AttemptMetrics emptyDurationMetric Nothing--makeLenses ''AttemptMetrics--instance FromJSON AttemptMetrics where- parseJSON = genericParseJSON scenarioOptions--instance ToJSON AttemptMetrics where- toEncoding = genericToEncoding scenarioOptions- toJSON = genericToJSON scenarioOptions
@@ -1,64 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Data types and functions applicable across different--- scoring methods.-module Swarm.Game.Scenario.Scoring.GenericMetrics where--import Data.Aeson-import Data.Ord (Down (Down))-import GHC.Generics (Generic)-import Swarm.Util (maxOn)---- | This is a subset of the "ScenarioStatus" type--- that excludes the "NotStarted" case.-data Progress- = Attempted- | Completed- deriving (Eq, Ord, Show, Read, Generic)--untaggedJsonOptions :: Options-untaggedJsonOptions =- defaultOptions- { sumEncoding = UntaggedValue- }--instance FromJSON Progress where- parseJSON = genericParseJSON untaggedJsonOptions--instance ToJSON Progress where- toJSON = genericToJSON untaggedJsonOptions--data Metric a = Metric Progress a- deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON)--getMetric :: Metric a -> a-getMetric (Metric _ x) = x---- | This encodes the notion of "more play is better"--- for incomplete games (rationale: more play = more fun),--- whereas "smaller inputs are better" for completed games.------ Since 'Maybe' has its own 'Ord' instance where--- @Nothing < Just x@ regardless of @x@, when we want to--- choose the minimum value we @fmap Down@ to ensure that--- the 'Just' is selected while inverting the ordering of--- the inner member.-chooseBetter ::- Ord a =>- -- | criteria; record field extractor- (b -> Maybe a) ->- -- | x- Metric b ->- -- | y- Metric b ->- Metric b-chooseBetter criteria (Metric Attempted x) (Metric Attempted y) =- Metric Attempted $ maxOn criteria x y-chooseBetter criteria (Metric Completed x) (Metric Completed y) =- Metric Completed $ maxOn (fmap Down . criteria) x y--- Having exhausted the possibilities where either both--- are Completed or both are Attempted, now we can just--- choose the Completed one.-chooseBetter _ x@(Metric Completed _) _ = x-chooseBetter _ _ y@(Metric Completed _) = y
@@ -1,135 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wno-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ High-level status of scenario play.--- Representation of progress, logic for updating.-module Swarm.Game.Scenario.Status where--import Control.Lens hiding (from, (<.>))-import Data.Aeson (- genericParseJSON,- genericToEncoding,- genericToJSON,- )-import Data.Function (on)-import Data.Time (ZonedTime, diffUTCTime, zonedTimeToUTC)-import Data.Yaml as Y-import GHC.Generics (Generic)-import Swarm.Game.CESK (TickNumber)-import Swarm.Game.Scenario-import Swarm.Game.Scenario.Scoring.Best-import Swarm.Game.Scenario.Scoring.CodeSize-import Swarm.Game.Scenario.Scoring.ConcreteMetrics-import Swarm.Game.Scenario.Scoring.GenericMetrics-import Swarm.Game.World.Gen (Seed)-import Swarm.Util.Lens (makeLensesNoSigs)---- | These launch parameters are used in a number of ways:------ * Serializing the seed/script path for saves--- * Holding parse status from form fields, including error info--- * Carrying fully-validated launch parameters.------ Type parameters are utilized to support all of these use cases.-data ParameterizableLaunchParams code f = LaunchParams- { seedVal :: f (Maybe Seed)- , initialCode :: f (Maybe code)- }--type SerializableLaunchParams = ParameterizableLaunchParams FilePath Identity-deriving instance Eq SerializableLaunchParams-deriving instance Ord SerializableLaunchParams-deriving instance Show SerializableLaunchParams-deriving instance Read SerializableLaunchParams-deriving instance Generic SerializableLaunchParams-deriving instance FromJSON SerializableLaunchParams-deriving instance ToJSON SerializableLaunchParams---- | A 'ScenarioStatus' stores the status of a scenario along with--- appropriate metadata: 'NotStarted', or 'Played'.--- The 'Played' status has two sub-states: 'Attempted' or 'Completed'.-data ScenarioStatus- = NotStarted- | Played- SerializableLaunchParams- ProgressMetric- BestRecords- deriving (Eq, Ord, Show, Read, Generic)--instance FromJSON ScenarioStatus where- parseJSON = genericParseJSON scenarioOptions--instance ToJSON ScenarioStatus where- toEncoding = genericToEncoding scenarioOptions- toJSON = genericToJSON scenarioOptions--emptyLaunchParams :: Applicative f => ParameterizableLaunchParams a f-emptyLaunchParams = LaunchParams (pure Nothing) (pure Nothing)--getLaunchParams :: ScenarioStatus -> SerializableLaunchParams-getLaunchParams = \case- NotStarted -> emptyLaunchParams- Played x _ _ -> x---- | A 'ScenarioInfo' record stores metadata about a scenario: its--- canonical path and status.--- By way of the 'ScenarioStatus' record, it stores the--- most recent status and best-ever status.-data ScenarioInfo = ScenarioInfo- { _scenarioPath :: FilePath- , _scenarioStatus :: ScenarioStatus- }- deriving (Eq, Ord, Show, Read, Generic)--instance FromJSON ScenarioInfo where- parseJSON = genericParseJSON scenarioOptions--instance ToJSON ScenarioInfo where- toEncoding = genericToEncoding scenarioOptions- toJSON = genericToJSON scenarioOptions--type ScenarioInfoPair = (Scenario, ScenarioInfo)--makeLensesNoSigs ''ScenarioInfo---- | The path of the scenario, relative to @data/scenarios@.-scenarioPath :: Lens' ScenarioInfo FilePath---- | The status of the scenario.-scenarioStatus :: Lens' ScenarioInfo ScenarioStatus---- | Update the current 'ScenarioInfo' record when quitting a game.------ Note that when comparing \"best\" times, shorter is not always better!--- As long as the scenario is not completed (e.g. some do not have win condition)--- we consider having fun /longer/ to be better.-updateScenarioInfoOnFinish ::- CodeSizeDeterminators ->- ZonedTime ->- TickNumber ->- Bool ->- ScenarioInfo ->- ScenarioInfo-updateScenarioInfoOnFinish- csd- z- ticks- completed- si@(ScenarioInfo p prevPlayState) = case prevPlayState of- Played launchParams (Metric _ (ProgressStats start _currentPlayMetrics)) prevBestRecords ->- ScenarioInfo p $- Played launchParams newPlayMetric $- updateBest newPlayMetric prevBestRecords- where- el = (diffUTCTime `on` zonedTimeToUTC) z start- cs = codeSizeFromDeterminator csd- newCompletionFlag = if completed then Completed else Attempted- newPlayMetric =- Metric newCompletionFlag $- ProgressStats start $- AttemptMetrics (DurationMetrics el ticks) cs- _ -> si
@@ -1,53 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Types for styling custom entity attributes-module Swarm.Game.Scenario.Style where--import Data.Aeson-import Data.Set (Set)-import Data.Text (Text)-import GHC.Generics (Generic)--data StyleFlag- = Standout- | Italic- | Strikethrough- | Underline- | ReverseVideo- | Blink- | Dim- | Bold- deriving (Eq, Ord, Show, Generic)--styleFlagJsonOptions :: Options-styleFlagJsonOptions =- defaultOptions- { sumEncoding = UntaggedValue- }--instance FromJSON StyleFlag where- parseJSON = genericParseJSON styleFlagJsonOptions--instance ToJSON StyleFlag where- toJSON = genericToJSON styleFlagJsonOptions---- | Hexadecimal color notation.--- May include a leading hash symbol (see 'Data.Colour.SRGB.sRGB24read').-newtype HexColor = HexColor Text- deriving (Eq, Show, Generic, FromJSON, ToJSON)--data CustomAttr = CustomAttr- { name :: String- , fg :: Maybe HexColor- , bg :: Maybe HexColor- , style :: Maybe (Set StyleFlag)- }- deriving (Eq, Show, Generic, FromJSON)--instance ToJSON CustomAttr where- toJSON =- genericToJSON- defaultOptions- { omitNothingFields = True- }
@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.Topography.Area where--import Data.Int (Int32)-import Data.List qualified as L-import Data.Maybe (listToMaybe)-import Linear (V2 (..))-import Swarm.Game.Location---- | Height and width of a 2D map region-data AreaDimensions = AreaDimensions- { rectWidth :: Int32- , rectHeight :: Int32- }--renderRectDimensions :: AreaDimensions -> String-renderRectDimensions (AreaDimensions w h) =- L.intercalate "x" $ map show [w, h]--invertY :: V2 Int32 -> V2 Int32-invertY (V2 x y) = V2 x (-y)---- | Incorporates an offset by @-1@, since the area is--- "inclusive" of the lower-right coordinate.--- Inverse of 'cornersToArea'.-upperLeftToBottomRight :: AreaDimensions -> Location -> Location-upperLeftToBottomRight (AreaDimensions w h) upperLeft =- upperLeft .+^ displacement- where- displacement = invertY $ subtract 1 <$> V2 w h---- | Converts the displacement vector between the two--- diagonal corners of the rectangle into an 'AreaDimensions' record.--- Adds one to both dimensions since the corner coordinates are "inclusive".--- Inverse of 'upperLeftToBottomRight'.-cornersToArea :: Location -> Location -> AreaDimensions-cornersToArea upperLeft lowerRight =- AreaDimensions x y- where- V2 x y = (+ 1) <$> invertY (lowerRight .-. upperLeft)---- | Has zero width or height.-isEmpty :: AreaDimensions -> Bool-isEmpty (AreaDimensions w h) = w == 0 || h == 0---- | Extracts the dimensions of a map grid.-getAreaDimensions :: [[a]] -> AreaDimensions-getAreaDimensions cellGrid =- AreaDimensions w h- where- w = fromIntegral $ maybe 0 length $ listToMaybe cellGrid -- column count- h = fromIntegral $ length cellGrid -- row count
@@ -1,125 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.Topography.Cell (- PCell (..),- Cell,- AugmentedCell (..),- CellPaintDisplay,-) where--import Control.Lens hiding (from, (.=), (<.>))-import Control.Monad.Extra (mapMaybeM)-import Data.List.NonEmpty qualified as NE-import Data.Maybe (catMaybes, listToMaybe)-import Data.Text (Text)-import Data.Vector qualified as V-import Data.Yaml as Y-import Swarm.Game.Entity hiding (empty)-import Swarm.Game.Scenario.RobotLookup-import Swarm.Game.Scenario.Topography.EntityFacade-import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)-import Swarm.Game.Terrain-import Swarm.Util.Erasable (Erasable (..))-import Swarm.Util.Yaml----------------------------------------------------------------- World cells----------------------------------------------------------------- | A single cell in a world map, which contains a terrain value,--- and optionally an entity and robot.--- It is parameterized on the 'Entity' type to facilitate less--- stateful versions of the 'Entity' type in rendering scenario data.-data PCell e = Cell- { cellTerrain :: TerrainType- , cellEntity :: Erasable e- , cellRobots :: [IndexedTRobot]- }- deriving (Eq, Show)---- | A single cell in a world map, which contains a terrain value,--- and optionally an entity and robot.-type Cell = PCell Entity---- | Supplements a cell with waypoint information-data AugmentedCell e = AugmentedCell- { waypointCfg :: Maybe WaypointConfig- , standardCell :: PCell e- }- deriving (Eq, Show)---- | Re-usable serialization for variants of 'PCell'-mkPCellJson :: ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value-mkPCellJson modifier x =- toJSON $- catMaybes- [ Just . toJSON . getTerrainWord $ cellTerrain x- , fmap toJSON . modifier $ cellEntity x- , listToMaybe []- ]--instance ToJSON Cell where- toJSON = mkPCellJson $ \case- EErase -> Just "erase"- ENothing -> Nothing- EJust e -> Just (e ^. entityName)--instance FromJSONE (EntityMap, RobotMap) Cell where- parseJSONE = withArrayE "tuple" $ \v -> do- let tupRaw = V.toList v- tup <- case NE.nonEmpty tupRaw of- Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)"- Just x -> return x-- terr <- liftE $ parseJSON (NE.head tup)-- ent <- case tup ^? ix 1 of- Nothing -> return ENothing- Just e -> do- meName <- liftE $ parseJSON @(Maybe Text) e- case meName of- Nothing -> return ENothing- Just "erase" -> return EErase- Just name -> fmap EJust . localE fst $ getEntity name-- let name2rob r = do- mrName <- liftE $ parseJSON @(Maybe RobotName) r- traverse (localE snd . getRobot) mrName-- robs <- mapMaybeM name2rob (drop 2 tupRaw)-- return $ Cell terr ent robs---- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'. The--- entity and robot, if present, are immediately looked up and--- converted into 'Entity' and 'TRobot' values. If they are not--- found, a parse error results.-instance FromJSONE (EntityMap, RobotMap) (AugmentedCell Entity) where- parseJSONE x = case x of- Object v -> objParse v- z -> AugmentedCell Nothing <$> parseJSONE z- where- objParse v =- AugmentedCell- <$> liftE (v .:? "waypoint")- <*> v- ..: "cell"----------------------------------------------------------------- World editor----------------------------------------------------------------- | Stateless cells used for the World Editor.--- These cells contain the bare minimum display information--- for rendering.-type CellPaintDisplay = PCell EntityFacade---- Note: This instance is used only for the purpose of 'WorldPalette'-instance ToJSON CellPaintDisplay where- toJSON = mkPCellJson $ \case- ENothing -> Nothing- EErase -> Just $ EntityFacade "erase" mempty- EJust e -> Just e
@@ -1,35 +0,0 @@-{-# LANGUAGE DerivingVia #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Stand-in type for an "Entity" for purposes--- that do not require carrying around the entire state--- of an Entity.------ Useful for simplified serialization, debugging,--- and equality checking, particularly for the World Editor.-module Swarm.Game.Scenario.Topography.EntityFacade where--import Control.Lens ((^.))-import Data.Yaml as Y (ToJSON (toJSON))-import Swarm.Game.Display (Display)-import Swarm.Game.Entity qualified as E---- | This datatype is a lightweight stand-in for the--- full-fledged "Entity" type without the baggage of all--- of its other fields.--- It contains the bare minimum display information--- for rendering.-data EntityFacade = EntityFacade E.EntityName Display- deriving (Eq)---- Note: This instance is used only for the purpose of WorldPalette-instance ToJSON EntityFacade where- toJSON (EntityFacade eName _display) = toJSON eName--mkFacade :: E.Entity -> EntityFacade-mkFacade e =- EntityFacade- (e ^. E.entityName)- (e ^. E.entityDisplay)
@@ -1,316 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Type definitions and validation logic for portals.------ Portals can be inter-world or intra-world.--- It is legal for a portal exit to be on the same cell as its entrance.------ By default, passage through a portal preserves the orientation--- of the robot, but an extra portal parameter can specify--- that the robot should be re-oriented.-module Swarm.Game.Scenario.Topography.Navigation.Portal where--import Control.Arrow ((&&&))-import Control.Lens (view)-import Control.Monad (forM, forM_, unless)-import Data.Aeson-import Data.Bifunctor (first)-import Data.BoolExpr (Signed (..))-import Data.Function (on)-import Data.Functor.Identity-import Data.Int (Int32)-import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (fromMaybe, listToMaybe)-import Data.Text qualified as T-import Data.Tuple (swap)-import GHC.Generics (Generic)-import Linear (V2, negated)-import Swarm.Game.Location-import Swarm.Game.Scenario.Topography.Navigation.Waypoint-import Swarm.Game.Universe-import Swarm.Language.Direction-import Swarm.Util (allEqual, binTuples, both, failT, quote, showT)--type WaypointMap = M.Map WaypointName (NonEmpty Location)--data AnnotatedDestination a = AnnotatedDestination- { enforceConsistency :: Bool- , reorientation :: Direction- , destination :: Cosmic a- }- deriving (Show, Eq)---- | Parameterized on waypoint dimensionality ('additionalDimension') and--- on the portal location specification method ('portalExitLoc').------ == @additionalDimension@--- As a member of the 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription', waypoints are only known within a--- a single subworld, so 'additionalDimension' is 'Identity' for the map--- of waypoint names to planar locations.--- At the Scenario level, in contrast, we have access to all subworlds, so--- we nest this map to planar locations in additional mapping layer by subworld.------ == @portalExitLoc@--- At the subworld parsing level, we only can obtain the planar location--- for portal /entrances/, but the /exits/ remain as waypoint names.--- At the Scenario-parsing level, we finally have--- access to the waypoints across all subworlds, and can therefore translate--- the portal exits to concrete planar locations.-data Navigation additionalDimension portalExitLoc = Navigation- { waypoints :: additionalDimension WaypointMap- -- ^ Note that waypoints defined at the "root" level are still relative to- -- the top-left corner of the map rectangle; they are not in absolute world- -- coordinates (as with applying the "ul" offset).- , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc)- }--deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b)-deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b)--data PortalExit = PortalExit- { exit :: WaypointName- , subworldName :: Maybe SubworldName- -- ^ Note: 'Nothing' indicates that references a waypoint within the same subworld.- }- deriving (Show, Eq, Generic, FromJSON)--data Portal = Portal- { entrance :: WaypointName- , exitInfo :: PortalExit- , consistent :: Bool- , reorient :: PlanarRelativeDir- }- deriving (Show, Eq)--instance FromJSON Portal where- parseJSON = withObject "Portal" $ \v ->- Portal- <$> v- .: "entrance"- <*> v- .: "exitInfo"- <*> v .:? "consistent" .!= False- <*> v .:? "reorient" .!= DForward--failUponDuplication ::- (MonadFail m, Show a, Show b) =>- T.Text ->- M.Map a (NonEmpty b) ->- m ()-failUponDuplication message binnedMap =- forM_ (listToMaybe $ M.toList duplicated) $ \(pIn, pOuts) ->- failT- [ "Waypoint"- , showT pIn- , message- , T.intercalate ", " $ map showT $ NE.toList pOuts- ]- where- duplicated = M.filter ((> 1) . NE.length) binnedMap--failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a-failWaypointLookup (WaypointName rawName) =- maybe (failT ["No waypoint named", quote rawName]) return---- |--- The following constraints must be enforced:------ * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit--- * no two portals share the same entrance location--- * waypoint uniqueness within a subworld when the 'unique' flag is specified------ == Data flow------ Waypoints are defined within a subworld and are namespaced by it.--- Optional intra-subworld uniqueness of Waypoints is enforced at 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription'--- parse time.--- Portals are declared within a subworld. The portal entrance must be a waypoint--- within this subworld.--- They can reference waypoints in other subworlds as exits, but these references--- are not validated until the Scenario parse level.------ * Since portal /entrances/ are specified at the subworld level, validation that--- no entrances overlap can also be performed at that level.--- * However, enforcement of single-multiplicity on portal /exits/ must be performed--- at scenario-parse level, because for a portal exit that references a waypoint in--- another subworld, we can't know at the single-'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription' level whether--- that waypoint has plural multiplicity.-validatePartialNavigation ::- (MonadFail m, Traversable t) =>- SubworldName ->- Location ->- [Originated Waypoint] ->- t Portal ->- m (Navigation Identity WaypointName)-validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do- failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag-- nestedPortalPairs <- forM portalDefs $ \p -> do- let Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent reOrient = p- -- Portals can have multiple entrances but only a single exit.- -- That is, the pairings of entries to exits must form a proper mathematical "function".- -- Multiple occurrences of entrance waypoints of a given name will result in- -- multiple portal entrances.- entranceLocs <- getLocs entranceName-- let sw = fromMaybe currentSubworldName maybeExitSubworldName- f = (,AnnotatedDestination isConsistent (DRelative $ DPlanar reOrient) $ Cosmic sw exitName) . extractLoc- return $ map f $ NE.toList entranceLocs-- let reconciledPortalPairs = concat nestedPortalPairs-- -- Aside from the enforcement of single-exit per portal, we apply another layer of- -- enforcement to ensure that no two portals share the same entrance location- failUponDuplication "has overlapping portal entrances exiting to" $- binTuples reconciledPortalPairs-- return . Navigation (pure bareWaypoints) . M.fromList $- map (first $ Cosmic currentSubworldName) reconciledPortalPairs- where- getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints-- extractLoc (Originated _ (Waypoint _ loc)) = loc- correctedWaypoints =- binTuples $- map- (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint $ upperLeft .-. origin) x))- unmergedWaypoints- bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints- waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints--validatePortals ::- MonadFail m =>- Navigation (M.Map SubworldName) WaypointName ->- m (M.Map (Cosmic Location) (AnnotatedDestination Location))-validatePortals (Navigation wpUniverse partialPortals) = do- portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent reOrient portalExit@(Cosmic swName (WaypointName rawExitName))) -> do- firstExitLoc :| otherExits <- getLocs portalExit- unless (null otherExits) $- failT- [ "Ambiguous exit waypoints named"- , quote rawExitName- , "for portal"- ]- return (portalEntrance, AnnotatedDestination isConsistent reOrient $ Cosmic swName firstExitLoc)-- ensureSpatialConsistency portalPairs-- return $ M.fromList portalPairs- where- getLocs (Cosmic swName wpWrapper@(WaypointName exitName)) = do- subworldWaypoints <- case M.lookup swName wpUniverse of- Just x -> return x- Nothing ->- failT- [ "Could not lookup waypoint"- , quote exitName- , "for portal exit because subworld"- , quote $ renderWorldName swName- , "does not exist"- ]-- failWaypointLookup wpWrapper $- M.lookup wpWrapper subworldWaypoints---- | A portal can be marked as \"consistent\", meaning that it represents--- a conventional physical passage rather than a \"magical\" teleportation.------ If there exists more than one \"consistent\" portal between the same--- two subworlds, then the portal locations must be spatially consistent--- between the two worlds. I.e. the space comprising the two subworlds--- forms a "conservative vector field".------ Verifying this is simple:--- For all of the portals between Subworlds A and B:------ * The coordinates of all \"consistent\" portal locations in Subworld A--- are subtracted from the corresponding coordinates in Subworld B. It--- does not matter which are exits vs. entrances.--- * The resulting \"vector\" from every pair must be equal.-ensureSpatialConsistency ::- MonadFail m =>- [(Cosmic Location, AnnotatedDestination Location)] ->- m ()-ensureSpatialConsistency xs =- unless (null nonUniform) $- failT- [ "Non-uniform portal distances:"- , showT nonUniform- ]- where- consistentPairs :: [(Cosmic Location, Cosmic Location)]- consistentPairs = map (fmap destination) $ filter (enforceConsistency . snd) xs-- interWorldPairs :: [(Cosmic Location, Cosmic Location)]- interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs-- normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)]- normalizedOrdering = map normalizePairOrder interWorldPairs-- normalizePairOrder :: (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)- normalizePairOrder pair =- if uncurry ((>) `on` view subworld) pair- then Negative $ swap pair- else Positive pair-- tuplify :: (Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a))- tuplify = both (view subworld) &&& both (view planar)-- getSigned :: Signed (V2 Int32) -> V2 Int32- getSigned = \case- Positive x -> x- Negative x -> negated x-- groupedBySubworldPair ::- Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location)))- groupedBySubworldPair = binTuples $ map (sequenceSigned . fmap tuplify) normalizedOrdering-- vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))- vectorized = M.map (NE.map (getSigned . fmap (uncurry (.-.)))) groupedBySubworldPair-- nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))- nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized---- |--- An implementation of 'sequenceA' for 'Signed' that does not--- require an 'Applicative' instance for the inner 'Functor'.------ == Discussion--- Compare to the 'Traversable' instance of 'Signed':------ @--- instance Traversable Signed where--- traverse f (Positive x) = Positive <$> f x--- traverse f (Negative x) = Negative <$> f x--- @------ if we were to substitute 'id' for f:------ @--- traverse id (Positive x) = Positive <$> id x--- traverse id (Negative x) = Negative <$> id x--- @--- our implementation essentially becomes @traverse id@.------ However, we cannot simply write our implementation as @traverse id@, because--- the 'traverse' function has an 'Applicative' constraint, which is superfluous--- for our purpose.------ Perhaps there is an opportunity to invent a typeclass for datatypes which--- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors,--- for which a less-constrained 'sequence' function could be automatically derived.--- Compare to the 'Comonad' class and its 'extract' function.-sequenceSigned ::- Functor f =>- Signed (f a) ->- f (Signed a)-sequenceSigned = \case- Positive x -> Positive <$> x- Negative x -> Negative <$> x
@@ -1,44 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.Topography.Navigation.Util where--import Control.Lens (view)-import Data.Function (on)-import Data.Int (Int32)-import Linear (V2)-import Swarm.Game.Location-import Swarm.Game.Robot-import Swarm.Game.Universe (Cosmic, planar)-import Swarm.Language.Direction---- |--- Computes the relative offset vector between a 'Robot' and a 'Location'--- (presumed to be in the same subworld, though the contrary will--- not result in failure), then re-interpret that vector based on the--- 'Robot'\'s current orientation.------ If the robot is not oriented in a cardinal direction, returns 'Nothing'.------ = Re-orientation semantics------ Given a displacement vector @(x, y)@ where:------ * positive @x@-coordinate represents @east@--- * negative @x@-coordinate represents @west@--- * positive @y@-coordinate represents @north@--- * negative @y@-coordinate represents @south@------ the re-interpreted vector @(x', y')@ becomes:------ * positive @x'@-coordinate represents @right@--- * negative @x'@-coordinate represents @left@--- * positive @y'@-coordinate represents @forward@--- * negative @y'@-coordinate represents @back@-orientationBasedRelativePosition :: Robot -> Cosmic Location -> Maybe (V2 Int32)-orientationBasedRelativePosition selfRobot otherLocation =- (`applyTurn` relativeCoords) <$> maybeSelfDirRelativeToNorth- where- maybeSelfDirection = view robotOrientation selfRobot >>= toAbsDirection- maybeSelfDirRelativeToNorth = DRelative . DPlanar . relativeTo DNorth <$> maybeSelfDirection-- relativeCoords = ((.-.) `on` view planar) otherLocation (view robotLocation selfRobot)
@@ -1,90 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Landmarks that are used to specify portal locations--- and can serve as navigation aids via the `waypoint` command.------ = Waypoint ordering------ The sequence of waypoints of a given name is dictated by criteria in the following order:------ 1. Ordering of structure placements--- (see implementation of 'Swarm.Game.Scenario.Topography.Structure.mergeStructures');--- later placements are ordered first.--- 2. Placement of cells within a map. Map locations go by row-major order--- (compare to docs for 'Swarm.Game.State.genRobotTemplates').------ TODO (#1366): May be useful to have a mechanism for more--- 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---- | Indicates which structure something came from--- for debugging purposes.-data Originated a = Originated- { parent :: Maybe Placement- , value :: a- }- deriving (Show, Eq, Functor)--newtype WaypointName = WaypointName T.Text- deriving (Show, Eq, Ord, Generic, FromJSON)---- | Metadata about a waypoint-data WaypointConfig = WaypointConfig- { wpName :: WaypointName- , wpUnique :: Bool- -- ^ Enforce global uniqueness of this waypoint- }- deriving (Show, Eq)--parseWaypointConfig :: Object -> Parser WaypointConfig-parseWaypointConfig v =- WaypointConfig- <$> v .: "name"- <*> v .:? "unique" .!= False--instance FromJSON WaypointConfig where- parseJSON = withObject "Waypoint Config" parseWaypointConfig---- |--- A parent world shouldn't have to know the exact layout of a subworld--- to specify where exactly a portal will deliver a robot to within the subworld.--- Therefore, we define named waypoints in the subworld and the parent world--- must reference them by name, rather than by coordinate.-data Waypoint = Waypoint- { wpConfig :: WaypointConfig- , wpLoc :: Location- }- deriving (Show, Eq)---- | JSON representation is flattened; all keys are at the same level,--- in contrast with the underlying record.-instance FromJSON Waypoint where- parseJSON = withObject "Waypoint" $ \v ->- Waypoint- <$> 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)
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Descriptions of the orientation and offset by--- which a structure should be placed.-module Swarm.Game.Scenario.Topography.Placement where--import Data.List (transpose)-import Data.Text (Text)-import Data.Yaml as Y-import GHC.Generics (Generic)-import Swarm.Game.Location-import Swarm.Game.Scenario.Topography.Area-import Swarm.Language.Syntax (AbsoluteDir (..))--newtype StructureName = StructureName Text- deriving (Eq, Ord, Show, Generic, FromJSON)---- | Orientation transformations are applied before translation.-data Orientation = Orientation- { up :: AbsoluteDir- -- ^ e.g. For "East", rotates 270 degrees.- , flipped :: Bool- -- ^ vertical flip, applied before rotation- }- deriving (Eq, Show)--instance FromJSON Orientation where- parseJSON = withObject "structure orientation" $ \v -> do- Orientation- <$> v .:? "up" .!= DNorth- <*> v .:? "flip" .!= False--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) =- rotational . flipping- where- transposeLoc (Location x y) = Location (-y) (-x)- flipV (Location x y) = Location x $ -(height - 1) - y- flipH (Location x y) = Location (width - 1 - x) y- flipping = if shouldFlip then flipV else id- rotational = case upDir of- DNorth -> id- DSouth -> flipH . flipV- DEast -> transposeLoc . flipV- DWest -> transposeLoc . flipH---- | affine transformation-applyOrientationTransform :: Orientation -> [[a]] -> [[a]]-applyOrientationTransform (Orientation upDir shouldFlip) =- rotational . flipping- where- flipV = reverse- flipping = if shouldFlip then flipV else id- rotational = case upDir of- DNorth -> id- DSouth -> transpose . flipV . transpose . flipV- DEast -> transpose . flipV- DWest -> flipV . transpose--data Placement = Placement- { src :: StructureName- , offset :: Location- , orient :: Orientation- }- deriving (Eq, Show)--instance FromJSON Placement where- parseJSON = withObject "structure placement" $ \v -> do- sName <- v .: "src"- Placement sName- <$> v .:? "offset" .!= origin- <*> v .:? "orient" .!= defaultOrientation
@@ -1,155 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ 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 Data.Aeson.Key qualified as Key-import Data.Aeson.KeyMap qualified as KeyMap-import Data.Coerce-import Data.Map qualified as M-import Data.Maybe (catMaybes, mapMaybe)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml as Y-import Swarm.Game.Entity-import Swarm.Game.Location-import Swarm.Game.Scenario.RobotLookup-import Swarm.Game.Scenario.Topography.Area-import Swarm.Game.Scenario.Topography.Cell-import Swarm.Game.Scenario.Topography.Navigation.Waypoint-import Swarm.Game.Scenario.Topography.Placement-import Swarm.Game.Scenario.Topography.WorldPalette-import Swarm.Util (failT, showT)-import Swarm.Util.Yaml-import Witch (into)--data NamedStructure c = NamedStructure- { name :: StructureName- , structure :: PStructure c- }- deriving (Eq, Show)--type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))]--instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where- parseJSONE = withObjectE "named structure" $ \v -> do- NamedStructure- <$> liftE (v .: "name")- <*> v- ..: "structure"--data PStructure c = Structure- { area :: [[c]]- , structures :: [NamedStructure c]- -- ^ structure definitions from parents shall be accessible by children- , placements :: [Placement]- -- ^ earlier placements will be overlaid on top of later placements in the YAML file- , waypoints :: [Waypoint]- }- deriving (Eq, Show)--data MergedStructure c = MergedStructure [[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)) ->- MergedStructure (Maybe a) ->- 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-- placeWaypoint =- offsetWaypoint (coerce loc)- . modifyLocation (reorientWaypoint orientation $ getAreaDimensions overlayArea)- mergedWaypoints = inputWaypoints <> map (fmap placeWaypoint) overlayWaypoints-- zipWithPad f a b = zipWith f a $ b <> repeat Nothing-- MergedStructure overlayArea overlayWaypoints = mergeStructures inheritedStrucDefs (Just p) struc- affineTransformedOverlay = applyOrientationTransform orientation overlayArea-- mergeSingleRow inputRow maybeOverlayRow =- zipWithPad (flip (<|>)) inputRow paddedSingleOverlayRow- where- paddedSingleOverlayRow = maybe [] (applyOffset colOffset) maybeOverlayRow-- paddedOverlayRows = applyOffset (negate rowOffset) . map Just $ affineTransformedOverlay- applyOffset offsetNum = modifyFront- where- integralOffset = fromIntegral offsetNum- modifyFront =- if integralOffset >= 0- then (replicate integralOffset Nothing <>)- else drop $ abs integralOffset---- | 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 ->- PStructure (Maybe a) ->- MergedStructure (Maybe a)-mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) =- foldr (overlaySingleStructure structureMap) (MergedStructure origArea 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- parseJSONE = withObjectE "structure definition" $ \v -> do- pal <- v ..:? "palette" ..!= WorldPalette mempty- localStructureDefs <- v ..:? "structures" ..!= []- placementDefs <- liftE $ v .:? "placements" .!= []- waypointDefs <- liftE $ v .:? "waypoints" .!= []- maybeMaskChar <- liftE $ v .:? "mask"- (maskedArea, mapWaypoints) <- liftE $ (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal- return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints---- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw--- string into a nested list of 'PCell' values by looking up each--- character in the palette, failing if any character in the raw map--- is not contained in the palette.-paintMap ::- MonadFail m =>- Maybe Char ->- WorldPalette e ->- Text ->- m ([[Maybe (PCell e)]], [Waypoint])-paintMap maskChar pal a = do- nestedLists <- readMap toCell a- let cells = map (map $ fmap standardCell) nestedLists- f i j maybeAugmentedCell = do- wpCfg <- waypointCfg =<< maybeAugmentedCell- return . Waypoint wpCfg . Location j $ negate i- wps = concat $ zipWith (\i -> catMaybes . zipWith (f i) [0 ..]) [0 ..] nestedLists-- return (cells, wps)- where- toCell c =- if Just c == maskChar- then return Nothing- else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of- Nothing -> failT ["Char not in world palette:", showT c]- Just cell -> return $ Just cell--readMap :: Applicative f => (Char -> f b) -> Text -> f [[b]]-readMap func = traverse (traverse func . into @String) . T.lines
@@ -1,117 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.Topography.WorldDescription where--import Control.Carrier.Reader (runReader)-import Control.Carrier.Throw.Either-import Control.Monad (forM)-import Data.Functor.Identity-import Data.Maybe (catMaybes)-import Data.Yaml as Y-import Swarm.Game.Entity-import Swarm.Game.Location-import Swarm.Game.Scenario.RobotLookup-import Swarm.Game.Scenario.Topography.Cell-import Swarm.Game.Scenario.Topography.EntityFacade-import Swarm.Game.Scenario.Topography.Navigation.Portal-import Swarm.Game.Scenario.Topography.Navigation.Waypoint (- WaypointName,- )-import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure))-import Swarm.Game.Scenario.Topography.Structure qualified as Structure-import Swarm.Game.Scenario.Topography.WorldPalette-import Swarm.Game.Universe-import Swarm.Game.World.Parse ()-import Swarm.Game.World.Syntax-import Swarm.Game.World.Typecheck-import Swarm.Language.Pretty (prettyString)-import Swarm.Util.Yaml----------------------------------------------------------------- World description----------------------------------------------------------------- | A description of a world parsed from a YAML file.--- This type is parameterized to accommodate Cells that--- utilize a less stateful Entity type.-data PWorldDescription e = WorldDescription- { offsetOrigin :: Bool- , scrollable :: Bool- , palette :: WorldPalette e- , ul :: Location- , area :: [[PCell e]]- , navigation :: Navigation Identity WaypointName- , worldName :: SubworldName- , worldProg :: Maybe (TTerm '[] (World CellVal))- }- deriving (Show)--type WorldDescription = PWorldDescription Entity--instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) WorldDescription where- parseJSONE = withObjectE "world description" $ \v -> do- (worldMap, scenarioLevelStructureDefs, em, rm) <- getE- (pal, rootWorldStructureDefs) <- localE (const (em, rm)) $ do- pal <- v ..:? "palette" ..!= WorldPalette mempty- rootWorldStructs <- v ..:? "structures" ..!= []- return (pal, rootWorldStructs)-- waypointDefs <- liftE $ v .:? "waypoints" .!= []- portalDefs <- liftE $ v .:? "portals" .!= []- placementDefs <- liftE $ v .:? "placements" .!= []- (initialArea, mapWaypoints) <- liftE ((v .:? "map" .!= "") >>= Structure.paintMap Nothing pal)-- upperLeft <- liftE (v .:? "upperleft" .!= origin)- subWorldName <- liftE (v .:? "name" .!= DefaultRootSubworld)-- let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs- struc = Structure initialArea initialStructureDefs placementDefs $ waypointDefs <> mapWaypoints- MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc-- validatedNavigation <-- validatePartialNavigation- subWorldName- upperLeft- unmergedWaypoints- portalDefs-- mwexp <- liftE (v .:? "dsl")- dslTerm <- forM mwexp $ \wexp -> do- let checkResult =- run . runThrow @CheckErr . runReader worldMap . runReader em $- check CNil (TTyWorld TTyCell) wexp- either (fail . prettyString) return checkResult- WorldDescription- <$> liftE (v .:? "offset" .!= False)- <*> liftE (v .:? "scrollable" .!= True)- <*> pure pal- <*> pure upperLeft- <*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells.- <*> pure validatedNavigation- <*> pure subWorldName- <*> pure dslTerm----------------------------------------------------------------- World editor----------------------------------------------------------------- | A pared-down (stateless) version of "WorldDescription" just for--- the purpose of rendering a Scenario file-type WorldDescriptionPaint = PWorldDescription EntityFacade--instance ToJSON WorldDescriptionPaint where- toJSON w =- object- [ "offset" .= offsetOrigin w- , "palette" .= Y.toJSON paletteKeymap- , "upperleft" .= ul w- , "map" .= Y.toJSON mapText- ]- where- cellGrid = area w- suggestedPalette = palette w- (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid
@@ -1,128 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Scenario.Topography.WorldPalette where--import Control.Arrow (first)-import Control.Lens hiding (from, (.=), (<.>))-import Data.Aeson.KeyMap (KeyMap)-import Data.Aeson.KeyMap qualified as KM-import Data.Map qualified as M-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Data.Tuple (swap)-import Swarm.Game.Entity-import Swarm.Game.Scenario.RobotLookup-import Swarm.Game.Scenario.Topography.Cell-import Swarm.Game.Scenario.Topography.EntityFacade-import Swarm.Game.Terrain (TerrainType)-import Swarm.Util.Erasable-import Swarm.Util.Yaml---- | A world palette maps characters to 'Cell' values.-newtype WorldPalette e = WorldPalette- {unPalette :: KeyMap (AugmentedCell e)}- deriving (Eq, Show)--instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where- parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE--type TerrainWith a = (TerrainType, Erasable a)--cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade-cellToTerrainPair (Cell terrain erasableEntity _) = (terrain, erasableEntity)--toCellPaintDisplay :: Cell -> CellPaintDisplay-toCellPaintDisplay (Cell terrain maybeEntity r) =- Cell terrain (mkFacade <$> maybeEntity) r--toKey :: TerrainWith EntityFacade -> TerrainWith EntityName-toKey = fmap $ fmap (\(EntityFacade eName _display) -> eName)---- | We want to identify all of the unique (terrain, entity facade) pairs.--- However, "EntityFacade" includes a "Display" record, which contains more--- fields than desirable for use as a unique key.--- Therefore, we extract just the entity name for use in a--- (terrain, entity name) key, and couple it with the original--- (terrain, entity facade) pair in a Map.-getUniqueTerrainFacadePairs ::- [[CellPaintDisplay]] ->- M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)-getUniqueTerrainFacadePairs cellGrid =- M.fromList $ concatMap (map genTuple) cellGrid- where- genTuple c =- (toKey terrainEfd, terrainEfd)- where- terrainEfd = cellToTerrainPair c--constructPalette ::- [(Char, TerrainWith EntityFacade)] ->- KM.KeyMap CellPaintDisplay-constructPalette mappedPairs =- KM.fromMapText terrainEntityPalette- where- g (terrain, maybeEfd) = Cell terrain maybeEfd []- terrainEntityPalette = M.fromList $ map (bimap T.singleton g) mappedPairs--constructWorldMap ::- [(Char, TerrainWith EntityFacade)] ->- [[CellPaintDisplay]] ->- Text-constructWorldMap mappedPairs =- T.unlines . map (T.pack . map renderMapCell)- where- invertedMappedPairs = map (swap . fmap toKey) mappedPairs-- renderMapCell c =- -- NOTE: This lookup should never fail- M.findWithDefault (error "Palette lookup failed!") k $- M.fromList invertedMappedPairs- where- k = toKey $ cellToTerrainPair c---- | All alphanumeric characters. These are used as supplemental--- map placeholders in case a pre-existing display character is--- not available to re-use.-genericCharacterPool :: Set.Set Char-genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9']---- | Note that display characters are not unique--- across different entities! However, the palette KeyMap--- as a conveyance serves to dedupe them.-prepForJson ::- WorldPalette EntityFacade ->- [[CellPaintDisplay]] ->- (Text, KM.KeyMap CellPaintDisplay)-prepForJson (WorldPalette suggestedPalette) cellGrid =- (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs)- where- preassignments :: [(Char, TerrainWith EntityFacade)]- preassignments =- map (first T.head . fmap (cellToTerrainPair . standardCell)) $- M.toList $- KM.toMapText suggestedPalette-- entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)- entityCells = getUniqueTerrainFacadePairs cellGrid-- unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)- unassignedCells =- M.withoutKeys entityCells $- Set.fromList $- map (toKey . snd) preassignments-- unassignedCharacters :: Set.Set Char- unassignedCharacters =- -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char")- -- to generate this pool?- Set.difference genericCharacterPool $- Set.fromList $- map fst preassignments-- newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]- newlyAssignedPairs = zip (Set.toList unassignedCharacters) $ M.elems unassignedCells-- mappedPairs = preassignments <> newlyAssignedPairs
@@ -1,286 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- -Wno-orphans is for the Eq/Ord Time instances---- |--- SPDX-License-Identifier: BSD-3-Clause------ Saving and loading info about scenarios (status, path, etc.) as--- well as loading recursive scenario collections.-module Swarm.Game.ScenarioInfo (- -- * Scenario info- ScenarioStatus (..),- _NotStarted,- ScenarioInfo (..),- scenarioPath,- scenarioStatus,- CodeSizeDeterminators (CodeSizeDeterminators),- updateScenarioInfoOnFinish,- ScenarioInfoPair,-- -- * Scenario collection- ScenarioCollection (..),- scenarioCollectionToList,- flatten,- scenarioItemByPath,- normalizeScenarioPath,- ScenarioItem (..),- scenarioItemName,- _SISingle,-- -- * Loading and saving scenarios- loadScenarios,- loadScenarioInfo,- saveScenarioInfo,-- -- * Re-exports- module Swarm.Game.Scenario,-) where--import Control.Algebra (Has)-import Control.Carrier.Lift (runM)-import Control.Carrier.Throw.Either (runThrow)-import Control.Effect.Accum (Accum, add)-import Control.Effect.Lift (Lift, sendIO)-import Control.Effect.Throw (Throw, liftEither)-import Control.Lens hiding (from, (<.>))-import Control.Monad (filterM, forM_, when, (<=<))-import Control.Monad.IO.Class (MonadIO (liftIO))-import Data.Char (isSpace)-import Data.Either (partitionEithers)-import Data.Either.Extra (fromRight')-import Data.List (intercalate, isPrefixOf, stripPrefix, (\\))-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (isJust)-import Data.Sequence (Seq)-import Data.Sequence qualified as Seq-import Data.Text (Text)-import Data.Yaml as Y-import Swarm.Game.Entity-import Swarm.Game.Failure-import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath)-import Swarm.Game.Scenario-import Swarm.Game.Scenario.Scoring.CodeSize-import Swarm.Game.Scenario.Status-import Swarm.Game.World.Typecheck (WorldMap)-import Swarm.Util.Effect (warn, withThrow)-import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory)-import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), (</>))-import Witch (into)---- ------------------------------------------------------------------------------- Scenario Item--- -------------------------------------------------------------------------------- | A scenario item is either a specific scenario, or a collection of--- scenarios (/e.g./ the scenarios contained in a subdirectory).-data ScenarioItem = SISingle ScenarioInfoPair | SICollection Text ScenarioCollection- deriving (Show)---- | Retrieve the name of a scenario item.-scenarioItemName :: ScenarioItem -> Text-scenarioItemName (SISingle (s, _ss)) = s ^. scenarioName-scenarioItemName (SICollection name _) = name---- | A scenario collection is a tree of scenarios, keyed by name,--- together with an optional order.------ /Invariant:/ every item in the--- 'scOrder' exists as a key in the 'scMap'.-data ScenarioCollection = SC- { scOrder :: Maybe [FilePath]- , scMap :: Map FilePath ScenarioItem- }- deriving (Show)---- | Access and modify 'ScenarioItem's in collection based on their path.-scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem-scenarioItemByPath path = ixp ps- where- ps = splitDirectories path- ixp :: (Applicative f) => [String] -> (ScenarioItem -> f ScenarioItem) -> ScenarioCollection -> f ScenarioCollection- ixp [] _ col = pure col- ixp [s] f (SC n m) = SC n <$> ix s f m- ixp (d : xs) f (SC n m) = SC n <$> ix d inner m- where- inner si = case si of- SISingle {} -> pure si- SICollection n' col -> SICollection n' <$> ixp xs f col---- | Canonicalize a scenario path, making it usable as a unique key.-normalizeScenarioPath ::- (MonadIO m) =>- ScenarioCollection ->- FilePath ->- m FilePath-normalizeScenarioPath col p =- let path = p -<.> "yaml"- in if isJust $ col ^? scenarioItemByPath path- then return path- else liftIO $ do- canonPath <- canonicalizePath path- eitherDdir <- runM . runThrow @SystemFailure $ getDataDirSafe Scenarios "." -- no way we got this far without data directory- d <- canonicalizePath $ fromRight' eitherDdir- let n =- stripPrefix (d </> "scenarios") canonPath- & maybe canonPath (dropWhile (== pathSeparator))- return n---- | Convert a scenario collection to a list of scenario items.-scenarioCollectionToList :: ScenarioCollection -> [ScenarioItem]-scenarioCollectionToList (SC Nothing m) = M.elems m-scenarioCollectionToList (SC (Just order) m) = (m M.!) <$> order--flatten :: ScenarioItem -> [ScenarioInfoPair]-flatten (SISingle p) = [p]-flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c---- | Load all the scenarios from the scenarios data directory.-loadScenarios ::- (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>- EntityMap ->- WorldMap ->- m ScenarioCollection-loadScenarios em worldMap = do- res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios"- case res of- Left err -> do- warn err- return $ SC mempty mempty- Right dataDir -> loadScenarioDir em worldMap dataDir---- | The name of the special file which indicates the order of--- scenarios in a folder.-orderFileName :: FilePath-orderFileName = "00-ORDER.txt"--readOrderFile :: (Has (Lift IO) sig m) => FilePath -> m [String]-readOrderFile orderFile =- filter (not . null) . lines <$> sendIO (readFile orderFile)---- | Recursively load all scenarios from a particular directory, and also load--- the 00-ORDER file (if any) giving the order for the scenarios.-loadScenarioDir ::- (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>- EntityMap ->- WorldMap ->- FilePath ->- m ScenarioCollection-loadScenarioDir em worldMap dir = do- let orderFile = dir </> orderFileName- dirName = takeBaseName dir- orderExists <- sendIO $ doesFileExist orderFile- morder <- case orderExists of- False -> do- when (dirName /= "Testing") . warn $- OrderFileWarning (dirName </> orderFileName) NoOrderFile- return Nothing- True -> Just <$> readOrderFile orderFile- itemPaths <- sendIO $ keepYamlOrPublicDirectory dir =<< listDirectory dir-- case morder of- Just order -> do- let missing = itemPaths \\ order- dangling = order \\ itemPaths-- forM_ (NE.nonEmpty missing) $- warn- . OrderFileWarning (dirName </> orderFileName)- . MissingFiles-- forM_ (NE.nonEmpty dangling) $- warn- . OrderFileWarning (dirName </> orderFileName)- . DanglingFiles- Nothing -> pure ()-- -- Only keep the files from 00-ORDER.txt that actually exist.- let morder' = filter (`elem` itemPaths) <$> morder- loadItem filepath = do- item <- loadScenarioItem em worldMap (dir </> filepath)- return (filepath, item)- scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths- let (failures, successes) = partitionEithers scenarios- scenarioMap = M.fromList successes- -- Now only keep the files that successfully parsed.- morder'' = filter (`M.member` scenarioMap) <$> morder'- collection = SC morder'' scenarioMap- add (Seq.fromList failures) -- Register failed individual scenarios as warnings- return collection- where- -- Keep only files which are .yaml files or directories that start- -- with something other than an underscore.- keepYamlOrPublicDirectory = filterM . isCatalogEntry-- -- Whether the directory or file should be included in the scenario catalog.- isCatalogEntry d f = do- isDir <- doesDirectoryExist $ d </> f- return $- if isDir- then not $ "_" `isPrefixOf` f- else takeExtensions f == ".yaml"---- | How to transform scenario path to save path.-scenarioPathToSavePath :: FilePath -> FilePath -> FilePath-scenarioPathToSavePath path swarmData = swarmData </> Data.List.intercalate "_" (splitDirectories path)---- | Load saved info about played scenario from XDG data directory.-loadScenarioInfo ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- FilePath ->- m ScenarioInfo-loadScenarioInfo p = do- path <- sendIO $ normalizeScenarioPath (SC Nothing mempty) p- infoPath <- sendIO $ scenarioPathToSavePath path <$> getSwarmSavePath False- hasInfo <- sendIO $ doesFileExist infoPath- if not hasInfo- then do- return $- ScenarioInfo path NotStarted- else- withThrow (AssetNotLoaded (Data Scenarios) infoPath . CanNotParseYaml)- . (liftEither <=< sendIO)- $ decodeFileEither infoPath---- | Save info about played scenario to XDG data directory.-saveScenarioInfo ::- FilePath ->- ScenarioInfo ->- IO ()-saveScenarioInfo path si = do- infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True- encodeFile infoPath si---- | Load a scenario item (either a scenario, or a subdirectory--- containing a collection of scenarios) from a particular path.-loadScenarioItem ::- ( Has (Throw SystemFailure) sig m- , Has (Accum (Seq SystemFailure)) sig m- , Has (Lift IO) sig m- ) =>- EntityMap ->- WorldMap ->- FilePath ->- m ScenarioItem-loadScenarioItem em worldMap path = do- isDir <- sendIO $ doesDirectoryExist path- let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path- case isDir of- True -> SICollection collectionName <$> loadScenarioDir em worldMap path- False -> do- s <- loadScenarioFile em worldMap path- eitherSi <- runThrow @SystemFailure (loadScenarioInfo path)- case eitherSi of- Right si -> return $ SISingle (s, si)- Left warning -> do- warn warning- return $ SISingle (s, ScenarioInfo path NotStarted)----------------------------------------------------------------- Some lenses + prisms---------------------------------------------------------------makePrisms ''ScenarioItem-makePrisms ''ScenarioStatus
@@ -1,1432 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Definition of the record holding all the game-related state, and various related--- utility functions.-module Swarm.Game.State (- -- * Game state record and related types- ViewCenterRule (..),- REPLStatus (..),- WinStatus (..),- WinCondition (..),- ObjectiveCompletion (..),- _NoWinCondition,- _WinConditions,- Announcement (..),- RunStatus (..),- Seed,- Step (..),- SingleStep (..),- GameState,-- -- ** GameState fields- creativeMode,- winCondition,- winSolution,- robotMap,- robotsByLocation,- robotsAtLocation,- robotsWatching,- robotsInArea,- baseRobot,- activeRobots,- waitingRobots,- messageNotifications,- seed,- randGen,- currentScenarioPath,- viewCenterRule,- viewCenter,- needsRedraw,- focusedRobotID,-- -- *** Subrecord accessors- temporal,- robotNaming,- recipesInfo,- messageInfo,- gameControls,- discovery,- landscape,-- -- ** GameState subrecords-- -- *** Temporal state- TemporalState,- gameStep,- runStatus,- ticks,- robotStepsPerTick,- paused,-- -- *** Robot naming- RobotNaming,- nameGenerator,- gensym,-- -- *** Recipes- Recipes,- recipesOut,- recipesIn,- recipesCat,-- -- *** Messages- Messages,- messageQueue,- lastSeenMessageTime,- announcementQueue,-- -- *** Controls- GameControls,- initiallyRunCode,- replStatus,- replNextValueIndex,- replWorking,- replActiveType,- inputHandler,-- -- *** Discovery- Discovery,- allDiscoveredEntities,- availableRecipes,- availableCommands,- knownEntities,- gameAchievements,-- -- *** Landscape- Landscape,- worldNavigation,- multiWorld,- worldScrollable,- entityMap,-- -- ** Notifications- Notifications (..),- notificationsCount,- notificationsContent,-- -- ** Launch parameters- LaunchParams,- ValidatedLaunchParams,-- -- ** GameState initialization- GameStateConfig (..),- initGameState,- scenarioToGameState,- CodeToRun (..),- Sha1 (..),- SolutionSource (..),- parseCodeFile,-- -- * Utilities- applyViewCenterRule,- recalcViewCenter,- modifyViewCenter,- viewingRegion,- unfocus,- focusedRobot,- RobotRange (..),- focusedRange,- getRadioRange,- clearFocusedRobotLogUpdated,- addRobot,- addRobotToLocation,- addTRobot,- emitMessage,- wakeWatchingRobots,- sleepUntil,- sleepForever,- wakeUpRobotsDoneSleeping,- deleteRobot,- removeRobotFromLocationMap,- activateRobot,- toggleRunStatus,- messageIsRecent,- messageIsFromNearby,- getRunCodePath,- buildWorldTuples,- genMultiWorld,- genRobotTemplates,-) where--import Control.Applicative ((<|>))-import Control.Arrow (Arrow ((&&&)))-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 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.Int (Int32)-import Data.IntMap (IntMap)-import Data.IntMap qualified as IM-import Data.IntSet (IntSet)-import Data.IntSet qualified as IS-import Data.IntSet.Lens (setOf)-import Data.List (partition, sortOn)-import Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)-import Data.Sequence (Seq ((:<|)))-import Data.Sequence qualified as Seq-import Data.Set qualified as S-import Data.Text (Text)-import Data.Text qualified as T (drop, take)-import Data.Text.IO qualified as TIO-import Data.Text.Lazy qualified as TL-import Data.Text.Lazy.Encoding qualified as TL-import Data.Tuple (swap)-import GHC.Generics (Generic)-import Servant.Docs (ToSample)-import Servant.Docs qualified as SD-import Swarm.Game.Achievement.Attainment-import Swarm.Game.Achievement.Definitions-import Swarm.Game.CESK (CESK (Waiting), TickNumber (..), addTicks, emptyStore, finalValue, initMachine)-import Swarm.Game.Entity-import Swarm.Game.Failure (SystemFailure (..))-import Swarm.Game.Location-import Swarm.Game.Recipe (- Recipe,- catRecipeMap,- inRecipeMap,- outRecipeMap,- )-import Swarm.Game.ResourceLoading (NameGenerator)-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.ScenarioInfo-import Swarm.Game.Terrain (TerrainType (..))-import Swarm.Game.Universe as U-import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray)-import Swarm.Game.World qualified as W-import Swarm.Game.World.Eval (runWorld)-import Swarm.Game.World.Gen (Seed, findGoodOrigin)-import Swarm.Game.World.Typecheck (WorldMap)-import Swarm.Language.Capability (constCaps)-import Swarm.Language.Context qualified as Ctx-import Swarm.Language.Module (Module (Module))-import Swarm.Language.Pipeline (ProcessedTerm (ProcessedTerm), processTermEither)-import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst)-import Swarm.Language.Typed (Typed (Typed))-import Swarm.Language.Types-import Swarm.Language.Value (Value)-import Swarm.Log-import Swarm.Util (applyWhen, binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?))-import Swarm.Util.Erasable-import Swarm.Util.Lens (makeLensesExcluding, makeLensesNoSigs)-import System.Clock qualified as Clock-import System.Random (StdGen, mkStdGen, randomRIO)----------------------------------------------------------------- Subsidiary data types----------------------------------------------------------------- | The 'ViewCenterRule' specifies how to determine the center of the--- world viewport.-data ViewCenterRule- = -- | The view should be centered on an absolute position.- VCLocation (Cosmic Location)- | -- | The view should be centered on a certain robot.- VCRobot RID- deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)--makePrisms ''ViewCenterRule---- | A data type to represent the current status of the REPL.-data REPLStatus- = -- | The REPL is not doing anything actively at the moment.- -- We persist the last value and its type though.- --- -- INVARIANT: the 'Value' stored here is not a 'Swarm.Language.Value.VResult'.- REPLDone (Maybe (Typed Value))- | -- | A command entered at the REPL is currently being run. The- -- 'Polytype' represents the type of the expression that was- -- entered. The @Maybe Value@ starts out as 'Nothing' and gets- -- filled in with a result once the command completes.- REPLWorking (Typed (Maybe Value))- deriving (Eq, Show, Generic, FromJSON, ToJSON)--data WinStatus- = -- | There are one or more objectives remaining that the player- -- has not yet accomplished.- Ongoing- | -- | The player has won.- -- The boolean indicates whether they have- -- already been congratulated.- Won Bool- | -- | The player has completed certain "goals" that preclude- -- (via negative prerequisites) the completion of all of the- -- required goals.- -- The boolean indicates whether they have- -- already been informed.- Unwinnable Bool- deriving (Show, Generic, FromJSON, ToJSON)--data WinCondition- = -- | There is no winning condition.- NoWinCondition- | -- | NOTE: It is possible to continue to achieve "optional" objectives- -- even after the game has been won (or deemed unwinnable).- WinConditions WinStatus ObjectiveCompletion- deriving (Show, Generic, FromJSON, ToJSON)--makePrisms ''WinCondition--instance ToSample WinCondition where- toSamples _ =- SD.samples- [ NoWinCondition- -- TODO: #1552 add simple objective sample- ]---- | A data type to keep track of the pause mode.-data RunStatus- = -- | The game is running.- Running- | -- | The user paused the game, and it should stay pause after visiting the help.- ManualPause- | -- | The game got paused while visiting the help,- -- and it should unpause after returning back to the game.- AutoPause- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | Switch (auto or manually) paused game to running and running to manually paused.------ Note that this function is not safe to use in the app directly, because the UI--- also tracks time between ticks---use 'Swarm.TUI.Controller.safeTogglePause' instead.-toggleRunStatus :: RunStatus -> RunStatus-toggleRunStatus s = if s == Running then ManualPause else Running---- | A data type to keep track of some kind of log or sequence, with--- an index to remember which ones are "new" and which ones have--- "already been seen".-data Notifications a = Notifications- { _notificationsCount :: Int- , _notificationsContent :: [a]- }- deriving (Eq, Show, Generic, FromJSON, ToJSON)--instance Semigroup (Notifications a) where- Notifications count1 xs1 <> Notifications count2 xs2 = Notifications (count1 + count2) (xs1 <> xs2)--instance Monoid (Notifications a) where- mempty = Notifications 0 []--makeLenses ''Notifications--newtype Sha1 = Sha1 String--data SolutionSource- = ScenarioSuggested- | -- | Includes the SHA1 of the program text- -- for the purpose of corroborating solutions- -- on a leaderboard.- PlayerAuthored FilePath Sha1--data CodeToRun = CodeToRun SolutionSource ProcessedTerm--getRunCodePath :: CodeToRun -> Maybe FilePath-getRunCodePath (CodeToRun solutionSource _) = case solutionSource of- ScenarioSuggested -> Nothing- PlayerAuthored fp _ -> Just fp--parseCodeFile ::- (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>- FilePath ->- m CodeToRun-parseCodeFile filepath = do- contents <- sendIO $ TIO.readFile filepath- pt@(ProcessedTerm (Module (Syntax' srcLoc _ _) _) _ _) <-- either (throwError . CustomFailure) return (processTermEither contents)- let strippedText = stripSrc srcLoc contents- programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText- sha1Hash = showDigest $ sha1 programBytestring- return $ CodeToRun (PlayerAuthored filepath $ Sha1 sha1Hash) pt- where- stripSrc :: SrcLoc -> Text -> Text- stripSrc (SrcLoc start end) txt = T.drop start $ T.take end txt- stripSrc NoLoc txt = txt----------------------------------------------------------------- The main GameState record type----------------------------------------------------------------- | By default, robots may make a maximum of 100 CESK machine steps--- during one game tick.-defaultRobotStepsPerTick :: Int-defaultRobotStepsPerTick = 100---- | Type for remembering which robots will be run next in a robot step mode.------ Once some robots have run, we need to store 'RID' to know which ones should go next.--- At 'SBefore' no robots were run yet, so it is safe to transition to and from 'WorldTick'.------ @--- tick--- ┌────────────────────────────────────┐--- │ │--- │ step │--- │ ┌────┐ │--- ▼ ▼ │ │--- ┌───────┐ step ┌───────┴───┐ step ┌────┴─────┐--- │SBefore├──────►│SSingle RID├──────►│SAfter RID│--- └──┬────┘ └───────────┘ └────┬─────┘--- │ ▲ player ▲ │--- ▼ │ switch └───────────────────┘--- ┌────┴────┐ view RID > oldRID--- │WorldTick│--- └─────────┘--- @-data SingleStep- = -- | Run the robots from the beginning until the focused robot (noninclusive).- SBefore- | -- | Run a single step of the focused robot.- SSingle RID- | -- | Run robots after the (previously) focused robot and finish the tick.- SAfter RID---- | Game step mode - we use the single step mode when debugging robot 'CESK' machine.-data Step = WorldTick | RobotStep SingleStep--data Recipes = Recipes- { _recipesOut :: IntMap [Recipe Entity]- , _recipesIn :: IntMap [Recipe Entity]- , _recipesCat :: IntMap [Recipe Entity]- }--makeLensesNoSigs ''Recipes---- | All recipes the game knows about, indexed by outputs.-recipesOut :: Lens' Recipes (IntMap [Recipe Entity])---- | All recipes the game knows about, indexed by inputs.-recipesIn :: Lens' Recipes (IntMap [Recipe Entity])---- | All recipes the game knows about, indexed by requirement/catalyst.-recipesCat :: Lens' Recipes (IntMap [Recipe Entity])--data Messages = Messages- { _messageQueue :: Seq LogEntry- , _lastSeenMessageTime :: TickNumber- , _announcementQueue :: Seq Announcement- }--makeLensesNoSigs ''Messages---- | A queue of global messages.------ Note that we put the newest entry to the right.-messageQueue :: Lens' Messages (Seq LogEntry)---- | Last time message queue has been viewed (used for notification).-lastSeenMessageTime :: Lens' Messages TickNumber---- | A queue of global announcements.--- Note that this is distinct from the 'messageQueue',--- which is for messages emitted by robots.------ Note that we put the newest entry to the right.-announcementQueue :: Lens' Messages (Seq Announcement)--data RobotNaming = RobotNaming- { _nameGenerator :: NameGenerator- , _gensym :: Int- }--makeLensesExcluding ['_nameGenerator] ''RobotNaming----- | Read-only list of words, for use in building random robot names.-nameGenerator :: Getter RobotNaming NameGenerator-nameGenerator = to _nameGenerator---- | A counter used to generate globally unique IDs.-gensym :: Lens' RobotNaming Int--data TemporalState = TemporalState- { _gameStep :: Step- , _runStatus :: RunStatus- , _ticks :: TickNumber- , _robotStepsPerTick :: Int- }--makeLensesNoSigs ''TemporalState---- | How to step the game: 'WorldTick' or 'RobotStep' for debugging the 'CESK' machine.-gameStep :: Lens' TemporalState Step---- | The current 'RunStatus'.-runStatus :: Lens' TemporalState RunStatus---- | Whether the game is currently paused.-paused :: Getter TemporalState Bool-paused = to (\s -> s ^. runStatus /= Running)---- | The number of ticks elapsed since the game started.-ticks :: Lens' TemporalState TickNumber---- | The maximum number of CESK machine steps a robot may take during--- a single tick.-robotStepsPerTick :: Lens' TemporalState Int--data GameControls = GameControls- { _replStatus :: REPLStatus- , _replNextValueIndex :: Integer- , _inputHandler :: Maybe (Text, Value)- , _initiallyRunCode :: Maybe ProcessedTerm- }--makeLensesNoSigs ''GameControls---- | The current status of the REPL.-replStatus :: Lens' GameControls REPLStatus---- | The index of the next @it{index}@ value-replNextValueIndex :: Lens' GameControls Integer---- | The currently installed input handler and hint text.-inputHandler :: Lens' GameControls (Maybe (Text, Value))---- | Code that is run upon scenario start, before any--- REPL interaction.-initiallyRunCode :: Lens' GameControls (Maybe ProcessedTerm)--data Discovery = Discovery- { _allDiscoveredEntities :: Inventory- , _availableRecipes :: Notifications (Recipe Entity)- , _availableCommands :: Notifications Const- , _knownEntities :: [Text]- , _gameAchievements :: Map GameplayAchievement Attainment- }--makeLensesNoSigs ''Discovery---- | The list of entities that have been discovered.-allDiscoveredEntities :: Lens' Discovery Inventory---- | The list of available recipes.-availableRecipes :: Lens' Discovery (Notifications (Recipe Entity))---- | The list of available commands.-availableCommands :: Lens' Discovery (Notifications Const)---- | The names of entities that should be considered \"known\", that is,--- robots know what they are without having to scan them.-knownEntities :: Lens' Discovery [Text]---- | Map of in-game achievements that were obtained-gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment)--data Landscape = Landscape- { _worldNavigation :: Navigation (M.Map SubworldName) Location- , _multiWorld :: W.MultiWorld Int Entity- , _entityMap :: EntityMap- , _worldScrollable :: Bool- }--makeLensesNoSigs ''Landscape---- | Includes a 'Map' of named locations and an--- "edge list" (graph) that maps portal entrances to exits-worldNavigation :: Lens' Landscape (Navigation (M.Map SubworldName) Location)---- | The current state of the world (terrain and entities only; robots--- are stored in the 'robotMap'). 'Int' is used instead of--- 'TerrainType' because we need to be able to store terrain values in--- unboxed tile arrays.-multiWorld :: Lens' Landscape (W.MultiWorld Int Entity)---- | The catalog of all entities that the game knows about.-entityMap :: Lens' Landscape EntityMap---- | Whether the world map is supposed to be scrollable or not.-worldScrollable :: Lens' Landscape Bool---- | The main record holding the state for the game itself (as--- distinct from the UI). See the lenses below for access to its--- fields.-data GameState = GameState- { _creativeMode :: Bool- , _temporal :: TemporalState- , _winCondition :: WinCondition- , _winSolution :: Maybe ProcessedTerm- , _robotMap :: IntMap Robot- , -- A set of robots to consider for the next game tick. It is guaranteed to- -- be a subset of the keys of 'robotMap'. It may contain waiting or idle- -- robots. But robots that are present in 'robotMap' and not in 'activeRobots'- -- are guaranteed to be either waiting or idle.- _activeRobots :: IntSet- , -- A set of probably waiting robots, indexed by probable wake-up time. It- -- may contain robots that are in fact active or idle, as well as robots- -- that do not exist anymore. Its only guarantee is that once a robot name- -- with its wake up time is inserted in it, it will remain there until the- -- wake-up time is reached, at which point it is removed via- -- 'wakeUpRobotsDoneSleeping'.- -- Waiting robots for a given time are a list because it is cheaper to- -- prepend to a list than insert into a 'Set'.- _waitingRobots :: Map TickNumber [RID]- , _robotsByLocation :: Map SubworldName (Map Location IntSet)- , -- This member exists as an optimization so- -- that we do not have to iterate over all "waiting" robots,- -- since there may be many.- _robotsWatching :: Map (Cosmic Location) (S.Set RID)- , _discovery :: Discovery- , _seed :: Seed- , _randGen :: StdGen- , _robotNaming :: RobotNaming- , _recipesInfo :: Recipes- , _currentScenarioPath :: Maybe FilePath- , _landscape :: Landscape- , _viewCenterRule :: ViewCenterRule- , _viewCenter :: Cosmic Location- , _needsRedraw :: Bool- , _gameControls :: GameControls- , _messageInfo :: Messages- , _focusedRobotID :: RID- }----------------------------------------------------------------- Lenses----------------------------------------------------------------- We want to access active and waiting robots via lenses inside--- this module but to expose it as a Getter to protect invariants.-makeLensesFor- [ ("_activeRobots", "internalActiveRobots")- , ("_waitingRobots", "internalWaitingRobots")- ]- ''GameState--makeLensesExcluding ['_viewCenter, '_focusedRobotID, '_viewCenterRule, '_activeRobots, '_waitingRobots] ''GameState---- | Is the user in creative mode (i.e. able to do anything without restriction)?-creativeMode :: Lens' GameState Bool---- | Aspects of the temporal state of the game-temporal :: Lens' GameState TemporalState---- | How to determine whether the player has won.-winCondition :: Lens' GameState WinCondition---- | How to win (if possible). This is useful for automated testing--- and to show help to cheaters (or testers).-winSolution :: Lens' GameState (Maybe ProcessedTerm)---- | All the robots that currently exist in the game, indexed by ID.-robotMap :: Lens' GameState (IntMap Robot)---- | The names of all robots that currently exist in the game, indexed by--- location (which we need both for /e.g./ the @salvage@ command as--- well as for actually drawing the world). Unfortunately there is--- no good way to automatically keep this up to date, since we don't--- just want to completely rebuild it every time the 'robotMap'--- changes. Instead, we just make sure to update it every time the--- location of a robot changes, or a robot is created or destroyed.--- Fortunately, there are relatively few ways for these things to--- happen.-robotsByLocation :: Lens' GameState (Map SubworldName (Map Location IntSet))---- | Get a list of all the robots at a particular location.-robotsAtLocation :: Cosmic Location -> GameState -> [Robot]-robotsAtLocation loc gs =- mapMaybe (`IM.lookup` (gs ^. robotMap))- . maybe [] IS.toList- . M.lookup (loc ^. planar)- . M.findWithDefault mempty (loc ^. subworld)- . view robotsByLocation- $ gs---- | Get a list of all the robots that are \"watching\" by location.-robotsWatching :: Lens' GameState (Map (Cosmic Location) (S.Set RID))---- | Get all the robots within a given Manhattan distance from a--- location.-robotsInArea :: Cosmic Location -> Int32 -> GameState -> [Robot]-robotsInArea (Cosmic subworldName o) d gs = map (rm IM.!) rids- where- rm = gs ^. robotMap- rl = gs ^. robotsByLocation- rids =- concatMap IS.elems $- getElemsInArea o d $- M.findWithDefault mempty subworldName rl---- | The base robot, if it exists.-baseRobot :: Traversal' GameState Robot-baseRobot = robotMap . ix 0---- | The names of the robots that are currently not sleeping.-activeRobots :: Getter GameState IntSet-activeRobots = internalActiveRobots---- | The names of the robots that are currently sleeping, indexed by wake up--- time. Note that this may not include all sleeping robots, particularly--- those that are only taking a short nap (e.g. @wait 1@).-waitingRobots :: Getter GameState (Map TickNumber [RID])-waitingRobots = internalWaitingRobots---- | Discovery state of entities, commands, recipes-discovery :: Lens' GameState Discovery---- | The initial seed that was used for the random number generator,--- and world generation.-seed :: Lens' GameState Seed---- | Pseudorandom generator initialized at start.-randGen :: Lens' GameState StdGen---- | State and data for assigning identifiers to robots-robotNaming :: Lens' GameState RobotNaming---- | Collection of recipe info-recipesInfo :: Lens' GameState Recipes---- | The filepath of the currently running scenario.------ This is useful as an index to the scenarios collection,--- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'.-currentScenarioPath :: Lens' GameState (Maybe FilePath)---- | Info about the lay of the land-landscape :: Lens' GameState Landscape---- | The current center of the world view. Note that this cannot be--- modified directly, since it is calculated automatically from the--- 'viewCenterRule'. To modify the view center, either set the--- 'viewCenterRule', or use 'modifyViewCenter'.-viewCenter :: Getter GameState (Cosmic Location)-viewCenter = to _viewCenter---- | Whether the world view needs to be redrawn.-needsRedraw :: Lens' GameState Bool---- | Controls, including REPL and key mapping-gameControls :: Lens' GameState GameControls---- | Message info-messageInfo :: Lens' GameState Messages---- | The current robot in focus.------ It is only a 'Getter' because this value should be updated only when--- the 'viewCenterRule' is specified to be a robot.------ Technically it's the last robot ID specified by 'viewCenterRule',--- but that robot may not be alive anymore - to be safe use 'focusedRobot'.-focusedRobotID :: Getter GameState RID-focusedRobotID = to _focusedRobotID----------------------------------------------------------------- Utilities----------------------------------------------------------------- | The current rule for determining the center of the world view.--- It updates also, 'viewCenter' and 'focusedRobot' to keep--- everything synchronized.-viewCenterRule :: Lens' GameState ViewCenterRule-viewCenterRule = lens getter setter- where- getter :: GameState -> ViewCenterRule- getter = _viewCenterRule-- -- The setter takes care of updating 'viewCenter' and 'focusedRobot'- -- So non of this fields get out of sync.- setter :: GameState -> ViewCenterRule -> GameState- setter g rule =- case rule of- VCLocation loc -> g {_viewCenterRule = rule, _viewCenter = loc}- VCRobot rid ->- let robotcenter = g ^? robotMap . ix rid . robotLocation- in -- retrieve the loc of the robot if it exists, Nothing otherwise.- -- sometimes, lenses are amazing...- case robotcenter of- Nothing -> g- Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid}---- | Whether the repl is currently working.-replWorking :: Getter GameControls Bool-replWorking = to (\s -> matchesWorking $ s ^. replStatus)- where- matchesWorking (REPLDone _) = False- matchesWorking (REPLWorking _) = True---- | Either the type of the command being executed, or of the last command-replActiveType :: Getter REPLStatus (Maybe Polytype)-replActiveType = to getter- where- getter (REPLDone (Just (Typed _ typ _))) = Just typ- getter (REPLWorking (Typed _ typ _)) = Just typ- getter _ = Nothing---- | Get the notification list of messages from the point of view of focused robot.-messageNotifications :: Getter GameState (Notifications LogEntry)-messageNotifications = to getNotif- where- getNotif gs = Notifications {_notificationsCount = length new, _notificationsContent = allUniq}- where- allUniq = uniq $ toList allMessages- new = takeWhile (\l -> l ^. leTime > gs ^. messageInfo . lastSeenMessageTime) $ reverse allUniq- -- creative players and system robots just see all messages (and focused robots logs)- unchecked = gs ^. creativeMode || fromMaybe False (focusedRobot gs ^? _Just . systemRobot)- messages = (if unchecked then id else focusedOrLatestClose) (gs ^. messageInfo . messageQueue)- allMessages = Seq.sort $ focusedLogs <> messages- focusedLogs = maybe Empty (view robotLog) (focusedRobot gs)- -- classic players only get to see messages that they said and a one message that they just heard- -- other they have to get from log- latestMsg = messageIsRecent gs- closeMsg = messageIsFromNearby (gs ^. viewCenter)- generatedBy rid logEntry = case logEntry ^. leSource of- RobotLog _ rid' _ -> rid == rid'- _ -> False-- focusedOrLatestClose mq =- (Seq.take 1 . Seq.reverse . Seq.filter closeMsg $ Seq.takeWhileR latestMsg mq)- <> Seq.filter (generatedBy (gs ^. focusedRobotID)) mq--messageIsRecent :: GameState -> LogEntry -> Bool-messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. temporal . ticks---- | Reconciles the possibilities of log messages being--- omnipresent and robots being in different worlds-messageIsFromNearby :: Cosmic Location -> LogEntry -> Bool-messageIsFromNearby l e = case e ^. leSource of- SystemLog -> True- RobotLog _ _ loc -> f loc- where- f logLoc = case cosmoMeasure manhattan l logLoc of- InfinitelyFar -> False- Measurable x -> x <= hearingDistance---- | Given a current mapping from robot names to robots, apply a--- 'ViewCenterRule' to derive the location it refers to. The result--- is 'Maybe' because the rule may refer to a robot which does not--- exist.-applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location)-applyViewCenterRule (VCLocation l) _ = Just l-applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation---- | Recalculate the view center (and cache the result in the--- 'viewCenter' field) based on the current 'viewCenterRule'. If--- the 'viewCenterRule' specifies a robot which does not exist,--- simply leave the current 'viewCenter' as it is. Set 'needsRedraw'--- if the view center changes.-recalcViewCenter :: GameState -> GameState-recalcViewCenter g =- g- { _viewCenter = newViewCenter- }- & (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id)- where- oldViewCenter = g ^. viewCenter- newViewCenter =- fromMaybe oldViewCenter $- applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap)---- | Modify the 'viewCenter' by applying an arbitrary function to the--- current value. Note that this also modifies the 'viewCenterRule'--- to match. After calling this function the 'viewCenterRule' will--- specify a particular location, not a robot.-modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> GameState -> GameState-modifyViewCenter update g =- g- & case g ^. viewCenterRule of- VCLocation l -> viewCenterRule .~ VCLocation (update l)- VCRobot _ -> viewCenterRule .~ VCLocation (update (g ^. viewCenter))---- | "Unfocus" by modifying the view center rule to look at the--- current location instead of a specific robot, and also set the--- focused robot ID to an invalid value. In classic mode this--- causes the map view to become nothing but static.-unfocus :: GameState -> GameState-unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id---- | Given a width and height, compute the region, centered on the--- 'viewCenter', that should currently be in view.-viewingRegion :: Cosmic Location -> (Int32, Int32) -> Cosmic W.BoundsRectangle-viewingRegion (Cosmic sw (Location cx cy)) (w, h) =- Cosmic sw (W.Coords (rmin, cmin), W.Coords (rmax, cmax))- where- (rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1)- (cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1)---- | Find out which robot has been last specified by the--- 'viewCenterRule', if any.-focusedRobot :: GameState -> Maybe Robot-focusedRobot g = g ^. robotMap . at (g ^. focusedRobotID)---- | Type for describing how far away a robot is from the base, which--- determines what kind of communication can take place.-data RobotRange- = -- | Close; communication is perfect.- Close- | -- | Mid-range; communication is possible but lossy.- MidRange Double- | -- | Far; communication is not possible.- Far- deriving (Eq, Ord)---- | Check how far away the focused robot is from the base. @Nothing@--- is returned if there is no focused robot; otherwise, return a--- 'RobotRange' value as follows.------ * If we are in creative or scroll-enabled mode, the focused robot is--- always considered 'Close'.--- * Otherwise, there is a "minimum radius" and "maximum radius".------ * If the robot is within the minimum radius, it is 'Close'.--- * If the robot is between the minimum and maximum radii, it--- is 'MidRange', with a 'Double' value ranging linearly from--- 0 to 1 proportional to the distance from the minimum to--- maximum radius. For example, @MidRange 0.5@ would indicate--- a robot exactly halfway between the minimum and maximum--- radii.--- * If the robot is beyond the maximum radius, it is 'Far'.------ * By default, the minimum radius is 16, and maximum is 64.--- * Device augmentations------ * If the focused robot has an @antenna@ installed, it doubles--- both radii.--- * If the base has an @antenna@ installed, it also doubles both radii.-focusedRange :: GameState -> Maybe RobotRange-focusedRange g = checkRange <$ maybeFocusedRobot- where- maybeBaseRobot = g ^. robotMap . at 0- maybeFocusedRobot = focusedRobot g-- checkRange = case r of- InfinitelyFar -> Far- Measurable r' -> computedRange r'-- computedRange r'- | g ^. creativeMode || g ^. landscape . worldScrollable || r' <= minRadius = Close- | r' > maxRadius = Far- | otherwise = MidRange $ (r' - minRadius) / (maxRadius - minRadius)-- -- Euclidean distance from the base to the view center.- r = case maybeBaseRobot of- -- if the base doesn't exist, we have bigger problems- Nothing -> InfinitelyFar- Just br -> cosmoMeasure euclidean (g ^. viewCenter) (br ^. robotLocation)-- (minRadius, maxRadius) = getRadioRange maybeBaseRobot maybeFocusedRobot---- | Get the min/max communication radii given possible augmentations on each end-getRadioRange :: Maybe Robot -> Maybe Robot -> (Double, Double)-getRadioRange maybeBaseRobot maybeTargetRobot =- (minRadius, maxRadius)- where- -- See whether the base or focused robot have antennas installed.- baseInv, focInv :: Maybe Inventory- baseInv = view equippedDevices <$> maybeBaseRobot- focInv = view equippedDevices <$> maybeTargetRobot-- gain :: Maybe Inventory -> (Double -> Double)- gain (Just inv)- | countByName "antenna" inv > 0 = (* 2)- gain _ = id-- -- Range radii. Default thresholds are 16, 64; each antenna- -- boosts the signal by 2x.- minRadius, maxRadius :: Double- (minRadius, maxRadius) = over both (gain baseInv . gain focInv) (16, 64)---- | Clear the 'robotLogUpdated' flag of the focused robot.-clearFocusedRobotLogUpdated :: (Has (State GameState) sig m) => m ()-clearFocusedRobotLogUpdated = do- n <- use focusedRobotID- robotMap . ix n . robotLogUpdated .= False---- | Add a concrete instance of a robot template to the game state:--- First, generate a unique ID number for it. Then, add it to the--- main robot map, the active robot set, and to to the index of--- robots by location. Return the updated robot.-addTRobot :: (Has (State GameState) sig m) => TRobot -> m Robot-addTRobot r = do- rid <- robotNaming . gensym <+= 1- let r' = instantiateRobot rid r- addRobot r'- return r'---- | Add a robot to the game state, adding it to the main robot map,--- the active robot set, and to to the index of robots by--- location.-addRobot :: (Has (State GameState) sig m) => Robot -> m ()-addRobot r = do- let rid = r ^. robotID-- robotMap %= IM.insert rid r- addRobotToLocation rid $ r ^. robotLocation- internalActiveRobots %= IS.insert rid---- | Helper function for updating the "robotsByLocation" bookkeeping-addRobotToLocation :: (Has (State GameState) sig m) => RID -> Cosmic Location -> m ()-addRobotToLocation rid rLoc =- robotsByLocation- %= M.insertWith- (M.unionWith IS.union)- (rLoc ^. subworld)- (M.singleton (rLoc ^. planar) (IS.singleton rid))--maxMessageQueueSize :: Int-maxMessageQueueSize = 1000---- | Add a message to the message queue.-emitMessage :: (Has (State GameState) sig m) => LogEntry -> m ()-emitMessage msg = messageInfo . messageQueue %= (|> msg) . dropLastIfLong- where- tooLong s = Seq.length s >= maxMessageQueueSize- dropLastIfLong whole@(_oldest :<| newer) = if tooLong whole then newer else whole- dropLastIfLong emptyQueue = emptyQueue---- | Takes a robot out of the 'activeRobots' set and puts it in the 'waitingRobots'--- queue.-sleepUntil :: (Has (State GameState) sig m) => RID -> TickNumber -> m ()-sleepUntil rid time = do- internalActiveRobots %= IS.delete rid- internalWaitingRobots . at time . non [] %= (rid :)---- | Takes a robot out of the 'activeRobots' set.-sleepForever :: (Has (State GameState) sig m) => RID -> m ()-sleepForever rid = internalActiveRobots %= IS.delete rid---- | Adds a robot to the 'activeRobots' set.-activateRobot :: (Has (State GameState) sig m) => RID -> m ()-activateRobot rid = internalActiveRobots %= IS.insert rid---- | Removes robots whose wake up time matches the current game ticks count--- from the 'waitingRobots' queue and put them back in the 'activeRobots' set--- if they still exist in the keys of 'robotMap'.-wakeUpRobotsDoneSleeping :: (Has (State GameState) sig m) => m ()-wakeUpRobotsDoneSleeping = do- time <- use $ temporal . ticks- mrids <- internalWaitingRobots . at time <<.= Nothing- case mrids of- Nothing -> return ()- Just rids -> do- robots <- use robotMap- let aliveRids = filter (`IM.member` robots) rids- internalActiveRobots %= IS.union (IS.fromList aliveRids)-- -- These robots' wake times may have been moved "forward"- -- by 'wakeWatchingRobots'.- clearWatchingRobots rids---- | Clear the "watch" state of all of the--- awakened robots-clearWatchingRobots ::- (Has (State GameState) sig m) =>- [RID] ->- m ()-clearWatchingRobots rids = do- robotsWatching %= M.map (`S.difference` S.fromList rids)---- | Iterates through all of the currently @wait@-ing robots,--- and moves forward the wake time of the ones that are @watch@-ing this location.------ NOTE: Clearing 'TickNumber' map entries from 'internalWaitingRobots'--- upon wakeup is handled by 'wakeUpRobotsDoneSleeping'-wakeWatchingRobots :: (Has (State GameState) sig m) => Cosmic Location -> m ()-wakeWatchingRobots loc = do- currentTick <- use $ temporal . ticks- waitingMap <- use waitingRobots- rMap <- use robotMap- watchingMap <- use robotsWatching-- -- The bookkeeping updates to robot waiting- -- states are prepared in 4 steps...-- let -- Step 1: Identify the robots that are watching this location.- botsWatchingThisLoc :: [Robot]- botsWatchingThisLoc =- mapMaybe (`IM.lookup` rMap) $- S.toList $- M.findWithDefault mempty loc watchingMap-- -- Step 2: Get the target wake time for each of these robots- wakeTimes :: [(RID, TickNumber)]- wakeTimes = mapMaybe (sequenceA . (view robotID &&& waitingUntil)) botsWatchingThisLoc-- wakeTimesToPurge :: Map TickNumber (S.Set RID)- wakeTimesToPurge = M.fromListWith (<>) $ map (fmap S.singleton . swap) wakeTimes-- -- Step 3: Take these robots out of their time-indexed slot in "waitingRobots".- -- To preserve performance, this should be done without iterating over the- -- entire "waitingRobots" map.- filteredWaiting = foldr f waitingMap $ M.toList wakeTimesToPurge- where- -- Note: some of the map values may become empty lists.- -- But we shall not worry about cleaning those up here;- -- they will be "garbage collected" as a matter of course- -- when their tick comes up in "wakeUpRobotsDoneSleeping".- f (k, botsToRemove) = M.adjust (filter (`S.notMember` botsToRemove)) k-- -- Step 4: Re-add the watching bots to be awakened at the next tick:- wakeableBotIds = map fst wakeTimes- newWakeTime = addTicks 1 currentTick- newInsertions = M.singleton newWakeTime wakeableBotIds-- -- NOTE: There are two "sources of truth" for the waiting state of robots:- -- 1. In the GameState via "internalWaitingRobots"- -- 2. In each robot, via the CESK machine state-- -- 1. Update the game state- internalWaitingRobots .= M.unionWith (<>) filteredWaiting newInsertions-- -- 2. Update the machine of each robot- forM_ wakeableBotIds $ \rid ->- robotMap . at rid . _Just . machine %= \case- Waiting _ c -> Waiting newWakeTime c- x -> x--deleteRobot :: (Has (State GameState) sig m) => RID -> m ()-deleteRobot rn = do- internalActiveRobots %= IS.delete rn- mrobot <- robotMap . at rn <<.= Nothing- mrobot `forM_` \robot -> do- -- Delete the robot from the index of robots by location.- removeRobotFromLocationMap (robot ^. robotLocation) rn---- | Makes sure empty sets don't hang around in the--- 'robotsByLocation' map. We don't want a key with an--- empty set at every location any robot has ever--- visited!-removeRobotFromLocationMap ::- (Has (State GameState) sig m) =>- Cosmic Location ->- RID ->- m ()-removeRobotFromLocationMap (Cosmic oldSubworld oldPlanar) rid =- robotsByLocation %= M.update (tidyDelete rid) oldSubworld- where- deleteOne x = surfaceEmpty IS.null . IS.delete x-- tidyDelete robID =- surfaceEmpty M.null . M.update (deleteOne robID) oldPlanar----------------------------------------------------------------- Initialization---------------------------------------------------------------type LaunchParams a = ParameterizableLaunchParams CodeToRun a---- | In this stage in the UI pipeline, both fields--- have already been validated, and "Nothing" means--- that the field is simply absent.-type ValidatedLaunchParams = LaunchParams Identity---- | Record to pass information needed to create an initial--- 'GameState' record when starting a scenario.-data GameStateConfig = GameStateConfig- { initNameParts :: NameGenerator- , initEntities :: EntityMap- , initRecipes :: [Recipe Entity]- , initWorldMap :: WorldMap- }---- | Create an initial, fresh game state record when starting a new scenario.-initGameState :: GameStateConfig -> GameState-initGameState gsc =- GameState- { _creativeMode = False- , _temporal =- TemporalState- { _gameStep = WorldTick- , _runStatus = Running- , _ticks = TickNumber 0- , _robotStepsPerTick = defaultRobotStepsPerTick- }- , _winCondition = NoWinCondition- , _winSolution = Nothing- , _robotMap = IM.empty- , _robotsByLocation = M.empty- , _robotsWatching = mempty- , _discovery =- Discovery- { _availableRecipes = mempty- , _availableCommands = mempty- , _allDiscoveredEntities = empty- , _knownEntities = []- , -- This does not need to be initialized with anything,- -- since the master list of achievements is stored in UIState- _gameAchievements = mempty- }- , _activeRobots = IS.empty- , _waitingRobots = M.empty- , _seed = 0- , _randGen = mkStdGen 0- , _robotNaming =- RobotNaming- { _nameGenerator = initNameParts gsc- , _gensym = 0- }- , _recipesInfo =- Recipes- { _recipesOut = outRecipeMap (initRecipes gsc)- , _recipesIn = inRecipeMap (initRecipes gsc)- , _recipesCat = catRecipeMap (initRecipes gsc)- }- , _currentScenarioPath = Nothing- , _landscape =- Landscape- { _worldNavigation = Navigation mempty mempty- , _multiWorld = mempty- , _entityMap = initEntities gsc- , _worldScrollable = True- }- , _viewCenterRule = VCRobot 0- , _viewCenter = defaultCosmicLocation- , _needsRedraw = False- , _gameControls =- GameControls- { _replStatus = REPLDone Nothing- , _replNextValueIndex = 0- , _inputHandler = Nothing- , _initiallyRunCode = Nothing- }- , _messageInfo =- Messages- { _messageQueue = Empty- , _lastSeenMessageTime = TickNumber (-1)- , _announcementQueue = mempty- }- , _focusedRobotID = 0- }--type SubworldDescription = (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int Entity))--buildWorldTuples :: Scenario -> NonEmpty SubworldDescription-buildWorldTuples s =- NE.map (worldName &&& buildWorld) $- s ^. scenarioWorlds--genMultiWorld :: NonEmpty SubworldDescription -> Seed -> W.MultiWorld Int Entity-genMultiWorld worldTuples s =- M.map genWorld- . M.fromList- . NE.toList- $ worldTuples- where- genWorld x = W.newWorld $ snd x s---- |--- Returns a list of robots, ordered by decreasing preference--- to serve as the "base".------ = Rules for selecting the "base" robot:------ What follows is a thorough description of how the base--- choice is made as of the most recent study of the code.--- This level of detail is not meant to be public-facing.------ For an abbreviated explanation, see the "Base robot" section of the--- <https://github.com/swarm-game/swarm/tree/main/data/scenarios#base-robot Scenario Authoring Guide>.------ == Precedence rules------ 1. Prefer those robots defined with a @loc@ ('robotLocation') in the scenario file------ 1. If multiple robots define a @loc@, use the robot that is defined--- first within the scenario file.--- 2. Note that if a robot is both given a @loc@ AND is specified in the--- world map, then two instances of the robot shall be created. The--- instance with the @loc@ shall be preferred as the base.------ 2. Fall back to robots generated from templates via the map and palette.------ 1. If multiple robots are specified in the map, prefer the one that--- is defined first within the scenario file.--- 2. If multiple robots are instantiated from the same template, then--- prefer the one with a lower-indexed subworld. Note that the root--- subworld is always first.--- 3. If multiple robots instantiated from the same template are in the--- same subworld, then--- prefer the one closest to the upper-left of the screen, with higher--- rows given precedence over columns (i.e. first in row-major order).-genRobotTemplates :: Scenario -> NonEmpty (a, ([(Int, TRobot)], b)) -> [TRobot]-genRobotTemplates scenario worldTuples =- locatedRobots ++ map snd (sortOn fst genRobots)- where- -- Keep only robots from the robot list with a concrete location;- -- the others existed only to serve as a template for robots drawn- -- in the world map- locatedRobots = filter (isJust . view trobotLocation) $ scenario ^. scenarioRobots-- -- Subworld order as encountered in the scenario YAML file is preserved for- -- the purpose of numbering robots, other than the "root" subworld- -- guaranteed to be first.- genRobots :: [(Int, TRobot)]- genRobots = concat $ NE.toList $ NE.map (fst . snd) 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)-- now <- Clock.getTime Clock.Monotonic- let robotList' = (robotCreatedAt .~ now) <$> robotList-- let modifyRecipesInfo oldRecipesInfo =- oldRecipesInfo- & recipesOut %~ addRecipesWith outRecipeMap- & recipesIn %~ addRecipesWith inRecipeMap- & recipesCat %~ addRecipesWith catRecipeMap-- return $- (initGameState gsc)- { _focusedRobotID = baseID- }- & creativeMode .~ scenario ^. scenarioCreative- & winCondition .~ theWinCondition- & winSolution .~ scenario ^. scenarioSolution- & robotMap .~ IM.fromList (map (view robotID &&& id) robotList')- & robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld robotList')- & internalActiveRobots .~ setOf (traverse . robotID) robotList'- & discovery . availableCommands .~ Notifications 0 initialCommands- & discovery . knownEntities .~ scenario ^. scenarioKnown- & robotNaming . gensym .~ initGensym- & seed .~ theSeed- & randGen .~ mkStdGen theSeed- & recipesInfo %~ modifyRecipesInfo- & landscape . entityMap .~ em- & landscape . worldNavigation .~ scenario ^. scenarioNavigation- & landscape . multiWorld .~ genMultiWorld worldTuples theSeed- -- TODO (#1370): Should we allow subworlds to have their own scrollability?- -- Leaning toward no , but for now just adopt the root world scrollability- -- as being universal.- & landscape . worldScrollable .~ NE.head (scenario ^. scenarioWorlds) ^. to scrollable- & viewCenterRule .~ VCRobot baseID- & gameControls . initiallyRunCode .~ initialCodeToRun- & gameControls . replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working,- -- otherwise the store of definition cells is not saved (see #333, #838)- False -> REPLDone Nothing- True -> REPLWorking (Typed Nothing PolyUnit mempty)- & temporal . robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick)- where- groupRobotsBySubworld =- binTuples . map (view (robotLocation . subworld) &&& id)-- groupRobotsByPlanarLocation rs =- M.fromListWith- IS.union- (map (view (robotLocation . planar) &&& (IS.singleton . view robotID)) rs)-- em = initEntities gsc <> scenario ^. scenarioEntities- baseID = 0- (things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))-- getCodeToRun (CodeToRun _ s) = s-- robotsByBasePrecedence = genRobotTemplates scenario worldTuples-- initialCodeToRun = getCodeToRun <$> toRun-- robotList =- zipWith instantiateRobot [baseID ..] robotsByBasePrecedence- -- If the --run flag was used, use it to replace the CESK machine of the- -- robot whose id is 0, i.e. the first robot listed in the scenario.- -- Note that this *replaces* any program the base robot otherwise- -- would have run (i.e. any program specified in the program: field- -- of the scenario description).- & ix baseID- . machine- %~ case initialCodeToRun of- Nothing -> id- Just pt -> const $ initMachine pt Ctx.empty emptyStore- -- If we are in creative mode, give base all the things- & ix baseID- . robotInventory- %~ case scenario ^. scenarioCreative of- False -> id- True -> union (fromElems (map (0,) things))- & ix baseID- . equippedDevices- %~ case scenario ^. scenarioCreative of- False -> id- True -> const (fromList devices)-- running = case robotList of- [] -> False- (base : _) -> isNothing (finalValue (base ^. machine))-- -- Initial list of available commands = all commands enabled by- -- devices in inventory or equipped; and commands that require no- -- capability.- allCapabilities r =- inventoryCapabilities (r ^. equippedDevices)- <> inventoryCapabilities (r ^. robotInventory)- initialCaps = mconcat $ map allCapabilities robotList- initialCommands =- filter- (maybe True (`S.member` initialCaps) . constCaps)- allConst-- worldTuples = buildWorldTuples scenario-- theWinCondition =- maybe- NoWinCondition- (\x -> WinConditions Ongoing (ObjectiveCompletion (CompletionBuckets (NE.toList x) mempty mempty) mempty))- (NE.nonEmpty (scenario ^. scenarioObjectives))-- initGensym = length robotList - 1- addRecipesWith f = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes)---- | 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)-buildWorld WorldDescription {..} = (robots worldName, first fromEnum . wf)- where- rs = fromIntegral $ length area- cs = fromIntegral $ maybe 0 length $ listToMaybe area- Coords (ulr, ulc) = locToCoords ul-- worldGrid :: [[(TerrainType, Erasable Entity)]]- worldGrid = (map . map) (cellTerrain &&& cellEntity) area-- worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity)- worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid)-- dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity- dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg- arrayWF = const (worldFunFromArray worldArray)-- wf = dslWF <> arrayWF-- -- Get all the robots described in cells and set their locations appropriately- robots :: SubworldName -> [IndexedTRobot]- robots swName =- area- & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices- & concat- & concatMap- ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) ->- let robotWithLoc = trobotLocation ?~ Cosmic swName (W.coordsToLoc (Coords (ulr + r, ulc + c)))- in map (fmap robotWithLoc) robotList- )
@@ -1,2870 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Facilities for stepping the robot CESK machines, /i.e./ the actual--- interpreter for the Swarm language.------ ** Note on the IO:------ The only reason we need @IO@ is so that robots can run programs--- loaded from files, via the 'Swarm.Language.Syntax.Run' command.--- This could be avoided by using a hypothetical @import@ command instead and parsing--- the required files at the time of declaration.--- See <https://github.com/swarm-game/swarm/issues/495>.-module Swarm.Game.Step where--import Control.Applicative (Applicative (..))-import Control.Arrow ((&&&))-import Control.Carrier.Error.Either (ErrorC, runError)-import Control.Carrier.State.Lazy-import Control.Carrier.Throw.Either (ThrowC, runThrow)-import Control.Effect.Error-import Control.Effect.Lens-import Control.Effect.Lift-import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))-import Control.Monad (foldM, forM, forM_, guard, msum, unless, when, zipWithM)-import Data.Bifunctor (second)-import Data.Bool (bool)-import Data.Char (chr, ord)-import Data.Either (partitionEithers, rights)-import Data.Foldable (asum, for_, traverse_)-import Data.Foldable.Extra (findM, firstJustM)-import Data.Function (on)-import Data.Functor (void)-import Data.Int (Int32)-import Data.IntMap qualified as IM-import Data.IntSet qualified as IS-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.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)-import Data.Ord (Down (Down))-import Data.Sequence ((><))-import Data.Sequence qualified as Seq-import Data.Set (Set)-import Data.Set qualified as S-import Data.Text (Text)-import Data.Text qualified as T-import Data.Time (getZonedTime)-import Data.Tuple (swap)-import Linear (V2 (..), perp, zero)-import Prettyprinter (pretty)-import Swarm.Game.Achievement.Attainment-import Swarm.Game.Achievement.Definitions-import Swarm.Game.CESK-import Swarm.Game.Display-import Swarm.Game.Entity hiding (empty, lookup, singleton, union)-import Swarm.Game.Entity qualified as E-import Swarm.Game.Exception-import Swarm.Game.Failure-import Swarm.Game.Location-import Swarm.Game.Recipe-import Swarm.Game.ResourceLoading (getDataFileNameSafe)-import Swarm.Game.Robot-import Swarm.Game.Scenario.Objective qualified as OB-import Swarm.Game.Scenario.Objective.WinCheck qualified as WC-import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation)-import Swarm.Game.Scenario.Topography.Navigation.Util-import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..))-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.Universe-import Swarm.Game.Value-import Swarm.Game.World qualified as W-import Swarm.Language.Capability-import Swarm.Language.Context hiding (delete)-import Swarm.Language.Key (parseKeyComboFull)-import Swarm.Language.Parse (runParser)-import Swarm.Language.Pipeline-import Swarm.Language.Pipeline.QQ (tmQ)-import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)-import Swarm.Language.Requirement qualified as R-import Swarm.Language.Syntax-import Swarm.Language.Text.Markdown qualified as Markdown-import Swarm.Language.Typed (Typed (..))-import Swarm.Language.Value-import Swarm.Log-import Swarm.Util hiding (both)-import Swarm.Util.Effect (throwToMaybe)-import Swarm.Util.WindowedCounter qualified as WC-import System.Clock (TimeSpec)-import Witch (From (from), into)-import Prelude hiding (Applicative (..), lookup)---- | The main function to do one game tick.------ Note that the game may be in 'RobotStep' mode and not finish--- the tick. Use the return value to check whether a full tick happened.-gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m Bool-gameTick = do- wakeUpRobotsDoneSleeping- active <- use activeRobots- focusedRob <- use focusedRobotID-- ticked <-- use (temporal . gameStep) >>= \case- WorldTick -> do- runRobotIDs active- temporal . ticks %= addTicks 1- pure True- RobotStep ss -> singleStep ss focusedRob active-- -- See if the base is finished with a computation, and if so, record- -- the result in the game state so it can be displayed by the REPL;- -- also save the current store into the robotContext so we can- -- restore it the next time we start a computation.- mr <- use (robotMap . at 0)- case mr of- Just r -> do- res <- use $ gameControls . replStatus- case res of- REPLWorking (Typed Nothing ty req) -> case getResult r of- Just (v, s) -> do- gameControls . replStatus .= REPLWorking (Typed (Just v) ty req)- baseRobot . robotContext . defStore .= s- Nothing -> pure ()- _otherREPLStatus -> pure ()- Nothing -> pure ()-- -- Possibly update the view center.- modify recalcViewCenter-- when ticked $ do- -- On new tick see if the winning condition for the current objective is met.- wc <- use winCondition- case wc of- WinConditions winState oc -> do- g <- get @GameState- em <- use $ landscape . entityMap- hypotheticalWinCheck em g winState oc- _ -> pure ()- return ticked---- | Finish a game tick in progress and set the game to 'WorldTick' mode afterwards.------ Use this function if you need to unpause the game.-finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m ()-finishGameTick =- use (temporal . gameStep) >>= \case- WorldTick -> pure ()- RobotStep SBefore -> temporal . gameStep .= WorldTick- RobotStep _ -> void gameTick >> finishGameTick---- Insert the robot back to robot map.--- Will selfdestruct or put the robot to sleep if it has that set.-insertBackRobot :: Has (State GameState) sig m => RID -> Robot -> m ()-insertBackRobot rn rob = do- time <- use $ temporal . ticks- if rob ^. selfDestruct- then deleteRobot rn- else do- robotMap %= IM.insert rn rob- case waitingUntil rob of- Just wakeUpTime- -- if w=2 t=1 then we do not needlessly put robot to waiting queue- | wakeUpTime <= addTicks 2 time -> return ()- | otherwise -> sleepUntil rn wakeUpTime- Nothing ->- unless (isActive rob) (sleepForever rn)---- Run a set of robots - this is used to run robots before/after the focused one.-runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m) => IS.IntSet -> m ()-runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do- mr <- uses robotMap (IM.lookup rn)- forM_ mr (stepOneRobot rn)- where- stepOneRobot rn rob = tickRobot rob >>= insertBackRobot rn---- This is a helper function to do one robot step or run robots before/after.-singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m) => SingleStep -> RID -> IS.IntSet -> m Bool-singleStep ss focRID robotSet = do- let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet- case ss of- ----------------------------------------------------------------------------- -- run robots from the beginning until focused robot- SBefore -> do- runRobotIDs preFoc- temporal . gameStep .= RobotStep (SSingle focRID)- -- also set ticks of focused robot- steps <- use $ temporal . robotStepsPerTick- robotMap . ix focRID . activityCounts . tickStepBudget .= steps- -- continue to focused robot if there were no previous robots- -- DO NOT SKIP THE ROBOT SETUP above- if IS.null preFoc- then singleStep (SSingle focRID) focRID robotSet- else return False- ----------------------------------------------------------------------------- -- run single step of the focused robot (may skip if inactive)- SSingle rid | not focusedActive -> do- singleStep (SAfter rid) rid postFoc -- skip inactive focused robot- SSingle rid -> do- mOldR <- uses robotMap (IM.lookup focRID)- case mOldR of- Nothing | rid == focRID -> do- debugLog "The debugged robot does not exist! Exiting single step mode."- runRobotIDs postFoc- temporal . gameStep .= WorldTick- temporal . ticks %= addTicks 1- return True- Nothing | otherwise -> do- debugLog "The previously debugged robot does not exist!"- singleStep SBefore focRID postFoc- Just oldR -> do- -- if focus changed we need to finish the previous robot- newR <- (if rid == focRID then stepRobot else tickRobotRec) oldR- insertBackRobot focRID newR- if rid == focRID- then do- when (newR ^. activityCounts . tickStepBudget == 0) $- temporal . gameStep .= RobotStep (SAfter focRID)- return False- else do- -- continue to newly focused- singleStep SBefore focRID postFoc- ----------------------------------------------------------------------------- -- run robots after the focused robot- SAfter rid | focRID <= rid -> do- -- This state takes care of two possibilities:- -- 1. normal - rid == focRID and we finish the tick- -- 2. changed focus and the newly focused robot has previously run- -- so we just finish the tick the same way- runRobotIDs postFoc- temporal . gameStep .= RobotStep SBefore- temporal . ticks %= addTicks 1- return True- SAfter rid | otherwise -> do- -- go to single step if new robot is focused- let (_pre, postRID) = IS.split rid robotSet- singleStep SBefore focRID postRID- where- h = hypotheticalRobot (Out VUnit emptyStore []) 0- debugLog txt = do- m <- evalState @Robot h $ createLogEntry RobotError Debug txt- emitMessage m---- | An accumulator for folding over the incomplete--- objectives to evaluate for their completion-data CompletionsWithExceptions = CompletionsWithExceptions- { exceptions :: [Text]- , completions :: ObjectiveCompletion- , completionAnnouncementQueue :: [OB.Objective]- -- ^ Upon completion, an objective is enqueued.- -- It is dequeued when displayed on the UI.- }---- | Execute the win condition check *hypothetically*: i.e. in a--- fresh CESK machine, using a copy of the current game state.------ The win check is performed only on "active" goals; that is,--- the goals that are currently unmet and have had all of their--- prerequisites satisfied.--- Note that it may be possible, while traversing through the--- goal list, for one goal to be met earlier in the list that--- happens to be a prerequisite later in the traversal. This--- is why:--- 1) We must not pre-filter the goals to be traversed based--- on satisfied prerequisites (i.e. we cannot use the--- "getActiveObjectives" function).--- 2) The traversal order must be "reverse topological" order, so--- that prerequisites are evaluated before dependent goals.--- 3) The iteration needs to be a "fold", so that state is updated--- after each element.-hypotheticalWinCheck ::- (Has (State GameState) sig m, Has (Lift IO) sig m) =>- EntityMap ->- GameState ->- WinStatus ->- ObjectiveCompletion ->- m ()-hypotheticalWinCheck em g ws oc = do- -- We can fully and accurately evaluate the new state of the objectives DAG- -- in a single pass, so long as we visit it in reverse topological order.- --- -- N.B. The "reverse" is essential due to the re-population of the- -- "incomplete" goal list by cons-ing.- finalAccumulator <-- foldM foldFunc initialAccumulator $- reverse incompleteGoals-- let newWinState = case ws of- Ongoing -> getNextWinState $ completions finalAccumulator- _ -> ws-- winCondition .= WinConditions newWinState (completions finalAccumulator)-- case newWinState of- Unwinnable _ -> do- grantAchievement LoseScenario- _ -> return ()-- messageInfo . announcementQueue %= (>< Seq.fromList (map ObjectiveCompleted $ completionAnnouncementQueue finalAccumulator))-- mapM_ handleException $ exceptions finalAccumulator- where- getNextWinState completedObjs- | WC.didWin completedObjs = Won False- | WC.didLose completedObjs = Unwinnable False- | otherwise = Ongoing-- (withoutIncomplete, incompleteGoals) = OB.extractIncomplete oc- initialAccumulator = CompletionsWithExceptions [] withoutIncomplete []-- -- All of the "incomplete" goals have been emptied from the initial accumulator, and- -- these are what we iterate over with the fold.- -- Each iteration, we either place the goal back into the "incomplete" bucket, or- -- we determine that it has been met or impossible and place it into the "completed"- -- or "unwinnable" bucket, respectively.- foldFunc (CompletionsWithExceptions exnTexts currentCompletions announcements) obj = do- v <-- if WC.isPrereqsSatisfied currentCompletions obj- then runThrow @Exn . evalState @GameState g $ evalPT $ obj ^. OB.objectiveCondition- else return $ Right $ VBool False- let simplified = simplifyResult $ stripVResult <$> v- return $ case simplified of- Left exnText ->- CompletionsWithExceptions- (exnText : exnTexts)- -- Push back the incomplete goal that had been popped for inspection- (OB.addIncomplete obj currentCompletions)- announcements- Right boolResult ->- CompletionsWithExceptions- exnTexts- -- Either restore the goal to the incomplete list from which it was popped- -- or move it to the complete (or unwinnable) bucket.- (modifyCompletions obj currentCompletions)- (modifyAnnouncements announcements)- where- (modifyCompletions, modifyAnnouncements)- | boolResult = (OB.addCompleted, (obj :))- | WC.isUnwinnable currentCompletions obj = (OB.addUnwinnable, id)- | otherwise = (OB.addIncomplete, id)-- simplifyResult = \case- Left exn -> Left $ formatExn em exn- Right (VBool x) -> Right x- Right val ->- Left $- T.unwords- [ "Non boolean value:"- , prettyValue val- , "real:"- , T.pack (show val)- ]-- -- Log exceptions in the message queue so we can check for them in tests- handleException exnText = do- m <- evalState @Robot h $ createLogEntry RobotError Critical exnText- emitMessage m- where- h = hypotheticalRobot (Out VUnit emptyStore []) 0--evalPT ::- (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>- ProcessedTerm ->- m Value-evalPT t = evaluateCESK (initMachine t empty emptyStore)---- | Create a special robot to check some hypothetical, for example the win condition.------ Use ID (-1) so it won't conflict with any robots currently in the robot map.-hypotheticalRobot :: CESK -> TimeSpec -> Robot-hypotheticalRobot c =- mkRobot- (-1)- Nothing- "hypothesis"- mempty- defaultCosmicLocation- zero- defaultRobotDisplay- c- []- []- True- False- mempty--evaluateCESK ::- (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>- CESK ->- m Value-evaluateCESK cesk = do- createdAt <- getNow- let r = hypotheticalRobot cesk createdAt- addRobot r -- Add the special robot to the robot map, so it can look itself up if needed- evalState r . runCESK $ cesk--runCESK ::- ( Has (Lift IO) sig m- , Has (Throw Exn) sig m- , Has (State GameState) sig m- , Has (State Robot) sig m- ) =>- CESK ->- m Value-runCESK (Up exn _ []) = throwError exn-runCESK cesk = case finalValue cesk of- Just (v, _) -> return v- Nothing -> stepCESK cesk >>= runCESK----------------------------------------------------------------- Debugging----------------------------------------------------------------- | Create a log entry given current robot and game time in ticks--- noting whether it has been said.------ This is the more generic version used both for (recorded) said--- messages and normal logs.-createLogEntry ::- (Has (State GameState) sig m, Has (State Robot) sig m) =>- RobotLogSource ->- Severity ->- Text ->- m LogEntry-createLogEntry source sev msg = do- rid <- use robotID- rn <- use robotName- time <- use $ temporal . ticks- loc <- use robotLocation- pure $ LogEntry time (RobotLog source rid loc) sev rn msg---- | Print some text via the robot's log.-traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => RobotLogSource -> Severity -> Text -> m LogEntry-traceLog source sev msg = do- m <- createLogEntry source sev msg- robotLog %= (Seq.|> m)- return m---- | Print a showable value via the robot's log.------ Useful for debugging.-traceLogShow :: (Has (State GameState) sig m, Has (State Robot) sig m, Show a) => a -> m ()-traceLogShow = void . traceLog Logged Info . from . show----------------------------------------------------------------- Exceptions and validation----------------------------------------------------------------- | Capabilities needed for a specific robot to evaluate or execute a--- constant. Right now, the only difference is whether the robot is--- heavy or not when executing the 'Swarm.Language.Syntax.Move' command, but there might--- be other exceptions added in the future.-constCapsFor :: Const -> Robot -> Maybe Capability-constCapsFor Move r- | r ^. robotHeavy = Just CMoveheavy-constCapsFor Backup r- | r ^. robotHeavy = Just CMoveheavy-constCapsFor Stride r- | r ^. robotHeavy = Just CMoveheavy-constCapsFor c _ = constCaps c---- | Ensure that a robot is capable of executing a certain constant--- (either because it has a device which gives it that capability,--- or it is a system robot, or we are in creative mode).-ensureCanExecute :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m ()-ensureCanExecute c =- gets @Robot (constCapsFor c) >>= \case- Nothing -> pure ()- Just cap -> do- isPrivileged <- isPrivilegedBot- robotCaps <- use robotCapabilities- let hasCaps = cap `S.member` robotCaps- (isPrivileged || hasCaps)- `holdsOr` Incapable FixByEquip (R.singletonCap cap) (TConst c)---- | Create an exception about a command failing, with an achievement-cmdExnWithAchievement :: Const -> [Text] -> GameplayAchievement -> Exn-cmdExnWithAchievement c parts a = CmdFailed c (T.unwords parts) $ Just a---- | Raise an exception about a command failing with a formatted error message.-raise :: (Has (Throw Exn) sig m) => Const -> [Text] -> m a-raise c parts = throwError (cmdExn c parts)---- | Run a subcomputation that might throw an exception in a context--- where we are returning a CESK machine; any exception will be--- turned into an 'Up' state.-withExceptions :: Monad m => Store -> Cont -> ThrowC Exn m CESK -> m CESK-withExceptions s k m = do- res <- runThrow m- case res of- Left exn -> return $ Up exn s k- Right a -> return a----------------------------------------------------------------- Stepping robots----------------------------------------------------------------- | Run a robot for one tick, which may consist of up to--- 'robotStepsPerTick' CESK machine steps and at most one tangible--- command execution, whichever comes first.-tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot-tickRobot r = do- steps <- use $ temporal . robotStepsPerTick- tickRobotRec (r & activityCounts . tickStepBudget .~ steps)---- | Recursive helper function for 'tickRobot', which checks if the--- robot is actively running and still has steps left, and if so--- runs it for one step, then calls itself recursively to continue--- stepping the robot.-tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot-tickRobotRec r = do- time <- use $ temporal . ticks- case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of- True -> stepRobot r >>= tickRobotRec- False -> return r---- | Single-step a robot by decrementing its 'tickStepBudget' counter and--- running its CESK machine for one step.-stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot-stepRobot r = do- (r', cesk') <- runState (r & activityCounts . tickStepBudget -~ 1) (stepCESK (r ^. machine))- -- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n")- t <- use $ temporal . ticks-- isCreative <- use creativeMode- let shouldTrackActivity = isCreative || not (r' ^. systemRobot)-- return $- applyWhen shouldTrackActivity (maintainActivityWindow t) $- r'- & machine .~ cesk'- & activityCounts . lifetimeStepCount +~ 1- where- maintainActivityWindow t bot =- bot & (activityCounts . activityWindow %~ WC.insert t)---- | replace some entity in the world with another entity-updateWorld ::- (Has (State GameState) sig m, Has (Throw Exn) sig m) =>- Const ->- WorldUpdate Entity ->- m ()-updateWorld c (ReplaceEntity loc eThen down) = do- w <- use $ landscape . multiWorld- let eNow = W.lookupCosmicEntity (fmap W.locToCoords loc) w- -- Can fail if a robot started a multi-tick "drill" operation on some entity- -- and meanwhile another entity swaps it out from under them.- if Just eThen /= eNow- then throwError $ cmdExn c ["The", eThen ^. entityName, "is not there."]- else updateEntityAt loc $ const down--applyRobotUpdates ::- (Has (State GameState) sig m, Has (State Robot) sig m) =>- [RobotUpdate] ->- m ()-applyRobotUpdates =- mapM_ \case- AddEntity c e -> robotInventory %= E.insertCount c e- LearnEntity e -> robotInventory %= E.insertCount 0 e--data SKpair = SKpair Store Cont---- | Performs some side-effectful computation--- for an "FImmediate" Frame.--- Aborts processing the continuation stack--- if an error is encountered.------ Compare to "withExceptions".-processImmediateFrame ::- (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) =>- Value ->- SKpair ->- -- | the unreliable computation- ErrorC Exn m () ->- m CESK-processImmediateFrame v (SKpair s k) unreliableComputation = do- wc <- runError unreliableComputation- case wc of- Left exn -> return $ Up exn s k- Right () -> stepCESK $ Out v s k--updateWorldAndRobots ::- (HasRobotStepState sig m) =>- Const ->- [WorldUpdate Entity] ->- [RobotUpdate] ->- m ()-updateWorldAndRobots cmd wf rf = do- mapM_ (updateWorld cmd) wf- applyRobotUpdates rf- flagRedraw---- | The main CESK machine workhorse. Given a robot, look at its CESK--- machine state and figure out a single next step.-stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK-stepCESK cesk = case cesk of- ------------------------------------------------------------- -- Evaluation-- -- We wake up robots whose wake-up time has been reached. If it hasn't yet- -- then stepCESK is a no-op.- Waiting wakeupTime cesk' -> do- time <- use $ temporal . ticks- if wakeupTime <= time- then stepCESK cesk'- else return cesk- Out v s (FImmediate cmd wf rf : k) ->- processImmediateFrame v (SKpair s k) $- updateWorldAndRobots cmd wf rf- -- Now some straightforward cases. These all immediately turn- -- into values.- In TUnit _ s k -> return $ Out VUnit s k- In (TDir d) _ s k -> return $ Out (VDir d) s k- In (TInt n) _ s k -> return $ Out (VInt n) s k- In (TText str) _ s k -> return $ Out (VText str) s k- In (TBool b) _ s k -> return $ Out (VBool b) s k- -- There should not be any antiquoted variables left at this point.- In (TAntiText v) _ s k ->- return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $str:" v)) s k- In (TAntiInt v) _ s k ->- return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $int:" v)) s k- -- Require and requireDevice just turn into no-ops.- In (TRequireDevice {}) e s k -> return $ In (TConst Noop) e s k- In (TRequire {}) e s k -> return $ In (TConst Noop) e s k- In (TRequirements x t) e s k -> return $ Out (VRequirements x t e) s k- -- Type ascriptions are ignored- In (TAnnotate v _) e s k -> return $ In v e s k- -- Normally it's not possible to have a TRobot value in surface- -- syntax, but the salvage command generates a program that needs to- -- refer directly to the salvaging robot.- In (TRobot rid) _ s k -> return $ Out (VRobot rid) s k- -- Function constants of arity 0 are evaluated immediately- -- (e.g. parent, self). Any other constant is turned into a VCApp,- -- which is waiting for arguments and/or an FExec frame.- In (TConst c) _ s k- | arity c == 0 && not (isCmd c) -> evalConst c [] s k- | otherwise -> return $ Out (VCApp c []) s k- -- To evaluate a variable, just look it up in the context.- In (TVar x) e s k -> withExceptions s k $ do- v <-- lookup x e- `isJustOr` Fatal (T.unwords ["Undefined variable", x, "encountered while running the interpreter."])- return $ Out v s k-- -- To evaluate a pair, start evaluating the first component.- In (TPair t1 t2) e s k -> return $ In t1 e s (FSnd t2 e : k)- -- Once that's done, evaluate the second component.- Out v1 s (FSnd t2 e : k) -> return $ In t2 e s (FFst v1 : k)- -- Finally, put the results together into a pair value.- Out v2 s (FFst v1 : k) -> return $ Out (VPair v1 v2) s k- -- Lambdas immediately turn into closures.- In (TLam x _ t) e s k -> return $ Out (VClo x t e) s k- -- To evaluate an application, start by focusing on the left-hand- -- side and saving the argument for later.- In (TApp t1 t2) e s k -> return $ In t1 e s (FArg t2 e : k)- -- Once that's done, switch to evaluating the argument.- Out v1 s (FArg t2 e : k) -> return $ In t2 e s (FApp v1 : k)- -- We can evaluate an application of a closure in the usual way.- Out v2 s (FApp (VClo x t e) : k) -> return $ In t (addBinding x v2 e) s k- -- We can also evaluate an application of a constant by collecting- -- arguments, eventually dispatching to evalConst for function- -- constants.- Out v2 s (FApp (VCApp c args) : k)- | not (isCmd c)- && arity c == length args + 1 ->- evalConst c (reverse (v2 : args)) s k- | otherwise -> return $ Out (VCApp c (v2 : args)) s k- Out _ s (FApp _ : _) -> badMachineState s "FApp of non-function"- -- Start evaluating a record. If it's empty, we're done. Otherwise, focus- -- on the first field and record the rest in a FRcd frame.- In (TRcd m) e s k -> return $ case M.assocs m of- [] -> Out (VRcd M.empty) s k- ((x, t) : fs) -> In (fromMaybe (TVar x) t) e s (FRcd e [] x fs : k)- -- When we finish evaluating the last field, return a record value.- Out v s (FRcd _ done x [] : k) -> return $ Out (VRcd (M.fromList ((x, v) : done))) s k- -- Otherwise, save the value of the field just evaluated and move on- -- to focus on evaluating the next one.- Out v s (FRcd e done x ((y, t) : rest) : k) ->- return $ In (fromMaybe (TVar y) t) e s (FRcd e ((x, v) : done) y rest : k)- -- Evaluate a record projection: evaluate the record and remember we- -- need to do the projection later.- In (TProj t x) e s k -> return $ In t e s (FProj x : k)- -- Do a record projection- Out v s (FProj x : k) -> case v of- VRcd m -> case M.lookup x m of- Nothing -> badMachineState s $ T.unwords ["Record projection for variable", x, "that does not exist"]- Just xv -> return $ Out xv s k- _ -> badMachineState s "FProj frame with non-record value"- -- To evaluate non-recursive let expressions, we start by focusing on the- -- let-bound expression.- In (TLet False x _ t1 t2) e s k -> return $ In t1 e s (FLet x t2 e : k)- -- To evaluate recursive let expressions, we evaluate the memoized- -- delay of the let-bound expression. Every free occurrence of x- -- in the let-bound expression and the body has already been- -- rewritten by elaboration to 'force x'.- In (TLet True x _ t1 t2) e s k ->- return $ In (TDelay (MemoizedDelay $ Just x) t1) e s (FLet x t2 e : k)- -- Once we've finished with the let-binding, we switch to evaluating- -- the body in a suitably extended environment.- Out v1 s (FLet x t2 e : k) -> return $ In t2 (addBinding x v1 e) s k- -- Definitions immediately turn into VDef values, awaiting execution.- In tm@(TDef r x _ t) e s k -> withExceptions s k $ do- hasCapabilityFor CEnv tm- return $ Out (VDef r x t e) s k-- -- Bind expressions don't evaluate: just package it up as a value- -- until such time as it is to be executed.- In (TBind mx t1 t2) e s k -> return $ Out (VBind mx t1 t2 e) s k- -- Simple (non-memoized) delay expressions immediately turn into- -- VDelay values, awaiting application of 'Force'.- In (TDelay SimpleDelay t) e s k -> return $ Out (VDelay t e) s k- -- For memoized delay expressions, we allocate a new cell in the store and- -- return a reference to it.- In (TDelay (MemoizedDelay x) t) e s k -> do- -- Note that if the delay expression is recursive, we add a- -- binding to the environment that wil be used to evaluate the- -- body, binding the variable to a reference to the memory cell we- -- just allocated for the body expression itself. As a fun aside,- -- notice how Haskell's recursion and laziness play a starring- -- role: @loc@ is both an output from @allocate@ and used as part- -- of an input! =D- let (loc, s') = allocate (maybe id (`addBinding` VRef loc) x e) t s- return $ Out (VRef loc) s' k- -- If we see an update frame, it means we're supposed to set the value- -- of a particular cell to the value we just finished computing.- Out v s (FUpdate loc : k) -> return $ Out v (setStore loc (V v) s) k- ------------------------------------------------------------- -- Execution-- -- Executing a 'requirements' command generates an appropriate log message- -- listing the requirements of the given expression.- Out (VRequirements src t _) s (FExec : k) -> do- currentContext <- use $ robotContext . defReqs- em <- use $ landscape . entityMap- let (R.Requirements caps devs inv, _) = R.requirements currentContext t-- devicesForCaps, requiredDevices :: Set (Set Text)- -- possible devices to provide each required capability- devicesForCaps = S.map (S.fromList . map (^. entityName) . (`deviceForCap` em)) caps- -- outright required devices- requiredDevices = S.map S.singleton devs-- deviceSets :: Set (Set Text)- deviceSets =- -- Union together all required device sets, and remove any- -- device sets which are a superset of another set. For- -- example, if (grabber OR fast grabber OR harvester) is- -- required but (grabber OR fast grabber) is also required- -- then we might as well remove the first set, since- -- satisfying the second device set will automatically- -- satisfy the first.- removeSupersets $ devicesForCaps `S.union` requiredDevices-- reqLog =- prettyText $- BulletList- (pretty $ T.unwords ["Requirements for", bquote src <> ":"])- ( filter- (not . null . bulletListItems)- [ BulletList- "Equipment:"- (T.intercalate " OR " . S.toList <$> S.toList deviceSets)- , BulletList- "Inventory:"- ((\(e, n) -> e <> " " <> parens (showT n)) <$> M.assocs inv)- ]- )-- _ <- traceLog Logged Info reqLog- return $ Out VUnit s k-- -- To execute a definition, we immediately turn the body into a- -- delayed value, so it will not even be evaluated until it is- -- called. We memoize both recursive and non-recursive definitions,- -- since the point of a definition is that it may be used many times.- Out (VDef r x t e) s (FExec : k) ->- return $ In (TDelay (MemoizedDelay $ bool Nothing (Just x) r) t) e s (FDef x : k)- -- Once we have finished evaluating the (memoized, delayed) body of- -- a definition, we return a special VResult value, which packages- -- up the return value from the @def@ command itself (@unit@)- -- together with the resulting environment (the variable bound to- -- the delayed value).- Out v s (FDef x : k) ->- return $ Out (VResult VUnit (singleton x v)) s k- -- To execute a constant application, delegate to the 'evalConst'- -- function. Set tickStepBudget to 0 if the command is supposed to take- -- a tick, so the robot won't take any more steps this tick.- Out (VCApp c args) s (FExec : k) -> do- when (isTangible c) $ activityCounts . tickStepBudget .= 0- evalConst c (reverse args) s k-- -- Reset the runningAtomic flag when we encounter an FFinishAtomic frame.- Out v s (FFinishAtomic : k) -> do- runningAtomic .= False- return $ Out v s k-- -- Machinery for implementing the 'Swarm.Language.Syntax.MeetAll' command.- -- First case: done meeting everyone.- Out b s (FMeetAll _ [] : k) -> return $ Out b s k- -- More still to meet: apply the function to the current value b and- -- then the next robot id. This will result in a command which we- -- execute, discard any generated environment, and then pass the- -- result to continue meeting the rest of the robots.- Out b s (FMeetAll f (rid : rids) : k) ->- return $ Out b s (FApp f : FArg (TRobot rid) empty : FExec : FDiscardEnv : FMeetAll f rids : k)- -- To execute a bind expression, evaluate and execute the first- -- command, and remember the second for execution later.- Out (VBind mx c1 c2 e) s (FExec : k) -> return $ In c1 e s (FExec : FBind mx c2 e : k)- -- If first command completes with a value along with an environment- -- resulting from definition commands and/or binds, switch to- -- evaluating the second command of the bind. Extend the- -- environment with both the environment resulting from the first- -- command, as well as a binding for the result (if the bind was of- -- the form @x <- c1; c2@). Remember that we must execute the- -- second command once it has been evaluated, then union any- -- resulting definition environment with the definition environment- -- from the first command.- Out (VResult v ve) s (FBind mx t2 e : k) -> do- let ve' = maybe id (`addBinding` v) mx ve- return $ In t2 (e `union` ve') s (FExec : fUnionEnv ve' k)- -- If the first command completes with a simple value and there is no binder,- -- then we just continue without worrying about the environment.- Out _ s (FBind Nothing t2 e : k) -> return $ In t2 e s (FExec : k)- -- If the first command completes with a simple value and there is a binder,- -- we promote it to the returned environment as well.- Out v s (FBind (Just x) t2 e : k) -> do- return $ In t2 (addBinding x v e) s (FExec : fUnionEnv (singleton x v) k)- -- If a command completes with a value and definition environment,- -- and the next continuation frame contains a previous environment- -- to union with, then pass the unioned environments along in- -- another VResult.-- Out (VResult v e2) s (FUnionEnv e1 : k) -> return $ Out (VResult v (e1 `union` e2)) s k- -- Or, if a command completes with no environment, but there is a- -- previous environment to union with, just use that environment.- Out v s (FUnionEnv e : k) -> return $ Out (VResult v e) s k- -- If there's an explicit DiscardEnv frame, throw away any returned environment.- Out (VResult v _) s (FDiscardEnv : k) -> return $ Out v s k- Out v s (FDiscardEnv : k) -> return $ Out v s k- -- If the top of the continuation stack contains a 'FLoadEnv' frame,- -- it means we are supposed to load up the resulting definition- -- environment, store, and type and capability contexts into the robot's- -- top-level environment and contexts, so they will be available to- -- future programs.- Out (VResult v e) s (FLoadEnv ctx rctx : k) -> do- robotContext . defVals %= (`union` e)- robotContext . defTypes %= (`union` ctx)- robotContext . defReqs %= (`union` rctx)- return $ Out v s k- Out v s (FLoadEnv {} : k) -> return $ Out v s k- -- Any other type of value wiwth an FExec frame is an error (should- -- never happen).- Out _ s (FExec : _) -> badMachineState s "FExec frame with non-executable value"- -- If we see a VResult in any other context, simply discard it. For- -- example, this is what happens when there are binders (i.e. a "do- -- block") nested inside another block instead of at the top level.- -- It used to be that (1) only 'def' could generate a VResult, and- -- (2) 'def' was guaranteed to only occur at the top level, hence- -- any VResult would be caught by a FLoadEnv frame, and seeing a- -- VResult anywhere else was an error. But- -- https://github.com/swarm-game/swarm/commit/b62d27e566565aa9a3ff351d91b23d2589b068dc- -- made top-level binders export a variable binding, also via the- -- VResult mechanism, and unlike 'def', binders do not have to occur- -- at the top level only. This led to- -- https://github.com/swarm-game/swarm/issues/327 , which was fixed- -- by changing this case from an error to simply ignoring the- -- VResult wrapper.- Out (VResult v _) s k -> return $ Out v s k- ------------------------------------------------------------- -- Exception handling- -------------------------------------------------------------- -- First, if we were running a try block but evaluation completed normally,- -- just ignore the try block and continue.- Out v s (FTry {} : k) -> return $ Out v s k- Up exn s [] -> do- -- Here, an exception has risen all the way to the top level without being- -- handled.- case exn of- CmdFailed _ _ (Just a) -> do- grantAchievement a- _ -> return ()-- -- If an exception rises all the way to the top level without being- -- handled, turn it into an error message.-- -- HOWEVER, we have to make sure to check that the robot has the- -- 'log' capability which is required to collect and view logs.- --- -- Notice how we call resetBlackholes on the store, so that any- -- cells which were in the middle of being evaluated will be reset.- let s' = resetBlackholes s- h <- hasCapability CLog- em <- use $ landscape . entityMap- if h- then do- void $ traceLog RobotError Error (formatExn em exn)- return $ Out VUnit s []- else return $ Out VUnit s' []- -- Fatal errors, capability errors, and infinite loop errors can't- -- be caught; just throw away the continuation stack.- Up exn@Fatal {} s _ -> return $ Up exn s []- Up exn@Incapable {} s _ -> return $ Up exn s []- Up exn@InfiniteLoop {} s _ -> return $ Up exn s []- -- Otherwise, if we are raising an exception up the continuation- -- stack and come to a Try frame, force and then execute the associated catch- -- block.- Up _ s (FTry c : k) -> return $ Out c s (FApp (VCApp Force []) : FExec : k)- -- Otherwise, keep popping from the continuation stack.- Up exn s (_ : k) -> return $ Up exn s k- -- Finally, if we're done evaluating and the continuation stack is- -- empty, return the machine unchanged.- done@(Out _ _ []) -> return done- where- badMachineState s msg =- let msg' =- T.unlines- [ T.append "Bad machine state in stepRobot: " msg- , prettyText cesk- ]- in return $ Up (Fatal msg') s []-- -- Note, the order of arguments to `union` is important in the below- -- definition of fUnionEnv. I wish I knew how to add an automated- -- test for this. But you can tell the difference in the following- -- REPL session:- --- -- > x <- return 1; x <- return 2- -- 2 : int- -- > x- -- 2 : int- --- -- If we switch the code to read 'e1 `union` e2' instead, then- -- the first expression above still correctly evaluates to 2, but- -- x ends up incorrectly bound to 1.-- fUnionEnv e1 = \case- FUnionEnv e2 : k -> FUnionEnv (e2 `union` e1) : k- k -> FUnionEnv e1 : k---- | Eexecute a constant, catching any exception thrown and returning--- it via a CESK machine state.-evalConst ::- (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK-evalConst c vs s k = do- res <- runError $ execConst c vs s k- case res of- Left exn -> return $ Up exn s k- Right cek' -> return cek'---- | A system program for a "seed robot", to regrow a growable entity--- after it is harvested.-seedProgram :: Integer -> Integer -> Text -> ProcessedTerm-seedProgram minTime randTime thing =- [tmQ|- try {- r <- random (1 + $int:randTime);- wait (r + $int:minTime);- appear "|";- r <- random (1 + $int:randTime);- wait (r + $int:minTime);- place $str:thing;- } {};- selfdestruct- |]---- | Construct a "seed robot" from entity, time range and position,--- and add it to the world. It has low priority and will be covered--- by placed entities.-addSeedBot ::- Has (State GameState) sig m =>- Entity ->- (Integer, Integer) ->- Cosmic Location ->- TimeSpec ->- m ()-addSeedBot e (minT, maxT) loc ts =- void $- addTRobot $- mkRobot- ()- Nothing- "seed"- (Markdown.fromText $ T.unwords ["A growing", e ^. entityName, "seed."])- (Just loc)- zero- ( defaultEntityDisplay '.'- & displayAttr .~ (e ^. entityDisplay . displayAttr)- & displayPriority .~ 0- )- (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore)- []- [(1, e)]- True- False- mempty- ts---- | Interpret the execution (or evaluation) of a constant application--- to some values.-execConst ::- (HasRobotStepState sig m, Has (Lift IO) sig m) =>- Const ->- [Value] ->- Store ->- Cont ->- m CESK-execConst c vs s k = do- -- First, ensure the robot is capable of executing/evaluating this constant.- ensureCanExecute c-- -- Increment command count regardless of success- when (isTangible c) $- activityCounts . tangibleCommandCount += 1-- activityCounts . commandsHistogram %= M.insertWith (+) c 1-- -- Now proceed to actually carry out the operation.- case c of- Noop -> return $ Out VUnit s k- Return -> case vs of- [v] -> return $ Out v s k- _ -> badConst- Wait -> case vs of- [VInt d] -> do- time <- use $ temporal . ticks- purgeFarAwayWatches- return $ Waiting (addTicks (fromIntegral d) time) (Out VUnit s k)- _ -> badConst- Selfdestruct -> do- destroyIfNotBase $ \case False -> Just AttemptSelfDestructBase; _ -> Nothing- flagRedraw- return $ Out VUnit s k- Move -> do- orient <- use robotOrientation- moveInDirection $ orient ? zero- Backup -> do- orient <- use robotOrientation- moveInDirection $ applyTurn (DRelative $ DPlanar DBack) $ orient ? zero- Path -> case vs of- [VInj hasLimit limitVal, VInj findEntity goalVal] -> do- maybeLimit <-- if hasLimit- then case limitVal of- VInt d -> return $ Just d- _ -> badConst- else return Nothing- goal <-- if findEntity- then case goalVal of- VText eName -> return $ EntityTarget eName- _ -> badConst- else case goalVal of- VPair (VInt x) (VInt y) ->- return $- LocationTarget $- Location (fromIntegral x) (fromIntegral y)- _ -> badConst- robotLoc <- use robotLocation- result <- pathCommand maybeLimit robotLoc goal- return $ Out (asValue result) s k- _ -> badConst- Push -> do- -- Figure out where we're going- loc <- use robotLocation- orient <- use robotOrientation- let applyHeading = (`offsetBy` (orient ? zero))- nextLoc = applyHeading loc- placementLoc = applyHeading nextLoc-- -- If unobstructed, the robot will move even if- -- there is nothing to push.- maybeCurrentE <- entityAt nextLoc- case maybeCurrentE of- Just e -> do- -- Make sure there's nothing already occupying the destination- nothingHere <- isNothing <$> entityAt placementLoc- nothingHere `holdsOrFail` ["Something is in the way!"]-- let verbed = verbedGrabbingCmd Push'- -- Ensure it can be pushed.- omni <- isPrivilegedBot- (omni || e `hasProperty` Portable && not (e `hasProperty` Liquid))- `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."]-- -- Place the entity and remove it from previous loc- updateEntityAt nextLoc (const Nothing)- updateEntityAt placementLoc (const (Just e))- Nothing -> return ()-- updateRobotLocation loc nextLoc- return $ Out VUnit s k- Stride -> case vs of- [VInt d] -> do- when (d > fromIntegral maxStrideRange) $- throwError $- CmdFailed- Stride- ( T.unwords- [ "Can only stride up to"- , T.pack $ show maxStrideRange- , "units."- ]- )- Nothing-- -- Figure out where we're going- loc <- use robotLocation- orient <- use robotOrientation- let heading = orient ? zero-- -- Excludes the base location.- let locsInDirection :: [Cosmic Location]- locsInDirection =- take (min (fromIntegral d) maxStrideRange) $- drop 1 $- iterate (`offsetBy` heading) loc-- failureMaybes <- mapM checkMoveFailure locsInDirection- let maybeFirstFailure = asum failureMaybes-- applyMoveFailureEffect maybeFirstFailure $ \case- PathBlocked -> ThrowExn- PathLiquid -> Destroy-- let maybeLastLoc = do- guard $ null maybeFirstFailure- listToMaybe $ reverse locsInDirection-- forM_ maybeLastLoc $ updateRobotLocation loc-- return $ Out VUnit s k- _ -> badConst- Teleport -> case vs of- [VRobot rid, VPair (VInt x) (VInt y)] -> do- -- Make sure the other robot exists and is close- target <- getRobotWithinTouch rid- -- either change current robot or one in robot map- let oldLoc = target ^. robotLocation- nextLoc = fmap (const $ Location (fromIntegral x) (fromIntegral y)) oldLoc-- onTarget rid $ do- checkMoveAhead nextLoc $ \case- PathBlocked -> Destroy- PathLiquid -> Destroy- updateRobotLocation oldLoc nextLoc-- return $ Out VUnit s k- _ -> badConst- Grab -> mkReturn <$> doGrab Grab'- Harvest -> mkReturn <$> doGrab Harvest'- Ignite -> case vs of- [VDir d] -> do- Combustion.igniteCommand c d- return $ Out VUnit s k- _ -> badConst- Swap -> case vs of- [VText name] -> do- loc <- use robotLocation- -- Make sure the robot has the thing in its inventory- e <- hasInInventoryOrFail name- -- Grab- newE <- doGrab Swap'-- -- Place the entity and remove it from the inventory- updateEntityAt loc (const (Just e))- robotInventory %= delete e-- when (e == newE) $- grantAchievement SwapSame-- return $ mkReturn newE- _ -> badConst- Turn -> case vs of- [VDir d] -> do- when (isCardinal d) $ hasCapabilityFor COrient (TDir d)- robotOrientation . _Just %= applyTurn d- flagRedraw-- inst <- use equippedDevices- when (d == DRelative DDown && countByName "compass" inst == 0) $ do- grantAchievement GetDisoriented-- return $ Out VUnit s k- _ -> badConst- Place -> case vs of- [VText name] -> do- loc <- use robotLocation-- -- Make sure there's nothing already here- nothingHere <- isNothing <$> entityAt loc- nothingHere `holdsOrFail` ["There is already an entity here."]-- -- Make sure the robot has the thing in its inventory- e <- hasInInventoryOrFail name-- -- Place the entity and remove it from the inventory- updateEntityAt loc (const (Just e))- robotInventory %= delete e-- flagRedraw- return $ Out VUnit s k- _ -> badConst- Ping -> case vs of- [VRobot otherID] -> do- maybeOtherRobot <- robotWithID otherID- selfRobot <- get- return $ Out (asValue $ displacementVector selfRobot maybeOtherRobot) s k- where- displacementVector :: Robot -> Maybe Robot -> Maybe (V2 Int32)- displacementVector selfRobot maybeOtherRobot = do- otherRobot <- maybeOtherRobot- let dist = (cosmoMeasure euclidean `on` view robotLocation) selfRobot otherRobot- (_minRange, maxRange) = getRadioRange (Just selfRobot) (Just otherRobot)- d <- getFiniteDistance dist- guard $ d <= maxRange- orientationBasedRelativePosition selfRobot $ view robotLocation otherRobot- _ -> badConst- Give -> case vs of- [VRobot otherID, VText itemName] -> do- -- Make sure the other robot exists and is close- _other <- getRobotWithinTouch otherID-- item <- ensureItem itemName "give"-- -- Giving something to ourself should be a no-op. We need- -- this as a special case since it will not work to modify- -- ourselves in the robotMap --- after performing a tick we- -- return a modified Robot which gets put back in the- -- robotMap, overwriting any changes to this robot made- -- directly in the robotMap during the tick.- myID <- use robotID- focusedID <- use focusedRobotID- when (otherID /= myID) $ do- -- Make the exchange- robotMap . at otherID . _Just . robotInventory %= insert item- robotInventory %= delete item-- -- Flag the UI for a redraw if we are currently showing either robot's inventory- when (focusedID == myID || focusedID == otherID) flagRedraw-- return $ Out VUnit s k- _ -> badConst- Equip -> case vs of- [VText itemName] -> do- item <- ensureItem itemName "equip"- myID <- use robotID- focusedID <- use focusedRobotID- -- Don't do anything if the robot already has the device.- already <- use (equippedDevices . to (`E.contains` item))- unless already $ do- equippedDevices %= insert item- robotInventory %= delete item-- -- Flag the UI for a redraw if we are currently showing our inventory- when (focusedID == myID) flagRedraw-- return $ Out VUnit s k- _ -> badConst- Unequip -> case vs of- [VText itemName] -> do- item <- ensureEquipped itemName- myID <- use robotID- focusedID <- use focusedRobotID- equippedDevices %= delete item- robotInventory %= insert item- -- Flag the UI for a redraw if we are currently showing our inventory- when (focusedID == myID) flagRedraw- return $ Out VUnit s k- _ -> badConst- Make -> case vs of- [VText name] -> do- inv <- use robotInventory- ins <- use equippedDevices- em <- use $ landscape . entityMap- e <-- lookupEntityName name em- `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]-- outRs <- use $ recipesInfo . recipesOut-- creative <- use creativeMode- let create l = l <> ["You can use 'create \"" <> name <> "\"' instead." | creative]-- -- Only consider recipes where the number of things we are trying to make- -- is greater in the outputs than in the inputs. This prevents us from doing- -- silly things like making copper pipes when the user says "make furnace".- let recipes = filter increase (recipesFor outRs e)- increase r = countIn (r ^. recipeOutputs) > countIn (r ^. recipeInputs)- countIn xs = maybe 0 fst (find ((== e) . snd) xs)- not (null recipes)- `holdsOrFail` create ["There is no known recipe for making", indefinite name <> "."]-- let displayMissingCount mc = \case- MissingInput -> from (show mc)- MissingCatalyst -> "not equipped"- displayMissingIngredient (MissingIngredient mk mc me) =- " - " <> me ^. entityName <> " (" <> displayMissingCount mc mk <> ")"- displayMissingIngredients xs = L.intercalate ["OR"] (map displayMissingIngredient <$> xs)-- -- Try recipes and make a weighted random choice among the- -- ones we have ingredients for.- let (badRecipes, goodRecipes) = partitionEithers . map (make (inv, ins)) $ recipes- chosenRecipe <- weightedChoice (^. _3 . recipeWeight) goodRecipes- (invTaken, changeInv, recipe) <-- chosenRecipe- `isJustOrFail` create- [ "You don't have the ingredients to make"- , indefinite name <> "."- , "Missing:\n" <> T.unlines (displayMissingIngredients badRecipes)- ]-- -- take recipe inputs from inventory and add outputs after recipeTime- robotInventory .= invTaken- traverse_ (updateDiscoveredEntities . snd) (recipe ^. recipeOutputs)- finishCookingRecipe recipe VUnit [] (map (uncurry AddEntity) changeInv)- _ -> badConst- Has -> case vs of- [VText name] -> do- inv <- use robotInventory- return $ Out (VBool ((> 0) $ countByName name inv)) s k- _ -> badConst- Equipped -> case vs of- [VText name] -> do- inv <- use equippedDevices- return $ Out (VBool ((> 0) $ countByName name inv)) s k- _ -> badConst- Count -> case vs of- [VText name] -> do- inv <- use robotInventory- return $ Out (VInt (fromIntegral $ countByName name inv)) s k- _ -> badConst- Scout -> case vs of- [VDir d] -> do- rMap <- use robotMap- myLoc <- use robotLocation- heading <- deriveHeading d- botsByLocs <- use robotsByLocation- selfRid <- use robotID-- -- Includes the base location, so we exclude the base robot later.- let locsInDirection :: [Cosmic Location]- locsInDirection = take maxScoutRange $ iterate (`offsetBy` heading) myLoc-- let hasOpaqueEntity =- fmap (maybe False (`hasProperty` E.Opaque)) . entityAt-- let hasVisibleBot :: Cosmic Location -> Bool- hasVisibleBot = any botIsVisible . IS.toList . excludeSelf . botsHere- where- excludeSelf = (`IS.difference` IS.singleton selfRid)- botsHere (Cosmic swName loc) =- M.findWithDefault mempty loc $- M.findWithDefault mempty swName botsByLocs- botIsVisible = maybe False canSee . (`IM.lookup` rMap)- canSee = not . (^. robotDisplay . invisible)-- -- A robot on the same cell as an opaque entity is considered hidden.- -- Returns (Just Bool) if the result is conclusively visible or opaque,- -- or Nothing if we don't have a conclusive answer yet.- let isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool- isConclusivelyVisible isOpaque loc- | isOpaque = Just False- | hasVisibleBot loc = Just True- | otherwise = Nothing-- let isConclusivelyVisibleM loc = do- opaque <- hasOpaqueEntity loc- return $ isConclusivelyVisible opaque loc-- -- This ensures that we only evaluate locations until- -- a conclusive result is obtained, so we don't always- -- have to inspect the maximum range of the command.- result <- firstJustM isConclusivelyVisibleM locsInDirection- let foundBot = fromMaybe False result- return $ Out (VBool foundBot) s k- _ -> badConst- Whereami -> do- loc <- use robotLocation- return $ Out (asValue $ loc ^. planar) s k- Waypoint -> case vs of- [VText name, VInt idx] -> do- lm <- use $ landscape . worldNavigation- Cosmic swName _ <- use robotLocation- case M.lookup (WaypointName name) $ M.findWithDefault mempty swName $ waypoints lm of- Nothing -> throwError $ CmdFailed Waypoint (T.unwords ["No waypoint named", name]) Nothing- Just wps -> return $ Out (asValue (NE.length wps, indexWrapNonEmpty wps idx)) s k- _ -> badConst- Detect -> case vs of- [VText name, VRect x1 y1 x2 y2] -> do- loc <- use robotLocation- let locs = rectCells x1 y1 x2 y2- -- sort offsets by (Manhattan) distance so that we return the closest occurrence- let sortedOffsets = sortOn (\(V2 x y) -> abs x + abs y) locs- let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc- firstOne <- findM f sortedOffsets- return $ Out (asValue firstOne) s k- _ -> badConst- Resonate -> case vs of- [VText name, VRect x1 y1 x2 y2] -> doResonate (maybe False $ isEntityNamed name) x1 y1 x2 y2- _ -> badConst- Density -> case vs of- [VRect x1 y1 x2 y2] -> doResonate isJust x1 y1 x2 y2- _ -> badConst- Sniff -> case vs of- [VText name] -> do- firstFound <- findNearest name- return $ Out (asValue $ maybe (-1) fst firstFound) s k- _ -> badConst- Watch -> case vs of- [VDir d] -> do- (loc, _me) <- lookInDirection d- addWatchedLocation loc- return $ Out VUnit s k- _ -> badConst- Surveil -> case vs of- [VPair (VInt x) (VInt y)] -> do- Cosmic swName _ <- use robotLocation- let loc = Cosmic swName $ Location (fromIntegral x) (fromIntegral y)- addWatchedLocation loc- return $ Out VUnit s k- _ -> badConst- Chirp -> case vs of- [VText name] -> do- firstFound <- findNearest name- mh <- use robotOrientation- inst <- use equippedDevices- let processDirection entityDir =- if countByName "compass" inst >= 1- then Just $ DAbsolute entityDir- else case mh >>= toDirection of- Just (DAbsolute robotDir) ->- Just . DRelative . DPlanar $ entityDir `relativeTo` robotDir- _ -> Nothing -- This may happen if the robot is facing "down"- val = VDir $ fromMaybe (DRelative DDown) $ do- entLoc <- firstFound- guard $ snd entLoc /= zero- processDirection . nearestDirection . snd $ entLoc- return $ Out val s k- _ -> badConst- Heading -> do- mh <- use robotOrientation- -- In general, (1) entities might not have an orientation, and- -- (2) even if they do, orientation is a general vector, which- -- might not correspond to a cardinal direction. We could make- -- 'heading' return a 'maybe dir' i.e. 'unit + dir', or return a- -- vector of type 'int * int', but those would both be annoying- -- for players in the vast majority of cases. We rather choose- -- to just return the direction 'down' in any case where we don't- -- otherwise have anything reasonable to return.- return $ Out (VDir (fromMaybe (DRelative DDown) $ mh >>= toDirection)) s k- Time -> do- TickNumber t <- use $ temporal . ticks- return $ Out (VInt $ fromIntegral t) s k- Drill -> case vs of- [VDir d] -> doDrill d- _ -> badConst- Use -> case vs of- [VText deviceName, VDir d] -> do- ins <- use equippedDevices- equippedEntity <- ensureEquipped deviceName- let verbPhrase = T.unwords ["use", deviceName, "on"]- applyDevice ins verbPhrase d equippedEntity- _ -> badConst- Blocked -> do- loc <- use robotLocation- orient <- use robotOrientation- let nextLoc = loc `offsetBy` (orient ? zero)- me <- entityAt nextLoc- return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) s k- Scan -> case vs of- [VDir d] -> do- (_loc, me) <- lookInDirection d- for_ me $ \e -> do- robotInventory %= insertCount 0 e- updateDiscoveredEntities e- -- Flag the world for a redraw since scanning something may- -- change the way it is drawn (if the base is doing the- -- scanning)- flagRedraw- return $ Out (asValue me) s k- _ -> badConst- Knows -> case vs of- [VText name] -> do- inv <- use robotInventory- ins <- use equippedDevices- let allKnown = inv `E.union` ins- let knows = case E.lookupByName name allKnown of- [] -> False- _ -> True- return $ Out (VBool knows) s k- _ -> badConst- Upload -> case vs of- [VRobot otherID] -> do- -- Make sure the other robot exists and is close- _other <- getRobotWithinTouch otherID-- -- Upload knowledge of everything in our inventory- inv <- use robotInventory- forM_ (elems inv) $ \(_, e) ->- robotMap . at otherID . _Just . robotInventory %= insertCount 0 e-- -- Upload our log- rlog <- use robotLog- robotMap . at otherID . _Just . robotLog <>= rlog-- -- Flag the world for redraw since uploading may change the- -- base's knowledge and hence how entities are drawn (if they- -- go from unknown to known).- flagRedraw-- return $ Out VUnit s k- _ -> badConst- Random -> case vs of- [VInt hi] -> do- n <- uniform (0, hi - 1)- return $ Out (VInt n) s k- _ -> badConst- Atomic -> goAtomic- Instant -> goAtomic- As -> case vs of- [VRobot rid, prog] -> do- -- Get the named robot and current game state- r <- robotWithID rid >>= (`isJustOrFail` ["There is no actor with ID", from (show rid)])- g <- get @GameState-- -- Execute the given program *hypothetically*: i.e. in a fresh- -- CESK machine, using *copies* of the current store, robot- -- and game state. We discard the state afterwards so any- -- modifications made by prog do not persist. Note we also- -- set the copied robot to be a "system" robot so it is- -- capable of executing any commands; the As command- -- already requires "God" capability.- v <-- evalState @Robot (r & systemRobot .~ True) . evalState @GameState g $- runCESK (Out prog s [FApp (VCApp Force []), FExec])-- -- Return the value returned by the hypothetical command.- return $ Out v s k- _ -> badConst- RobotNamed -> case vs of- [VText rname] -> do- r <- robotWithName rname >>= (`isJustOrFail` ["There is no robot named", rname])- return $ Out (asValue r) s k- _ -> badConst- RobotNumbered -> case vs of- [VInt rid] -> do- r <-- robotWithID (fromIntegral rid)- >>= (`isJustOrFail` ["There is no robot with number", from (show rid)])- return $ Out (asValue r) s k- _ -> badConst- Say -> case vs of- [VText msg] -> do- isPrivileged <- isPrivilegedBot- loc <- use robotLocation-- -- current robot will be inserted into the robot set, so it needs the log- m <- traceLog Said Info msg- emitMessage m- let measureToLog robLoc = \case- RobotLog _ _ logLoc -> cosmoMeasure manhattan robLoc logLoc- SystemLog -> Measurable 0- addLatestClosest rl = \case- Seq.Empty -> Seq.singleton m- es Seq.:|> e- | e `isEarlierThan` m -> es |> e |> m- | e `isFartherThan` m -> es |> m- | otherwise -> es |> e- where- isEarlierThan = (<) `on` (^. leTime)- isFartherThan = (>) `on` (measureToLog rl . view leSource)- let addToRobotLog :: (Has (State GameState) sgn m) => Robot -> m ()- addToRobotLog r = do- maybeRidLoc <- evalState r $ do- hasLog <- hasCapability CLog- hasListen <- hasCapability CListen- loc' <- use robotLocation- rid <- use robotID- return $ do- guard $ hasLog && hasListen- Just (rid, loc')- forM_ maybeRidLoc $ \(rid, loc') ->- robotMap . at rid . _Just . robotLog %= addLatestClosest loc'- robotsAround <-- if isPrivileged- then use $ robotMap . to IM.elems- else gets $ robotsInArea loc hearingDistance- mapM_ addToRobotLog robotsAround- return $ Out VUnit s k- _ -> badConst- Listen -> do- gs <- get @GameState- loc <- use robotLocation- rid <- use robotID- isPrivileged <- isPrivilegedBot- mq <- use $ messageInfo . messageQueue- let isClose e = isPrivileged || messageIsFromNearby loc e- notMine e = case e ^. leSource of- SystemLog {} -> False- RobotLog _ lrid _ -> rid /= lrid- limitLast = \case- _s Seq.:|> l -> Just $ l ^. leText- _ -> Nothing- mm = limitLast . Seq.filter (liftA2 (&&) notMine isClose) $ Seq.takeWhileR (messageIsRecent gs) mq- return $- maybe- (In (TConst Listen) mempty s (FExec : k)) -- continue listening- (\m -> Out (VText m) s k) -- return found message- mm- Log -> case vs of- [VText msg] -> do- void $ traceLog Logged Info msg- return $ Out VUnit s k- _ -> badConst- View -> case vs of- [VRobot rid] -> do- -- Only the base can actually change the view in the UI. Other robots can- -- execute this command but it does nothing (at least for now).- rn <- use robotID- when (rn == 0) $- robotWithID rid >>= \case- -- If the robot does not exist...- Nothing -> do- cr <- use creativeMode- ws <- use $ landscape . worldScrollable- case cr || ws of- -- If we are in creative mode or allowed to scroll, then we are allowed- -- to learn that the robot doesn't exist.- True -> throwError $ cmdExn c ["There is no actor with ID", from (show rid), "to view."]- -- Otherwise, "unfocus" from any robot, which- -- means the world view will turn to static. The- -- point is that there's no way to tell the difference- -- between this situation and the situation where the- -- robot exists but is too far away.- False -> modify unfocus-- -- If it does exist, set it as the view center.- Just _ -> viewCenterRule .= VCRobot rid-- return $ Out VUnit s k- _ -> badConst- Appear -> case vs of- [VText app] -> do- flagRedraw- case into @String app of- [dc] -> do- robotDisplay . defaultChar .= dc- robotDisplay . orientationMap .= M.empty- return $ Out VUnit s k- [dc, nc, ec, sc, wc] -> do- robotDisplay . defaultChar .= dc- robotDisplay . orientationMap . ix DNorth .= nc- robotDisplay . orientationMap . ix DEast .= ec- robotDisplay . orientationMap . ix DSouth .= sc- robotDisplay . orientationMap . ix DWest .= wc- return $ Out VUnit s k- _other -> raise Appear [quote app, "is not a valid appearance string. 'appear' must be given a string with exactly 1 or 5 characters."]- _ -> badConst- Create -> case vs of- [VText name] -> do- em <- use $ landscape . entityMap- e <-- lookupEntityName name em- `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]-- robotInventory %= insert e- updateDiscoveredEntities e-- return $ Out VUnit s k- _ -> badConst- Halt -> case vs of- [VRobot targetID] -> do- myID <- use robotID- case myID == targetID of- -- To halt ourselves, just return a cancelled CESK machine.- -- It will be reinstalled as our current machine; then,- -- based on the fact that our CESK machine is done we will- -- be put to sleep and the REPL will be reset if we are the- -- base robot.- True -> return $ cancel $ Out VUnit s k- False -> do- -- Make sure the other robot exists and is close enough.- target <- getRobotWithinTouch targetID- -- Make sure either we are privileged, OR the target robot- -- is NOT. In other words unprivileged bots should not be- -- able to halt privileged ones.- omni <- isPrivilegedBot- case omni || not (target ^. systemRobot) of- True -> do- -- Cancel its CESK machine, and put it to sleep.- robotMap . at targetID . _Just . machine %= cancel- sleepForever targetID- return $ Out VUnit s k- False -> throwError $ cmdExn c ["You are not authorized to halt that robot."]- _ -> badConst- Ishere -> case vs of- [VText name] -> do- loc <- use robotLocation- me <- entityAt loc- let here = maybe False (isEntityNamed name) me- return $ Out (VBool here) s k- _ -> badConst- Isempty -> do- loc <- use robotLocation- me <- entityAt loc- return $ Out (VBool (isNothing me)) s k- Self -> do- rid <- use robotID- return $ Out (VRobot rid) s k- Parent -> do- mp <- use robotParentID- rid <- use robotID- return $ Out (VRobot (fromMaybe rid mp)) s k- Base -> return $ Out (VRobot 0) s k- Meet -> do- loc <- use robotLocation- rid <- use robotID- g <- get @GameState- let neighbor =- find ((/= rid) . (^. robotID)) -- pick one other than ourself- . sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer- $ robotsInArea loc 1 g -- all robots within Manhattan distance 1- return $ Out (asValue neighbor) s k- MeetAll -> case vs of- [f, b] -> do- loc <- use robotLocation- rid <- use robotID- g <- get @GameState- let neighborIDs = filter (/= rid) . map (^. robotID) $ robotsInArea loc 1 g- return $ Out b s (FMeetAll f neighborIDs : k)- _ -> badConst- Whoami -> case vs of- [] -> do- name <- use robotName- return $ Out (VText name) s k- _ -> badConst- Setname -> case vs of- [VText name] -> do- robotName .= name- return $ Out VUnit s k- _ -> badConst- Force -> case vs of- [VDelay t e] -> return $ In t e s k- [VRef loc] ->- -- To force a VRef, we look up the location in the store.- case lookupStore loc s of- -- If there's no cell at that location, it's a bug! It- -- shouldn't be possible to get a VRef to a non-existent- -- location, since the only way VRefs get created is at the- -- time we allocate a new cell.- Nothing ->- return $- Up (Fatal $ T.append "Reference to unknown memory cell " (from (show loc))) s k- -- If the location contains an unevaluated expression, it's- -- time to evaluate it. Set the cell to a 'Blackhole', push- -- an 'FUpdate' frame so we remember to update the location- -- to its value once we finish evaluating it, and focus on- -- the expression.- Just (E t e') -> return $ In t e' (setStore loc (Blackhole t e') s) (FUpdate loc : k)- -- If the location contains a Blackhole, that means we are- -- already currently in the middle of evaluating it, i.e. it- -- depends on itself, so throw an 'InfiniteLoop' error.- Just Blackhole {} -> return $ Up InfiniteLoop s k- -- If the location already contains a value, just return it.- Just (V v) -> return $ Out v s k- -- If a force is applied to any other kind of value, just ignore it.- -- This is needed because of the way we wrap all free variables in @force@- -- in case they come from a @def@ which are always wrapped in @delay@.- -- But binders (i.e. @x <- ...@) are also exported to the global context.- [v] -> return $ Out v s k- _ -> badConst- If -> case vs of- -- Use the boolean to pick the correct branch, and apply @force@ to it.- [VBool b, thn, els] -> return $ Out (bool els thn b) s (FApp (VCApp Force []) : k)- _ -> badConst- Inl -> case vs of- [v] -> return $ Out (VInj False v) s k- _ -> badConst- Inr -> case vs of- [v] -> return $ Out (VInj True v) s k- _ -> badConst- Case -> case vs of- [VInj side v, kl, kr] -> return $ Out v s (FApp (bool kl kr side) : k)- _ -> badConst- Fst -> case vs of- [VPair v _] -> return $ Out v s k- _ -> badConst- Snd -> case vs of- [VPair _ v] -> return $ Out v s k- _ -> badConst- Try -> case vs of- [c1, c2] -> return $ Out c1 s (FApp (VCApp Force []) : FExec : FTry c2 : k)- _ -> badConst- Undefined -> return $ Up (User "undefined") s k- Fail -> case vs of- [VText msg] -> return $ Up (User msg) s k- _ -> badConst- Key -> case vs of- [VText ktxt] -> case runParser parseKeyComboFull ktxt of- Right kc -> return $ Out (VKey kc) s k- Left _ -> return $ Up (CmdFailed Key (T.unwords ["Unknown key", quote ktxt]) Nothing) s k- _ -> badConst- InstallKeyHandler -> case vs of- [VText hint, handler] -> do- gameControls . inputHandler .= Just (hint, handler)- return $ Out VUnit s k- _ -> badConst- Reprogram -> case vs of- [VRobot childRobotID, VDelay cmd e] -> do- r <- get- isPrivileged <- isPrivilegedBot-- -- check if robot exists- childRobot <-- robotWithID childRobotID- >>= (`isJustOrFail` ["There is no actor with ID", from (show childRobotID) <> "."])-- -- check that current robot is not trying to reprogram self- myID <- use robotID- (childRobotID /= myID)- `holdsOrFail` ["You cannot make a robot reprogram itself."]-- -- check if robot has completed executing it's current command- _ <-- finalValue (childRobot ^. machine)- `isJustOrFail` ["You cannot reprogram a robot that is actively running a program."]-- -- check if childRobot is at the correct distance- -- a robot can program adjacent robots- -- privileged bots ignore distance checks- loc <- use robotLocation-- isNearbyOrExempt isPrivileged loc (childRobot ^. robotLocation)- `holdsOrFail` ["You can only reprogram an adjacent robot."]-- -- Figure out if we can supply what the target robot requires,- -- and if so, what is needed.- (toEquip, toGive) <-- checkRequirements- (r ^. robotInventory)- (childRobot ^. robotInventory)- (childRobot ^. equippedDevices)- cmd- "The target robot"- FixByObtain-- -- update other robot's CESK machine, environment and context- -- the childRobot inherits the parent robot's environment- -- and context which collectively mean all the variables- -- declared in the parent robot- robotMap . at childRobotID . _Just . machine .= In cmd e s [FExec]- robotMap . at childRobotID . _Just . robotContext .= r ^. robotContext-- -- Provision the target robot with any required devices and- -- inventory that are lacking.- provisionChild childRobotID (fromList . S.toList $ toEquip) toGive-- -- Finally, re-activate the reprogrammed target robot.- activateRobot childRobotID-- return $ Out VUnit s k- _ -> badConst- Build -> case vs of- -- NOTE, pattern-matching on a VDelay here means we are- -- /relying/ on the fact that 'Build' can only be given a- -- /non-memoized/ delayed value. If it were given a memoized- -- delayed value we would see a VRef instead of a VDelay. If- -- and Try are generalized to handle any type of delayed value,- -- but Build and Reprogram still assume they are given a VDelay- -- and not a VRef. In the future, if we enable memoized delays- -- by default, or allow the user to explicitly request- -- memoization via double braces or something similar, this will- -- have to be generalized. The difficulty is that we do a- -- capability check on the delayed program at runtime, just- -- before creating the newly built robot (see the call to- -- 'requirements' below); but if we have a VRef instead of a- -- VDelay, we may only be able to get a Value out of it instead- -- of a Term as we currently do, and capability checking a Value- -- is annoying and/or problematic. One solution might be to- -- annotate delayed expressions with their required capabilities- -- at typechecking time, and carry those along so they flow to- -- this point. Another solution would be to just bite the bullet- -- and figure out how to do capability checking on Values (which- -- would return the capabilities needed to *execute* them),- -- hopefully without duplicating too much code.- [VDelay cmd e] -> do- r <- get @Robot- pid <- use robotID-- (toEquip, toGive) <-- checkRequirements (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtain-- -- Pick a random display name.- displayName <- randomName- createdAt <- getNow- isSystemRobot <- use systemRobot-- -- Construct the new robot and add it to the world.- parentCtx <- use robotContext- newRobot <-- addTRobot . (trobotContext .~ parentCtx) $- mkRobot- ()- (Just pid)- displayName- (Markdown.fromText $ "A robot built by the robot named " <> (r ^. robotName) <> ".")- (Just (r ^. robotLocation))- ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir)- ? north- )- defaultRobotDisplay- (In cmd e s [FExec])- []- []- isSystemRobot- False- mempty- createdAt-- -- Provision the new robot with the necessary devices and inventory.- provisionChild (newRobot ^. robotID) (fromList . S.toList $ toEquip) toGive-- -- Flag the world for a redraw and return the name of the newly constructed robot.- flagRedraw- return $ Out (asValue newRobot) s k- _ -> badConst- Salvage -> case vs of- [] -> do- loc <- use robotLocation- let okToSalvage r = (r ^. robotID /= 0) && (not . isActive $ r)- mtarget <- gets (find okToSalvage . robotsAtLocation loc)- case mtarget of- Nothing -> return $ Out VUnit s k -- Nothing to salvage- Just target -> do- -- Copy the salvaged robot's equipped devices into its inventory, in preparation- -- for transferring it.- let salvageInventory = E.union (target ^. robotInventory) (target ^. equippedDevices)- robotMap . at (target ^. robotID) . traverse . robotInventory .= salvageInventory-- let salvageItems = concatMap (\(n, e) -> replicate n (e ^. entityName)) (E.elems salvageInventory)- numItems = length salvageItems-- -- Copy over the salvaged robot's log, if we have one- inst <- use equippedDevices- em <- use $ landscape . entityMap- isPrivileged <- isPrivilegedBot- logger <-- lookupEntityName "logger" em- `isJustOr` Fatal "While executing 'salvage': there's no such thing as a logger!?"- when (isPrivileged || inst `E.contains` logger) $ robotLog <>= target ^. robotLog-- -- Immediately copy over any items the robot knows about- -- but has 0 of- let knownItems = map snd . filter ((== 0) . fst) . elems $ salvageInventory- robotInventory %= \i -> foldr (insertCount 0) i knownItems-- -- Now reprogram the robot being salvaged to 'give' each- -- item in its inventory to us, one at a time, then- -- self-destruct at the end. Make it a system robot so we- -- don't have to worry about capabilities.- robotMap . at (target ^. robotID) . traverse . systemRobot .= True-- ourID <- use @Robot robotID-- -- The program for the salvaged robot to run- let giveInventory =- foldr (TBind Nothing . giveItem) (TConst Selfdestruct) salvageItems- giveItem item = TApp (TApp (TConst Give) (TRobot ourID)) (TText item)-- -- Reprogram and activate the salvaged robot- robotMap- . at (target ^. robotID)- . traverse- . machine- .= In giveInventory empty emptyStore [FExec]- activateRobot (target ^. robotID)-- -- Now wait the right amount of time for it to finish.- time <- use $ temporal . ticks- return $ Waiting (addTicks (numItems + 1) time) (Out VUnit s k)- _ -> badConst- -- run can take both types of text inputs- -- with and without file extension as in- -- "./path/to/file.sw" and "./path/to/file"- Run -> case vs of- [VText fileName] -> do- let filePath = into @String fileName- sData <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script filePath- sDataSW <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script (filePath <> ".sw")- mf <- sendIO $ mapM readFileMay $ [filePath, filePath <> ".sw"] <> catMaybes [sData, sDataSW]-- f <- msum mf `isJustOrFail` ["File not found:", fileName]-- mt <-- processTerm (into @Text f) `isRightOr` \err ->- cmdExn Run ["Error in", fileName, "\n", err]-- case mt of- Nothing -> return $ Out VUnit s k- Just t@(ProcessedTerm _ _ reqCtx) -> do- -- Add the reqCtx from the ProcessedTerm to the current robot's defReqs.- -- See #827 for an explanation of (1) why this is needed, (2) why- -- it's slightly technically incorrect, and (3) why it is still way- -- better than what we had before.- robotContext . defReqs <>= reqCtx- return $ initMachine' t empty s k- _ -> badConst- Not -> case vs of- [VBool b] -> return $ Out (VBool (not b)) s k- _ -> badConst- Neg -> case vs of- [VInt n] -> return $ Out (VInt (-n)) s k- _ -> badConst- Eq -> returnEvalCmp- Neq -> returnEvalCmp- Lt -> returnEvalCmp- Gt -> returnEvalCmp- Leq -> returnEvalCmp- Geq -> returnEvalCmp- And -> case vs of- [VBool a, VBool b] -> return $ Out (VBool (a && b)) s k- _ -> badConst- Or -> case vs of- [VBool a, VBool b] -> return $ Out (VBool (a || b)) s k- _ -> badConst- Add -> returnEvalArith- Sub -> returnEvalArith- Mul -> returnEvalArith- Div -> returnEvalArith- Exp -> returnEvalArith- Format -> case vs of- [v] -> return $ Out (VText (prettyValue v)) s k- _ -> badConst- Chars -> case vs of- [VText t] -> return $ Out (VInt (fromIntegral $ T.length t)) s k- _ -> badConst- Split -> case vs of- [VInt i, VText t] ->- let p = T.splitAt (fromInteger i) t- t2 = over both VText p- in return $ Out (uncurry VPair t2) s k- _ -> badConst- Concat -> case vs of- [VText v1, VText v2] -> return $ Out (VText (v1 <> v2)) s k- _ -> badConst- CharAt -> case vs of- [VInt i, VText t]- | i < 0 || i >= fromIntegral (T.length t) ->- raise CharAt ["Index", prettyValue (VInt i), "out of bounds for length", from @String $ show (T.length t)]- | otherwise -> return $ Out (VInt . fromIntegral . ord . T.index t . fromIntegral $ i) s k- _ -> badConst- ToChar -> case vs of- [VInt i]- | i < 0 || i > fromIntegral (ord (maxBound :: Char)) ->- raise ToChar ["Value", prettyValue (VInt i), "is an invalid character code"]- | otherwise ->- return $ Out (VText . T.singleton . chr . fromIntegral $ i) s k- _ -> badConst- AppF ->- let msg = "The operator '$' should only be a syntactic sugar and removed in elaboration:\n"- in throwError . Fatal $ msg <> badConstMsg- where- doDrill d = do- ins <- use equippedDevices-- let equippedDrills = extantElemsWithCapability CDrill ins- -- Heuristic: choose the drill with the more elaborate name.- -- E.g. "metal drill" vs. "drill"- preferredDrill = listToMaybe $ sortOn (Down . T.length . (^. entityName)) equippedDrills-- tool <- preferredDrill `isJustOr` Fatal "Drill is required but not equipped?!"- applyDevice ins "drill" d tool-- applyDevice ins verbPhrase d tool = do- (nextLoc, nextE) <- getDeviceTarget verbPhrase d- inRs <- use $ recipesInfo . recipesIn-- let recipes = filter isApplicableRecipe (recipesFor inRs nextE)- isApplicableRecipe = any ((== tool) . snd) . view recipeCatalysts-- not (null recipes)- `holdsOrFail` [ "There is no way to"- , verbPhrase- , indefinite (nextE ^. entityName) <> "."- ]-- inv <- use robotInventory-- -- add the targeted entity so it can be consumed by the recipe- let makeRecipe r = (,r) <$> make' (insert nextE inv, ins) r- chosenRecipe <-- weightedChoice (\((_, _), r) -> r ^. recipeWeight) $- rights $- map makeRecipe recipes- ((invTaken, outs), recipe) <-- chosenRecipe- `isJustOrFail` ["You don't have the ingredients to", verbPhrase, indefinite (nextE ^. entityName) <> "."]-- let (out, down) = L.partition ((`hasProperty` Portable) . snd) outs- learn = map (LearnEntity . snd) down- gain = map (uncurry AddEntity) out-- newEntity <- case down of- [] -> pure Nothing- [(1, de)] -> pure $ Just de- _ -> throwError $ Fatal "Bad recipe:\n more than one unmovable entity produced."- let changeWorld =- ReplaceEntity- { updatedLoc = nextLoc- , originalEntity = nextE- , newEntity = newEntity- }-- -- take recipe inputs from inventory and add outputs after recipeTime- robotInventory .= invTaken-- let cmdOutput = asValue $ snd <$> listToMaybe out- finishCookingRecipe recipe cmdOutput [changeWorld] (learn <> gain)-- getDeviceTarget verb d = do- rname <- use robotName-- (nextLoc, nextME) <- lookInDirection d- nextE <-- nextME- `isJustOrFail` ["There is nothing to", verb, directionText, "robot", rname <> "."]- return (nextLoc, nextE)- where- directionText = case d of- DRelative DDown -> "under"- DRelative (DPlanar DForward) -> "ahead of"- DRelative (DPlanar DBack) -> "behind"- _ -> directionSyntax d <> " of"-- goAtomic :: HasRobotStepState sig m => m CESK- goAtomic = case vs of- -- To execute an atomic block, set the runningAtomic flag,- -- push an FFinishAtomic frame so that we unset the flag when done, and- -- proceed to execute the argument.- [cmd] -> do- runningAtomic .= True- return $ Out cmd s (FExec : FFinishAtomic : k)- _ -> badConst-- -- Case-insensitive matching on entity names- isEntityNamed :: T.Text -> Entity -> Bool- isEntityNamed n e = ((==) `on` T.toLower) (e ^. entityName) n-- badConst :: HasRobotStepState sig m => m a- badConst = throwError $ Fatal badConstMsg-- badConstMsg :: Text- badConstMsg =- T.unlines- [ "Bad application of execConst:"- , T.pack (show c)- , T.pack (show (reverse vs))- , prettyText (Out (VCApp c (reverse vs)) s k)- ]-- doResonate ::- (HasRobotStepState sig m, Has (Lift IO) sig m) =>- (Maybe Entity -> Bool) ->- Integer ->- Integer ->- Integer ->- Integer ->- m CESK- doResonate p x1 y1 x2 y2 = do- loc <- use robotLocation- let offsets = rectCells x1 y1 x2 y2- hits <- mapM (fmap (fromEnum . p) . entityAt . offsetBy loc) offsets- return $ Out (VInt $ fromIntegral $ sum hits) s k-- rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32]- rectCells x1 y1 x2 y2 =- rectCellsInt32- (fromIntegral x1)- (fromIntegral y1)- (fromIntegral x2)- (fromIntegral y2)-- rectCellsInt32 :: Int32 -> Int32 -> Int32 -> Int32 -> [V2 Int32]- rectCellsInt32 x1 y1 x2 y2 = [V2 x y | x <- [xMin .. xMax], y <- [yMin .. yMax]]- where- (xMin, xMax) = sortPair (x1, x2)- (yMin, yMax) = sortPair (y1, y2)-- findNearest ::- HasRobotStepState sig m =>- Text ->- m (Maybe (Int32, V2 Int32))- findNearest name = do- loc <- use robotLocation- let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc . snd- findM f sortedOffsets- where- sortedOffsets :: [(Int32, V2 Int32)]- sortedOffsets = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange]-- -- Grow a list of locations in a diamond shape outward, such that the nearest cells- -- are searched first by construction, rather than having to sort.- genDiamondSides :: Int32 -> [(Int32, V2 Int32)]- genDiamondSides diameter = concat [f diameter x | x <- [0 .. diameter]]- where- -- Adds a single cell to each of the four sides of the diamond- f d x = map (d,) . take 4 . iterate perp $ V2 x (d - x)-- finishCookingRecipe ::- HasRobotStepState sig m =>- Recipe e ->- Value ->- [WorldUpdate Entity] ->- [RobotUpdate] ->- m CESK- finishCookingRecipe r v wf rf =- if remTime <= 0- then do- updateWorldAndRobots c wf rf- return $ Out v s k- else do- time <- use $ temporal . ticks- return . (if remTime <= 1 then id else Waiting (addTicks (fromIntegral remTime) time)) $- Out v s (FImmediate c wf rf : k)- where- remTime = r ^. recipeTime-- ensureEquipped :: HasRobotStepState sig m => Text -> m Entity- ensureEquipped itemName = do- inst <- use equippedDevices- listToMaybe (lookupByName itemName inst)- `isJustOrFail` ["You don't have a", indefinite itemName, "equipped."]-- ensureItem :: HasRobotStepState sig m => Text -> Text -> m Entity- ensureItem itemName action = do- -- First, make sure we know about the entity.- inv <- use robotInventory- inst <- use equippedDevices- item <-- asum (map (listToMaybe . lookupByName itemName) [inv, inst])- `isJustOrFail` ["What is", indefinite itemName <> "?"]-- -- Next, check whether we have one. If we don't, add a hint about- -- 'create' in creative mode.- creative <- use creativeMode- let create l = l <> ["You can make one first with 'create \"" <> itemName <> "\"'." | creative]-- (E.lookup item inv > 0)- `holdsOrFail` create ["You don't have", indefinite itemName, "to", action <> "."]-- return item-- -- Check the required devices and inventory for running the given- -- command on a target robot. This function is used in common by- -- both 'Build' and 'Reprogram'.- --- -- It is given as inputs the parent robot inventory, the inventory- -- and equipped devices of the child (these will be empty in the- -- case of 'Build'), and the command to be run (along with a few- -- inputs to configure any error messages to be generated).- --- -- Throws an exception if it's not possible to set up the child- -- robot with the things it needs to execute the given program.- -- Otherwise, returns a pair consisting of the set of devices to be- -- equipped, and the inventory that should be transferred from- -- parent to child.- checkRequirements ::- HasRobotStepState sig m =>- Inventory ->- Inventory ->- Inventory ->- Term ->- Text ->- IncapableFix ->- m (Set Entity, Inventory)- checkRequirements parentInventory childInventory childDevices cmd subject fixI = do- currentContext <- use $ robotContext . defReqs- em <- use $ landscape . entityMap- creative <- use creativeMode- let -- Note that _capCtx must be empty: at least at the- -- moment, definitions are only allowed at the top level,- -- so there can't be any inside the argument to build.- -- (Though perhaps there is an argument that this ought to be- -- relaxed specifically in the cases of 'Build' and 'Reprogram'.)- -- See #349- (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd-- -- Check that all required device names exist (fail with- -- an exception if not) and convert them to 'Entity' values.- (devs :: [Entity]) <- forM devNames $ \devName ->- E.lookupEntityName devName em `isJustOrFail` ["Unknown device required: " <> devName]-- -- Check that all required inventory entity names exist (fail with- -- an exception if not) and convert them to 'Entity' values, with- -- an associated count for each.- (reqInv :: Inventory) <- fmap E.fromElems . forM (M.assocs reqInvNames) $ \(eName, n) ->- (n,)- <$> ( E.lookupEntityName eName em- `isJustOrFail` ["Unknown entity required: " <> eName]- )-- let -- List of possible devices per requirement. For the- -- requirements that stem from a required capability, we- -- remember the capability alongside the possible devices, to- -- help with later error message generation.- possibleDevices :: [(Maybe Capability, [Entity])]- possibleDevices =- map (Just &&& (`deviceForCap` em)) caps -- Possible devices for capabilities- ++ map ((Nothing,) . (: [])) devs -- Outright required devices-- -- A device is OK if it is available in the inventory of the- -- parent robot, or already equipped in the child robot.- deviceOK :: Entity -> Bool- deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d-- -- Partition each list of possible devices into a set of- -- available devices and a set of unavailable devices.- -- There's a problem if some capability is required but no- -- devices that provide it are available. In that case we can- -- print an error message, using the second set as a list of- -- suggestions.- partitionedDevices :: [(Set Entity, Set Entity)]- partitionedDevices =- map (Lens.over both S.fromList . L.partition deviceOK . snd) possibleDevices-- -- Devices equipped on the child, as a Set instead of an- -- Inventory for convenience.- alreadyEquipped :: Set Entity- alreadyEquipped = S.fromList . map snd . E.elems $ childDevices-- -- Figure out what is still missing of the required inventory:- -- the required inventory, less any inventory the child robot- -- already has.- missingChildInv = reqInv `E.difference` childInventory-- if creative- then- return- ( -- In creative mode, just equip ALL the devices- -- providing each required capability (because, why- -- not?). But don't re-equip any that are already- -- equipped.- S.unions (map (S.fromList . snd) possibleDevices) `S.difference` alreadyEquipped- , -- Conjure the necessary missing inventory out of thin- -- air.- missingChildInv- )- else do- -- First, check that devices actually exist AT ALL to provide every- -- required capability. If not, we will generate an error message saying- -- something like "missing capability X but no device yet provides it".- let capsWithNoDevice = mapMaybe fst . filter (null . snd) $ possibleDevices- null capsWithNoDevice- `holdsOr` Incapable fixI (R.Requirements (S.fromList capsWithNoDevice) S.empty M.empty) cmd-- -- Now, ensure there is at least one device available to be- -- equipped for each requirement.- let missingDevices = map snd . filter (null . fst) $ partitionedDevices- null missingDevices- `holdsOrFail` ( singularSubjectVerb subject "do"- : "not have required devices, please"- : formatIncapableFix fixI <> ":"- : (("\n - " <>) . formatDevices <$> missingDevices)- )-- let minimalEquipSet = smallHittingSet (filter (S.null . S.intersection alreadyEquipped) (map fst partitionedDevices))-- -- Check that we have enough in our inventory to cover the- -- required devices PLUS what's missing from the child- -- inventory.-- -- What do we need?- neededParentInv =- missingChildInv- `E.union` (fromList . S.toList $ minimalEquipSet)-- -- What are we missing?- missingParentInv = neededParentInv `E.difference` parentInventory- missingMap =- M.fromList- . filter ((> 0) . snd)- . map (swap . second (^. entityName))- . E.elems- $ missingParentInv-- -- If we're missing anything, throw an error- E.isEmpty missingParentInv- `holdsOr` Incapable fixI (R.Requirements S.empty S.empty missingMap) cmd-- return (minimalEquipSet, missingChildInv)-- -- Destroy the current robot, as long as it is not the base robot.- --- -- Depending on whether we destroy (True) or do not destroy- -- (False) the current robot, possibly grant an achievement.- --- -- Note we cannot simply return a Boolean and grant achievements- -- at call sites, because in the case that we do not destroy the- -- base we actually throw an exception, so we do not return to the- -- original call site.- destroyIfNotBase ::- (HasRobotStepState sig m, Has (Lift IO) sig m) =>- (Bool -> Maybe GameplayAchievement) ->- m ()- destroyIfNotBase mAch = do- rid <- use robotID- holdsOrFailWithAchievement- (rid /= 0)- ["You consider destroying your base, but decide not to do it after all."]- (mAch False)-- selfDestruct .= True- maybe (return ()) grantAchievement (mAch True)-- moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK- moveInDirection orientation = do- -- Figure out where we're going- loc <- use robotLocation- let nextLoc = loc `offsetBy` orientation- checkMoveAhead nextLoc $ \case- PathBlocked -> ThrowExn- PathLiquid -> Destroy- updateRobotLocation loc nextLoc- return $ Out VUnit s k-- applyMoveFailureEffect ::- (HasRobotStepState sig m, Has (Lift IO) sig m) =>- Maybe MoveFailureDetails ->- MoveFailureHandler ->- m ()- applyMoveFailureEffect maybeFailure failureHandler =- case maybeFailure of- Nothing -> return ()- Just (MoveFailureDetails e failureMode) -> case failureHandler failureMode of- IgnoreFail -> return ()- Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of- (True, PathLiquid) -> Just RobotIntoWater -- achievement for drowning- _ -> Nothing- ThrowExn -> throwError . cmdExn c $- case failureMode of- PathBlocked -> ["There is a", e ^. entityName, "in the way!"]- PathLiquid -> ["There is a dangerous liquid", e ^. entityName, "in the way!"]-- -- Determine the move failure mode and apply the corresponding effect.- checkMoveAhead ::- (HasRobotStepState sig m, Has (Lift IO) sig m) =>- Cosmic Location ->- MoveFailureHandler ->- m ()- checkMoveAhead nextLoc failureHandler = do- maybeFailure <- checkMoveFailure nextLoc- applyMoveFailureEffect maybeFailure failureHandler-- getRobotWithinTouch :: HasRobotStepState sig m => RID -> m Robot- getRobotWithinTouch rid = do- cid <- use robotID- if cid == rid- then get @Robot- else do- mother <- robotWithID rid- other <- mother `isJustOrFail` ["There is no robot with ID", from (show rid) <> "."]-- let otherLoc = other ^. robotLocation- privileged <- isPrivilegedBot- myLoc <- use robotLocation-- -- Make sure it is either in the same location or we do not care- isNearbyOrExempt privileged myLoc otherLoc- `holdsOrFail` ["The robot with ID", from (show rid), "is not close enough."]- return other-- holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m ()- holdsOrFail = holdsOrFail' c-- holdsOrFailWithAchievement :: (Has (Throw Exn) sig m) => Bool -> [Text] -> Maybe GameplayAchievement -> m ()- holdsOrFailWithAchievement a ts mAch = case mAch of- Nothing -> holdsOrFail a ts- Just ach -> a `holdsOr` cmdExnWithAchievement c ts ach-- isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a- isJustOrFail = isJustOrFail' c-- returnEvalCmp = case vs of- [v1, v2] -> (\b -> Out (VBool b) s k) <$> evalCmp c v1 v2- _ -> badConst- returnEvalArith = case vs of- [VInt n1, VInt n2] -> (\r -> Out (VInt r) s k) <$> evalArith c n1 n2- _ -> badConst-- -- Make sure the robot has the thing in its inventory- hasInInventoryOrFail :: HasRobotStepState sig m => Text -> m Entity- hasInInventoryOrFail eName = do- inv <- use robotInventory- e <-- listToMaybe (lookupByName eName inv)- `isJustOrFail` ["What is", indefinite eName <> "?"]- let cmd = T.toLower . T.pack . show $ c- (E.lookup e inv > 0)- `holdsOrFail` ["You don't have", indefinite eName, "to", cmd <> "."]- return e-- mkReturn :: Valuable a => a -> CESK- mkReturn x = Out (asValue x) s k-- -- The code for grab and harvest is almost identical, hence factored- -- out here.- doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m Entity- doGrab cmd = do- let verb = verbGrabbingCmd cmd- verbed = verbedGrabbingCmd cmd-- -- Ensure there is an entity here.- loc <- use robotLocation- e <-- entityAt loc- >>= (`isJustOrFail` ["There is nothing here to", verb <> "."])-- -- Ensure it can be picked up.- omni <- isPrivilegedBot- (omni || e `hasProperty` Portable)- `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."]-- -- Remove the entity from the world.- updateEntityAt loc (const Nothing)- flagRedraw-- -- Immediately regenerate entities with 'infinite' property.- when (e `hasProperty` Infinite) $- updateEntityAt loc (const (Just e))-- -- Possibly regrow the entity, if it is growable and the 'harvest'- -- command was used.- when ((e `hasProperty` Growable) && cmd == Harvest') $ do- let GrowthTime (minT, maxT) = (e ^. entityGrowth) ? defaultGrowthTime-- createdAt <- getNow-- -- Grow a new entity from a seed.- addSeedBot e (minT, maxT) loc createdAt-- -- Add the picked up item to the robot's inventory. If the- -- entity yields something different, add that instead.- let yieldName = e ^. entityYields- e' <- case yieldName of- Nothing -> return e- Just n -> fromMaybe e <$> uses (landscape . entityMap) (lookupEntityName n)-- robotInventory %= insert e'- updateDiscoveredEntities e'-- -- Return the item obtained.- return e'----------------------------------------------------------------- The "watch" command---------------------------------------------------------------addWatchedLocation ::- HasRobotStepState sig m =>- Cosmic Location ->- m ()-addWatchedLocation loc = do- rid <- use robotID- robotsWatching %= M.insertWith (<>) loc (S.singleton rid)---- | Clear watches that are out of range-purgeFarAwayWatches ::- HasRobotStepState sig m => m ()-purgeFarAwayWatches = do- privileged <- isPrivilegedBot- myLoc <- use robotLocation- rid <- use robotID-- let isNearby = isNearbyOrExempt privileged myLoc- f loc =- if not $ isNearby loc- then S.delete rid- else id-- robotsWatching %= M.filter (not . null) . M.mapWithKey f----------------------------------------------------------------- Some utility functions----------------------------------------------------------------- | Requires that the target location is within one cell.--- Requirement is waived if the bot is privileged.-isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool-isNearbyOrExempt privileged myLoc otherLoc =- privileged || case cosmoMeasure manhattan myLoc otherLoc of- InfinitelyFar -> False- Measurable x -> x <= 1--grantAchievement ::- (Has (State GameState) sig m, Has (Lift IO) sig m) =>- GameplayAchievement ->- m ()-grantAchievement a = do- currentTime <- sendIO getZonedTime- scenarioPath <- use currentScenarioPath- discovery . gameAchievements- %= M.insertWith- (<>)- a- (Attainment (GameplayAchievement a) scenarioPath currentTime)---- | How to handle failure, for example when moving to blocked location-data RobotFailure = ThrowExn | Destroy | IgnoreFail---- | How to handle different types of failure when moving/teleporting--- to a location.-type MoveFailureHandler = MoveFailureMode -> RobotFailure--data GrabbingCmd = Grab' | Harvest' | Swap' | Push' deriving (Eq, Show)--verbGrabbingCmd :: GrabbingCmd -> Text-verbGrabbingCmd = \case- Harvest' -> "harvest"- Grab' -> "grab"- Swap' -> "swap"- Push' -> "push"--verbedGrabbingCmd :: GrabbingCmd -> Text-verbedGrabbingCmd = \case- Harvest' -> "harvested"- Grab' -> "grabbed"- Swap' -> "swapped"- Push' -> "pushed"---- | Format a set of suggested devices for use in an error message,--- in the format @device1 or device2 or ... or deviceN@.-formatDevices :: Set Entity -> Text-formatDevices = T.intercalate " or " . map (^. entityName) . S.toList---- | Give some entities from a parent robot (the robot represented by--- the ambient @State Robot@ effect) to a child robot (represented--- by the given 'RID') as part of a 'Swarm.Language.Syntax.Build'--- or 'Swarm.Language.Syntax.Reprogram' command.--- The first 'Inventory' is devices to be equipped, and the second--- is entities to be transferred.------ In classic mode, the entities will be /transferred/ (that is,--- removed from the parent robot's inventory); in creative mode, the--- entities will be copied/created, that is, no entities will be--- removed from the parent robot.-provisionChild ::- (HasRobotStepState sig m) =>- RID ->- Inventory ->- Inventory ->- m ()-provisionChild childID toEquip toGive = do- -- Equip and give devices to child- robotMap . ix childID . equippedDevices %= E.union toEquip- robotMap . ix childID . robotInventory %= E.union toGive-- -- Delete all items from parent in classic mode- creative <- use creativeMode- unless creative $- robotInventory %= (`E.difference` (toEquip `E.union` toGive))---- | Update the location of a robot, and simultaneously update the--- 'robotsByLocation' map, so we can always look up robots by--- location. This should be the /only/ way to update the location--- of a robot.--- Also implements teleportation by portals.-updateRobotLocation ::- (HasRobotStepState sig m) =>- Cosmic Location ->- Cosmic Location ->- m ()-updateRobotLocation oldLoc newLoc- | oldLoc == newLoc = return ()- | otherwise = do- newlocWithPortal <- applyPortal newLoc- rid <- use robotID- removeRobotFromLocationMap oldLoc rid- addRobotToLocation rid newlocWithPortal- modify (unsafeSetRobotLocation newlocWithPortal)- flagRedraw- where- applyPortal loc = do- lms <- use $ landscape . worldNavigation- let maybePortalInfo = M.lookup loc $ portals lms- updatedLoc = maybe loc destination maybePortalInfo- maybeTurn = reorientation <$> maybePortalInfo- forM_ maybeTurn $ \d ->- robotOrientation . _Just %= applyTurn d- return updatedLoc---- | Execute a stateful action on a target robot --- whether the--- current one or another.-onTarget ::- (HasRobotStepState sig m, Has (Lift IO) sig m) =>- RID ->- (forall sig' m'. (HasRobotStepState sig' m', Has (Lift IO) sig' m') => m' ()) ->- m ()-onTarget rid act = do- myID <- use robotID- case myID == rid of- True -> act- False -> do- mtgt <- use (robotMap . at rid)- case mtgt of- Nothing -> return ()- Just tgt -> do- tgt' <- execState @Robot tgt act- if tgt' ^. selfDestruct- then deleteRobot rid- else robotMap . ix rid .= tgt'----------------------------------------------------------------- Comparison----------------------------------------------------------------- | Evaluate the application of a comparison operator. Returns--- @Nothing@ if the application does not make sense.-evalCmp :: Has (Throw Exn) sig m => Const -> Value -> Value -> m Bool-evalCmp c v1 v2 = decideCmp c $ compareValues v1 v2- where- decideCmp = \case- Eq -> fmap (== EQ)- Neq -> fmap (/= EQ)- Lt -> fmap (== LT)- Gt -> fmap (== GT)- Leq -> fmap (/= GT)- Geq -> fmap (/= LT)- _ -> const . throwError . Fatal . T.append "evalCmp called on bad constant " . from $ show c---- | Compare two values, returning an 'Ordering' if they can be--- compared, or @Nothing@ if they cannot.-compareValues :: Has (Throw Exn) sig m => Value -> Value -> m Ordering-compareValues v1 = case v1 of- VUnit -> \case VUnit -> return EQ; v2 -> incompatCmp VUnit v2- VInt n1 -> \case VInt n2 -> return (compare n1 n2); v2 -> incompatCmp v1 v2- VText t1 -> \case VText t2 -> return (compare t1 t2); v2 -> incompatCmp v1 v2- VDir d1 -> \case VDir d2 -> return (compare d1 d2); v2 -> incompatCmp v1 v2- VBool b1 -> \case VBool b2 -> return (compare b1 b2); v2 -> incompatCmp v1 v2- VRobot r1 -> \case VRobot r2 -> return (compare r1 r2); v2 -> incompatCmp v1 v2- VInj s1 v1' -> \case- VInj s2 v2' ->- case compare s1 s2 of- EQ -> compareValues v1' v2'- o -> return o- v2 -> incompatCmp v1 v2- VPair v11 v12 -> \case- VPair v21 v22 ->- (<>) <$> compareValues v11 v21 <*> compareValues v12 v22- v2 -> incompatCmp v1 v2- VRcd m1 -> \case- VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2- v2 -> incompatCmp v1 v2- VKey kc1 -> \case- VKey kc2 -> return (compare kc1 kc2)- v2 -> incompatCmp v1 v2- VClo {} -> incomparable v1- VCApp {} -> incomparable v1- VDef {} -> incomparable v1- VResult {} -> incomparable v1- VBind {} -> incomparable v1- VDelay {} -> incomparable v1- VRef {} -> incomparable v1- VRequirements {} -> incomparable v1---- | Values with different types were compared; this should not be--- possible since the type system should catch it.-incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a-incompatCmp v1 v2 =- throwError $- Fatal $- T.unwords ["Incompatible comparison of ", prettyValue v1, "and", prettyValue v2]---- | Values were compared of a type which cannot be compared--- (e.g. functions, etc.).-incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a-incomparable v1 v2 =- throwError $- cmdExn- Lt- ["Comparison is undefined for ", prettyValue v1, "and", prettyValue v2]----------------------------------------------------------------- Arithmetic----------------------------------------------------------------- | Evaluate the application of an arithmetic operator, returning--- an exception in the case of a failing operation, or in case we--- incorrectly use it on a bad 'Const' in the library.-evalArith :: Has (Throw Exn) sig m => Const -> Integer -> Integer -> m Integer-evalArith = \case- Add -> ok (+)- Sub -> ok (-)- Mul -> ok (*)- Div -> safeDiv- Exp -> safeExp- c -> \_ _ -> throwError $ Fatal $ T.append "evalArith called on bad constant " (from (show c))- where- ok f x y = return $ f x y---- | Perform an integer division, but return @Nothing@ for division by--- zero.-safeDiv :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer-safeDiv _ 0 = throwError $ cmdExn Div $ pure "Division by zero"-safeDiv a b = return $ a `div` b---- | Perform exponentiation, but return @Nothing@ if the power is negative.-safeExp :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer-safeExp a b- | b < 0 = throwError $ cmdExn Exp $ pure "Negative exponent"- | otherwise = return $ a ^ b----------------------------------------------------------------- Updating discovered entities, recipes, and commands----------------------------------------------------------------- | Update the global list of discovered entities, and check for new recipes.-updateDiscoveredEntities :: (HasRobotStepState sig m) => Entity -> m ()-updateDiscoveredEntities e = do- allDiscovered <- use $ discovery . allDiscoveredEntities- if E.contains0plus e allDiscovered- then pure ()- else do- let newAllDiscovered = E.insertCount 1 e allDiscovered- updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e- updateAvailableCommands e- discovery . allDiscoveredEntities .= newAllDiscovered---- | Update the availableRecipes list.--- This implementation is not efficient:--- * Every time we discover a new entity, we iterate through the entire list of recipes to see which ones we can make.--- Trying to do something more clever seems like it would definitely be a case of premature optimization.--- One doesn't discover new entities all that often.--- * For each usable recipe, we do a linear search through the list of known recipes to see if we already know it.--- This is a little more troubling, since it's quadratic in the number of recipes.--- But it probably doesn't really make that much difference until we get up to thousands of recipes.-updateAvailableRecipes :: Has (State GameState) sig m => (Inventory, Inventory) -> Entity -> m ()-updateAvailableRecipes invs e = do- allInRecipes <- use $ recipesInfo . recipesIn- let entityRecipes = recipesFor allInRecipes e- usableRecipes = filter (knowsIngredientsFor invs) entityRecipes- knownRecipes <- use $ discovery . availableRecipes . notificationsContent- let newRecipes = filter (`notElem` knownRecipes) usableRecipes- newCount = length newRecipes- discovery . availableRecipes %= mappend (Notifications newCount newRecipes)- updateAvailableCommands e--updateAvailableCommands :: Has (State GameState) sig m => Entity -> m ()-updateAvailableCommands e = do- let newCaps = e ^. entityCapabilities- keepConsts = \case- Just cap -> cap `S.member` newCaps- Nothing -> False- entityConsts = filter (keepConsts . constCaps) allConst- knownCommands <- use $ discovery . availableCommands . notificationsContent- let newCommands = filter (`notElem` knownCommands) entityConsts- newCount = length newCommands- discovery . availableCommands %= mappend (Notifications newCount newCommands)
@@ -1,227 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Some entities are "combustible". A command, 'Swarm.Language.Syntax.Ignite', will--- initiate combustion on such an entity.--- Furthermore, combustion can spread to (4-)adjacent entities, depending--- on the 'ignition' property of that entity.------ Short-lived robots are used to illustrate the combusting entity as--- well as to initiate the delayed combustion of its neighbors.-module Swarm.Game.Step.Combustion where--import Control.Applicative (Applicative (..))-import Control.Carrier.State.Lazy-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_, void, when)-import Data.Text qualified as T-import Linear (zero)-import Swarm.Game.CESK (emptyStore, initMachine)-import Swarm.Game.Display-import Swarm.Game.Entity hiding (empty, lookup, singleton, union)-import Swarm.Game.Entity qualified as E-import Swarm.Game.Location-import Swarm.Game.Robot-import Swarm.Game.State-import Swarm.Game.Step.Util-import Swarm.Game.Universe-import Swarm.Language.Context (empty)-import Swarm.Language.Pipeline (ProcessedTerm)-import Swarm.Language.Pipeline.QQ (tmQ)-import Swarm.Language.Syntax-import Swarm.Language.Text.Markdown qualified as Markdown-import Swarm.Util hiding (both)-import System.Clock (TimeSpec)-import Prelude hiding (Applicative (..), lookup)--igniteCommand :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Const -> Direction -> m ()-igniteCommand c d = do- (loc, me) <- lookInDirection d- -- Ensure there is an entity here.- e <-- me `isJustOrFail` ["There is nothing here to", verb <> "."]-- -- Ensure it can be ignited.- (e `hasProperty` Combustible)- `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."]-- -- Remove the entity from the world.- updateEntityAt loc (const Nothing)- flagRedraw-- -- Start burning process- let selfCombustibility = (e ^. entityCombustion) ? defaultCombustibility- createdAt <- getNow- combustionDurationRand <- addCombustionBot e selfCombustibility createdAt loc- forM_ (getNeighborLocs loc) $ igniteNeighbor createdAt combustionDurationRand- where- verb = "ignite"- verbed = "ignited"-- holdsOrFail = holdsOrFail' c- isJustOrFail = isJustOrFail' c---- | Construct a "combustion robot" from entity and position--- and add it to the world.--- It has low priority and will be covered--- by placed entities.--- The "combustion bot" represents the burning of a single--- entity; propagating the fire to neighbors is handled upstream,--- within the 'Swarm.Language.Syntax.Ignite' command.-addCombustionBot ::- Has (State GameState) sig m =>- Entity ->- Combustibility ->- TimeSpec ->- Cosmic Location ->- m Integer-addCombustionBot inputEntity combustibility ts loc = do- botInventory <- case maybeCombustionProduct of- Nothing -> return []- Just n -> do- maybeE <- uses (landscape . entityMap) (lookupEntityName n)- return $ maybe [] (pure . (1,)) maybeE- combustionDurationRand <- uniform durationRange- let combustionProg = combustionProgram combustionDurationRand combustibility- void $- addTRobot $- mkRobot- ()- Nothing- "fire"- (Markdown.fromText $ T.unwords ["A burning", (inputEntity ^. entityName) <> "."])- (Just loc)- zero- ( defaultEntityDisplay '*'- & displayAttr .~ AWorld "fire"- & displayPriority .~ 0- )- (initMachine combustionProg empty emptyStore)- []- botInventory- True- False- mempty- ts- return combustionDurationRand- where- Combustibility _ durationRange maybeCombustionProduct = combustibility---- Triggers the ignition of the entity underfoot with some delay.-ignitionProgram :: Integer -> ProcessedTerm-ignitionProgram waitTime =- [tmQ|- wait $int:waitTime;- try {- ignite down;- noop;- } {};- selfdestruct- |]---- | A system program for a "combustion robot", to burn an entity--- after it is ignited.------ For efficiency, we determine a priori (i.e. the instant--- the combustion robot is spawned) whether any neighbors will eventually--- be burned, based on probabilities.------ Note that it is possible that new neighbors may be introduced while--- combustion is in progress. Although it may be more realistic to subject--- these to possible combustion as well, we do not bother.------ Though if we did actually want to do that, some options are:------ 1. Create sub-partitions (of say, 10-tick duration) of the combustion duration--- to re-evaluate opportunities to light adjacent entities on fire.--- 2. Use the 'Swarm.Language.Syntax.Watch' command to observe for changes to adjacent entities.--- Note that if we "wake" from our 'Swarm.Language.Syntax.Wait' due to the 'Swarm.Language.Syntax.Watch' being triggered,--- we would need to maintain bookkeeping of how much time is left.--- 3. Spawn more robots whose sole purpose is to observe for changes to neighbor--- cells. This would avoid polluting the logic of the currently burning cell--- with logic to manage probabilities of combustion propagation.-combustionProgram :: Integer -> Combustibility -> ProcessedTerm-combustionProgram combustionDuration (Combustibility _ _ maybeCombustionProduct) =- [tmQ|- wait $int:combustionDuration;- if ($int:invQuantity > 0) {- try {- place $str:combustionProduct;- } {};- } {};- selfdestruct- |]- where- (invQuantity, combustionProduct) = case maybeCombustionProduct of- Nothing -> (0, "")- Just p -> (1, p)---- | We treat the 'ignition' field in the 'Combustibility' record--- as a /rate/ in a Poisson distribution.--- Ignition of neighbors depends on that particular neighbor entity's--- combustion /rate/, but also on the duration--- that the current entity will burn.-igniteNeighbor ::- Has (State GameState) sig m =>- TimeSpec ->- Integer ->- Cosmic Location ->- m ()-igniteNeighbor creationTime sourceDuration loc = do- maybeEnt <- entityAt loc- forM_ maybeEnt igniteEntity- where- igniteEntity e =- when (e `hasProperty` Combustible) $ do- threshold <- uniform (0, 1)- when (probabilityOfIgnition >= threshold) $ do- ignitionDelayRand <- uniform (0, 1)- let ignitionDelay =- floor- . min (fromIntegral sourceDuration)- . negate- $ log ignitionDelayRand / rate- addIgnitionBot ignitionDelay e creationTime loc- where- neighborCombustibility = (e ^. entityCombustion) ? defaultCombustibility- rate = E.ignition neighborCombustibility- probabilityOfIgnition = 1 - exp (negate $ rate * fromIntegral sourceDuration)---- | Construct an invisible "ignition robot" and add it to the world.--- Its sole purpose is to delay the 'Swarm.Language.Syntax.Ignite' command for a neighbor--- that has been a priori determined that it shall be ignited.-addIgnitionBot ::- Has (State GameState) sig m =>- Integer ->- Entity ->- TimeSpec ->- Cosmic Location ->- m ()-addIgnitionBot ignitionDelay inputEntity ts loc =- void $- addTRobot $- mkRobot- ()- Nothing- "firestarter"- (Markdown.fromText $ T.unwords ["Delayed ignition of", (inputEntity ^. entityName) <> "."])- (Just loc)- zero- ( defaultEntityDisplay '*'- & invisible .~ True- )- (initMachine (ignitionProgram ignitionDelay) empty emptyStore)- []- []- True- False- mempty- ts
@@ -1,137 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Implementation of the @path@ command for robots.------ = Design considerations--- One possible design of the @path@ command entailed storing a computed--- shortest path and providing a mechanism to retrieve parts of it later--- without recomputing the whole thing.--- However, in general the playfield can be dynamic and obstructions may--- appear that invalidate a given computed shortest path.--- Therefore, there can be limited value in caching a computed path for use--- across ticks.------ Instead, in the current implementation a complete path is computed--- internally upon invoking the @path@ command, and just the direction of the--- first "move" along that path is returned as a result to the caller.------ == Max distance------ We allow the caller to supply a max distance, but also impose an internal maximum--- distance to prevent programming errors from irrecoverably freezing the game.-module Swarm.Game.Step.Pathfinding where--import Control.Carrier.State.Lazy-import Control.Effect.Lens-import Control.Monad (filterM, guard)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Graph.AStar (aStarM)-import Data.HashSet (HashSet)-import Data.HashSet qualified as HashSet-import Data.Int (Int32)-import Swarm.Game.Entity-import Swarm.Game.Location-import Swarm.Game.State-import Swarm.Game.Step.Util-import Swarm.Game.Universe-import Swarm.Language.Syntax-import Swarm.Util (hoistMaybe)---- | Shortest paths can either be computed to the nearest entity of--- a given type or to a specific location.-data PathfindingTarget- = LocationTarget Location- | -- | Note: navigation to entities does not benefit from the- -- distance heuristic optimization of the A* algorithm.- EntityTarget EntityName---- | swarm command arguments are converted to idiomatic Haskell--- types before invoking this function, and conversely the callsite--- is also responsible for translating the output type to a swarm value.------ The cost function is uniformly @1@ between adjacent cells.------ Viable paths are determined by walkability.--- If the goal type is an Entity, than it is permissible for that--- entity to be 'Unwalkable'.-pathCommand ::- (HasRobotStepState sig m, Has (State GameState) sig m) =>- -- | Distance limit- Maybe Integer ->- -- | Starting location- Cosmic Location ->- -- | Search goal- PathfindingTarget ->- m (Maybe Direction)-pathCommand maybeLimit (Cosmic currentSubworld robotLoc) target = do- -- This is a short-circuiting optimization; if the goal itself- -- is not a walkable cell, then no amount of searching will reach it.- isGoalLocWalkable <- case target of- LocationTarget loc -> null <$> checkMoveFailure (Cosmic currentSubworld loc)- EntityTarget _ -> return True-- runMaybeT $ do- guard isGoalLocWalkable- maybeFoundPath <- lift computePath- foundPath <- hoistMaybe maybeFoundPath- return $ nextDir foundPath- where- computePath =- aStarM- (neighborFunc withinDistanceLimit . Cosmic currentSubworld)- (const $ const $ return 1)- (return . distHeuristic)- goalReachedFunc- (return robotLoc)-- withinDistanceLimit :: Location -> Bool- withinDistanceLimit = (<= distanceLimit) . fromIntegral . manhattan robotLoc-- -- Extracts the head of the found path to determine- -- the next direction for the robot to proceed along- nextDir :: [Location] -> Direction- nextDir pathLocs = case pathLocs of- [] -> DRelative DDown- (nextLoc : _) -> DAbsolute $ nearestDirection $ nextLoc .-. robotLoc-- neighborFunc ::- HasRobotStepState sig m =>- (Location -> Bool) ->- Cosmic Location ->- m (HashSet Location)- neighborFunc isWithinRange loc = do- locs <- filterM isWalkableLoc neighborLocs- return $ HashSet.fromList $ map (view planar) locs- where- neighborLocs = getNeighborLocs loc- isWalkableLoc someLoc =- if not $ isWithinRange $ view planar someLoc- then return False- else do- isGoal <- goalReachedFunc $ view planar someLoc- if isGoal- then return True- else null <$> checkMoveFailureUnprivileged someLoc-- -- This is an optimization for when a specific location- -- is given as the target.- -- However, it is not strictly necessary, and in fact- -- cannot be used when the target is a certain type of- -- entity.- distHeuristic :: Location -> Int32- distHeuristic = case target of- LocationTarget gLoc -> manhattan gLoc- EntityTarget _eName -> const 0-- goalReachedFunc :: Has (State GameState) sig m => Location -> m Bool- goalReachedFunc loc = case target of- LocationTarget gLoc -> return $ loc == gLoc- EntityTarget eName -> do- me <- entityAt $ Cosmic currentSubworld loc- return $ (view entityName <$> me) == Just eName-- -- A failsafe limit is hardcoded to prevent the game from freezing- -- if an error exists in some .sw code.- distanceLimit = maybe maxPathRange (min maxPathRange) maybeLimit
@@ -1,224 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Game.Step.Util where--import Control.Applicative (Applicative (..))-import Control.Carrier.State.Lazy-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.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-import Linear (zero)-import Swarm.Game.Entity hiding (empty, lookup, singleton, union)-import Swarm.Game.Exception-import Swarm.Game.Location-import Swarm.Game.ResourceLoading (NameGenerator (..))-import Swarm.Game.Robot-import Swarm.Game.State-import Swarm.Game.Universe-import Swarm.Game.World qualified as W-import Swarm.Game.World.Modify qualified as WM-import Swarm.Language.Capability-import Swarm.Language.Requirement qualified as R-import Swarm.Language.Syntax-import Swarm.Util hiding (both)-import System.Clock (TimeSpec)-import System.Clock qualified-import System.Random (UniformRange, uniformR)-import Prelude hiding (Applicative (..), lookup)---- | All functions that are used for robot step can access 'GameState' and the current 'Robot'.------ They can also throw exception of our custom type, which is handled elsewhere.--- Because of that the constraint is only 'Throw', but not 'Catch'/'Error'.-type HasRobotStepState sig m = (Has (State GameState) sig m, Has (State Robot) sig m, Has (Throw Exn) sig m)--deriveHeading :: HasRobotStepState sig m => Direction -> m Heading-deriveHeading d = do- orient <- use robotOrientation- when (isCardinal d) $ hasCapabilityFor COrient $ TDir d- return $ applyTurn d $ orient ? zero--lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity)-lookInDirection d = do- newHeading <- deriveHeading d- loc <- use robotLocation- let nextLoc = loc `offsetBy` newHeading- (nextLoc,) <$> entityAt nextLoc---- | Modify the entity (if any) at a given location.-updateEntityAt ::- (Has (State GameState) sig m) =>- Cosmic Location ->- (Maybe Entity -> Maybe Entity) ->- m ()-updateEntityAt cLoc@(Cosmic subworldName loc) upd = do- someChange <-- zoomWorld subworldName $- W.updateM @Int (W.locToCoords loc) upd-- forM_ (WM.getModification =<< someChange) $ \_modType -> do- wakeWatchingRobots cLoc---- * Capabilities---- | Exempts the robot from various command constraints--- when it is either a system robot or playing in creative mode-isPrivilegedBot :: (Has (State GameState) sig m, Has (State Robot) sig m) => m Bool-isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode---- | Test whether the current robot has a given capability (either--- because it has a device which gives it that capability, or it is a--- system robot, or we are in creative mode).-hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool-hasCapability cap = do- isPrivileged <- isPrivilegedBot- caps <- use robotCapabilities- return (isPrivileged || cap `S.member` caps)---- | Ensure that either a robot has a given capability, OR we are in creative--- mode.-hasCapabilityFor ::- (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m ()-hasCapabilityFor cap term = do- h <- hasCapability cap- h `holdsOr` Incapable FixByEquip (R.singletonCap cap) term---- * Exceptions--holdsOrFail' :: (Has (Throw Exn) sig m) => Const -> Bool -> [Text] -> m ()-holdsOrFail' c a ts = a `holdsOr` cmdExn c ts--isJustOrFail' :: (Has (Throw Exn) sig m) => Const -> Maybe a -> [Text] -> m a-isJustOrFail' c a ts = a `isJustOr` cmdExn c ts---- | Create an exception about a command failing.-cmdExn :: Const -> [Text] -> Exn-cmdExn c parts = CmdFailed c (T.unwords parts) Nothing---- * Some utility functions--getNow :: Has (Lift IO) sig m => m TimeSpec-getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic---- | Set a flag telling the UI that the world needs to be redrawn.-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--- the game state.-uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a-uniform bnds = do- rand <- use randGen- let (n, g) = uniformR bnds rand- randGen .= g- return n---- | Given a weighting function and a list of values, choose one of--- the values randomly (using the random generator in the game--- state), with the probability of each being proportional to its--- weight. Return @Nothing@ if the list is empty.-weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a)-weightedChoice weight as = do- r <- uniform (0, total - 1)- return $ go r as- where- total = sum (map weight as)-- go _ [] = Nothing- go !k (x : xs)- | k < w = Just x- | otherwise = go (k - w) xs- where- w = weight x---- | Generate a random robot name in the form @adjective_name@.-randomName :: Has (State GameState) sig m => m Text-randomName = do- NameGenerator adjs names <- use $ robotNaming . nameGenerator- i <- uniform (bounds adjs)- j <- uniform (bounds names)- return $ T.concat [adjs ! i, "_", names ! j]---- * Moving--data MoveFailureMode = PathBlocked | PathLiquid-data MoveFailureDetails = MoveFailureDetails Entity MoveFailureMode---- | Make sure nothing is in the way.--- No exception for system robots-checkMoveFailureUnprivileged :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureDetails)-checkMoveFailureUnprivileged nextLoc = do- me <- entityAt nextLoc- caps <- use robotCapabilities- unwalkables <- use unwalkableEntities- return $ do- e <- me- go caps unwalkables e- where- go caps unwalkables e- -- robots can not walk through walls- | e `hasProperty` Unwalkable || (e ^. entityName) `S.member` unwalkables = Just $ MoveFailureDetails e PathBlocked- -- robots drown if they walk over liquid without boat- | e `hasProperty` Liquid && CFloat `S.notMember` caps =- Just $ MoveFailureDetails e PathLiquid- | otherwise = Nothing---- | Make sure nothing is in the way. Note that system robots implicitly ignore--- and base throws on failure.-checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureDetails)-checkMoveFailure nextLoc = do- systemRob <- use systemRobot- runMaybeT $ do- guard $ not systemRob- maybeMoveFailure <- lift $ checkMoveFailureUnprivileged nextLoc- hoistMaybe maybeMoveFailure
@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Terrain types and properties.-module Swarm.Game.Terrain (- -- * Terrain- TerrainType (..),- readTerrain,- terrainMap,- getTerrainDefaultPaletteChar,- getTerrainWord,-) where--import Data.Aeson (FromJSON (..), withText)-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Text qualified as T-import Swarm.Game.Display-import Swarm.Util (failT, showEnum)-import Text.Read (readMaybe)-import Witch (into)---- | The different possible types of terrain. Unlike entities and--- robots, these are hard-coded into the game.-data TerrainType- = StoneT- | DirtT- | GrassT- | IceT- | BlankT- deriving (Eq, Ord, Show, Read, Bounded, Enum)--readTerrain :: T.Text -> Maybe TerrainType-readTerrain t = readMaybe (into @String (T.toTitle t) ++ "T")--instance Semigroup TerrainType where- t <> BlankT = t- _ <> t = t--instance Monoid TerrainType where- mempty = BlankT--instance FromJSON TerrainType where- parseJSON = withText "text" $ \t ->- case readTerrain t of- Just ter -> return ter- Nothing -> failT ["Unknown terrain type:", t]--getTerrainDefaultPaletteChar :: TerrainType -> Char-getTerrainDefaultPaletteChar = NE.head . showEnum--getTerrainWord :: TerrainType -> T.Text-getTerrainWord = T.toLower . T.pack . init . show---- | A map containing a 'Display' record for each different 'TerrainType'.-terrainMap :: Map TerrainType Display-terrainMap =- M.fromList- [ (StoneT, defaultTerrainDisplay '▒' (ATerrain "stone"))- , (DirtT, defaultTerrainDisplay '▒' (ATerrain "dirt"))- , (GrassT, defaultTerrainDisplay '▒' (ATerrain "grass"))- , (IceT, defaultTerrainDisplay ' ' (ATerrain "ice"))- , (BlankT, defaultTerrainDisplay ' ' ADefault)- ]
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Types and utilities for working with "universal locations";--- locations that encompass different 2-D subworlds.-module Swarm.Game.Universe where--import Control.Lens (makeLenses, view)-import Data.Function (on)-import Data.Int (Int32)-import Data.Text (Text)-import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:))-import GHC.Generics (Generic)-import Linear (V2 (..))-import Swarm.Game.Location---- * Referring to subworlds--data SubworldName = DefaultRootSubworld | SubworldName Text- deriving (Show, Eq, Ord, Generic, ToJSON)--instance FromJSON SubworldName where- parseJSON = withText "subworld name" $ return . SubworldName--renderWorldName :: SubworldName -> Text-renderWorldName = \case- SubworldName s -> s- DefaultRootSubworld -> "<default>"---- * Universal location---- | The swarm universe consists of locations--- indexed by subworld.--- Not only is this parameterized datatype useful for planar (2D)--- coordinates, but is also used for named waypoints.-data Cosmic a = Cosmic- { _subworld :: SubworldName- , _planar :: a- }- deriving (Show, Eq, Ord, Functor, Generic, ToJSON)--makeLenses ''Cosmic--instance (FromJSON a) => FromJSON (Cosmic a) where- parseJSON x = case x of- Object v -> objParse v- _ -> Cosmic DefaultRootSubworld <$> parseJSON x- where- objParse v =- Cosmic- <$> v .: "subworld"- <*> v .: "loc"---- * Measurement--data DistanceMeasure b = Measurable b | InfinitelyFar- deriving (Eq, Ord)--getFiniteDistance :: DistanceMeasure b -> Maybe b-getFiniteDistance = \case- Measurable x -> Just x- InfinitelyFar -> Nothing---- | Returns 'InfinitelyFar' if not within the same subworld.-cosmoMeasure :: (a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b-cosmoMeasure f a b- | ((/=) `on` view subworld) a b = InfinitelyFar- | otherwise = Measurable $ (f `on` view planar) a b---- * Utilities--defaultCosmicLocation :: Cosmic Location-defaultCosmicLocation = Cosmic DefaultRootSubworld origin--offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location-offsetBy loc v = fmap (.+^ v) loc
@@ -1,66 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Conversions from native Haskell values--- to values in the swarm language.-module Swarm.Game.Value where--import Control.Lens (view)-import Data.Int (Int32)-import Linear (V2 (..))-import Swarm.Game.Entity-import Swarm.Game.Location-import Swarm.Game.Robot-import Swarm.Language.Direction-import Swarm.Language.Value---- * Patterns--type VRect = Value-pattern VRect :: Integer -> Integer -> Integer -> Integer -> VRect-pattern VRect x1 y1 x2 y2 = VPair (VPair (VInt x1) (VInt y1)) (VPair (VInt x2) (VInt y2))---- * Conversions---- | Conversion from native Haskell types--- to their swarm-lang equivalents, useful for--- implementing swarm--- <https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet commands>--- in Haskell.-class Valuable a where- asValue :: a -> Value--instance Valuable Int32 where- asValue = VInt . fromIntegral--instance Valuable Int where- asValue = VInt . fromIntegral--instance (Valuable a) => Valuable (V2 a) where- asValue (V2 x y) = asValue (x, y)--instance (Valuable a, Valuable b) => Valuable (a, b) where- asValue (x, y) = VPair (asValue x) (asValue y)--instance Valuable Location where- asValue (Location x y) = asValue (x, y)--instance Valuable Entity where- asValue = VText . view entityName--instance Valuable Robot where- asValue = VRobot . view robotID--instance Valuable Direction where- asValue = VDir--instance (Valuable a) => Valuable (Maybe a) where- asValue Nothing = VInj False VUnit- asValue (Just x) = VInj True $ asValue x--instance (Valuable a, Valuable b) => Valuable (Either a b) where- asValue (Left x) = VInj False $ asValue x- asValue (Right x) = VInj True $ asValue x
@@ -1,328 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ A /world/ refers to the grid on which the game takes place, and the--- things in it (besides robots). A world has a base, immutable--- /terrain/ layer, where each cell contains a terrain type, and a--- mutable /entity/ layer, with at most one entity per cell.------ A world is technically finite but practically infinite (worlds are--- indexed by 32-bit signed integers, so they correspond to a--- \( 2^{32} \times 2^{32} \) torus).-module Swarm.Game.World (- -- * World coordinates- Coords (..),- locToCoords,- coordsToLoc,- BoundsRectangle,-- -- * Worlds- WorldFun (..),- runWF,- worldFunFromArray,- World,- MultiWorld,-- -- ** Tile management- loadCell,- loadRegion,-- -- ** World functions- newWorld,- lookupCosmicTerrain,- lookupTerrain,- lookupCosmicEntity,- lookupEntity,- update,-- -- ** Monadic variants- lookupTerrainM,- lookupEntityM,- updateM,-- -- ** Runtime updates- WorldUpdate (..),-) where--import Control.Algebra (Has)-import Control.Arrow ((&&&))-import Control.Effect.State (State, get, modify, state)-import Control.Lens-import Data.Array qualified as A-import Data.Array.IArray-import Data.Array.Unboxed qualified as U-import Data.Bifunctor (second)-import Data.Bits-import Data.Foldable (foldl')-import Data.Int (Int32)-import Data.Map (Map)-import Data.Map.Strict qualified as M-import Data.Semigroup (Last (..))-import Data.Yaml (FromJSON, ToJSON)-import GHC.Generics (Generic)-import Swarm.Game.Entity (Entity)-import Swarm.Game.Location-import Swarm.Game.Terrain (TerrainType (BlankT))-import Swarm.Game.Universe-import Swarm.Game.World.Coords-import Swarm.Game.World.Modify-import Swarm.Util ((?))-import Swarm.Util.Erasable-import Prelude hiding (lookup)----------------------------------------------------------------- World function----------------------------------------------------------------- | A @WorldFun t e@ represents a 2D world with terrain of type @t@--- (exactly one per cell) and entities of type @e@ (at most one per--- cell).-newtype WorldFun t e = WF {getWF :: Coords -> (t, Erasable (Last e))}- deriving stock (Functor)- deriving newtype (Semigroup, Monoid)--runWF :: WorldFun t e -> Coords -> (t, Maybe e)-runWF wf = second (erasableToMaybe . fmap getLast) . getWF wf--instance Bifunctor WorldFun where- bimap g h (WF z) = WF (bimap g (fmap (fmap h)) . z)---- | Create a world function from a finite array of specified cells.-worldFunFromArray :: Monoid t => Array (Int32, Int32) (t, Erasable e) -> WorldFun t e-worldFunFromArray arr = WF $ \(Coords (r, c)) ->- if inRange bnds (r, c)- then second (fmap Last) (arr ! (r, c))- else mempty- where- bnds = bounds arr----------------------------------------------------------------- Tiles and coordinates----------------------------------------------------------------- | The number of bits we need in each coordinate to represent all--- the locations in a tile. In other words, each tile has a size of--- @2^tileBits x 2^tileBits@.------ Currently, 'tileBits' is set to 6, giving us 64x64 tiles, with--- 4096 cells in each tile. That seems intuitively like a good size,--- but I don't have a good sense for the tradeoffs here, and I don't--- know how much the choice of tile size matters.-tileBits :: Int-tileBits = 6---- | The number consisting of 'tileBits' many 1 bits. We can use this--- to mask out the tile offset of a coordinate.-tileMask :: Int32-tileMask = (1 `shiftL` tileBits) - 1---- | If we think of the world as a grid of /tiles/, we can assign each--- tile some coordinates in the same way we would if each tile was a--- single cell. These are the tile coordinates.-newtype TileCoords = TileCoords {unTileCoords :: Coords}- deriving (Eq, Ord, Show, Ix, Generic)--instance Rewrapped TileCoords t-instance Wrapped TileCoords---- | Convert from a cell's coordinates to the coordinates of its tile,--- simply by shifting out 'tileBits' many bits.-tileCoords :: Coords -> TileCoords-tileCoords = TileCoords . over (_Wrapped . both) (`shiftR` tileBits)---- | Find the coordinates of the upper-left corner of a tile.-tileOrigin :: TileCoords -> Coords-tileOrigin = over (_Wrapped . both) (`shiftL` tileBits) . unTileCoords---- | A 'TileOffset' represents an offset from the upper-left corner of--- some tile to a cell in its interior.-newtype TileOffset = TileOffset Coords- deriving (Eq, Ord, Show, Ix, Generic)---- | The offsets of the upper-left and lower-right corners of a tile:--- (0,0) to ('tileMask', 'tileMask').-tileBounds :: (TileOffset, TileOffset)-tileBounds = (TileOffset (Coords (0, 0)), TileOffset (Coords (tileMask, tileMask)))---- | Compute the offset of a given coordinate within its tile.-tileOffset :: Coords -> TileOffset-tileOffset = TileOffset . over (_Wrapped . both) (.&. tileMask)---- | Add a tile offset to the coordinates of the tile's upper left--- corner. NOTE that for efficiency, this function only works when--- the first argument is in fact the coordinates of a tile's--- upper-left corner (/i.e./ it is an output of 'tileOrigin'). In--- that case the coordinates will end with all 0 bits, and we can--- add the tile offset just by doing a coordinatewise 'xor'.-plusOffset :: Coords -> TileOffset -> Coords-plusOffset (Coords (x1, y1)) (TileOffset (Coords (x2, y2))) = Coords (x1 `xor` x2, y1 `xor` y2)--instance Rewrapped TileOffset t-instance Wrapped TileOffset---- | A terrain tile is an unboxed array of terrain values.-type TerrainTile t = U.UArray TileOffset t---- | An entity tile is an array of possible entity values. Note it--- cannot be an unboxed array since entities are complex records--- which have to be boxed.-type EntityTile e = A.Array TileOffset (Maybe e)--type MultiWorld t e = Map SubworldName (World t e)---- | A 'World' consists of a 'WorldFun' that specifies the initial--- world, a cache of loaded square tiles to make lookups faster, and--- a map storing locations whose entities have changed from their--- initial values.------ Right now the 'World' simply holds on to all the tiles it has--- ever loaded. Ideally it would use some kind of LRU caching--- scheme to keep memory usage bounded, but it would be a bit--- tricky, and in any case it's probably not going to matter much--- for a while. Once tile loads can trigger robots to spawn, it--- would also make for some difficult decisions in terms of how to--- handle respawning.-data World t e = World- { _worldFun :: WorldFun t e- , _tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e)- , _changed :: M.Map Coords (Maybe e)- }---- | Create a new 'World' from a 'WorldFun'.-newWorld :: WorldFun t e -> World t e-newWorld f = World f M.empty M.empty--lookupCosmicTerrain ::- IArray U.UArray Int =>- Cosmic Coords ->- MultiWorld Int e ->- TerrainType-lookupCosmicTerrain (Cosmic subworldName i) multiWorld =- maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName multiWorld---- | Look up the terrain value at certain coordinates: try looking it--- up in the tile cache first, and fall back to running the 'WorldFun'--- otherwise.------ This function does /not/ ensure that the tile containing the--- given coordinates is loaded. For that, see 'lookupTerrainM'.-lookupTerrain :: (IArray U.UArray t) => Coords -> World t e -> t-lookupTerrain i (World f t _) =- ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t)- ? fst (runWF f i)---- | A stateful variant of 'lookupTerrain', which first loads the tile--- containing the given coordinates if it is not already loaded,--- then looks up the terrain value.-lookupTerrainM ::- forall t e sig m.- (Has (State (World t e)) sig m, IArray U.UArray t) =>- Coords ->- m t-lookupTerrainM c = do- modify @(World t e) $ loadCell c- lookupTerrain c <$> get @(World t e)--lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e-lookupCosmicEntity (Cosmic subworldName i) multiWorld =- lookupEntity i =<< M.lookup subworldName multiWorld---- | Look up the entity at certain coordinates: first, see if it is in--- the map of locations with changed entities; then try looking it--- up in the tile cache first; and finally fall back to running the--- 'WorldFun'.------ This function does /not/ ensure that the tile containing the--- given coordinates is loaded. For that, see 'lookupEntityM'.-lookupEntity :: Coords -> World t e -> Maybe e-lookupEntity i (World f t m) =- M.lookup i m- ? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)- ? snd (runWF f i)---- | A stateful variant of 'lookupEntity', which first loads the tile--- containing the given coordinates if it is not already loaded,--- then looks up the terrain value.-lookupEntityM ::- forall t e sig m.- (Has (State (World t e)) sig m, IArray U.UArray t) =>- Coords ->- m (Maybe e)-lookupEntityM c = do- modify @(World t e) $ loadCell c- lookupEntity c <$> get @(World t e)---- | Update the entity (or absence thereof) at a certain location,--- returning an updated 'World' and a Boolean indicating whether--- the update changed the entity here.--- See also 'updateM'.-update ::- Coords ->- (Maybe Entity -> Maybe Entity) ->- World t Entity ->- (World t Entity, CellUpdate Entity)-update i g w@(World f t m) =- (wNew, classifyModification entityBefore entityAfter)- where- wNew = World f t $ M.insert i entityAfter m- entityBefore = lookupEntity i w- entityAfter = g entityBefore---- | A stateful variant of 'update', which also ensures the tile--- containing the given coordinates is loaded.-updateM ::- forall t sig m.- (Has (State (World t Entity)) sig m, IArray U.UArray t) =>- Coords ->- (Maybe Entity -> Maybe Entity) ->- m (CellUpdate Entity)-updateM c g = do- state @(World t Entity) $ update c g . loadCell c---- | Load the tile containing a specific cell.-loadCell :: (IArray U.UArray t) => Coords -> World t e -> World t e-loadCell c = loadRegion (c, c)---- | Load all the tiles which overlap the given rectangular region--- (specified as an upper-left and lower-right corner, inclusive).-loadRegion ::- forall t e.- (IArray U.UArray t) =>- (Coords, Coords) ->- World t e ->- World t e-loadRegion reg (World f t m) = World f t' m- where- tiles = range (over both tileCoords reg)- t' = foldl' (\hm (i, tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles)-- maybeInsert k v tm- | k `M.member` tm = tm- | otherwise = M.insert k v tm-- loadTile :: TileCoords -> (TerrainTile t, EntityTile e)- loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities)- where- tileCorner = tileOrigin tc- (terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds)-------------------------------------------------------------------------- Runtime world update-------------------------------------------------------------------------- | Enumeration of world updates. This type is used for changes by--- /e.g./ the @drill@ command which must be carried out at a later--- tick. Using a first-order representation (as opposed to /e.g./--- just a @World -> World@ function) allows us to serialize and--- inspect the updates.-data WorldUpdate e = ReplaceEntity- { updatedLoc :: Cosmic Location- , originalEntity :: e- , newEntity :: Maybe e- }- deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
@@ -1,102 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Explicitly type-preserving bracket abstraction, a la Oleg Kiselyov.--- Turn elaborated, type-indexed terms into variableless, type-indexed--- terms with only constants and application.------ For more information, see:------ https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/-module Swarm.Game.World.Abstract where--import Data.Kind (Type)-import Swarm.Game.World.Typecheck (Applicable (..), Const (..), HasConst (..), Idx (..), TTerm (..), ($$.), (.$$), (.$$.))----------------------------------------------------------------- Bracket abstraction-------------------------------------------------------------------------------------------------------------------- Closed terms---- | Closed, fully abstracted terms. All computation is represented--- by combinators. This is the ultimate target for the bracket--- abstraction operation.-data BTerm :: Type -> Type where- BApp :: BTerm (a -> b) -> BTerm a -> BTerm b- BConst :: Const a -> BTerm a--deriving instance Show (BTerm t)--instance Applicable BTerm where- ($$) = BApp--instance HasConst BTerm where- embed = BConst------------------------------------------------------- Open terms---- | These explicitly open terms are an intermediate stage in the--- bracket abstraction algorithm, /i.e./ they represent terms which have--- been only partially abstracted.-data OTerm :: [Type] -> Type -> Type where- -- Embedded closed term.- E :: BTerm a -> OTerm g a- -- Reference to the innermost/top environment variable, i.e. Z- V :: OTerm (a ': g) a- -- Internalize the topmost env variable as a function argument- N :: OTerm g (a -> b) -> OTerm (a ': g) b- -- Ignore the topmost env variable- W :: OTerm g b -> OTerm (a ': g) b--instance HasConst (OTerm g) where- embed = E . embed---- | Bracket abstraction: convert the 'TTerm' to an 'OTerm', then--- project out the embedded 'BTerm'. GHC can see this is total--- since 'E' is the only constructor that can produce an 'OTerm'--- with an empty environment.-bracket :: TTerm '[] a -> BTerm a-bracket t = case conv t of- E t' -> t'---- | Type-preserving conversion from 'TTerm' to 'OTerm' ('conv' + the--- 'Applicable' instance). Taken directly from Kiselyov.-conv :: TTerm g a -> OTerm g a-conv (TVar VZ) = V-conv (TVar (VS x)) = W (conv (TVar x))-conv (TLam t) = case conv t of- V -> E (BConst I)- E d -> E (K .$$ d)- N e -> e- W e -> K .$$ e-conv (TApp t1 t2) = conv t1 $$ conv t2-conv (TConst c) = embed c--instance Applicable (OTerm g) where- ($$) :: OTerm g (a -> b) -> OTerm g a -> OTerm g b- W e1 $$ W e2 = W (e1 $$ e2)- W e $$ E d = W (e $$ E d)- E d $$ W e = W (E d $$ e)- W e $$ V = N e- V $$ W e = N (E (C .$$. I) $$ e)- W e1 $$ N e2 = N (B .$$ e1 $$ e2)- N e1 $$ W e2 = N (C .$$ e1 $$ e2)- N e1 $$ N e2 = N (S .$$ e1 $$ e2)- N e $$ V = N (S .$$ e $$. I)- V $$ N e = N (E (S .$$. I) $$ e)- E d $$ N e = N (E (B .$$ d) $$ e)- E d $$ V = N (E d)- V $$ E d = N (E (C .$$. I $$ d))- N e $$ E d = N (E (C .$$. C $$ d) $$ e)- E d1 $$ E d2 = E (d1 $$ d2)---- There are only 15 cases above: GHC can tell that V $$ V is--- impossible (it would be ill-typed)!
@@ -1,126 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Compiling abstracted combinator expressions ('BTerm') to native--- Haskell terms. This can supposedly be more efficient than directly--- interpreting 'BTerm's, but some benchmarking is probably needed to--- decide whether we want this or not.------ For more info, see:------ https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/-module Swarm.Game.World.Compile where--import Data.ByteString (ByteString)-import Data.Hash.Murmur (murmur3)-import Data.Kind (Constraint)-import Data.Tagged (Tagged (unTagged))-import Numeric.Noise.Perlin (noiseValue, perlin)-import Swarm.Game.Location (pattern Location)-import Swarm.Game.World.Abstract (BTerm (..))-import Swarm.Game.World.Coords (Coords (..), coordsToLoc)-import Swarm.Game.World.Gen (Seed)-import Swarm.Game.World.Interpret (interpReflect, interpRot)-import Swarm.Game.World.Syntax (Axis (..), Rot, World)-import Swarm.Game.World.Typecheck (Applicable (..), Const (..), Empty (..), NotFun, Over (..))-import Witch (from)-import Witch.Encoding qualified as Encoding--data CTerm a where- CFun :: (CTerm a -> CTerm b) -> CTerm (a -> b)- CConst :: (NotFun a) => a -> CTerm a--instance Applicable CTerm where- CFun f $$ x = f x--compile :: Seed -> BTerm a -> CTerm a-compile seed (BApp b1 b2) = compile seed b1 $$ compile seed b2-compile seed (BConst c) = compileConst seed c--compileConst :: Seed -> Const a -> CTerm a-compileConst seed = \case- CLit i -> CConst i- CCell c -> CConst c- CFI -> unary fromIntegral- CIf -> CFun $ \(CConst b) -> CFun $ \t -> CFun $ \e -> if b then t else e- CNot -> unary not- CNeg -> unary negate- CAbs -> unary abs- CAnd -> binary (&&)- COr -> binary (||)- CAdd -> binary (+)- CSub -> binary (-)- CMul -> binary (*)- CDiv -> binary (/)- CIDiv -> binary div- CMod -> binary mod- CEq -> binary (==)- CNeq -> binary (/=)- CLt -> binary (<)- CLeq -> binary (<=)- CGt -> binary (>)- CGeq -> binary (>=)- CMask -> compileMask- CSeed -> CConst (fromIntegral seed)- CCoord ax -> CFun $ \(CConst (coordsToLoc -> Location x y)) -> CConst (fromIntegral (case ax of X -> x; Y -> y))- CHash -> compileHash- CPerlin -> compilePerlin- CReflect ax -> compileReflect ax- CRot rot -> compileRot rot- COver -> binary (<!>)- K -> CFun $ \x -> CFun $ const x- S -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ x $$ (g $$ x)- I -> CFun id- B -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ (g $$ x)- C -> CFun $ \f -> CFun $ \x -> CFun $ \y -> f $$ y $$ x- Φ -> CFun $ \c -> CFun $ \f -> CFun $ \g -> CFun $ \x -> c $$ (f $$ x) $$ (g $$ x)--unary :: (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)-unary op = CFun $ \(CConst x) -> CConst (op x)--binary :: (NotFun a, NotFun b, NotFun c) => (a -> b -> c) -> CTerm (a -> b -> c)-binary op = CFun $ \(CConst x) -> CFun $ \(CConst y) -> CConst (op x y)---- Note we could desugar 'mask p a -> if p a empty' but that would--- require an explicit 'empty' node, whose type can't be inferred.-compileMask :: (NotFun a, Empty a) => CTerm (World Bool -> World a -> World a)-compileMask = CFun $ \p -> CFun $ \a -> CFun $ \ix ->- case p $$ ix of- CConst b -> if b then a $$ ix else CConst empty--compileHash :: CTerm (Coords -> Integer)-compileHash = CFun $ \(CConst (Coords ix)) -> CConst (fromIntegral (h ix))- where- h = murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show--compilePerlin :: CTerm (Integer -> Integer -> Double -> Double -> World Double)-compilePerlin =- CFun $ \(CConst s) ->- CFun $ \(CConst o) ->- CFun $ \(CConst k) ->- CFun $ \(CConst p) ->- let noise = perlin (fromIntegral s) (fromIntegral o) k p- in CFun $ \(CConst (Coords ix)) -> CConst (sample ix noise)- where- sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)--compileReflect :: Axis -> CTerm (World a -> World a)-compileReflect ax = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpReflect ax c)--compileRot :: Rot -> CTerm (World a -> World a)-compileRot rot = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpRot rot c)--type family NoFunParams a :: Constraint where- NoFunParams (a -> b) = (NotFun a, NoFunParams b)- NoFunParams _ = ()---- | Interpret a compiled term into the host language.-runCTerm :: (NoFunParams a) => CTerm a -> a-runCTerm (CConst a) = a-runCTerm (CFun f) = runCTerm . f . CConst
@@ -1,48 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ World coordinates.-module Swarm.Game.World.Coords (- Coords (..),- locToCoords,- coordsToLoc,- BoundsRectangle,-)-where--import Control.Lens (Rewrapped, Wrapped)-import Data.Array.IArray (Ix)-import Data.Int (Int32)-import GHC.Generics (Generic)-import Swarm.Game.Location (Location, pattern Location)----------------------------------------------------------------- World coordinates----------------------------------------------------------------- | World coordinates use @(row,column)@ format, with the row--- increasing as we move down the screen. We use this format for--- indexing worlds internally, since it plays nicely with things--- like drawing the screen, and reading maps from configuration--- files. The 'locToCoords' and 'coordsToLoc' functions convert back--- and forth between this type and t'Location', which is used when--- presenting coordinates externally to the player.-newtype Coords = Coords {unCoords :: (Int32, Int32)}- deriving (Eq, Ord, Show, Ix, Generic)--instance Rewrapped Coords t-instance Wrapped Coords---- | Convert an external @(x,y)@ location to an internal 'Coords' value.-locToCoords :: Location -> Coords-locToCoords (Location x y) = Coords (-y, x)---- | Convert an internal 'Coords' value to an external @(x,y)@ location.-coordsToLoc :: Coords -> Location-coordsToLoc (Coords (r, c)) = Location c (-r)---- | Represents the top-left and bottom-right coordinates--- of a bounding rectangle of cells in the world map-type BoundsRectangle = (Coords, Coords)
@@ -1,39 +0,0 @@-{-# LANGUAGE DataKinds #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Evaluation for the Swarm world description DSL.-module Swarm.Game.World.Eval (- runWorld,-) where--import Swarm.Game.Entity (Entity)-import Swarm.Game.Terrain (TerrainType (..))-import Swarm.Game.World (WorldFun (..))-import Swarm.Game.World.Abstract (bracket)-import Swarm.Game.World.Coords (Coords)-import Swarm.Game.World.Gen (Seed)-import Swarm.Game.World.Interpret (interpBTerm)-import Swarm.Game.World.Syntax-import Swarm.Game.World.Typecheck---- | Run a typechecked world description DSL term to produce a--- 'WorldFun'.-runWorld :: TTerm '[] (World CellVal) -> Seed -> WorldFun TerrainType Entity-runWorld t seed = convertWF . interpBTerm seed . bracket $ t---- Currently we run a DSL term by performing bracket abstraction,--- producing a 'BTerm', then directly interpreting the 'BTerm' with--- 'interpBTerm'. We could also compile the 'BTerm' to a 'CTerm' and--- run it, i.e.------ convertWF . runCTerm . compile seed . bracket $ t------ which can supposedly give a performance boost, but it is unclear--- whether this actually makes a difference in our case.---- | Simple adapter function to convert a plain @Coords -> CellVal@--- function into a 'WorldFun' value.-convertWF :: (Coords -> CellVal) -> WorldFun TerrainType Entity-convertWF f = WF ((\(CellVal t e _) -> (t, e)) . f)
@@ -1,79 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Utilities for working with procedurally generated worlds.-module Swarm.Game.World.Gen where--import Control.Lens (view)-import Data.Enumeration-import Data.Int (Int32)-import Data.List (find)-import Data.Maybe (fromMaybe, mapMaybe)-import Data.Semigroup (Last (..), getLast)-import Data.Set qualified as S-import Data.Text (Text)-import Swarm.Game.Entity-import Swarm.Game.World-import Swarm.Game.World.Syntax (CellVal (..))-import Swarm.Game.World.Typecheck (Const (CCell), TTerm (..))-import Swarm.Util.Erasable--type Seed = Int---- | Extract a list of all entities mentioned in a given world DSL term.-extractEntities :: TTerm g a -> S.Set Entity-extractEntities (TLam t) = extractEntities t-extractEntities (TApp t1 t2) = extractEntities t1 <> extractEntities t2-extractEntities (TConst (CCell (CellVal _ ee _))) = getEntity ee- where- getEntity (EJust (Last e)) = S.singleton e- getEntity _ = S.empty-extractEntities _ = S.empty---- | Offset a world by a multiple of the @skip@ in such a way that it--- satisfies the given predicate.-findOffset :: Integer -> ((Coords -> (t, Erasable (Last e))) -> Bool) -> WorldFun t e -> WorldFun t e-findOffset skip isGood (WF f) = WF f'- where- offset :: Enumeration Int32- offset = fromIntegral . (skip *) <$> int-- f' =- fromMaybe (error "the impossible happened, no offsets were found!")- . find isGood- . map shift- . enumerate- $ offset >< offset-- shift (dr, dc) (Coords (r, c)) = f (Coords (r - dr, c - dc))---- | Offset the world so the base starts in a 32x32 patch containing at least one--- of each of a list of required entities.-findPatchWith :: [Text] -> WorldFun t Entity -> WorldFun t Entity-findPatchWith reqs = findOffset 32 isGoodPatch- where- patchCoords = [(r, c) | r <- [-16 .. 16], c <- [-16 .. 16]]- isGoodPatch f = all (`S.member` es) reqs- where- es = S.fromList . map (view entityName) . mapMaybe (erasableToMaybe . fmap getLast . snd . f . Coords) $ patchCoords---- | Offset the world so the base starts on empty spot next to tree and grass.-findTreeOffset :: WorldFun t Entity -> WorldFun t Entity-findTreeOffset = findOffset 1 isGoodPlace- where- isGoodPlace f =- hasEntity Nothing (0, 0)- && any (hasEntity (Just "tree")) neighbors- && all (\c -> hasEntity (Just "tree") c || hasEntity Nothing c) neighbors- where- hasEntity mayE = (== mayE) . erasableToMaybe . fmap (view entityName . getLast) . snd . f . Coords-- neighbors = [(r, c) | r <- [-1 .. 1], c <- [-1 .. 1]]---- | Offset the world so the base starts in a good patch (near--- necessary items), next to a tree.-findGoodOrigin :: WorldFun t Entity -> WorldFun t Entity-findGoodOrigin = findTreeOffset . findPatchWith ["tree", "copper ore", "bit (0)", "bit (1)", "rock", "lambda", "water", "sand"]
@@ -1,87 +0,0 @@-{-# LANGUAGE GADTs #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Interpreter for the Swarm world description DSL.-module Swarm.Game.World.Interpret (- interpBTerm,- interpConst,- interpReflect,- interpRot,-) where--import Control.Applicative (Applicative (..))-import Data.ByteString (ByteString)-import Data.Hash.Murmur (murmur3)-import Data.Tagged (unTagged)-import Numeric.Noise.Perlin (noiseValue, perlin)-import Swarm.Game.World.Abstract (BTerm (..))-import Swarm.Game.World.Coords (Coords (..))-import Swarm.Game.World.Gen (Seed)-import Swarm.Game.World.Syntax (Axis (..), Rot (..))-import Swarm.Game.World.Typecheck (Const (..), Empty (..), Over (..))-import Witch (from)-import Witch.Encoding qualified as Encoding-import Prelude hiding (Applicative (..))---- | Interpret an abstracted term into the host language.-interpBTerm :: Seed -> BTerm a -> a-interpBTerm seed (BApp f x) = interpBTerm seed f (interpBTerm seed x)-interpBTerm seed (BConst c) = interpConst seed c---- | Interpret a constant into the host language.-interpConst :: Seed -> Const a -> a-interpConst seed = \case- CLit a -> a- CCell c -> c- CIf -> \b t e -> if b then t else e- CNot -> not- CNeg -> negate- CAbs -> abs- CAnd -> (&&)- COr -> (||)- CAdd -> (+)- CSub -> (-)- CMul -> (*)- CDiv -> (/)- CIDiv -> div- CMod -> mod- CEq -> (==)- CNeq -> (/=)- CLt -> (<)- CLeq -> (<=)- CGt -> (>)- CGeq -> (>=)- CMask -> \b x c -> if b c then x c else empty- CSeed -> fromIntegral seed- CCoord ax -> \(Coords (x, y)) -> fromIntegral (case ax of X -> x; Y -> y)- CHash -> \(Coords ix) -> fromIntegral . murmur3 0 . unTagged . from @String @(Encoding.UTF_8 ByteString) . show $ ix- CPerlin -> \s o k p ->- let noise = perlin (fromIntegral s) (fromIntegral o) k p- sample (i, j) = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)- in \(Coords ix) -> sample ix- CReflect ax -> \w -> w . interpReflect ax- CRot r -> \w -> w . interpRot r- CFI -> fromInteger- COver -> (<!>)- K -> const- S -> (<*>)- I -> id- B -> (.)- C -> flip- Φ -> liftA2---- | Interprect a reflection.-interpReflect :: Axis -> Coords -> Coords-interpReflect ax (Coords (r, c)) = Coords (case ax of X -> (r, -c); Y -> (-r, c))---- | Interpret a rotation.-interpRot :: Rot -> Coords -> Coords-interpRot rot (Coords crd) = Coords (rotTuple rot crd)- where- rotTuple = \case- Rot0 -> id- Rot90 -> \(r, c) -> (-c, r)- Rot180 -> \(r, c) -> (-r, -c)- Rot270 -> \(r, c) -> (c, -r)
@@ -1,65 +0,0 @@-{-# LANGUAGE DataKinds #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Loading world descriptions from `worlds/*.world`.-module Swarm.Game.World.Load where--import Control.Algebra (Has)-import Control.Arrow (left)-import Control.Carrier.Accum.FixedStrict (Accum)-import Control.Carrier.Lift (Lift, sendIO)-import Control.Carrier.Reader (runReader)-import Control.Effect.Throw (Throw, liftEither)-import Data.Map qualified as M-import Data.Maybe (catMaybes)-import Data.Sequence (Seq)-import Data.Text (Text)-import Swarm.Game.Entity (EntityMap)-import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..))-import Swarm.Game.ResourceLoading (getDataDirSafe)-import Swarm.Game.World.Parse (parseWExp, runParser)-import Swarm.Game.World.Typecheck-import Swarm.Language.Pretty (prettyText)-import Swarm.Util (acquireAllWithExt)-import Swarm.Util.Effect (throwToWarning, withThrow)-import System.FilePath (dropExtension, joinPath, splitPath)-import Witch (into)---- | Load and typecheck all world descriptions from `worlds/*.world`.--- Emit a warning for each one which fails to parse or typecheck.-loadWorlds ::- (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>- EntityMap ->- m WorldMap-loadWorlds em = do- res <- throwToWarning @SystemFailure $ getDataDirSafe Worlds "worlds"- case res of- Nothing -> return M.empty- Just dir -> do- worldFiles <- sendIO $ acquireAllWithExt dir "world"- ws <- mapM (throwToWarning @SystemFailure . loadWorld dir em) worldFiles- return . M.fromList . catMaybes $ ws---- | Load a file containing a world DSL term, throwing an exception if--- it fails to parse or typecheck.-loadWorld ::- (Has (Throw SystemFailure) sig m) =>- FilePath ->- EntityMap ->- (FilePath, String) ->- m (Text, Some (TTerm '[]))-loadWorld dir em (fp, src) = do- wexp <-- liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $- runParser parseWExp (into @Text src)- t <-- withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $- runReader em . runReader @WorldMap M.empty $- infer CNil wexp- return (into @Text (dropExtension (stripDir dir fp)), t)---- | Strip a leading directory from a 'FilePath'.-stripDir :: FilePath -> FilePath -> FilePath-stripDir dir fp = joinPath (drop (length (splitPath dir)) (splitPath fp))
@@ -1,40 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Captures the various possibilities of cell--- modification as a sum type for use by the structure recognizer--- (see 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified').-module Swarm.Game.World.Modify where--import Control.Lens (view)-import Data.Function (on)-import Swarm.Game.Entity (Entity, entityHash)---- | Compare to 'WorldUpdate' in "Swarm.Game.World"-data CellUpdate e- = NoChange (Maybe e)- | Modified (CellModification e)--getModification :: CellUpdate e -> Maybe (CellModification e)-getModification (NoChange _) = Nothing-getModification (Modified x) = Just x--data CellModification e- = -- | Fields represent what existed in the cell "before" and "after", in that order.- Swap e e- | Remove e- | Add e--classifyModification ::- -- | before- Maybe Entity ->- -- | after- Maybe Entity ->- CellUpdate Entity-classifyModification Nothing Nothing = NoChange Nothing-classifyModification Nothing (Just x) = Modified $ Add x-classifyModification (Just x) Nothing = Modified $ Remove x-classifyModification (Just x) (Just y) =- if ((/=) `on` view entityHash) x y- then Modified $ Swap x y- else NoChange $ Just x
@@ -1,263 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--- FromJSON WExp-{-# OPTIONS_GHC -Wno-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Parser for the Swarm world description DSL.-module Swarm.Game.World.Parse where--import Control.Monad (void)-import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)-import Control.Monad.Combinators.NonEmpty qualified as CNE (sepBy1)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Void (Void)-import Data.Yaml (FromJSON (parseJSON), withText)-import Swarm.Game.World.Syntax-import Swarm.Util (failT, showT, squote)-import Swarm.Util.Parse (fully)-import Text.Megaparsec hiding (runParser)-import Text.Megaparsec.Char-import Text.Megaparsec.Char.Lexer qualified as L-import Witch (into)--type Parser = Parsec Void Text-type ParserError = ParseErrorBundle Text Void----------------------------------------------------------------- Lexing--reservedWords :: [Text]-reservedWords =- [ "not"- , "true"- , "false"- , "seed"- , "x"- , "y"- , "hash"- , "let"- , "in"- , "overlay"- , "hcat"- , "vcat"- , "if"- , "then"- , "else"- , "perlin"- , "mask"- , "empty"- , "abs"- ]---- | Skip spaces and comments.-sc :: Parser ()-sc =- L.space- space1- (L.skipLineComment "//")- (L.skipBlockComment "/*" "*/")---- | In general, we follow the convention that every token parser--- assumes no leading whitespace and consumes all trailing--- whitespace. Concretely, we achieve this by wrapping every token--- parser using 'lexeme'.-lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc---- | A lexeme consisting of a literal string.-symbol :: Text -> Parser Text-symbol = L.symbol sc--operatorChar :: Parser Char-operatorChar = oneOf ("!@#$%^&*=+-/<>" :: String)--operator :: Text -> Parser Text-operator op = (lexeme . try) $ string op <* notFollowedBy operatorChar---- | A positive integer literal token.-integerOrFloat :: Parser (Either Integer Double)-integerOrFloat =- label "numeric literal" $- lexeme (Right <$> try L.float <|> Left <$> L.decimal)---- | Parse a case-insensitive reserved word, making sure it is not a--- prefix of a longer variable name, and allowing the parser to--- backtrack if it fails.-reserved :: Text -> Parser ()-reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_')---- | Parse an identifier, i.e. any non-reserved string containing--- alphanumeric characters and underscores and not starting with a--- number.-identifier :: Parser Var-identifier = (lexeme . try) (p >>= check) <?> "variable name"- where- p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'')- check (into @Text -> t)- | T.toLower t `elem` reservedWords =- failT ["reserved word", squote t, "cannot be used as variable name"]- | otherwise = return t--brackets :: Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--comma :: Parser ()-comma = void $ symbol ","----------------------------------------------------------------- Parser--------------------------------------------------------------------------- NOTE: when updating the parser, be sure to update the BNF in--- data/worlds/README.md to match!-------------------------------------------------------------------------parseWExpAtom :: Parser WExp-parseWExpAtom =- either WInt WFloat <$> integerOrFloat- <|> WBool <$> (True <$ reserved "true" <|> False <$ reserved "false")- <|> parseCell- <|> WVar <$> identifier- <|> WSeed <$ reserved "seed"- <|> WCoord <$> (X <$ reserved "x" <|> Y <$ reserved "y")- <|> WHash <$ reserved "hash"- <|> parseIf- <|> parsePerlin- <|> parseAbs- <|> parseLet- <|> parseOverlay- <|> parseMask- <|> parseImport- -- <|> parseCat- -- <|> parseStruct- <|> parens parseWExp--parseWExp :: Parser WExp-parseWExp =- makeExprParser- parseWExpAtom- [- [ Prefix (unary Not <$ reserved "not")- , Prefix (unary Neg <$ operator "-")- ]- ,- [ InfixL (binary Mul <$ operator "*")- , InfixL (binary Div <$ operator "/")- , InfixL (binary Mod <$ operator "%")- ]- ,- [ InfixL (binary Add <$ operator "+")- , InfixL (binary Sub <$ operator "-")- , InfixR (binary Overlay <$ operator "<>")- ]- ,- [ InfixN (binary Eq <$ operator "==")- , InfixN (binary Neq <$ operator "/=")- , InfixN (binary Lt <$ operator "<")- , InfixN (binary Leq <$ operator "<=")- , InfixN (binary Gt <$ operator ">")- , InfixN (binary Geq <$ operator ">=")- ]- , [InfixR (binary And <$ operator "&&")]- , [InfixR (binary Or <$ operator "||")]- ]- where- unary op x = WOp op [x]- binary op x1 x2 = WOp op [x1, x2]--parseCell :: Parser WExp-parseCell =- braces $ WCell <$> parseCellItem `sepBy1` comma--parseCellItem :: Parser (Maybe CellTag, Text)-parseCellItem =- (,)- <$> optional (try (parseCellTag <* symbol ":"))- <*> parseName--parseCellTag :: Parser CellTag-parseCellTag = choice (map mkCellTagParser [minBound .. maxBound :: CellTag])- where- mkCellTagParser ct = ct <$ string' (T.drop 4 $ showT ct)--parseName :: Parser Text-parseName =- into @Text- <$> manyTill anySingle (lookAhead (satisfy (\c -> c == ',' || c == '}' || c == ']')))--parseIf :: Parser WExp-parseIf =- (\i t e -> WOp If [i, t, e])- <$> (reserved "if" *> parseWExp)- <*> (reserved "then" *> parseWExp)- <*> (reserved "else" *> parseWExp)--parsePerlin :: Parser WExp-parsePerlin =- (\s o k p -> WOp Perlin [s, o, k, p])- <$> (reserved "perlin" *> parseWExpAtom)- <*> parseWExpAtom- <*> parseWExpAtom- <*> parseWExpAtom--parseAbs :: Parser WExp-parseAbs =- WOp Abs . (: []) <$> (reserved "abs" *> parseWExpAtom)--parseLet :: Parser WExp-parseLet =- WLet- <$> ( reserved "let"- *> (((,) <$> identifier <*> (symbol "=" *> parseWExp)) `sepBy` comma)- )- <*> (reserved "in" *> parseWExp)--parseOverlay :: Parser WExp-parseOverlay = do- reserved "overlay"- brackets $ WOverlay <$> parseWExp `CNE.sepBy1` comma--parseMask :: Parser WExp-parseMask = do- reserved "mask"- w1 <- parseWExpAtom- w2 <- parseWExpAtom- return $ WOp Mask [w1, w2]--parseImport :: Parser WExp-parseImport = WImport . into @Text <$> between (symbol "\"") (symbol "\"") (some (satisfy (/= '"')))---- parseCat :: Parser WExp--- parseCat =--- WCat--- <$> (X <$ reserved "hcat" <|> Y <$ reserved "vcat")--- <*> brackets (parseWExp `sepBy` comma)---- parseStruct :: Parser WExp--- parseStruct = reserved "struct" *> fail "struct not implemented"----------------------------------------------------------------- Utility--runParser :: Parser a -> Text -> Either ParserError a-runParser p = parse (fully sc p) ""----------------------------------------------------------------- JSON instance--instance FromJSON WExp where- parseJSON = withText "World DSL program" $ \t ->- case runParser parseWExp t of- Left err -> error (errorBundlePretty err)- Right wexp -> return wexp
@@ -1,65 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ TUI-independent world rendering.-module Swarm.Game.World.Render where--import Control.Effect.Lift (sendIO)-import Control.Lens (view)-import Data.List.NonEmpty qualified as NE-import Swarm.Doc.Gen (loadStandaloneScenario)-import Swarm.Game.Display (defaultChar)-import Swarm.Game.ResourceLoading (initNameGenerator, readAppData)-import Swarm.Game.Scenario (Scenario, area, scenarioWorlds, ul, worldName)-import Swarm.Game.Scenario.Status (emptyLaunchParams)-import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions, isEmpty, upperLeftToBottomRight)-import Swarm.Game.Scenario.Topography.Cell-import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)-import Swarm.Game.State-import Swarm.Game.Universe-import Swarm.Game.World qualified as W-import Swarm.TUI.Editor.Util (getContentAt, getMapRectangle)-import Swarm.Util.Effect (simpleErrorHandle)-import Swarm.Util.Erasable (erasableToMaybe)--getDisplayChar :: PCell EntityFacade -> Char-getDisplayChar = maybe ' ' facadeChar . erasableToMaybe . cellEntity- where- facadeChar (EntityFacade _ d) = view defaultChar d--getDisplayGrid :: Scenario -> GameState -> [[PCell EntityFacade]]-getDisplayGrid myScenario gs =- getMapRectangle- mkFacade- (getContentAt worlds . mkCosmic)- boundingBox- where- worlds = view (landscape . multiWorld) gs-- firstScenarioWorld = NE.head $ view scenarioWorlds myScenario- worldArea = area firstScenarioWorld- upperLeftLocation = ul firstScenarioWorld- rawAreaDims = getAreaDimensions worldArea- areaDims =- if isEmpty rawAreaDims- then AreaDimensions 20 10- else rawAreaDims- lowerRightLocation = upperLeftToBottomRight areaDims upperLeftLocation-- mkCosmic = Cosmic $ worldName firstScenarioWorld- boundingBox = (W.locToCoords upperLeftLocation, W.locToCoords lowerRightLocation)--renderScenarioMap :: FilePath -> IO [String]-renderScenarioMap fp = simpleErrorHandle $ do- (myScenario, (worldDefs, entities, recipes)) <- loadStandaloneScenario fp- appDataMap <- readAppData- nameGen <- initNameGenerator appDataMap- let gsc = GameStateConfig nameGen entities recipes worldDefs- gs <- sendIO $ scenarioToGameState myScenario emptyLaunchParams gsc- let grid = getDisplayGrid myScenario gs-- return $ map (map getDisplayChar) grid--printScenarioMap :: [String] -> IO ()-printScenarioMap =- sendIO . mapM_ putStrLn
@@ -1,119 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Abstract syntax for the Swarm world description DSL.-module Swarm.Game.World.Syntax (- -- | Various component types- World,- RawCellVal,- CellTag (..),- CellVal (..),- Rot (..),- Var,- Axis (..),- Op (..),- -- | The main AST type- WExp (..),-)-where--import Control.Lens (view, (^.))-import Data.List.NonEmpty qualified as NE-import Data.Semigroup (Last (..))-import Data.Text (Text)-import Data.Text qualified as T-import Prettyprinter-import Swarm.Game.Entity (Entity, entityName)-import Swarm.Game.Robot (Robot, robotName)-import Swarm.Game.Terrain-import Swarm.Game.World.Coords-import Swarm.Language.Pretty-import Swarm.Util (showT)-import Swarm.Util.Erasable----------------------------------------------------------------- Bits and bobs--type World b = Coords -> b--data CellTag = CellTerrain | CellEntity | CellRobot- deriving (Eq, Ord, Show, Enum, Bounded)--instance PrettyPrec CellTag where- prettyPrec _ = \case- CellTerrain -> "terrain"- CellEntity -> "an entity"- CellRobot -> "a robot"--type RawCellVal = [(Maybe CellTag, Text)]--prettyRawCellItem :: (Maybe CellTag, Text) -> Doc ann-prettyRawCellItem (Nothing, t) = pretty t-prettyRawCellItem (Just tag, t) = pretty (T.toLower . T.drop 4 . showT $ tag) <> ":" <> pretty t--data CellVal = CellVal TerrainType (Erasable (Last Entity)) [Robot]- deriving (Eq, Show)--instance PrettyPrec CellVal where- prettyPrec _ (CellVal terr ent rs) =- "{" <> hsep (punctuate "," (map prettyRawCellItem items)) <> "}"- where- items =- [(Just CellTerrain, getTerrainWord terr) | terr /= BlankT]- ++ [(Just CellEntity, e ^. entityName) | EJust (Last e) <- [ent]]- ++ map ((Just CellRobot,) . view robotName) rs--data Rot = Rot0 | Rot90 | Rot180 | Rot270- deriving (Eq, Ord, Show, Bounded, Enum)--instance PrettyPrec Rot where- prettyPrec _ = \case- Rot0 -> "rot0"- Rot90 -> "rot90"- Rot180 -> "rot180"- Rot270 -> "rot270"--type Var = Text--data Axis = X | Y- deriving (Eq, Ord, Show, Bounded, Enum)--instance PrettyPrec Axis where- prettyPrec _ = \case X -> "x"; Y -> "y"--data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Reflect Axis | Rot Rot | Mask | Overlay | Abs- deriving (Eq, Ord, Show)----------------------------------------------------------------- Main AST--data WExp where- WInt :: Integer -> WExp- WFloat :: Double -> WExp- WBool :: Bool -> WExp- WCell :: RawCellVal -> WExp- WVar :: Text -> WExp- -- Require all operators to be fully saturated. Just embedding- -- operators as constants and including function application would- -- be a more elegant encoding, but it requires being more clever- -- with type inference.- WOp :: Op -> [WExp] -> WExp- WSeed :: WExp- WCoord :: Axis -> WExp- WHash :: WExp- WLet :: [(Var, WExp)] -> WExp -> WExp- WOverlay :: NE.NonEmpty WExp -> WExp- WImport :: Text -> WExp- deriving (Eq, Show)---- We don't have an explicit Empty case because we can't infer its--- type. It could be done but it would require a lot more care with--- inference vs checking mode.---- TODO (#1394): Add hcat and vcat operations--- WCat :: Axis -> [WExp] -> WExp---- TODO (#1394): Add support for structures--- WStruct :: WorldPalette Text -> [Text] -> WExp
@@ -1,687 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Typechecking and elaboration for the Swarm world DSL. For more--- information, see:------ https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/-module Swarm.Game.World.Typecheck where--import Control.Algebra (Has)-import Control.Effect.Reader (Reader, ask)-import Control.Effect.Throw (Throw, throwError)-import Data.Foldable qualified as F-import Data.Functor.Const qualified as F-import Data.Kind (Type)-import Data.List (foldl')-import Data.List.NonEmpty qualified as NE-import Data.Map (Map)-import Data.Map qualified as M-import Data.Semigroup (Last (..))-import Data.Text (Text)-import Data.Type.Equality (TestEquality (..), type (:~:) (Refl))-import Prettyprinter-import Swarm.Game.Entity (EntityMap, lookupEntityName)-import Swarm.Game.Terrain (readTerrain)-import Swarm.Game.World.Syntax-import Swarm.Language.Pretty-import Swarm.Util (showT)-import Swarm.Util.Erasable-import Prelude hiding (lookup)----------------------------------------------------------------- Type classes for monoidal world values---- We could use Semigroup and Monoid, but we want to use the two--- classes separately and make instances for base types, so it's--- cleaner to just make our own classes (the instances would be--- orphans if we used Semigroup and Monoid).--class Empty e where- empty :: e--instance Empty CellVal where- empty = CellVal mempty mempty mempty--class Over m where- (<!>) :: m -> m -> m--instance Over Bool where- _ <!> x = x--instance Over Integer where- _ <!> x = x--instance Over Double where- _ <!> x = x--instance Over CellVal where- CellVal t1 e1 r1 <!> CellVal t2 e2 r2 = CellVal (t1 <> t2) (e1 <> e2) (r1 <> r2)----------------------------------------------------------------- Type class for type-indexed application--infixl 1 $$-class Applicable t where- ($$) :: t (a -> b) -> t a -> t b----------------------------------------------------------------- Distinguishing functions and non-functions at the type level---- In several places, for efficiency we will require something to be--- not a function, which we can enforce using the 'NotFun' constraint.--type family IsFun a where- IsFun (_ -> _) = 'True- IsFun _ = 'False--type NotFun a = IsFun a ~ 'False----------------------------------------------------------------- Type-indexed constants---- | Type-indexed constants. These include both language built-ins--- (@if@, arithmetic, comparison, @<>@, etc.) as well as combinators--- (@S@, @I@, @C@, @K@, @B@, @Φ@) we will use both for elaboration--- and later as a compilation target.-data Const :: Type -> Type where- CLit :: (Show a, NotFun a) => a -> Const a- CCell :: CellVal -> Const CellVal- -- We have a separate CCell instead of using CLit for cells so that we can- -- later extract all the entities from a world expression.- CFI :: Const (Integer -> Double)- CIf :: Const (Bool -> a -> a -> a)- CNot :: Const (Bool -> Bool)- CNeg :: (Num a, NotFun a) => Const (a -> a)- CAbs :: (Num a, NotFun a) => Const (a -> a)- CAnd :: Const (Bool -> Bool -> Bool)- COr :: Const (Bool -> Bool -> Bool)- CAdd :: (Num a, NotFun a) => Const (a -> a -> a)- CSub :: (Num a, NotFun a) => Const (a -> a -> a)- CMul :: (Num a, NotFun a) => Const (a -> a -> a)- CDiv :: (Fractional a, NotFun a) => Const (a -> a -> a)- CIDiv :: (Integral a, NotFun a) => Const (a -> a -> a)- CMod :: (Integral a, NotFun a) => Const (a -> a -> a)- CEq :: (Eq a, NotFun a) => Const (a -> a -> Bool)- CNeq :: (Eq a, NotFun a) => Const (a -> a -> Bool)- CLt :: (Ord a, NotFun a) => Const (a -> a -> Bool)- CLeq :: (Ord a, NotFun a) => Const (a -> a -> Bool)- CGt :: (Ord a, NotFun a) => Const (a -> a -> Bool)- CGeq :: (Ord a, NotFun a) => Const (a -> a -> Bool)- CMask :: (Empty a, NotFun a) => Const (World Bool -> World a -> World a)- CSeed :: Const Integer- CCoord :: Axis -> Const (World Integer)- CHash :: Const (World Integer)- CPerlin :: Const (Integer -> Integer -> Double -> Double -> World Double)- CReflect :: Axis -> Const (World a -> World a)- CRot :: Rot -> Const (World a -> World a)- COver :: (Over a, NotFun a) => Const (a -> a -> a)- -- Combinators generated during elaboration + variable abstraction- K :: Const (a -> b -> a)- S :: Const ((a -> b -> c) -> (a -> b) -> a -> c)- I :: Const (a -> a)- B :: Const ((b -> c) -> (a -> b) -> a -> c)- C :: Const ((a -> b -> c) -> b -> a -> c)- -- Phoenix combinator, aka liftA2. Including this combinator in the- -- target set is not typical, but it turns out to be very helpful in- -- elaborating the "over" operation.- Φ :: Const ((a -> b -> c) -> (d -> a) -> (d -> b) -> (d -> c))--deriving instance Show (Const ty)--class HasConst t where- embed :: Const a -> t a--infixl 1 .$$-(.$$) :: (HasConst t, Applicable t) => Const (a -> b) -> t a -> t b-c .$$ t = embed c $$ t--infixl 1 $$.-($$.) :: (HasConst t, Applicable t) => t (a -> b) -> Const a -> t b-t $$. c = t $$ embed c--infixl 1 .$$.-(.$$.) :: (HasConst t, Applicable t) => Const (a -> b) -> Const a -> t b-c1 .$$. c2 = embed c1 $$ embed c2--instance PrettyPrec (Const α) where- prettyPrec _ = \case- CLit a -> pretty (showT a)- CCell c -> ppr c- CFI -> "fromIntegral"- CIf -> "if"- CNot -> "not"- CNeg -> "negate"- CAbs -> "abs"- CAnd -> "and"- COr -> "or"- CAdd -> "add"- CSub -> "sub"- CMul -> "mul"- CDiv -> "div"- CIDiv -> "idiv"- CMod -> "mod"- CEq -> "eq"- CNeq -> "neq"- CLt -> "lt"- CLeq -> "leq"- CGt -> "gt"- CGeq -> "geq"- CMask -> "mask"- CSeed -> "seed"- CCoord ax -> ppr ax- CHash -> "hash"- CPerlin -> "perlin"- CReflect ax -> case ax of X -> "vreflect"; Y -> "hreflect"- CRot rot -> ppr rot- COver -> "over"- K -> "K"- S -> "S"- I -> "I"- B -> "B"- C -> "C"- Φ -> "Φ"----------------------------------------------------------------- Intrinsically typed core language---- | Type-level list append.-type family Append (xs :: [k]) (ys :: [k]) :: [k] where- Append '[] ys = ys- Append (x ': xs) ys = x ': Append xs ys---- | Type- and context-indexed de Bruijn indices. (v :: Idx g a) means--- v represents a variable with type a in a type context g.-data Idx :: [Type] -> Type -> Type where- VZ :: Idx (ty ': g) ty- VS :: Idx g ty -> Idx (x ': g) ty--deriving instance Show (Idx g ty)--idxToNat :: Idx g a -> Int-idxToNat VZ = 0-idxToNat (VS x) = 1 + idxToNat x---- | A variable valid in one context is also valid in another extended--- context with additional variables.-weakenVar :: forall h g a. Idx g a -> Idx (Append g h) a-weakenVar VZ = VZ-weakenVar (VS x) = VS (weakenVar @h x)---- | Type-indexed terms. Note this is a stripped-down core language,--- with only variables, lambdas, application, and constants.-data TTerm :: [Type] -> Type -> Type where- TVar :: Idx g a -> TTerm g a- TLam :: TTerm (ty1 ': g) ty2 -> TTerm g (ty1 -> ty2)- TApp :: TTerm g (a -> b) -> TTerm g a -> TTerm g b- TConst :: Const a -> TTerm g a--deriving instance Show (TTerm g ty)--instance Applicable (TTerm g) where- TConst I $$ x = x- f $$ x = TApp f x--instance HasConst (TTerm g) where- embed = TConst--instance PrettyPrec (TTerm g α) where- prettyPrec :: Int -> TTerm g α -> Doc ann- prettyPrec p = \case- TVar ix -> pretty (idxToNat ix)- TLam t ->- pparens (p > 0) $- "λ." <+> ppr t- TApp t1 t2 ->- pparens (p > 1) $- prettyPrec 1 t1 <+> prettyPrec 2 t2- TConst c -> ppr c---- | A term valid in one context is also valid in another extended--- context with additional variables (which the term does not use).-weaken :: forall h g a. TTerm g a -> TTerm (Append g h) a-weaken (TVar x) = TVar (weakenVar @h x)-weaken (TLam t) = TLam (weaken @h t)-weaken (TApp t1 t2) = TApp (weaken @h t1) (weaken @h t2)-weaken (TConst c) = TConst c----------------------------------------------------------------- Errors---- | Errors that can occur during typechecking/elaboration.-data CheckErr where- ApplyErr :: Some (TTerm g) -> Some (TTerm g) -> CheckErr- NoInstance :: Text -> TTy a -> CheckErr- Unbound :: Text -> CheckErr- BadType :: Some (TTerm g) -> TTy b -> CheckErr- BadDivType :: TTy a -> CheckErr- UnknownImport :: Text -> CheckErr- NotAThing :: Text -> CellTag -> CheckErr- NotAnything :: Text -> CheckErr--deriving instance Show CheckErr--instance PrettyPrec CheckErr where- prettyPrec _ = \case- ApplyErr (Some ty1 t1) (Some ty2 t2) ->- nest 2 . vsep $- [ "Error in application:"- , squotes (ppr t1) <> " has type " <> squotes (ppr ty1)- , "and cannot be applied to"- , squotes (ppr t2) <> " which has type " <> squotes (ppr ty2)- ]- NoInstance cls ty -> squotes (ppr ty) <+> "is not an instance of" <+> pretty cls- Unbound x -> "Undefined variable" <+> pretty x- BadType (Some tty t) ty ->- hsep- [squotes (ppr t), "has type", squotes (ppr tty), "and cannot be given type", squotes (ppr ty)]- BadDivType ty -> "Division operator used at type" <+> squotes (ppr ty)- UnknownImport key -> "Import" <+> squotes (pretty key) <+> "not found"- NotAThing item tag -> squotes (pretty item) <+> "is not" <+> ppr tag- NotAnything item -> "Cannot resolve cell item" <+> squotes (pretty item)----------------------------------------------------------------- Type representations---- | Base types.-data Base :: Type -> Type where- BInt :: Base Integer- BFloat :: Base Double- BBool :: Base Bool- BCell :: Base CellVal--deriving instance Show (Base ty)---- | Testing base type representations for equality to yield reflected--- type-level equalities.-instance TestEquality Base where- testEquality BInt BInt = Just Refl- testEquality BFloat BFloat = Just Refl- testEquality BBool BBool = Just Refl- testEquality BCell BCell = Just Refl- testEquality _ _ = Nothing--instance PrettyPrec (Base α) where- prettyPrec _ = \case- BInt -> "int"- BFloat -> "float"- BBool -> "bool"- BCell -> "cell"---- | Type representations indexed by the corresponding host language--- type.-data TTy :: Type -> Type where- TTyBase :: Base t -> TTy t- (:->:) :: TTy a -> TTy b -> TTy (a -> b)- TTyWorld :: TTy t -> TTy (World t)--infixr 0 :->:--pattern TTyBool :: TTy Bool-pattern TTyBool = TTyBase BBool--pattern TTyInt :: TTy Integer-pattern TTyInt = TTyBase BInt--pattern TTyFloat :: TTy Double-pattern TTyFloat = TTyBase BFloat--pattern TTyCell :: TTy CellVal-pattern TTyCell = TTyBase BCell--deriving instance Show (TTy ty)---- | Testing type representations for equality to yield reflected--- type-level equalities.-instance TestEquality TTy where- testEquality (TTyBase b1) (TTyBase b2) = testEquality b1 b2- testEquality (TTyWorld b1) (TTyWorld b2) =- case testEquality b1 b2 of- Just Refl -> Just Refl- Nothing -> Nothing- testEquality _ _ = Nothing--instance PrettyPrec (TTy ty) where- prettyPrec :: Int -> TTy ty -> Doc ann- prettyPrec _ (TTyBase b) = ppr b- prettyPrec p (α :->: β) =- pparens (p > 0) $- prettyPrec 1 α <+> "->" <+> prettyPrec 0 β- prettyPrec p (TTyWorld t) =- pparens (p > 1) $- "World" <+> prettyPrec 2 t----------------------------------------------------------------- Instance checking---- | Check that a particular type has an 'GHC.Classes.Eq' instance, and run a--- computation in a context provided with an 'GHC.Classes.Eq' constraint. The--- other @checkX@ functions are similar.-checkEq :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Eq ty, NotFun ty) => m a) -> m a-checkEq (TTyBase BBool) a = a-checkEq (TTyBase BInt) a = a-checkEq (TTyBase BFloat) a = a-checkEq ty _ = throwError $ NoInstance "Eq" ty--checkOrd :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Ord ty, NotFun ty) => m a) -> m a-checkOrd (TTyBase BBool) a = a-checkOrd (TTyBase BInt) a = a-checkOrd (TTyBase BFloat) a = a-checkOrd ty _ = throwError $ NoInstance "Ord" ty--checkNum :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Num ty, NotFun ty) => m a) -> m a-checkNum (TTyBase BInt) a = a-checkNum (TTyBase BFloat) a = a-checkNum ty _ = throwError $ NoInstance "Num" ty--checkIntegral :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Integral ty, NotFun ty) => m a) -> m a-checkIntegral (TTyBase BInt) a = a-checkIntegral ty _ = throwError $ NoInstance "Integral" ty--checkEmpty :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Empty ty, NotFun ty) => m a) -> m a-checkEmpty (TTyBase BCell) a = a-checkEmpty ty _ = throwError $ NoInstance "Empty" ty--checkOver :: (Has (Throw CheckErr) sig m) => TTy ty -> ((Over ty, NotFun ty) => m a) -> m a-checkOver (TTyBase BBool) a = a-checkOver (TTyBase BInt) a = a-checkOver (TTyBase BFloat) a = a-checkOver (TTyBase BCell) a = a-checkOver ty _ = throwError $ NoInstance "Over" ty----------------------------------------------------------------- Existential wrappers---- | Wrap up a type-indexed thing to hide the type index, but package--- it with a 'TTy' which we can pattern-match on to recover the type--- later.-data Some :: (Type -> Type) -> Type where- Some :: TTy α -> t α -> Some t--deriving instance (forall α. Show (t α)) => Show (Some t)--mapSome :: (forall α. s α -> t α) -> Some s -> Some t-mapSome f (Some ty t) = Some ty (f t)--type SomeTy = Some (F.Const ())--pattern SomeTy :: TTy α -> SomeTy-pattern SomeTy α = Some α (F.Const ())-{-# COMPLETE SomeTy #-}----------------------------------------------------------------- Type inference/checking + elaboration--type WorldMap = Map Text (Some (TTerm '[]))---- | Type contexts, indexed by a type-level list of types of all the--- variables in the context.-data Ctx :: [Type] -> Type where- CNil :: Ctx '[]- CCons :: Text -> TTy ty -> Ctx g -> Ctx (ty ': g)---- | Look up a variable name in the context, returning a type-indexed--- de Bruijn index.-lookup :: (Has (Throw CheckErr) sig m) => Text -> Ctx g -> m (Some (Idx g))-lookup x CNil = throwError $ Unbound x-lookup x (CCons y ty ctx)- | x == y = return $ Some ty VZ- | otherwise = mapSome VS <$> lookup x ctx---- | Check that a term has a given type, and if so, return a--- corresponding elaborated and type-indexed term. Note that this--- also deals with subtyping: for example, if we check that the term--- @3@ has type @World Int@, we will get back a suitably lifted--- value (/i.e./ @const 3@).-check ::- ( Has (Throw CheckErr) sig m- , Has (Reader EntityMap) sig m- , Has (Reader WorldMap) sig m- ) =>- Ctx g ->- TTy t ->- WExp ->- m (TTerm g t)-check e ty t = do- t1 <- infer e t- Some ty' t' <- apply (Some (ty :->: ty) (embed I)) t1- case testEquality ty ty' of- Nothing -> throwError $ BadType t1 ty- Just Refl -> return t'---- | Get the underlying base type of a term which either has a base--- type or a World type.-getBaseType :: Some (TTerm g) -> SomeTy-getBaseType (Some (TTyWorld ty) _) = SomeTy ty-getBaseType (Some ty _) = SomeTy ty---- | Apply one term to another term, automatically handling promotion--- and lifting, via the fact that World is Applicative. That is,--- (1) if a term of type T is used where a term of type World T is--- expected, it will automatically be promoted (by an application of--- const); (2) if a function of type (T1 -> T2 -> ... -> Tn) is--- applied to any arguments of type (World Ti), the function will be--- lifted to (World T1 -> World T2 -> ... -> World Tn).-apply :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g))--- Normal function application-apply (Some (ty11 :->: ty12) t1) (Some ty2 t2)- | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ t2)--- (World T -> ...) applied to T: promote the argument to (World T) with const-apply (Some (TTyWorld ty11 :->: ty12) t1) (Some ty2 t2)- | Just Refl <- testEquality ty11 ty2 = return $ Some ty12 (t1 $$ (K .$$ t2))--- (S -> T) applied to (World S): lift the function to (World S -> World T).-apply (Some (ty11 :->: ty12) t1) (Some (TTyWorld ty2) t2)- | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (B .$$ t1 $$ t2)--- World (S -> T) applied to S. Note this case and the next are--- needed because in the previous case, when (S -> T) is lifted to--- (World S -> World T), T may itself be a function type.-apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some ty2 t2)- | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ (K .$$ t2))--- World (S -> T) applied to (World S)-apply (Some (TTyWorld (ty11 :->: ty12)) t1) (Some (TTyWorld ty2) t2)- | Just Refl <- testEquality ty11 ty2 = return $ Some (TTyWorld ty12) (S .$$ t1 $$ t2)-apply t1 t2 = throwError $ ApplyErr t1 t2--applyTo :: (Has (Throw CheckErr) sig m) => Some (TTerm g) -> Some (TTerm g) -> m (Some (TTerm g))-applyTo = flip apply---- | Infer the type of an operator: turn a raw operator into a--- type-indexed constant. However, some operators are polymorphic,--- so we also provide a list of type arguments. For example, the--- type of the negation operator can be either (Int -> Int) or--- (Float -> Float) so we provide it as an argument.------ Currently, all operators take at most one type argument, so--- (Maybe SomeTy) might seem more appropriate than [SomeTy], but--- that is just a coincidence; in general one can easily imagine--- operators that are polymorphic in more than one type variable,--- and we may wish to add such in the future.-inferOp :: (Has (Throw CheckErr) sig m) => [SomeTy] -> Op -> m (Some (TTerm g))-inferOp _ Not = return $ Some (TTyBool :->: TTyBool) (embed CNot)-inferOp [SomeTy tyA] Neg = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CNeg)-inferOp _ And = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed CAnd)-inferOp _ Or = return $ Some (TTyBool :->: TTyBool :->: TTyBool) (embed COr)-inferOp [SomeTy tyA] Abs = Some (tyA :->: tyA) <$> checkNum tyA (return $ embed CAbs)-inferOp [SomeTy tyA] Add = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CAdd)-inferOp [SomeTy tyA] Sub = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CSub)-inferOp [SomeTy tyA] Mul = Some (tyA :->: tyA :->: tyA) <$> checkNum tyA (return $ embed CMul)-inferOp [SomeTy tyA] Div = case tyA of- TTyBase BInt -> return $ Some (tyA :->: tyA :->: tyA) (embed CIDiv)- TTyBase BFloat -> return $ Some (tyA :->: tyA :->: tyA) (embed CDiv)- _ -> throwError $ BadDivType tyA-inferOp [SomeTy tyA] Mod = Some (tyA :->: tyA :->: tyA) <$> checkIntegral tyA (return $ embed CMod)-inferOp [SomeTy tyA] Eq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CEq)-inferOp [SomeTy tyA] Neq = Some (tyA :->: tyA :->: TTyBool) <$> checkEq tyA (return $ embed CNeq)-inferOp [SomeTy tyA] Lt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLt)-inferOp [SomeTy tyA] Leq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CLeq)-inferOp [SomeTy tyA] Gt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGt)-inferOp [SomeTy tyA] Geq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGeq)-inferOp [SomeTy tyA] If = return $ Some (TTyBool :->: tyA :->: tyA :->: tyA) (embed CIf)-inferOp _ Perlin = return $ Some (TTyInt :->: TTyInt :->: TTyFloat :->: TTyFloat :->: TTyWorld TTyFloat) (embed CPerlin)-inferOp [SomeTy tyA] (Reflect r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CReflect r))-inferOp [SomeTy tyA] (Rot r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CRot r))-inferOp [SomeTy tyA] Mask = Some (TTyWorld TTyBool :->: TTyWorld tyA :->: TTyWorld tyA) <$> checkEmpty tyA (return $ embed CMask)-inferOp [SomeTy tyA] Overlay = Some (tyA :->: tyA :->: tyA) <$> checkOver tyA (return $ embed COver)-inferOp tys op = error $ "bad call to inferOp: " ++ show tys ++ " " ++ show op---- | Given a raw operator and the terms the operator is applied to,--- select which types should be supplied as the type arguments to--- the operator. For example, for an operator like @+@ we can just--- select the type of its first argument; for an operator like @if@,--- we must select the type of its second argument, since @if : Bool--- -> a -> a -> a@. In all cases we must also select the underlying--- base type in case the argument has a @World@ type. For example--- if @+@ is applied to an argument of type @World Int@ we still--- want to give @+@ the type @Int -> Int -> Int@. It can be lifted--- to have type @World Int -> World Int -> World Int@ but that will--- be taken care of by application, which will insert the right--- combinators to do the lifting.-typeArgsFor :: Op -> [Some (TTerm g)] -> [SomeTy]-typeArgsFor op (t : _)- | op `elem` [Neg, Abs, Add, Sub, Mul, Div, Mod, Eq, Neq, Lt, Leq, Gt, Geq] = [getBaseType t]-typeArgsFor (Reflect _) (t : _) = [getBaseType t]-typeArgsFor (Rot _) (t : _) = [getBaseType t]-typeArgsFor op (_ : t : _)- | op `elem` [If, Mask, Overlay] = [getBaseType t]-typeArgsFor _ _ = []---- | Typecheck the application of an operator to some terms, returning--- a typed, elaborated version of the application.-applyOp ::- ( Has (Throw CheckErr) sig m- , Has (Reader EntityMap) sig m- , Has (Reader WorldMap) sig m- ) =>- Ctx g ->- Op ->- [WExp] ->- m (Some (TTerm g))-applyOp ctx op ts = do- tts <- mapM (infer ctx) ts- foldl (\r -> (r >>=) . applyTo) (inferOp (typeArgsFor op tts) op) tts---- | Infer the type of a term, and elaborate along the way.-infer ::- forall sig m g.- ( Has (Throw CheckErr) sig m- , Has (Reader EntityMap) sig m- , Has (Reader WorldMap) sig m- ) =>- Ctx g ->- WExp ->- m (Some (TTerm g))-infer _ (WInt i) = return $ Some (TTyBase BInt) (embed (CLit i))-infer _ (WFloat f) = return $ Some (TTyBase BFloat) (embed (CLit f))-infer _ (WBool b) = return $ Some (TTyBase BBool) (embed (CLit b))-infer _ (WCell c) = do- c' <- resolveCell c- return $ Some TTyCell (embed (CCell c'))-infer ctx (WVar x) = mapSome TVar <$> lookup x ctx-infer ctx (WOp op ts) = applyOp ctx op ts-infer _ WSeed = return $ Some TTyInt (embed CSeed)-infer _ (WCoord ax) = return $ Some (TTyWorld TTyInt) (embed (CCoord ax))-infer _ WHash = return $ Some (TTyWorld TTyInt) (embed CHash)-infer ctx (WLet defs body) = inferLet ctx defs body-infer ctx (WOverlay ts) = inferOverlay ctx ts-infer _ctx (WImport key) = do- worldMap <- ask @WorldMap- case M.lookup key worldMap of- Just (Some ty t) -> return (Some ty (weaken @g t))- Nothing -> throwError $ UnknownImport key---- | Try to resolve a 'RawCellVal'---containing only 'Text' names for--- terrain, entities, and robots---into a real 'CellVal' with--- references to actual terrain, entities, and robots.-resolveCell ::- (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) =>- RawCellVal ->- m CellVal-resolveCell items = do- cellVals <- mapM resolveCellItem items- return $ foldl' (<!>) empty cellVals---- | Try to resolve one cell item name into an actual item (terrain,--- entity, robot, etc.).-resolveCellItem ::- forall sig m.- (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) =>- (Maybe CellTag, Text) ->- m CellVal-resolveCellItem (mCellTag, item) = case mCellTag of- Just cellTag -> do- -- The item was tagged specifically, like {terrain: dirt} or {entity: water}- mCell <- resolverByTag cellTag item- maybe (throwError $ NotAThing item cellTag) return mCell- Nothing -> do- -- The item was not tagged; try resolving in all possible ways and choose- -- the first that works- maybeCells <- mapM (`resolverByTag` item) [minBound .. maxBound :: CellTag]- case F.asum maybeCells of- Nothing -> throwError $ NotAnything item- Just cell -> return cell- where- mkTerrain t = CellVal t mempty mempty- mkEntity e = CellVal mempty (EJust (Last e)) mempty- resolverByTag :: CellTag -> Text -> m (Maybe CellVal)- resolverByTag = \case- CellTerrain -> return . fmap mkTerrain . readTerrain- CellEntity -> \eName ->- case eName of- "erase" -> return $ Just (CellVal mempty EErase mempty)- _ -> do- em <- ask @EntityMap- return . fmap mkEntity $ lookupEntityName eName em- CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots---- | Infer the type of a let expression, and elaborate into a series--- of lambda applications.-inferLet ::- ( Has (Throw CheckErr) sig m- , Has (Reader EntityMap) sig m- , Has (Reader WorldMap) sig m- ) =>- Ctx g ->- [(Var, WExp)] ->- WExp ->- m (Some (TTerm g))-inferLet ctx [] body = infer ctx body-inferLet ctx ((x, e) : xs) body = do- e'@(Some ty1 _) <- infer ctx e- Some ty2 let' <- inferLet (CCons x ty1 ctx) xs body- apply (Some (ty1 :->: ty2) (TLam let')) e'---- | Infer the type of an @overlay@ expression, and elaborate into a--- chain of @<>@ (over) operations.-inferOverlay ::- ( Has (Throw CheckErr) sig m- , Has (Reader EntityMap) sig m- , Has (Reader WorldMap) sig m- ) =>- Ctx g ->- NE.NonEmpty WExp ->- m (Some (TTerm g))-inferOverlay ctx es = case NE.uncons es of- -- @overlay [e] = e@- (e, Nothing) -> infer ctx e- -- @overlay (e : es') = e <> overlay es'@- (e, Just es') -> do- e' <- infer ctx e- o' <- inferOverlay ctx es'- case getBaseType e' of- SomeTy ty -> do- let wty = TTyWorld ty- c <- checkOver ty (return $ embed COver)- apply (Some (wty :->: wty :->: wty) (Φ .$$ c)) e' >>= applyTo o'
@@ -1,325 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Capabilities needed to evaluate and execute programs. Language--- constructs or commands require certain capabilities, and in turn--- capabilities are provided by various devices. A robot must have an--- appropriate device equipped in order to make use of each language--- construct or command.-module Swarm.Language.Capability (- Capability (..),- capabilityName,- constCaps,-) where--import Data.Aeson (FromJSONKey, ToJSONKey)-import Data.Char (toLower)-import Data.Data (Data)-import Data.Hashable (Hashable)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml-import GHC.Generics (Generic)-import Swarm.Language.Syntax-import Swarm.Util (failT)-import Text.Read (readMaybe)-import Witch (from)-import Prelude hiding (lookup)---- | Various capabilities which robots can have.-data Capability- = -- | Be powered, i.e. execute anything at all- CPower- | -- | Execute the 'Move' command- CMove- | -- | Execute the 'Backup' command- CBackup- | -- | Execute the 'Path' command- CPath- | -- | Execute the 'Push' command- CPush- | -- | Execute the 'Stride' command- CMovemultiple- | -- | Execute the 'Move' command for a heavy robot- CMoveheavy- | -- | Execute the 'Turn' command- --- -- NOTE: using cardinal directions is separate 'COrient' capability- CTurn- | -- | Execute the 'Selfdestruct' command- CSelfdestruct- | -- | Execute the 'Grab' command- CGrab- | -- | Execute the 'Harvest' command- CHarvest- | -- | Execute the 'Ignite' command- CIgnite- | -- | Execute the 'Place' command- CPlace- | -- | Execute the 'Ping' command- CPing- | -- | Execute the 'Give' command- CGive- | -- | Execute the 'Equip' command- CEquip- | -- | Execute the 'Unequip' command- CUnequip- | -- | Execute the 'Make' command- CMake- | -- | Execute the 'Count' command- CCount- | -- | Execute the 'Scout' command. Reconnaissance along a line in a direction.- CRecondir- | -- | Execute the 'Build' command- CBuild- | -- | Execute the 'Salvage' command- CSalvage- | -- | Execute the 'Drill' command- CDrill- | -- | Execute the 'Waypoint' command- CWaypoint- | -- | Execute the 'Whereami' command- CSenseloc- | -- | Execute the 'Blocked' command- CSensefront- | -- | Execute the 'Ishere' and 'Isempty' commands- CSensehere- | -- | Execute the 'Detect' command- CDetectloc- | -- | Execute the 'Resonate' and 'Density' commands- CDetectcount- | -- | Execute the 'Sniff' command- CDetectdistance- | -- | Execute the 'Chirp' command- CDetectdirection- | -- | Execute the 'Watch' command- CWakeself- | -- | Execute the 'Scan' command- CScan- | -- | Execute the 'Random' command- CRandom- | -- | Execute the 'Appear' command- CAppear- | -- | Execute the 'Create' command- CCreate- | -- | Execute the 'Listen' command and passively log messages if also has 'CLog'- CListen- | -- | Execute the 'Log' command- CLog- | -- | Format values as text- CFormat- | -- | Split text into two pieces- CConcat- | -- | Join two text values into one- CSplit- | -- | Count the characters in a text value- CCharcount- | -- | Convert between characters/text and Unicode values- CCode- | -- | Don't drown in liquid- CFloat- | -- | Evaluate conditional expressions- CCond- | -- | Negate boolean value- CNegation- | -- | Evaluate comparison operations- CCompare- | -- | Use cardinal direction constants.- COrient- | -- | Evaluate arithmetic operations- CArith- | -- | Store and look up definitions in an environment- CEnv- | -- | Interpret lambda abstractions- CLambda- | -- | Enable recursive definitions- CRecursion- | -- | Execute the 'Reprogram' command- CReprogram- | -- | Execute the `meet` and `meetAll` commands.- CMeet- | -- | Capability to introspect and see its own name- CWhoami- | -- | Capability to set its own name- CSetname- | -- | Capability to move unrestricted to any place- CTeleport- | -- | Capability to run commands atomically- CAtomic- | -- | Capability to execute swap (grab and place atomically at the same time).- CSwap- | -- | Capability to obtain absolute time, namely via the `time` command.- CTimeabs- | -- | Capability to utilize relative passage of time, namely via the `wait` command.- -- This is strictly weaker than "CTimeAbs".- CTimerel- | -- | Capability to execute `try`.- CTry- | -- | Capability for working with sum types.- CSum- | -- | Capability for working with product types.- CProd- | -- | Capability for working with record types.- CRecord- | -- | Debug capability.- CDebug- | -- | Capability to handle keyboard input.- CHandleinput- | -- | Capability to make other robots halt.- CHalt- | -- | God-like capabilities. For e.g. commands intended only for- -- checking challenge mode win conditions, and not for use by- -- players.- CGod- deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data, FromJSONKey, ToJSONKey)--capabilityName :: Capability -> Text-capabilityName = from @String . map toLower . drop 1 . show--instance ToJSON Capability where- toJSON = String . capabilityName--instance FromJSON Capability where- parseJSON = withText "Capability" tryRead- where- tryRead :: Text -> Parser Capability- tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of- Just c -> return c- Nothing -> failT ["Unknown capability", t]---- | Capabilities needed to evaluate or execute a constant.-constCaps :: Const -> Maybe Capability-constCaps = \case- -- ----------------------------------------------------------------- -- Some built-in constants that don't require any special capability.- Noop -> Nothing- AppF -> Nothing- Force -> Nothing- Return -> Nothing- Parent -> Nothing- Base -> Nothing- Setname -> Nothing- Undefined -> Nothing- Fail -> Nothing- Has -> Nothing- Equipped -> Nothing- -- speaking is natural to robots (unlike listening)- Say -> Nothing- -- TODO: #495- -- the require command will be inlined once the Issue is fixed- -- so the capabilities of the run commands will be checked instead- Run -> Nothing- -- ----------------------------------------------------------------- -- Some straightforward ones.- Listen -> Just CListen- Log -> Just CLog- Selfdestruct -> Just CSelfdestruct- Move -> Just CMove- Backup -> Just CBackup- Path -> Just CPath- Push -> Just CPush- Stride -> Just CMovemultiple- Turn -> Just CTurn- Grab -> Just CGrab- Harvest -> Just CHarvest- Ignite -> Just CIgnite- Place -> Just CPlace- Ping -> Just CPing- Give -> Just CGive- Equip -> Just CEquip- Unequip -> Just CUnequip- Make -> Just CMake- Count -> Just CCount- If -> Just CCond- Blocked -> Just CSensefront- Scan -> Just CScan- Ishere -> Just CSensehere- Isempty -> Just CSensehere- Upload -> Just CScan- Build -> Just CBuild- Salvage -> Just CSalvage- Reprogram -> Just CReprogram- Meet -> Just CMeet- MeetAll -> Just CMeet- Drill -> Just CDrill- Use -> Nothing -- Recipes alone shall dictate whether things can be "used"- Neg -> Just CArith- Add -> Just CArith- Sub -> Just CArith- Mul -> Just CArith- Div -> Just CArith- Exp -> Just CArith- Whoami -> Just CWhoami- Self -> Just CWhoami- Swap -> Just CSwap- Atomic -> Just CAtomic- Instant -> Just CGod- Time -> Just CTimeabs- Wait -> Just CTimerel- Scout -> Just CRecondir- Whereami -> Just CSenseloc- Waypoint -> Just CWaypoint- Detect -> Just CDetectloc- Resonate -> Just CDetectcount- Density -> Just CDetectcount- Sniff -> Just CDetectdistance- Chirp -> Just CDetectdirection- Watch -> Just CWakeself- Heading -> Just COrient- Key -> Just CHandleinput- InstallKeyHandler -> Just CHandleinput- Halt -> Just CHalt- -- ----------------------------------------------------------------- -- Text operations- Format -> Just CFormat- Concat -> Just CConcat- Split -> Just CSplit- Chars -> Just CCharcount- CharAt -> Just CCode- ToChar -> Just CCode- -- ----------------------------------------------------------------- -- Some God-like abilities.- As -> Just CGod- RobotNamed -> Just CGod- RobotNumbered -> Just CGod- Create -> Just CGod- Surveil -> Just CGod- -- ----------------------------------------------------------------- -- arithmetic- Eq -> Just CCompare- Neq -> Just CCompare- Lt -> Just CCompare- Gt -> Just CCompare- Leq -> Just CCompare- Geq -> Just CCompare- -- ----------------------------------------------------------------- -- boolean logic- And -> Just CCond- Or -> Just CCond- Not -> Just CNegation- -- ----------------------------------------------------------------- -- exceptions- Try -> Just CTry- -- ----------------------------------------------------------------- -- type-level arithmetic- Inl -> Just CSum- Inr -> Just CSum- Case -> Just CSum- Fst -> Just CProd- Snd -> Just CProd- -- TODO: #563 pair syntax (1,2,3...) should require CProd too-- -- ----------------------------------------------------------------- -- Some additional straightforward ones, which however currently- -- cannot be used in classic mode since there is no craftable item- -- which conveys their capability. TODO: #26- Teleport -> Just CTeleport -- Some space-time machine like Tardis?- Appear -> Just CAppear -- paint?- Random -> Just CRandom -- randomness device (with bitcoins)?- -- ----------------------------------------------------------------- -- Some more constants which *ought* to have their own capability but- -- currently don't.- View -> Nothing -- TODO: #17 should require equipping an antenna- Knows -> Nothing
@@ -1,79 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Generic contexts (mappings from variables to other things, such as--- types, values, or capability sets) used throughout the codebase.-module Swarm.Language.Context where--import Control.Lens.Empty (AsEmpty (..))-import Control.Lens.Prism (prism)-import Control.Monad.Reader (MonadReader, local)-import Data.Aeson (FromJSON, ToJSON)-import Data.Data (Data)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Text (Text)-import GHC.Generics (Generic)-import Prelude hiding (lookup)---- | We use 'Text' values to represent variables.-type Var = Text---- | A context is a mapping from variable names to things.-newtype Ctx t = Ctx {unCtx :: Map Var t}- deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON)---- | The semigroup operation for contexts is /right/-biased union.-instance Semigroup (Ctx t) where- (<>) = union--instance Monoid (Ctx t) where- mempty = empty- mappend = (<>)--instance AsEmpty (Ctx t) where- _Empty = prism (const empty) isEmpty- where- isEmpty (Ctx c)- | M.null c = Right ()- | otherwise = Left (Ctx c)---- | The empty context.-empty :: Ctx t-empty = Ctx M.empty---- | A singleton context.-singleton :: Var -> t -> Ctx t-singleton x t = Ctx (M.singleton x t)---- | Look up a variable in a context.-lookup :: Var -> Ctx t -> Maybe t-lookup x (Ctx c) = M.lookup x c---- | Delete a variable from a context.-delete :: Var -> Ctx t -> Ctx t-delete x (Ctx c) = Ctx (M.delete x c)---- | Get the list of key-value associations from a context.-assocs :: Ctx t -> [(Var, t)]-assocs = M.assocs . unCtx---- | Add a key-value binding to a context (overwriting the old one if--- the key is already present).-addBinding :: Var -> t -> Ctx t -> Ctx t-addBinding x t (Ctx c) = Ctx (M.insert x t c)---- | /Right/-biased union of contexts.-union :: Ctx t -> Ctx t -> Ctx t-union (Ctx c1) (Ctx c2) = Ctx (c2 `M.union` c1)---- | Locally extend the context with an additional binding.-withBinding :: MonadReader (Ctx t) m => Var -> t -> m a -> m a-withBinding x ty = local (addBinding x ty)---- | Locally extend the context with an additional context of--- bindings.-withBindings :: MonadReader (Ctx t) m => Ctx t -> m a -> m a-withBindings ctx = local (`union` ctx)
@@ -1,116 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Types and helper functions for working with directions-module Swarm.Language.Direction (- -- * Directions- Direction (..),- AbsoluteDir (..),- RelativeDir (..),- PlanarRelativeDir (..),- directionSyntax,- isCardinal,- allDirs,-) where--import Data.Aeson.Types hiding (Key)-import Data.Char qualified as C (toLower)-import Data.Data (Data)-import Data.Hashable (Hashable)-import Data.List qualified as L (tail)-import Data.Text hiding (filter, length, map)-import Data.Text qualified as T-import GHC.Generics (Generic)-import Swarm.Util qualified as Util-import Witch.From (from)----------------------------------------------------------------- Directions----------------------------------------------------------------- | An absolute direction is one which is defined with respect to an--- external frame of reference; robots need a compass in order to--- use them.------ NOTE: These values are ordered by increasing angle according to--- the standard mathematical convention.--- That is, the right-pointing direction, East, is considered--- the "reference angle" and the order proceeds counter-clockwise.--- See https://en.wikipedia.org/wiki/Polar_coordinate_system#Conventions------ Do not alter this ordering, as there exist functions that depend on it--- (e.g. 'Swarm.Game.Location.nearestDirection' and 'Swarm.Game.Location.relativeTo').-data AbsoluteDir = DEast | DNorth | DWest | DSouth- deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded)--directionJsonModifier :: String -> String-directionJsonModifier = map C.toLower . L.tail--directionJsonOptions :: Options-directionJsonOptions =- defaultOptions- { constructorTagModifier = directionJsonModifier- }--instance FromJSON AbsoluteDir where- parseJSON = genericParseJSON directionJsonOptions--instance ToJSON AbsoluteDir where- toJSON = genericToJSON directionJsonOptions--cardinalDirectionKeyOptions :: JSONKeyOptions-cardinalDirectionKeyOptions =- defaultJSONKeyOptions- { keyModifier = directionJsonModifier- }--instance ToJSONKey AbsoluteDir where- toJSONKey = genericToJSONKey cardinalDirectionKeyOptions--instance FromJSONKey AbsoluteDir where- fromJSONKey = genericFromJSONKey cardinalDirectionKeyOptions---- | A relative direction is one which is defined with respect to the--- robot's frame of reference; no special capability is needed to--- use them.-data RelativeDir = DPlanar PlanarRelativeDir | DDown- deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON)---- | Caution: Do not alter this ordering, as there exist functions that depend on it--- (e.g. 'Swarm.Game.Location.nearestDirection' and 'Swarm.Game.Location.relativeTo').-data PlanarRelativeDir = DForward | DLeft | DBack | DRight- deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded)--instance FromJSON PlanarRelativeDir where- parseJSON = genericParseJSON directionJsonOptions--instance ToJSON PlanarRelativeDir where- toJSON = genericToJSON directionJsonOptions---- | The type of directions. Used /e.g./ to indicate which way a robot--- will turn.-data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir- deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON)---- | Direction name is generated from the deepest nested data constructor--- e.g. 'DLeft' becomes "left"-directionSyntax :: Direction -> Text-directionSyntax d = toLower . T.tail . from $ case d of- DAbsolute x -> show x- DRelative x -> case x of- DPlanar y -> show y- _ -> show x---- | Check if the direction is absolute (e.g. 'Swarm.Game.Location.north' or 'Swarm.Game.Location.south').-isCardinal :: Direction -> Bool-isCardinal = \case- DAbsolute _ -> True- _ -> False--allDirs :: [Direction]-allDirs = map DAbsolute Util.listEnums <> map DRelative (DDown : map DPlanar Util.listEnums)
@@ -1,56 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Term elaboration which happens after type checking.-module Swarm.Language.Elaborate where--import Control.Lens (transform, (%~), (^.))-import Swarm.Language.Syntax-import Swarm.Language.Types---- | Perform some elaboration / rewriting on a fully type-annotated--- term. This currently performs such operations as rewriting @if@--- expressions and recursive let expressions to use laziness--- appropriately. In theory it could also perform rewriting for--- overloaded constants depending on the actual type they are used--- at, but currently that sort of thing tends to make type inference--- fall over.-elaborate :: Syntax' Polytype -> Syntax' Polytype-elaborate =- -- Wrap all *free* variables in 'Force'. Free variables must be- -- referring to a previous definition, which are all wrapped in- -- 'TDelay'.- (freeVarsS %~ \s -> Syntax' (s ^. sLoc) (SApp sForce s) (s ^. sType))- -- Now do additional rewriting on all subterms.- . transform rewrite- where- rewrite :: Syntax' Polytype -> Syntax' Polytype- rewrite (Syntax' l t ty) = Syntax' l (rewriteTerm t) ty-- rewriteTerm :: Term' Polytype -> Term' Polytype- rewriteTerm = \case- -- For recursive let bindings, rewrite any occurrences of x to- -- (force x). When interpreting t1, we will put a binding (x |->- -- delay t1) in the context.- SLet True x ty t1 t2 -> SLet True x ty (wrapForce (lvVar x) t1) (wrapForce (lvVar x) t2)- -- Rewrite any recursive occurrences of x inside t1 to (force x).- -- When a TDef is encountered at runtime its body will immediately- -- be wrapped in a VDelay. However, to make this work we also need- -- to wrap all free variables in any term with 'force' --- since- -- any such variables must in fact refer to things previously- -- bound by 'def'.- SDef True x ty t1 -> SDef True x ty (wrapForce (lvVar x) t1)- -- Rewrite @f $ x@ to @f x@.- SApp (Syntax' _ (SApp (Syntax' _ (TConst AppF) _) l) _) r -> SApp l r- -- Leave any other subterms alone.- t -> t--wrapForce :: Var -> Syntax' Polytype -> Syntax' Polytype-wrapForce x = mapFreeS x (\s@(Syntax' l _ ty) -> Syntax' l (SApp sForce s) ty)---- Note, TyUnit is not the right type, but I don't want to bother--sForce :: Syntax' Polytype-sForce = Syntax' NoLoc (TConst Force) (Forall ["a"] (TyDelay (TyVar "a") :->: TyVar "a"))
@@ -1,137 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-orphans #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Parsing and pretty-printing for keys (as in, keys on a keyboard)--- and key combos.-module Swarm.Language.Key (- KeyCombo,- mkKeyCombo,- parseKeyComboFull,- parseKeyCombo,- prettyKeyCombo,- specialKeyNames,-)-where--import Data.Aeson (FromJSON, ToJSON)-import Data.Foldable (asum)-import Data.Kind qualified-import Data.List (sort, (\\))-import Data.Set (Set)-import Data.Set qualified as S-import Data.Text (Text)-import Data.Text qualified as T-import GHC.Generics hiding (from)-import Graphics.Vty.Input.Events qualified as V-import Swarm.Language.Parse-import Text.Megaparsec-import Text.Megaparsec.Char (char, string)-import Text.Megaparsec.Char.Lexer (decimal)-import Witch (from)----------------------------------------------------------------- Parsing---- | A keyboard input, represented as a key + modifiers. Invariant:--- the modifier list is always sorted.-data KeyCombo = KeyCombo V.Key [V.Modifier]- deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)--deriving instance FromJSON V.Key-deriving instance FromJSON V.Modifier-deriving instance ToJSON V.Key-deriving instance ToJSON V.Modifier---- | Smart constructor for 'KeyCombo'.-mkKeyCombo :: [V.Modifier] -> V.Key -> KeyCombo-mkKeyCombo mods k = KeyCombo k (sort mods)---- | Parse a key combo with nothing after it.-parseKeyComboFull :: Parser KeyCombo-parseKeyComboFull = parseKeyCombo <* eof---- | Parse a key combo like @\"M-C-F5\"@, @\"Down\"@, or @\"C-x\"@.-parseKeyCombo :: Parser KeyCombo-parseKeyCombo =- mkKeyCombo <$> many (try (parseModifier <* char '-')) <*> parseKey--parseModifier :: Parser V.Modifier-parseModifier =- V.MShift <$ string "S"- <|> V.MCtrl <$ string "C"- <|> V.MMeta <$ string "M"- <|> V.MAlt <$ string "A"--parseKey :: Parser V.Key-parseKey =- -- For an explanation of the 'reverse', see Note [Key names are not prefix-free]- (asum . map specialKeyParser . reverse . S.toList $ specialKeyNames)- <|> parseFunctionKey- <|> parseCharKey---- Note [Key names are not prefix-free]------ The names of special keys are not prefix-free, and in particular--- include 'Down', 'DownRight', 'DownLeft', and also 'Up', 'UpRight',--- 'UpLeft'. When we try to parse a particular name with 'string' it--- will backtrack as long as the whole string is not consumed, which--- means it's OK if key names share a common prefix, like Enter and--- Esc. However, when one key name is a prefix of another we have to--- be careful of the order in which we try parsing them, and in--- particular we must try parsing the longer one first. If we have--- 'Up' come first and then 'UpLeft', for example, given the input--- "UpLeft" the 'Up' would succeed, but then the entire parse would--- fail since there is input left over. If we simply reverse the list--- of key names (which are sorted alphabetically), it guarantees that--- longer names will come before names which are prefixes of them.--parseFunctionKey :: Parser V.Key-parseFunctionKey = V.KFun <$> try (char 'F' *> decimal)--parseCharKey :: Parser V.Key-parseCharKey = V.KChar <$> anySingle--specialKeyParser :: Text -> Parser V.Key-specialKeyParser t = read . ('K' :) . from @Text <$> string t---- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell-specialKeyNames :: Set Text-specialKeyNames = S.fromList . map T.tail $ (names' @(Rep V.Key) \\ ["KChar", "KFun"])--class Names' (f :: Data.Kind.Type -> Data.Kind.Type) where- names' :: [Text]-instance (Names' f) => Names' (M1 D t f) where- names' = names' @f-instance (Names' f, Names' g) => Names' (f :+: g) where- names' = names' @f ++ names' @g-instance (Constructor c) => Names' (C1 c f) where- names' = [from @String (conName (undefined :: C1 c f g))]----------------------------------------------------------------- Pretty-printing---- | Pretty-print a key combo, e.g. @\"C-M-F5\"@. Right inverse to--- 'parseKeyCombo'. Left inverse up to reordering of modifiers.-prettyKeyCombo :: KeyCombo -> Text-prettyKeyCombo (KeyCombo k mods) = T.append (T.concat (map prettyModifier mods)) (prettyKey k)--prettyModifier :: V.Modifier -> Text-prettyModifier m = from @String [modifierChar m, '-']- where- modifierChar = \case- V.MAlt -> 'A'- V.MCtrl -> 'C'- V.MMeta -> 'M'- V.MShift -> 'S'--prettyKey :: V.Key -> Text-prettyKey =- from @String . \case- V.KChar c -> [c]- V.KFun n -> 'F' : show n- k -> drop 1 (show k)
@@ -1,170 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Language Server Protocol (LSP) server for the Swarm language.--- See the docs/EDITORS.md to learn how to use it.-module Swarm.Language.LSP where--import Control.Lens (to, (^.))-import Control.Monad (void)-import Control.Monad.IO.Class-import Data.Maybe (fromMaybe, mapMaybe)-import Data.Text (Text)-import Data.Text.IO qualified as Text-import Language.LSP.Diagnostics-import Language.LSP.Server-import Language.LSP.Types (Hover (Hover))-import Language.LSP.Types qualified as J-import Language.LSP.Types.Lens qualified as J-import Language.LSP.VFS (VirtualFile (..), virtualFileText)-import Swarm.Language.LSP.Hover qualified as H-import Swarm.Language.LSP.VarUsage qualified as VU-import Swarm.Language.Parse-import Swarm.Language.Pipeline-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Syntax (SrcLoc (..))-import Swarm.Language.Typecheck (ContextualTypeErr (..))-import System.IO (stderr)-import Witch--lspMain :: IO ()-lspMain =- void $- runServer $- ServerDefinition- { onConfigurationChange = const $ const $ Right ()- , defaultConfig = ()- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = handlers- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options =- defaultOptions- { -- set sync options to get DidSave event, as well as Open and Close events.- textDocumentSync =- Just- ( J.TextDocumentSyncOptions- (Just True)- (Just syncKind)- (Just False)- (Just False)- (Just . J.InR . J.SaveOptions $ Just True)- )- }- }- where- -- Using SyncFull seems to handle the debounce for us.- -- The alternative is to use SyncIncremental, but then then- -- handler is called for each key-stroke.- syncKind = J.TdSyncFull--diagnosticSourcePrefix :: Text-diagnosticSourcePrefix = "swarm-lsp"--debug :: (MonadIO m) => Text -> m ()-debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg--validateSwarmCode :: J.NormalizedUri -> J.TextDocumentVersion -> Text -> LspM () ()-validateSwarmCode doc version content = do- -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")"-- -- FIXME: #1040 With this call to flushDiagnosticsBySource in place, the warnings- -- in other buffers (editor tabs) end up getting cleared when switching between- -- (focusing on) other buffers in VS Code.- -- However, getting rid of this seems to break error highlighting.- flushDiagnosticsBySource 0 (Just diagnosticSourcePrefix)-- let (parsingErrs, unusedVarWarnings) = case readTerm' content of- Right Nothing -> ([], [])- Right (Just term) -> (parsingErrors, unusedWarnings)- where- VU.Usage _ problems = VU.getUsage mempty term- unusedWarnings = mapMaybe (VU.toErrPos content) problems-- parsingErrors = case processParsedTerm' mempty mempty term of- Right _ -> []- Left e -> pure $ showTypeErrorPos content e- Left e -> (pure $ showErrorPos e, [])- -- debug $ "-> " <> from (show err)-- publishDiags $- map makeUnusedVarDiagnostic unusedVarWarnings-- -- NOTE: "publishDiags" keeps only one diagnostic at a- -- time (the most recent) so we make sure the errors are- -- issued last (after any warnings).- -- Note that it does not achieve the desired effect to simply- -- concatenate the two diagnostic lists into a single- -- publishDiagnostics function call (regardless of the order- -- of the lists).- publishDiags $- map makeParseErrorDiagnostic parsingErrs- where- publishDiags :: [J.Diagnostic] -> LspM () ()- publishDiags = publishDiagnostics 1 doc version . partitionBySource-- makeUnusedVarDiagnostic :: (J.Range, Text) -> J.Diagnostic- makeUnusedVarDiagnostic (range, msg) =- J.Diagnostic- range- (Just J.DsWarning) -- severity- Nothing -- code- (Just diagnosticSourcePrefix) -- source- msg- (Just (J.List [J.DtUnnecessary])) -- tags- Nothing -- related source code info- makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> J.Diagnostic- makeParseErrorDiagnostic ((startLine, startCol), (endLine, endCol), msg) =- J.Diagnostic- ( J.Range- (J.Position (fromIntegral startLine) (fromIntegral startCol))- (J.Position (fromIntegral endLine) (fromIntegral endCol))- )- (Just J.DsError) -- severity- Nothing -- code- (Just diagnosticSourcePrefix) -- source- msg- Nothing -- tags- (Just (J.List []))--showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text)-showTypeErrorPos code (CTE l _ te) = (minusOne start, minusOne end, msg)- where- minusOne (x, y) = (x - 1, y - 1)-- (start, end) = case l of- SrcLoc s e -> getLocRange code (s, e)- NoLoc -> ((1, 1), (65535, 65535)) -- unknown loc spans the whole document- msg = prettyText te--handlers :: Handlers (LspM ())-handlers =- mconcat- [ notificationHandler J.SInitialized $ \_not -> do- debug "Initialized"- , notificationHandler J.STextDocumentDidSave $ \msg -> do- let doc = msg ^. J.params . J.textDocument . J.uri- content = fromMaybe "?" $ msg ^. J.params . J.text- validateSwarmCode (J.toNormalizedUri doc) Nothing content- , notificationHandler J.STextDocumentDidOpen $ \msg -> do- let doc = msg ^. J.params . J.textDocument . J.uri- content = msg ^. J.params . J.textDocument . J.text- validateSwarmCode (J.toNormalizedUri doc) Nothing content- , notificationHandler J.STextDocumentDidChange $ \msg -> do- let doc = msg ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri- mdoc <- getVirtualFile doc- case mdoc of- Just vf@(VirtualFile _ version _rope) -> do- validateSwarmCode doc (Just $ fromIntegral version) (virtualFileText vf)- _ -> debug $ "No virtual file found for: " <> from (show msg)- , requestHandler J.STextDocumentHover $ \req responder -> do- let doc = req ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri- pos = req ^. J.params . J.position- mdoc <- getVirtualFile doc- let maybeHover = do- vf <- mdoc- (markdownText, maybeRange) <- H.showHoverInfo doc Nothing pos vf- return $ Hover (J.HoverContents $ J.MarkupContent J.MkMarkdown markdownText) maybeRange- responder $ Right maybeHover- ]
@@ -1,276 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Language.LSP.Hover (- showHoverInfo,-- -- * Documentation rendering- renderDoc,- treeToMarkdown,-- -- * Finding source location- narrowToPosition,-- -- * Explaining source position- explain,-) where--import Control.Applicative ((<|>))-import Control.Lens ((^.))-import Control.Monad (guard, void)-import Data.Foldable (asum)-import Data.Graph-import Data.List.NonEmpty (NonEmpty (..))-import Data.Map qualified as M-import Data.Maybe (catMaybes, fromMaybe)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.Utf16.Rope qualified as R-import Language.LSP.Types qualified as J-import Language.LSP.VFS-import Swarm.Language.Context as Ctx-import Swarm.Language.Module (Module (..))-import Swarm.Language.Parse (readTerm', unTuple)-import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm)-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Syntax-import Swarm.Language.Typecheck (inferConst)-import Swarm.Language.Types-import Swarm.Util qualified as U--withinBound :: Int -> SrcLoc -> Bool-withinBound pos (SrcLoc s e) = pos >= s && pos < e-withinBound _ NoLoc = False--ropeToLspPosition :: R.Position -> J.Position-ropeToLspPosition (R.Position l c) =- J.Position (fromIntegral l) (fromIntegral c)--lspToRopePosition :: J.Position -> R.Position-lspToRopePosition (J.Position myLine myCol) =- R.Position (fromIntegral myLine) (fromIntegral myCol)--showHoverInfo ::- J.NormalizedUri ->- J.TextDocumentVersion ->- J.Position ->- VirtualFile ->- Maybe (Text, Maybe J.Range)-showHoverInfo _ _ p vf@(VirtualFile _ _ myRope) =- case readTerm' content of- Left _ -> Nothing- Right Nothing -> Nothing- Right (Just stx) -> Just $ case processParsedTerm stx of- Left _e ->- let found@(Syntax foundSloc _) = narrowToPosition stx $ fromIntegral absolutePos- finalPos = posToRange myRope foundSloc- in (,finalPos) . treeToMarkdown 0 $ explain found- Right (ProcessedTerm modul _req _reqCtx) ->- let found@(Syntax' foundSloc _ _) = narrowToPosition (moduleAST modul) $ fromIntegral absolutePos- finalPos = posToRange myRope foundSloc- in (,finalPos) . treeToMarkdown 0 $ explain found- where- content = virtualFileText vf- absolutePos =- maybe 0 (R.length . fst) $- R.splitAtPosition (lspToRopePosition p) myRope--posToRange :: R.Rope -> SrcLoc -> Maybe J.Range-posToRange myRope foundSloc = do- (s, e) <- case foundSloc of- SrcLoc s e -> Just (s, e)- _ -> Nothing- (startRope, _) <- R.splitAt (fromIntegral s) myRope- (endRope, _) <- R.splitAt (fromIntegral e) myRope- return $- J.Range- (ropeToLspPosition $ R.lengthAsPosition startRope)- (ropeToLspPosition $ R.lengthAsPosition endRope)--descend ::- ExplainableType ty =>- -- | position- Int ->- -- | next element to inspect- Syntax' ty ->- Maybe (Syntax' ty)-descend pos s1@(Syntax' l1 _ _) = do- guard $ withinBound pos l1- return $ narrowToPosition s1 pos---- | Find the most specific term for a given--- position within the code.-narrowToPosition ::- ExplainableType ty =>- -- | parent term- Syntax' ty ->- -- | absolute offset within the file- Int ->- Syntax' ty-narrowToPosition s0@(Syntax' _ t ty) pos = fromMaybe s0 $ case t of- SLam lv _ s -> d (locVarToSyntax' lv $ getInnerType ty) <|> d s- SApp s1 s2 -> d s1 <|> d s2- SLet _ lv _ s1@(Syntax' _ _ lty) s2 -> d (locVarToSyntax' lv lty) <|> d s1 <|> d s2- SDef _ lv _ s@(Syntax' _ _ lty) -> d (locVarToSyntax' lv lty) <|> d s- SBind mlv s1@(Syntax' _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2- SPair s1 s2 -> d s1 <|> d s2- SDelay _ s -> d s- SRcd m -> asum . map d . catMaybes . M.elems $ m- SProj s1 _ -> d s1- SAnnotate s _ -> d s- SRequirements _ s -> d s- -- atoms - return their position and end recursion- TUnit -> Nothing- TConst {} -> Nothing- TDir {} -> Nothing- TInt {} -> Nothing- TText {} -> Nothing- TBool {} -> Nothing- TVar {} -> Nothing- TRequire {} -> Nothing- TRequireDevice {} -> Nothing- -- these should not show up in surface language- TRef {} -> Nothing- TRobot {} -> Nothing- TAntiInt {} -> Nothing- TAntiText {} -> Nothing- where- d = descend pos--renderDoc :: Int -> Text -> Text-renderDoc d t- | d == 0 = t- | otherwise = T.drop 2 . indent (max 0 (4 * (d - 1)) + 2) $ "* " <> t- where- indent x = T.unlines . map (T.replicate x " " <>) . T.lines--treeToMarkdown :: Int -> Tree Text -> Text-treeToMarkdown d (Node t children) =- T.unlines $ renderDoc d t : map (treeToMarkdown $ d + 1) children--class Show t => ExplainableType t where- -- | Pretty print the type.- prettyType :: t -> Text-- -- | Strip the type of its outermost layer.- --- -- This allows us to strip lambda or command type- -- and get the type of the bound variable.- getInnerType :: t -> t-- -- | Check if this type is same as the given 'Polytype'.- --- -- We use it to not print same type twice (e.g. inferred and generic).- eq :: t -> Polytype -> Bool--instance ExplainableType () where- prettyType = const "?"- getInnerType = id- eq _ _ = False--instance ExplainableType Polytype where- prettyType = prettyText- getInnerType = fmap $ \case- (l :->: _r) -> l- (TyCmd t) -> t- t -> t- eq = (==)--explain :: ExplainableType ty => Syntax' ty -> Tree Text-explain trm = case trm ^. sTerm of- TUnit -> literal "The unit value."- TConst c -> literal . constGenSig c $ briefDoc (constDoc $ constInfo c)- TDir {} -> literal "A direction literal."- TInt {} -> literal "An integer literal."- TText {} -> literal "A text literal."- TBool {} -> literal "A boolean literal."- TVar v -> pure $ typeSignature v ty ""- SRcd {} -> literal "A record literal."- SProj {} -> literal "A record projection."- -- type ascription- SAnnotate lhs typeAnn ->- Node- (typeSignature "_" typeAnn "A type ascription for")- [explain lhs]- -- special forms (function application will show for `$`, but really should be rare)- SApp {} -> explainFunction trm- TRequireDevice {} -> pure "Require a specific device to be equipped."- TRequire {} -> pure "Require a certain number of an entity."- SRequirements {} -> pure "Query the requirements of a term."- -- definition or bindings- SLet isRecursive var mTypeAnn rhs _b -> pure $ explainDefinition False isRecursive var (rhs ^. sType) mTypeAnn- SDef isRecursive var mTypeAnn rhs -> pure $ explainDefinition True isRecursive var (rhs ^. sType) mTypeAnn- SLam (LV _s v) _mType _syn ->- pure $- typeSignature v ty $- "A lambda expression binding the variable " <> U.bquote v <> "."- SBind mv rhs _cmds ->- pure $- typeSignature (maybe "__rhs" lvVar mv) (getInnerType $ rhs ^. sType) $- "A monadic bind for commands" <> maybe "." (\(LV _s v) -> ", that binds variable " <> U.bquote v <> ".") mv- -- composite types- SPair {} ->- Node- (typeSignature "_" ty "A tuple consisting of:")- (explain <$> unTuple trm)- SDelay {} ->- pure . T.unlines $- [ "Delay evaluation of a term, written `{...}`."- , ""- , "Swarm is an eager language, but in some cases (e.g. for `if` statements and recursive bindings) we need to delay evaluation."- , ""- , "The counterpart to `{...}` is `force`:"- , "```"- , "force {t} = t"- , "```"- ]- -- internal syntax that should not actually show in hover- TRef {} -> internal "A memory reference."- TAntiInt {} -> internal "An antiquoted Haskell variable name of type Integer."- TAntiText {} -> internal "An antiquoted Haskell variable name of type Text."- TRobot {} -> internal "A robot reference."- where- ty = trm ^. sType- literal = pure . typeSignature (prettyText . void $ trm ^. sTerm) ty- internal description = literal $ description <> "\n**These should never show up in surface syntax.**"- constGenSig c =- let ity = inferConst c- in if ty `eq` ity then id else typeSignature (prettyText c) ity---- | Helper function to explain function application.------ Note that 'Force' is often inserted internally, so--- if it shows up here we drop it.-explainFunction :: ExplainableType ty => Syntax' ty -> Tree Text-explainFunction s =- case unfoldApps s of- (Syntax' _ (TConst Force) _ :| [innerT]) -> explain innerT- (Syntax' _ (TConst Force) _ :| f : params) -> explainF f params- (f :| params) -> explainF f params- where- explainF f params =- Node- "Function application of:"- [ explain f- , Node- "with parameters:"- (map explain params)- ]--explainDefinition :: ExplainableType ty => Bool -> Bool -> LocVar -> ty -> Maybe Polytype -> Text-explainDefinition isDef isRecursive (LV _s var) ty maybeTypeAnnotation =- typeSignature var ty $- T.unwords- [ "A"- , (if isRecursive then "" else "non-") <> "recursive"- , if isDef then "definition" else "let"- , "expression"- , if null maybeTypeAnnotation then "without" else "with"- , "a type annotation on the variable."- ]--typeSignature :: ExplainableType ty => Var -> ty -> Text -> Text-typeSignature v typ body = T.unlines ["```", short, "```", body]- where- short = v <> ": " <> prettyType typ
@@ -1,110 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Language.LSP.VarUsage where--import Control.Monad (guard)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Map (Map)-import Data.Map qualified as M-import Data.Set (Set)-import Data.Set qualified as S-import Data.Text (Text)-import Data.Text qualified as T-import Language.LSP.Types qualified as J-import Swarm.Language.Parse qualified as P-import Swarm.Language.Syntax-import Swarm.Util qualified as U--data BindingType- = Lambda- | Let- | Bind- deriving (Eq, Show)--data VarUsage = VarUsage LocVar BindingType--type BindingSites = Map Var (NonEmpty SrcLoc)--data Usage = Usage- { usages :: Set LocVar- -- ^ Variable references- , problems :: [VarUsage]- -- ^ Variable declarations without any references- }--instance Semigroup Usage where- Usage y1 z1 <> Usage y2 z2 =- Usage- (y1 <> y2)- (z1 <> z2)--instance Monoid Usage where- mempty = Usage mempty mempty--toErrPos :: Text -> VarUsage -> Maybe (J.Range, Text)-toErrPos code (VarUsage (LV loc v) scope) = do- -- A leading underscore will suppress the unused variable warning- guard $ not $ "_" `T.isPrefixOf` v- rangePair <- case loc of- SrcLoc s e -> Just (s, e)- _ -> Nothing- let (start, end) = P.getLocRange code rangePair- ((startLine, startCol), (endLine, endCol)) = (minusOne start, minusOne end)- range =- J.Range- (J.Position (fromIntegral startLine) (fromIntegral startCol))- (J.Position (fromIntegral endLine) (fromIntegral endCol))- return (range, txt)- where- txt =- T.unwords- [ "Unused variable"- , U.quote v- , "in"- , T.pack $ show scope- , "expression"- ]- minusOne (x, y) = (x - 1, y - 1)---- | Descends the syntax tree rooted at a variable declaration,--- accumulating variable references.--- Generates a "problem" if an associated variable reference--- is not encountered in the subtree for this declaration.-checkOccurrences ::- BindingSites ->- LocVar ->- BindingType ->- [Syntax] ->- Usage-checkOccurrences bindings lv@(LV loc v) declType childSyntaxes =- Usage childUsages $ missing <> deeperMissing- where- deeperBindings = M.insertWith (<>) v (pure loc) bindings- Usage childUsages deeperMissing = mconcat $ map (getUsage deeperBindings) childSyntaxes- missing = [VarUsage lv declType | lv `S.notMember` childUsages]---- | Build up the bindings map as a function argument as--- we descend into the syntax tree.--- Aggregates unused bindings as we return from each layer.-getUsage ::- BindingSites ->- Syntax ->- Usage-getUsage bindings (Syntax _pos t) = case t of- TVar v -> Usage myUsages mempty- where- myUsages = case M.lookup v bindings of- Nothing -> mempty- Just (loc :| _) -> S.singleton $ LV loc v- SLam v _ s -> checkOccurrences bindings v Lambda [s]- SApp s1 s2 -> getUsage bindings s1 <> getUsage bindings s2- SLet _ v _ s1 s2 -> getUsage bindings s1 <> checkOccurrences bindings v Let [s2]- SPair s1 s2 -> getUsage bindings s1 <> getUsage bindings s2- SDef _ _v _ s -> getUsage bindings s- SBind maybeVar s1 s2 -> case maybeVar of- Just v -> checkOccurrences bindings v Bind [s1, s2]- Nothing -> getUsage bindings s1 <> getUsage bindings s2- SDelay _ s -> getUsage bindings s- _ -> mempty
@@ -1,47 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ A 'Module' packages together a type-annotated syntax tree along--- with a context of top-level definitions.-module Swarm.Language.Module (- -- * Modules- Module (..),- TModule,- UModule,- trivMod,-) where--import Data.Data (Data)-import Data.Yaml (FromJSON, ToJSON)-import GHC.Generics (Generic)-import Swarm.Language.Context (Ctx, empty)-import Swarm.Language.Syntax (Syntax')-import Swarm.Language.Types (Polytype, UPolytype, UType)----------------------------------------------------------------- Modules----------------------------------------------------------------- | A module generally represents the result of performing type--- inference on a top-level expression, which in particular can--- contain definitions ('Swarm.Language.Syntax.TDef'). A module--- contains the type-annotated AST of the expression itself, as well--- as the context giving the types of any defined variables.-data Module s t = Module {moduleAST :: Syntax' s, moduleCtx :: Ctx t}- deriving (Show, Eq, Functor, Data, Generic, FromJSON, ToJSON)---- | A 'TModule' is the final result of the type inference process on--- an expression: we get a polytype for the expression, and a--- context of polytypes for the defined variables.-type TModule = Module Polytype Polytype---- | A 'UModule' represents the type of an expression at some--- intermediate stage during the type inference process. We get a--- 'UType' (/not/ a 'UPolytype') for the expression, which may--- contain some free unification or type variables, as well as a--- context of 'UPolytype's for any defined variables.-type UModule = Module UType UPolytype---- | The trivial module for a given AST, with the empty context.-trivMod :: Syntax' s -> Module s t-trivMod t = Module t empty
@@ -1,585 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Parser for the Swarm language. Note, you probably don't want to--- use this directly, unless there is a good reason to parse a term--- without also type checking it; use--- 'Swarm.Language.Pipeline.processTerm' instead, which parses,--- typechecks, elaborates, and capability checks a term all at once.-module Swarm.Language.Parse (- -- * Reserved words- reservedWords,-- -- * Parsers- Parser,- parsePolytype,- parseType,- parseTerm,- binOps,- unOps,-- -- * Utility functions- runParser,- runParserTH,- readTerm,- readTerm',- showShortError,- showErrorPos,- getLocRange,- unTuple,-) where--import Control.Lens (view, (^.))-import Control.Monad (guard, join)-import Control.Monad.Combinators.Expr-import Control.Monad.Reader (- MonadReader (ask),- ReaderT (runReaderT),- )-import Data.Bifunctor-import Data.Foldable (asum)-import Data.List (foldl', nub)-import Data.List.NonEmpty qualified (head)-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe, mapMaybe)-import Data.Set qualified as S-import Data.Set.Lens (setOf)-import Data.Text (Text, index, toLower)-import Data.Text qualified as T-import Data.Void-import Swarm.Language.Syntax-import Swarm.Language.Types-import Swarm.Util (failT, findDup, squote)-import Swarm.Util.Parse (fully, fullyMaybe)-import Text.Megaparsec hiding (runParser)-import Text.Megaparsec.Char-import Text.Megaparsec.Char.Lexer qualified as L-import Text.Megaparsec.Pos qualified as Pos-import Witch---- Imports for doctests (cabal-docspec needs this)---- $setup--- >>> import qualified Data.Map.Strict as Map---- | When parsing a term using a quasiquoter (i.e. something in the--- Swarm source code that will be parsed at compile time), we want--- to allow antiquoting, i.e. writing something like $x to refer to--- an existing Haskell variable. But when parsing a term entered by--- the user at the REPL, we do not want to allow this syntax.-data Antiquoting = AllowAntiquoting | DisallowAntiquoting- deriving (Eq, Ord, Show)--type Parser = ReaderT Antiquoting (Parsec Void Text)--type ParserError = ParseErrorBundle Text Void------------------------------------------------------- Lexer---- | List of reserved words that cannot be used as variable names.-reservedWords :: [Text]-reservedWords =- map (syntax . constInfo) (filter isUserFunc allConst)- ++ map directionSyntax allDirs- ++ [ "void"- , "unit"- , "int"- , "text"- , "dir"- , "bool"- , "actor"- , "key"- , "cmd"- , "delay"- , "let"- , "def"- , "end"- , "in"- , "true"- , "false"- , "forall"- , "require"- , "requirements"- ]---- | Skip spaces and comments.-sc :: Parser ()-sc =- L.space- space1- (L.skipLineComment "//")- (L.skipBlockComment "/*" "*/")---- | In general, we follow the convention that every token parser--- assumes no leading whitespace and consumes all trailing--- whitespace. Concretely, we achieve this by wrapping every token--- parser using 'lexeme'.-lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc---- | A lexeme consisting of a literal string.-symbol :: Text -> Parser Text-symbol = L.symbol sc---- | Parse a case-insensitive reserved word, making sure it is not a--- prefix of a longer variable name, and allowing the parser to--- backtrack if it fails.-reserved :: Text -> Parser ()-reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char '_')---- | Parse an identifier, i.e. any non-reserved string containing--- alphanumeric characters and underscores and not starting with a--- number.-identifier :: Parser Var-identifier = lvVar <$> locIdentifier---- | Parse an identifier together with its source location info.-locIdentifier :: Parser LocVar-locIdentifier = uncurry LV <$> parseLocG ((lexeme . try) (p >>= check) <?> "variable name")- where- p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'')- check (into @Text -> t)- | toLower t `elem` reservedWords =- failT ["reserved word", squote t, "cannot be used as variable name"]- | otherwise = return t---- | Parse a text literal (including escape sequences) in double quotes.-textLiteral :: Parser Text-textLiteral = into <$> lexeme (char '"' >> manyTill L.charLiteral (char '"'))---- | Parse a positive integer literal token, in decimal, binary,--- octal, or hexadecimal notation. Note that negation is handled as--- a separate operator.-integer :: Parser Integer-integer =- label "integer literal" $- lexeme $ do- n <-- string "0b" *> L.binary- <|> string "0o" *> L.octal- <|> string "0x" *> L.hexadecimal- <|> L.decimal- notFollowedBy alphaNumChar- return n--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--brackets :: Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")------------------------------------------------------- Parser---- | Parse a Swarm language polytype, which starts with an optional--- quanitifation (@forall@ followed by one or more variables and a--- period) followed by a type. Note that anything accepted by--- 'parseType' is also accepted by 'parsePolytype'.-parsePolytype :: Parser Polytype-parsePolytype =- join $- quantify- <$> (fromMaybe [] <$> optional (reserved "forall" *> some identifier <* symbol "."))- <*> parseType- where- quantify :: [Var] -> Type -> Parser Polytype- quantify xs ty- -- Iplicitly quantify over free type variables if the user didn't write a forall- | null xs = return $ Forall (S.toList free) ty- -- Otherwise, require all variables to be explicitly quantified- | S.null free = return $ Forall xs ty- | otherwise =- fail $- unlines- [ " Type contains free variable(s): " ++ unwords (map from (S.toList free))- , " Try adding them to the 'forall'."- ]- where- free = tyVars ty `S.difference` S.fromList xs---- | Parse a Swarm language (mono)type.-parseType :: Parser Type-parseType = makeExprParser parseTypeAtom table- where- table =- [ [InfixR ((:*:) <$ symbol "*")]- , [InfixR ((:+:) <$ symbol "+")]- , [InfixR ((:->:) <$ symbol "->")]- ]--parseTypeAtom :: Parser Type-parseTypeAtom =- TyVoid <$ reserved "void"- <|> TyUnit <$ reserved "unit"- <|> TyVar <$> identifier- <|> TyInt <$ reserved "int"- <|> TyText <$ reserved "text"- <|> TyDir <$ reserved "dir"- <|> TyBool <$ reserved "bool"- <|> TyActor <$ reserved "actor"- <|> TyKey <$ reserved "key"- <|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)- <|> TyDelay <$> braces parseType- <|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType))- <|> parens parseType--parseRecord :: Parser a -> Parser (Map Var a)-parseRecord p = (parseBinding `sepBy` symbol ",") >>= fromListUnique- where- parseBinding = (,) <$> identifier <*> p- fromListUnique kvs = case findDup (map fst kvs) of- Nothing -> return $ Map.fromList kvs- Just x -> failT ["duplicate field name", squote x, "in record literal"]--parseDirection :: Parser Direction-parseDirection = asum (map alternative allDirs) <?> "direction constant"- where- alternative d = d <$ (reserved . directionSyntax) d---- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@)-parseConst :: Parser Const-parseConst = asum (map alternative consts) <?> "built-in user function"- where- consts = filter isUserFunc allConst- alternative c = c <$ reserved (syntax $ constInfo c)---- | Add 'SrcLoc' to a parser-parseLocG :: Parser a -> Parser (SrcLoc, a)-parseLocG pa = do- start <- getOffset- a <- pa- end <- getOffset- pure (SrcLoc start end, a)---- | Add 'SrcLoc' to a 'Term' parser-parseLoc :: Parser Term -> Parser Syntax-parseLoc pterm = uncurry Syntax <$> parseLocG pterm---- | Parse an atomic term, optionally trailed by record projections like @t.x.y.z@.--- Record projection binds more tightly than function application.-parseTermAtom :: Parser Syntax-parseTermAtom = do- s1 <- parseTermAtom2- ps <- many (symbol "." *> parseLocG identifier)- return $ foldl' (\(Syntax l1 t) (l2, x) -> Syntax (l1 <> l2) (TProj t x)) s1 ps---- | Parse an atomic term.-parseTermAtom2 :: Parser Syntax-parseTermAtom2 =- parseLoc- ( TUnit <$ symbol "()"- <|> TConst <$> parseConst- <|> TVar <$> identifier- <|> TDir <$> parseDirection- <|> TInt <$> integer- <|> TText <$> textLiteral- <|> TBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false"))- <|> reserved "require"- *> ( ( TRequireDevice- <$> (textLiteral <?> "device name in double quotes")- )- <|> ( TRequire- <$> (fromIntegral <$> integer)- <*> (textLiteral <?> "entity name in double quotes")- )- )- <|> uncurry SRequirements <$> (reserved "requirements" *> match parseTerm)- <|> SLam- <$> (symbol "\\" *> locIdentifier)- <*> optional (symbol ":" *> parseType)- <*> (symbol "." *> parseTerm)- <|> sLet- <$> (reserved "let" *> locIdentifier)- <*> optional (symbol ":" *> parsePolytype)- <*> (symbol "=" *> parseTerm)- <*> (reserved "in" *> parseTerm)- <|> sDef- <$> (reserved "def" *> locIdentifier)- <*> optional (symbol ":" *> parsePolytype)- <*> (symbol "=" *> parseTerm <* reserved "end")- <|> SRcd <$> brackets (parseRecord (optional (symbol "=" *> parseTerm)))- <|> parens (view sTerm . mkTuple <$> (parseTerm `sepBy` symbol ","))- )- -- Potential syntax for explicitly requesting memoized delay.- -- Perhaps we will not need this in the end; see the discussion at- -- https://github.com/swarm-game/swarm/issues/150 .- -- <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{{" *> symbol "}}"))- -- <|> parseLoc (SDelay MemoizedDelay <$> dbraces parseTerm)-- <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{" *> symbol "}"))- <|> parseLoc (SDelay SimpleDelay <$> braces parseTerm)- <|> parseLoc (ask >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation)--mkTuple :: [Syntax] -> Syntax-mkTuple [] = Syntax NoLoc TUnit -- should never happen-mkTuple [x] = x-mkTuple (x : xs) = let r = mkTuple xs in loc x r $ SPair x r- where- loc a b = Syntax $ (a ^. sLoc) <> (b ^. sLoc)--unTuple :: Syntax' ty -> [Syntax' ty]-unTuple = \case- Syntax' _ (SPair s1 s2) _ -> s1 : unTuple s2- s -> [s]---- | Construct an 'SLet', automatically filling in the Boolean field--- indicating whether it is recursive.-sLet :: LocVar -> Maybe Polytype -> Syntax -> Syntax -> Term-sLet x ty t1 = SLet (lvVar x `S.member` setOf freeVarsV t1) x ty t1---- | Construct an 'SDef', automatically filling in the Boolean field--- indicating whether it is recursive.-sDef :: LocVar -> Maybe Polytype -> Syntax -> Term-sDef x ty t = SDef (lvVar x `S.member` setOf freeVarsV t) x ty t--parseAntiquotation :: Parser Term-parseAntiquotation =- TAntiText <$> (lexeme . try) (symbol "$str:" *> identifier)- <|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> identifier)---- | Parse a Swarm language term.-parseTerm :: Parser Syntax-parseTerm = sepEndBy1 parseStmt (symbol ";") >>= mkBindChain--mkBindChain :: [Stmt] -> Parser Syntax-mkBindChain stmts = case last stmts of- Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Return) (TVar (lvVar x)))) stmts- BareTerm t -> return $ foldr mkBind t (init stmts)- where- mkBind (BareTerm t1) t2 = loc Nothing t1 t2 $ SBind Nothing t1 t2- mkBind (Binder x t1) t2 = loc (Just x) t1 t2 $ SBind (Just x) t1 t2- loc mx a b = Syntax $ maybe NoLoc lvSrcLoc mx <> (a ^. sLoc) <> (b ^. sLoc)--data Stmt- = BareTerm Syntax- | Binder LocVar Syntax- deriving (Show)--parseStmt :: Parser Stmt-parseStmt =- mkStmt <$> optional (try (locIdentifier <* symbol "<-")) <*> parseExpr--mkStmt :: Maybe LocVar -> Syntax -> Stmt-mkStmt Nothing = BareTerm-mkStmt (Just x) = Binder x---- | When semicolons are missing between definitions, for example:--- def a = 1 end def b = 2 end def c = 3 end--- The makeExprParser produces:--- App (App (TDef a) (TDef b)) (TDef x)--- This function fix that by converting the Apps into Binds, so that it results in:--- Bind a (Bind b (Bind c))-fixDefMissingSemis :: Syntax -> Syntax-fixDefMissingSemis term =- case nestedDefs term [] of- [] -> term- defs -> foldr1 mkBind defs- where- mkBind t1 t2 = Syntax ((t1 ^. sLoc) <> (t2 ^. sLoc)) $ SBind Nothing t1 t2- nestedDefs term' acc = case term' of- def@(Syntax _ SDef {}) -> def : acc- (Syntax _ (SApp nestedTerm def@(Syntax _ SDef {}))) -> nestedDefs nestedTerm (def : acc)- -- Otherwise returns an empty list to keep the term unchanged- _ -> []--parseExpr :: Parser Syntax-parseExpr =- parseLoc $ ascribe <$> parseExpr' <*> optional (symbol ":" *> parsePolytype)- where- ascribe :: Syntax -> Maybe Polytype -> Term- ascribe s Nothing = s ^. sTerm- ascribe s (Just ty) = SAnnotate s ty--parseExpr' :: Parser Syntax-parseExpr' = fixDefMissingSemis <$> makeExprParser parseTermAtom table- where- table = snd <$> Map.toDescList tableMap- tableMap =- Map.unionsWith- (++)- [ Map.singleton 9 [InfixL (exprLoc2 $ SApp <$ string "")]- , binOps- , unOps- ]-- -- add location for ExprParser by combining all- exprLoc2 :: Parser (Syntax -> Syntax -> Term) -> Parser (Syntax -> Syntax -> Syntax)- exprLoc2 p = do- (l, f) <- parseLocG p- pure $ \s1 s2 -> Syntax (l <> (s1 ^. sLoc) <> (s2 ^. sLoc)) $ f s1 s2---- | Precedences and parsers of binary operators.------ >>> Map.map length binOps--- fromList [(0,1),(2,1),(3,1),(4,6),(6,3),(7,2),(8,1)]-binOps :: Map.Map Int [Operator Parser Syntax]-binOps = Map.unionsWith (++) $ mapMaybe binOpToTuple allConst- where- binOpToTuple c = do- let ci = constInfo c- ConstMBinOp assoc <- pure (constMeta ci)- let assI = case assoc of- L -> InfixL- N -> InfixN- R -> InfixR- pure $- Map.singleton- (fixity ci)- [assI (mkOp c <$ operatorString (syntax ci))]---- | Precedences and parsers of unary operators (currently only 'Neg').------ >>> Map.map length unOps--- fromList [(7,1)]-unOps :: Map.Map Int [Operator Parser Syntax]-unOps = Map.unionsWith (++) $ mapMaybe unOpToTuple allConst- where- unOpToTuple c = do- let ci = constInfo c- ConstMUnOp assoc <- pure (constMeta ci)- let assI = case assoc of- P -> Prefix- S -> Postfix- pure $- Map.singleton- (fixity ci)- [assI (exprLoc1 $ SApp (noLoc $ TConst c) <$ operatorString (syntax ci))]-- -- combine location for ExprParser- exprLoc1 :: Parser (Syntax -> Term) -> Parser (Syntax -> Syntax)- exprLoc1 p = do- (l, f) <- parseLocG p- pure $ \s -> Syntax (l <> s ^. sLoc) $ f s--operatorString :: Text -> Parser Text-operatorString n = (lexeme . try) (string n <* notFollowedBy operatorSymbol)--operatorSymbol :: Parser Text-operatorSymbol = T.singleton <$> oneOf opChars- where- isOp = \case { ConstMFunc {} -> False; _ -> True } . constMeta- opChars = nub . concatMap (from . syntax) . filter isOp $ map constInfo allConst------------------------------------------------------- Utilities---- | Run a parser on some input text, returning either the result or a--- pretty-printed parse error message.-runParser :: Parser a -> Text -> Either Text a-runParser p t = first (from . errorBundlePretty) (parse (runReaderT p DisallowAntiquoting) "" t)---- | A utility for running a parser in an arbitrary 'MonadFail' (which--- is going to be the TemplateHaskell 'Language.Haskell.TH.Q' monad --- see--- "Swarm.Language.Parse.QQ"), with a specified source position.-runParserTH :: (Monad m, MonadFail m) => (String, Int, Int) -> Parser a -> String -> m a-runParserTH (file, line, col) p s =- case snd (runParser' (runReaderT (fully sc p) AllowAntiquoting) initState) of- Left err -> fail $ errorBundlePretty err- Right e -> return e- where- -- This is annoying --- megaparsec does not export its function to- -- construct an initial parser state, so we can't just use that- -- and then change the one field we need to be different (the- -- 'pstateSourcePos'). We have to copy-paste the whole thing.- initState :: State Text Void- initState =- State- { stateInput = from s- , stateOffset = 0- , statePosState =- PosState- { pstateInput = from s- , pstateOffset = 0- , pstateSourcePos = SourcePos file (mkPos line) (mkPos col)- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- , stateParseErrors = []- }---- | Parse some input 'Text' completely as a 'Term', consuming leading--- whitespace and ensuring the parsing extends all the way to the--- end of the input 'Text'. Returns either the resulting 'Term' (or--- 'Nothing' if the input was only whitespace) or a pretty-printed--- parse error message.-readTerm :: Text -> Either Text (Maybe Syntax)-readTerm = runParser (fullyMaybe sc parseTerm)---- | A lower-level `readTerm` which returns the megaparsec bundle error--- for precise error reporting.-readTerm' :: Text -> Either ParserError (Maybe Syntax)-readTerm' = parse (runReaderT (fullyMaybe sc parseTerm) DisallowAntiquoting) ""---- | A utility for converting a ParserError into a one line message:--- @<line-nr>: <error-msg>@-showShortError :: ParserError -> String-showShortError pe = show (line + 1) <> ": " <> from msg- where- ((line, _), _, msg) = showErrorPos pe---- | A utility for converting a ParseError into a range and error message.-showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text)-showErrorPos (ParseErrorBundle errs sourcePS) = (minusOne start, minusOne end, from msg)- where- -- convert megaparsec source pos to starts at 0- minusOne (x, y) = (x - 1, y - 1)-- -- get the first error position (ps) and line content (str)- err = Data.List.NonEmpty.head errs- offset = case err of- TrivialError x _ _ -> x- FancyError x _ -> x- (str, ps) = reachOffset offset sourcePS- msg = parseErrorTextPretty err-- -- extract the error starting position- start@(line, col) = getLineCol ps-- -- compute the ending position based on the word at starting position- wordlength = case break (== ' ') . drop col <$> str of- Just (word, _) -> length word + 1- _ -> 0- end = (line, col + wordlength)--getLineCol :: PosState a -> (Int, Int)-getLineCol ps = (line, col)- where- line = unPos $ sourceLine $ pstateSourcePos ps- col = unPos $ sourceColumn $ pstateSourcePos ps---- | A utility for converting a SrcLoc into a range-getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int))-getLocRange code (locStart, locEnd) = (start, end)- where- start = getLocPos locStart- end = getLocPos (dropWhiteSpace locEnd)-- -- remove trailing whitespace that got included by the lexer- dropWhiteSpace offset- | isWhiteSpace offset = dropWhiteSpace (offset - 1)- | otherwise = offset- isWhiteSpace offset =- -- Megaparsec offset needs to be (-1) to start at 0- Data.Text.index code (offset - 1) `elem` [' ', '\n', '\r', '\t']-- -- using megaparsec offset facility, compute the line/col- getLocPos offset =- let sourcePS =- PosState- { pstateInput = code- , pstateOffset = 0- , pstateSourcePos = Pos.initialPos ""- , pstateTabWidth = Pos.defaultTabWidth- , pstateLinePrefix = ""- }- (_, ps) = reachOffset offset sourcePS- in getLineCol ps
@@ -1,39 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ A quasiquoter for Swarm polytypes.-module Swarm.Language.Parse.QQ (tyQ) where--import Data.Generics-import Language.Haskell.TH qualified as TH-import Language.Haskell.TH.Quote-import Swarm.Language.Parse-import Swarm.Util (liftText)----------------------------------------------------------------- Quasiquoters----------------------------------------------------------------- | A quasiquoter for Swarm polytypes, so we can conveniently write them--- down using concrete syntax and have them parsed into abstract--- syntax at compile time. This is used, for example, in writing down--- the concrete types of constants (see "Swarm.Language.Typecheck").-tyQ :: QuasiQuoter-tyQ =- QuasiQuoter- { quoteExp = quoteTypeExp- , quotePat = error "quotePat not implemented for polytypes"- , quoteType = error "quoteType not implemented for polytypes"- , quoteDec = error "quoteDec not implemented for polytypes"- }--quoteTypeExp :: String -> TH.ExpQ-quoteTypeExp s = do- loc <- TH.location- let pos =- ( TH.loc_filename loc- , fst (TH.loc_start loc)- , snd (TH.loc_start loc)- )- parsed <- runParserTH pos parsePolytype s- dataToExpQ (fmap liftText . cast) parsed
@@ -1,94 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Some convenient functions for putting together the whole Swarm--- language processing pipeline: parsing, type checking, capability--- checking, and elaboration. If you want to simply turn some raw--- text representing a Swarm program into something useful, this is--- probably the module you want.-module Swarm.Language.Pipeline (- ProcessedTerm (..),- processTerm,- processParsedTerm,- processTerm',- processParsedTerm',- processTermEither,-) where--import Control.Lens ((^.))-import Data.Bifunctor (first)-import Data.Data (Data)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Yaml as Y-import GHC.Generics (Generic)-import Swarm.Language.Context-import Swarm.Language.Elaborate-import Swarm.Language.Module-import Swarm.Language.Parse-import Swarm.Language.Pretty-import Swarm.Language.Requirement-import Swarm.Language.Syntax-import Swarm.Language.Typecheck-import Swarm.Language.Types-import Witch (into)---- | A record containing the results of the language processing--- pipeline. Put a 'Term' in, and get one of these out. A--- 'ProcessedTerm' contains:------ * The elaborated + type-annotated term, plus the types of any--- embedded definitions ('TModule')------ * The 'Requirements' of the term------ * The requirements context for any definitions embedded in the--- term ('ReqCtx')-data ProcessedTerm = ProcessedTerm TModule Requirements ReqCtx- deriving (Data, Show, Eq, Generic)--processTermEither :: Text -> Either Text ProcessedTerm-processTermEither t = case processTerm t of- Left err -> Left $ T.unwords ["Could not parse term:", err]- Right Nothing -> Left "Term was only whitespace"- Right (Just pt) -> Right pt--instance FromJSON ProcessedTerm where- parseJSON = withText "Term" $ either (fail . into @String) return . processTermEither--instance ToJSON ProcessedTerm where- toJSON (ProcessedTerm t _ _) = String $ prettyText (moduleAST t)---- | Given a 'Text' value representing a Swarm program,------ 1. Parse it (see "Swarm.Language.Parse")--- 2. Typecheck it (see "Swarm.Language.Typecheck")--- 3. Elaborate it (see "Swarm.Language.Elaborate")--- 4. Check what capabilities it requires (see "Swarm.Language.Capability")------ Return either the end result (or @Nothing@ if the input was only--- whitespace) or a pretty-printed error message.-processTerm :: Text -> Either Text (Maybe ProcessedTerm)-processTerm = processTerm' empty empty---- | Like 'processTerm', but use a term that has already been parsed.-processParsedTerm :: Syntax -> Either ContextualTypeErr ProcessedTerm-processParsedTerm = processParsedTerm' empty empty---- | Like 'processTerm', but use explicit starting contexts.-processTerm' :: TCtx -> ReqCtx -> Text -> Either Text (Maybe ProcessedTerm)-processTerm' ctx capCtx txt = do- mt <- readTerm txt- first (prettyTypeErrText txt) $ traverse (processParsedTerm' ctx capCtx) mt---- | Like 'processTerm'', but use a term that has already been parsed.-processParsedTerm' :: TCtx -> ReqCtx -> Syntax -> Either ContextualTypeErr ProcessedTerm-processParsedTerm' ctx capCtx t = do- m <- inferTop ctx t- let (caps, capCtx') = requirements capCtx (t ^. sTerm)- return $ ProcessedTerm (elaborateModule m) caps capCtx'--elaborateModule :: TModule -> TModule-elaborateModule (Module ast ctx) = Module (elaborate ast) ctx
@@ -1,57 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ A quasiquoter for Swarm terms.-module Swarm.Language.Pipeline.QQ (tmQ) where--import Data.Generics-import Language.Haskell.TH qualified as TH-import Language.Haskell.TH.Quote-import Swarm.Language.Parse-import Swarm.Language.Pipeline-import Swarm.Language.Pretty-import Swarm.Language.Syntax-import Swarm.Language.Types (Polytype)-import Swarm.Util (failT, liftText)-import Witch (from)---- | A quasiquoter for Swarm language terms, so we can conveniently--- write them down using concrete syntax and have them parsed into--- abstract syntax at compile time. The quasiquoter actually runs--- the entire pipeline on them (parsing, typechecking, elaborating),--- so a quasiquoted Swarm program with a parse error or a type error--- will fail at Haskell compile time. This is useful for creating--- system robot programs (for example, see--- 'Swarm.Game.Step.seedProgram').-tmQ :: QuasiQuoter-tmQ =- QuasiQuoter- { quoteExp = quoteTermExp- , quotePat = error "quotePat not implemented for terms"- , quoteType = error "quoteType not implemented for terms"- , quoteDec = error "quoteDec not implemented for terms"- }--quoteTermExp :: String -> TH.ExpQ-quoteTermExp s = do- loc <- TH.location- let pos =- ( TH.loc_filename loc- , fst (TH.loc_start loc)- , snd (TH.loc_start loc)- )- parsed <- runParserTH pos parseTerm s- case processParsedTerm parsed of- Left err -> failT [prettyTypeErrText (from s) err]- Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm--antiTermExp :: Term' Polytype -> Maybe TH.ExpQ-antiTermExp (TAntiText v) =- Just $ TH.appE (TH.conE (TH.mkName "TText")) (TH.varE (TH.mkName (from v)))-antiTermExp (TAntiInt v) =- Just $ TH.appE (TH.conE (TH.mkName "TInt")) (TH.varE (TH.mkName (from v)))-antiTermExp _ = Nothing---- At the moment, only antiquotation of literal text and ints are--- supported, because that's what we need for the seedProgram. But--- we can easily add more in the future.
@@ -1,447 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Pretty-printing for the Swarm language.-module Swarm.Language.Pretty where--import Control.Lens.Combinators (pattern Empty)-import Control.Unification-import Control.Unification.IntVar-import Data.Bool (bool)-import Data.Functor.Fixedpoint (Fix, unFix)-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict qualified as M-import Data.Set (Set)-import Data.Set qualified as S-import Data.String (fromString)-import Data.Text (Text)-import Data.Text qualified as T-import Prettyprinter-import Prettyprinter.Render.String qualified as RS-import Prettyprinter.Render.Text qualified as RT-import Swarm.Language.Capability-import Swarm.Language.Context-import Swarm.Language.Parse (getLocRange)-import Swarm.Language.Syntax-import Swarm.Language.Typecheck-import Swarm.Language.Types-import Swarm.Util (showEnum, showLowT, unsnocNE)-import Witch----------------------------------------------------------------- PrettyPrec class + utilities---- | Type class for things that can be pretty-printed, given a--- precedence level of their context.-class PrettyPrec a where- prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired---- | Pretty-print a thing, with a context precedence level of zero.-ppr :: (PrettyPrec a) => a -> Doc ann-ppr = prettyPrec 0---- | Render a pretty-printed document as @Text@.-docToText :: Doc a -> Text-docToText = RT.renderStrict . layoutPretty defaultLayoutOptions---- | Pretty-print something and render it as @Text@.-prettyText :: (PrettyPrec a) => a -> Text-prettyText = docToText . ppr---- | Pretty-print something and render it as (preferably) one line @Text@.-prettyTextLine :: (PrettyPrec a) => a -> Text-prettyTextLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr---- | Render a pretty-printed document as a @String@.-docToString :: Doc a -> String-docToString = RS.renderString . layoutPretty defaultLayoutOptions---- | Pretty-print something and render it as a @String@.-prettyString :: (PrettyPrec a) => a -> String-prettyString = docToString . ppr---- | Optionally surround a document with parentheses depending on the--- @Bool@ argument and if it does not fit on line, indent the lines,--- with the parens on separate lines.-pparens :: Bool -> Doc ann -> Doc ann-pparens True = group . encloseWithIndent 2 lparen rparen-pparens False = id--encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann-encloseWithIndent i l r = nest i . enclose (l <> line') (nest (-2) $ line' <> r)---- | Surround a document with backticks.-bquote :: Doc ann -> Doc ann-bquote = group . enclose "`" "`"---- | Turn a 'Show' instance into a @Doc@, lowercasing it in the--- process.-prettyShowLow :: Show a => a -> Doc ann-prettyShowLow = pretty . showLowT------------------------------------------------------- Bullet lists--data Prec a = Prec Int a--data BulletList i = BulletList- { bulletListHeader :: forall a. Doc a- , bulletListItems :: [i]- }--instance (PrettyPrec i) => PrettyPrec (BulletList i) where- prettyPrec _ (BulletList hdr items) =- nest 2 . vcat $ hdr : map (("-" <+>) . ppr) items----------------------------------------------------------------- PrettyPrec instances for terms, types, etc.--instance PrettyPrec Text where- prettyPrec _ = pretty--instance PrettyPrec BaseTy where- prettyPrec _ BVoid = "void"- prettyPrec _ BUnit = "unit"- prettyPrec _ BInt = "int"- prettyPrec _ BDir = "dir"- prettyPrec _ BText = "text"- prettyPrec _ BBool = "bool"- prettyPrec _ BActor = "actor"- prettyPrec _ BKey = "key"--instance PrettyPrec IntVar where- prettyPrec _ = pretty . mkVarName "u"---- | We can use the 'Wildcard' value to replace unification variables--- when we don't care about them, e.g. to print out the shape of a--- type like @(_ -> _) * _@-data Wildcard = Wildcard- deriving (Eq, Ord, Show)--instance PrettyPrec Wildcard where- prettyPrec _ _ = "_"---- | Split a function type chain, so that we can pretty print--- the type parameters aligned on each line when they don't fit.-class UnchainableFun t where- unchainFun :: t -> [t]--instance UnchainableFun Type where- unchainFun (a :->: ty) = a : unchainFun ty- unchainFun ty = [ty]--instance UnchainableFun (UTerm TypeF ty) where- unchainFun (UTerm (TyFunF ty1 ty2)) = ty1 : unchainFun ty2- unchainFun ty = [ty]--instance (PrettyPrec (t (Fix t))) => PrettyPrec (Fix t) where- prettyPrec p = prettyPrec p . unFix--instance (PrettyPrec (t (UTerm t v)), PrettyPrec v) => PrettyPrec (UTerm t v) where- prettyPrec p (UTerm t) = prettyPrec p t- prettyPrec p (UVar v) = prettyPrec p v--instance ((UnchainableFun t), (PrettyPrec t)) => PrettyPrec (TypeF t) where- prettyPrec _ (TyBaseF b) = ppr b- prettyPrec _ (TyVarF v) = pretty v- prettyPrec p (TySumF ty1 ty2) =- pparens (p > 1) $- prettyPrec 2 ty1 <+> "+" <+> prettyPrec 1 ty2- prettyPrec p (TyProdF ty1 ty2) =- pparens (p > 2) $- prettyPrec 3 ty1 <+> "*" <+> prettyPrec 2 ty2- prettyPrec p (TyCmdF ty) = pparens (p > 9) $ "cmd" <+> prettyPrec 10 ty- prettyPrec _ (TyDelayF ty) = braces $ ppr ty- prettyPrec p (TyFunF ty1 ty2) =- let (iniF, lastF) = unsnocNE $ ty1 NE.:| unchainFun ty2- funs = (prettyPrec 1 <$> iniF) <> [ppr lastF]- inLine l r = l <+> "->" <+> r- multiLine l r = l <+> "->" <> hardline <> r- in pparens (p > 0) . align $- flatAlt (concatWith multiLine funs) (concatWith inLine funs)- prettyPrec _ (TyRcdF m) = brackets $ hsep (punctuate "," (map prettyBinding (M.assocs m)))--instance PrettyPrec Polytype where- prettyPrec _ (Forall [] t) = ppr t- prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t--instance PrettyPrec UPolytype where- prettyPrec _ (Forall [] t) = ppr t- prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t--instance (PrettyPrec t) => PrettyPrec (Ctx t) where- prettyPrec _ Empty = emptyDoc- prettyPrec _ (assocs -> bs) = brackets (hsep (punctuate "," (map prettyBinding bs)))--prettyBinding :: (Pretty a, PrettyPrec b) => (a, b) -> Doc ann-prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty--instance PrettyPrec Direction where- prettyPrec _ = pretty . directionSyntax--instance PrettyPrec Capability where- prettyPrec _ c = pretty $ T.toLower (from (NE.tail $ showEnum c))--instance PrettyPrec Const where- prettyPrec p c = pparens (p > fixity (constInfo c)) $ pretty . syntax . constInfo $ c--instance PrettyPrec (Syntax' ty) where- prettyPrec p = prettyPrec p . eraseS--instance PrettyPrec Term where- prettyPrec _ TUnit = "()"- prettyPrec p (TConst c) = prettyPrec p c- prettyPrec _ (TDir d) = ppr d- prettyPrec _ (TInt n) = pretty n- prettyPrec _ (TAntiInt v) = "$int:" <> pretty v- prettyPrec _ (TText s) = fromString (show s)- prettyPrec _ (TAntiText v) = "$str:" <> pretty v- prettyPrec _ (TBool b) = bool "false" "true" b- prettyPrec _ (TRobot r) = "<a" <> pretty r <> ">"- prettyPrec _ (TRef r) = "@" <> pretty r- prettyPrec p (TRequireDevice d) = pparens (p > 10) $ "require" <+> ppr @Term (TText d)- prettyPrec p (TRequire n e) = pparens (p > 10) $ "require" <+> pretty n <+> ppr @Term (TText e)- prettyPrec p (TRequirements _ e) = pparens (p > 10) $ "requirements" <+> ppr e- prettyPrec _ (TVar s) = pretty s- prettyPrec _ (TDelay _ t) = group . encloseWithIndent 2 lbrace rbrace $ ppr t- prettyPrec _ t@TPair {} = prettyTuple t- prettyPrec p t@(TLam {}) =- pparens (p > 9) $- prettyLambdas t- -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3- prettyPrec p (TApp t@(TApp (TConst c) l) r) =- let ci = constInfo c- pC = fixity ci- in case constMeta ci of- ConstMBinOp assoc ->- pparens (p > pC) $- hsep- [ prettyPrec (pC + fromEnum (assoc == R)) l- , ppr c- , prettyPrec (pC + fromEnum (assoc == L)) r- ]- _ -> prettyPrecApp p t r- prettyPrec p (TApp t1 t2) = case t1 of- TConst c ->- let ci = constInfo c- pC = fixity ci- in case constMeta ci of- ConstMUnOp P -> pparens (p > pC) $ ppr t1 <> prettyPrec (succ pC) t2- ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1- _ -> prettyPrecApp p t1 t2- _ -> prettyPrecApp p t1 t2- prettyPrec _ (TLet _ x mty t1 t2) =- sep- [ prettyDefinition "let" x mty t1 <+> "in"- , ppr t2- ]- prettyPrec _ (TDef _ x mty t1) =- sep- [ prettyDefinition "def" x mty t1- , "end"- ]- prettyPrec p (TBind Nothing t1 t2) =- pparens (p > 0) $- prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2- prettyPrec p (TBind (Just x) t1 t2) =- pparens (p > 0) $- pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2- prettyPrec _ (TRcd m) = brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m)))- prettyPrec _ (TProj t x) = prettyPrec 11 t <> "." <> pretty x- prettyPrec p (TAnnotate t pt) =- pparens (p > 0) $- prettyPrec 1 t <+> ":" <+> ppr pt--prettyEquality :: (Pretty a, PrettyPrec b) => (a, Maybe b) -> Doc ann-prettyEquality (x, Nothing) = pretty x-prettyEquality (x, Just t) = pretty x <+> "=" <+> ppr t--prettyTuple :: Term -> Doc a-prettyTuple = tupled . map ppr . unnestTuple- where- unnestTuple (TPair t1 t2) = t1 : unnestTuple t2- unnestTuple t = [t]--prettyDefinition :: Doc ann -> Var -> Maybe Polytype -> Term -> Doc ann-prettyDefinition defName x mty t1 =- nest 2 . sep $- [ flatAlt- (defHead <> group defType <+> eqAndLambdaLine)- (defHead <> group defType' <+> defEqLambdas)- , ppr defBody- ]- where- (defBody, defLambdaList) = unchainLambdas t1- defHead = defName <+> pretty x- defType = maybe "" (\ty -> ":" <+> flatAlt (line <> indent 2 (ppr ty)) (ppr ty)) mty- defType' = maybe "" (\ty -> ":" <+> ppr ty) mty- defEqLambdas = hsep ("=" : map prettyLambda defLambdaList)- eqAndLambdaLine = if null defLambdaList then "=" else line <> defEqLambdas--prettyPrecApp :: Int -> Term -> Term -> Doc a-prettyPrecApp p t1 t2 =- pparens (p > 10) $- prettyPrec 10 t1 <+> prettyPrec 11 t2--appliedTermPrec :: Term -> Int-appliedTermPrec (TApp f _) = case f of- TConst c -> fixity $ constInfo c- _ -> appliedTermPrec f-appliedTermPrec _ = 10--prettyLambdas :: Term -> Doc a-prettyLambdas t = hsep (prettyLambda <$> lms) <> softline <> ppr rest- where- (rest, lms) = unchainLambdas t--unchainLambdas :: Term -> (Term, [(Var, Maybe Type)])-unchainLambdas = \case- TLam x mty body -> ((x, mty) :) <$> unchainLambdas body- body -> (body, [])--prettyLambda :: (Pretty a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann-prettyLambda (x, mty) = "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "."----------------------------------------------------------------- Error messages---- | Format a 'ContextualTypeError' for the user and render it as--- @Text@.-prettyTypeErrText :: Text -> ContextualTypeErr -> Text-prettyTypeErrText code = docToText . prettyTypeErr code---- | Format a 'ContextualTypeError' for the user.-prettyTypeErr :: Text -> ContextualTypeErr -> Doc ann-prettyTypeErr code (CTE l tcStack te) =- vcat- [ teLoc <> ppr te- , ppr (BulletList "" tcStack)- ]- where- teLoc = case l of- SrcLoc s e -> (showLoc . fst $ getLocRange code (s, e)) <> ": "- NoLoc -> emptyDoc- showLoc (r, c) = pretty r <> ":" <> pretty c--instance PrettyPrec TypeErr where- prettyPrec _ = \case- UnifyErr ty1 ty2 ->- "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2- Mismatch Nothing (getJoin -> (ty1, ty2)) ->- "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2- Mismatch (Just t) (getJoin -> (ty1, ty2)) ->- nest 2 . vcat $- [ "Type mismatch:"- , "From context, expected" <+> pprCode t <+> "to" <+> typeDescription Expected ty1 <> ","- , "but it" <+> typeDescription Actual ty2- ]- LambdaArgMismatch (getJoin -> (ty1, ty2)) ->- "Lambda argument has type annotation" <+> pprCode ty2 <> ", but expected argument type" <+> pprCode ty1- FieldsMismatch (getJoin -> (expFs, actFs)) ->- fieldMismatchMsg expFs actFs- EscapedSkolem x ->- "Skolem variable" <+> pretty x <+> "would escape its scope"- UnboundVar x ->- "Unbound variable" <+> pretty x- Infinite x uty ->- "Infinite type:" <+> ppr x <+> "=" <+> ppr uty- DefNotTopLevel t ->- "Definitions may only be at the top level:" <+> pprCode t- CantInfer t ->- "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> pprCode t- CantInferProj t ->- "Can't infer the type of a record projection:" <+> pprCode t- UnknownProj x t ->- "Record does not have a field with name" <+> pretty x <> ":" <+> pprCode t- InvalidAtomic reason t ->- "Invalid atomic block:" <+> ppr reason <> ":" <+> pprCode t- Impredicative ->- "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ."- where- pprCode :: PrettyPrec a => a -> Doc ann- pprCode = bquote . ppr---- | Given a type and its source, construct an appropriate description--- of it to go in a type mismatch error message.-typeDescription :: Source -> UType -> Doc a-typeDescription src ty- | not (hasAnyUVars ty) =- withSource src "have" "actually has" <+> "type" <+> bquote (ppr ty)- | Just f <- isTopLevelConstructor ty =- withSource src "be" "is actually" <+> tyNounPhrase f- | otherwise =- withSource src "have" "actually has" <+> "a type like" <+> bquote (ppr (fmap (const Wildcard) ty))---- | Check whether a type contains any unification variables at all.-hasAnyUVars :: UType -> Bool-hasAnyUVars = ucata (const True) or---- | Check whether a type consists of a top-level type constructor--- immediately applied to unification variables.-isTopLevelConstructor :: UType -> Maybe (TypeF ())-isTopLevelConstructor (UTyCmd (UVar {})) = Just $ TyCmdF ()-isTopLevelConstructor (UTyDelay (UVar {})) = Just $ TyDelayF ()-isTopLevelConstructor (UTySum (UVar {}) (UVar {})) = Just $ TySumF () ()-isTopLevelConstructor (UTyProd (UVar {}) (UVar {})) = Just $ TyProdF () ()-isTopLevelConstructor (UTyFun (UVar {}) (UVar {})) = Just $ TyFunF () ()-isTopLevelConstructor _ = Nothing---- | Return an English noun phrase describing things with the given--- top-level type constructor.-tyNounPhrase :: TypeF () -> Doc a-tyNounPhrase = \case- TyBaseF b -> baseTyNounPhrase b- TyVarF {} -> "a type variable"- TyCmdF {} -> "a command"- TyDelayF {} -> "a delayed expression"- TySumF {} -> "a sum"- TyProdF {} -> "a pair"- TyFunF {} -> "a function"- TyRcdF {} -> "a record"---- | Return an English noun phrase describing things with the given--- base type.-baseTyNounPhrase :: BaseTy -> Doc a-baseTyNounPhrase = \case- BVoid -> "void"- BUnit -> "the unit value"- BInt -> "an integer"- BText -> "text"- BDir -> "a direction"- BBool -> "a boolean"- BActor -> "an actor"- BKey -> "a key"---- | Generate an appropriate message when the sets of fields in two--- record types do not match, explaining which fields are extra and--- which are missing.-fieldMismatchMsg :: Set Var -> Set Var -> Doc a-fieldMismatchMsg expFs actFs =- nest 2 . vcat $- ["Field mismatch; record literal has:"]- ++ ["- Extra field(s)" <+> prettyFieldSet extraFs | not (S.null extraFs)]- ++ ["- Missing field(s)" <+> prettyFieldSet missingFs | not (S.null missingFs)]- where- extraFs = actFs `S.difference` expFs- missingFs = expFs `S.difference` actFs- prettyFieldSet = hsep . punctuate "," . map (bquote . pretty) . S.toList--instance PrettyPrec InvalidAtomicReason where- prettyPrec _ (TooManyTicks n) = "block could take too many ticks (" <> pretty n <> ")"- prettyPrec _ AtomicDupingThing = "def, let, and lambda are not allowed"- prettyPrec _ (NonSimpleVarType _ ty) = "reference to variable with non-simple type" <+> ppr (prettyTextLine ty)- prettyPrec _ NestedAtomic = "nested atomic block"- prettyPrec _ LongConst = "commands that can take multiple ticks to execute are not allowed"--instance PrettyPrec LocatedTCFrame where- prettyPrec p (LocatedTCFrame _ f) = prettyPrec p f--instance PrettyPrec TCFrame where- prettyPrec _ (TCDef x) = "While checking the definition of" <+> pretty x- prettyPrec _ TCBindL = "While checking the left-hand side of a semicolon"- prettyPrec _ TCBindR = "While checking the right-hand side of a semicolon"
@@ -1,250 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ A requirement is something that is needed in order to successfully--- build a robot running a certain program.-module Swarm.Language.Requirement (- -- * Requirements-- -- ** The 'Requirement' type- Requirement (..),-- -- ** The 'Requirements' type and utility functions- Requirements (..),- singleton,- singletonCap,- singletonDev,- singletonInv,- insert,- ReqCtx,-- -- * Requirements analysis- requirements,-) where--import Data.Aeson (FromJSON, ToJSON)-import Data.Bifunctor (first)-import Data.Data (Data)-import Data.Hashable (Hashable)-import Data.Map (Map)-import Data.Map qualified as M-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import Data.Set qualified as S-import Data.Text (Text)-import GHC.Generics (Generic)-import Swarm.Language.Capability (Capability (..), constCaps)-import Swarm.Language.Context (Ctx)-import Swarm.Language.Context qualified as Ctx-import Swarm.Language.Syntax---- | A /requirement/ is something a robot must have when it is--- built. There are three types:--- - A robot can require a certain 'Capability', which should be fulfilled--- by equipping an appropriate device.--- - A robot can require a specific /device/, which should be equipped.--- - A robot can require some number of a specific entity in its inventory.-data Requirement- = -- | Require a specific capability. This must be fulfilled by- -- equipping an appropriate device. Requiring the same- -- capability multiple times is the same as requiring it once.- ReqCap Capability- | -- | Require a specific device to be equipped. Note that at this- -- point it is only a name, and has not been resolved to an actual- -- 'Swarm.Game.Entity.Entity'. That's because programs have to be type- and- -- capability-checked independent of an 'Swarm.Game.Entity.EntityMap'. The name- -- will be looked up at runtime, when actually executing a 'Swarm.Language.Syntax.Build'- -- or 'Swarm.Language.Syntax.Reprogram' command, and an appropriate exception thrown if- -- a device with the given name does not exist.- --- -- Requiring the same device multiple times is the same as- -- requiring it once.- ReqDev Text- | -- | Require a certain number of a specific entity to be available- -- in the inventory. The same comments apply re: resolving the- -- entity name to an actual 'Swarm.Game.Entity.Entity'.- --- -- Inventory requirements are additive, that is, say, requiring 5- -- of entity @"e"@ and later requiring 7 is the same as requiring- -- 12.- ReqInv Int Text- deriving (Eq, Ord, Show, Read, Generic, Hashable, Data, FromJSON, ToJSON)---- | It is tempting to define @Requirements = Set Requirement@, but--- that would be wrong, since two identical 'ReqInv' should have--- their counts added rather than simply being deduplicated.------ Since we will eventually need to deal with the different types of--- requirements separately, it makes sense to store them separately--- anyway.-data Requirements = Requirements- { capReqs :: Set Capability- , devReqs :: Set Text- , invReqs :: Map Text Int- }- deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)--instance Semigroup Requirements where- Requirements c1 d1 i1 <> Requirements c2 d2 i2 =- Requirements (c1 <> c2) (d1 <> d2) (M.unionWith (+) i1 i2)--instance Monoid Requirements where- mempty = Requirements S.empty S.empty M.empty---- | Create a 'Requirements' set with a single 'Requirement'.-singleton :: Requirement -> Requirements-singleton (ReqCap c) = Requirements (S.singleton c) S.empty M.empty-singleton (ReqDev d) = Requirements S.empty (S.singleton d) M.empty-singleton (ReqInv n e) = Requirements S.empty S.empty (M.singleton e n)---- | For convenience, create a 'Requirements' set with a single--- 'Capability' requirement.-singletonCap :: Capability -> Requirements-singletonCap = singleton . ReqCap---- | For convenience, create a 'Requirements' set with a single--- device requirement.-singletonDev :: Text -> Requirements-singletonDev = singleton . ReqDev---- | For convenience, create a 'Requirements' set with a single--- inventory requirement.-singletonInv :: Int -> Text -> Requirements-singletonInv n e = singleton (ReqInv n e)--insert :: Requirement -> Requirements -> Requirements-insert = (<>) . singleton---- | A requirement context records the requirements for the--- definitions bound to variables.-type ReqCtx = Ctx Requirements---- | Analyze a program to see what capabilities may be needed to--- execute it. Also return a capability context mapping from any--- variables declared via 'TDef' to the capabilities needed by--- their definitions.------ Note that this is necessarily a conservative analysis, especially--- if the program contains conditional expressions. Some--- capabilities may end up not being actually needed if certain--- commands end up not being executed. However, the analysis should--- be safe in the sense that a robot with the indicated capabilities--- will always be able to run the given program.-requirements :: ReqCtx -> Term -> (Requirements, ReqCtx)-requirements ctx tm = first (insert (ReqCap CPower)) $ case tm of- -- First, at the top level, we have to keep track of the- -- requirements for variables bound with the 'TDef' command.-- -- To make a definition requires the env capability. Note that the- -- act of MAKING the definition does not require the capabilities of- -- the body of the definition (including the possibility of the- -- recursion capability, if the definition is recursive). However,- -- we also return a map which associates the defined name to the- -- capabilities it requires.- TDef r x _ t ->- let bodyReqs = (if r then insert (ReqCap CRecursion) else id) (requirements' ctx t)- in (singletonCap CEnv, Ctx.singleton x bodyReqs)- TBind _ t1 t2 ->- -- First, see what the requirements are to execute the- -- first command. It may also define some names, so we get a- -- map of those names to their required capabilities.- let (reqs1, ctx1) = requirements ctx t1-- -- Now see what capabilities are required for the second- -- command; use an extended context since it may refer to- -- things defined in the first command.- ctx' = ctx `Ctx.union` ctx1- (reqs2, ctx2) = requirements ctx' t2- in -- Finally return the union of everything.- (reqs1 <> reqs2, ctx' `Ctx.union` ctx2)- -- Any other term can't bind variables with 'TDef', so we no longer- -- need to worry about tracking a returned context.- _ -> (requirements' ctx tm, Ctx.empty)---- | Infer the requirements to execute/evaluate a term in a--- given context, where the term is guaranteed not to contain any--- 'TDef'.------ For function application and let-expressions, we assume that the--- argument (respectively let-bound expression) is used at least--- once in the body. Doing otherwise would require a much more--- fine-grained analysis where we differentiate between the--- capabilities needed to *evaluate* versus *execute* any expression--- (since e.g. an unused let-binding would still incur the--- capabilities to *evaluate* it), which does not seem worth it at--- all.-requirements' :: ReqCtx -> Term -> Requirements-requirements' = go- where- go ctx tm = case tm of- -- Some primitive literals that don't require any special- -- capability.- TUnit -> mempty- TDir d -> if isCardinal d then singletonCap COrient else mempty- TInt _ -> mempty- TAntiInt _ -> mempty- TText _ -> mempty- TAntiText _ -> mempty- TBool _ -> mempty- -- It doesn't require any special capability to *inquire* about- -- the requirements of a term.- TRequirements _ _ -> mempty- -- Look up the capabilities required by a function/command- -- constants using 'constCaps'.- TConst c -> maybe mempty singletonCap (constCaps c)- -- Simply record device or inventory requirements.- TRequireDevice d -> singletonDev d- TRequire n e -> singletonInv n e- -- Note that a variable might not show up in the context, and- -- that's OK. In particular, only variables bound by 'TDef' go- -- in the context; variables bound by a lambda or let will not- -- be there.- TVar x -> fromMaybe mempty (Ctx.lookup x ctx)- -- A lambda expression requires the 'CLambda' capability, and- -- also all the capabilities of the body. We assume that the- -- lambda will eventually get applied, at which point it will- -- indeed require the body's capabilities (this is unnecessarily- -- conservative if the lambda is never applied, but such a- -- program could easily be rewritten without the unused- -- lambda). We also don't do anything with the argument: we- -- assume that it is used at least once within the body, and the- -- capabilities required by any argument will be picked up at- -- the application site. Again, this is overly conservative in- -- the case that the argument is unused, but in that case the- -- unused argument could be removed.- --- -- Note, however, that we do need to *delete* the argument from- -- the context, in case the context already contains a definition- -- with the same name: inside the lambda that definition will be- -- shadowed, so we do not want the name to be associated to any- -- capabilities.- TLam x _ t -> insert (ReqCap CLambda) $ go (Ctx.delete x ctx) t- -- An application simply requires the union of the capabilities- -- from the left- and right-hand sides. This assumes that the- -- argument will be used at least once by the function.- TApp t1 t2 -> go ctx t1 <> go ctx t2- -- Similarly, for a let, we assume that the let-bound expression- -- will be used at least once in the body. We delete the let-bound- -- name from the context when recursing for the same reason as- -- lambda.- TLet r x _ t1 t2 ->- (if r then insert (ReqCap CRecursion) else id) $- insert (ReqCap CEnv) $- go (Ctx.delete x ctx) t1 <> go (Ctx.delete x ctx) t2- -- We also delete the name in a TBind, if any, while recursing on- -- the RHS.- TBind mx t1 t2 -> go ctx t1 <> go (maybe id Ctx.delete mx ctx) t2- -- Everything else is straightforward.- TPair t1 t2 -> insert (ReqCap CProd) $ go ctx t1 <> go ctx t2- TDelay _ t -> go ctx t- -- This case should never happen if the term has been- -- typechecked; Def commands are only allowed at the top level,- -- so simply returning mempty is safe.- TDef {} -> mempty- TRcd m -> insert (ReqCap CRecord) $ foldMap (go ctx . expandEq) (M.assocs m)- where- expandEq (x, Nothing) = TVar x- expandEq (_, Just t) = t- TProj t _ -> insert (ReqCap CRecord) $ go ctx t- -- A type ascription doesn't change requirements- TAnnotate t _ -> go ctx t
@@ -1,1177 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Abstract syntax for terms of the Swarm programming language.-module Swarm.Language.Syntax (- -- * Directions- Direction (..),- AbsoluteDir (..),- RelativeDir (..),- PlanarRelativeDir (..),- directionSyntax,- isCardinal,- allDirs,-- -- * Constants- Const (..),- allConst,- ConstInfo (..),- ConstDoc (..),- ConstMeta (..),- MBinAssoc (..),- MUnAssoc (..),- constInfo,- arity,- isCmd,- isUserFunc,- isOperator,- isBuiltinFunction,- isTangible,- isLong,- maxSniffRange,- maxScoutRange,- maxStrideRange,- maxPathRange,-- -- * Syntax- Syntax' (..),- sLoc,- sTerm,- sType,- Syntax,- pattern Syntax,- LocVar (..),- SrcLoc (..),- noLoc,- pattern STerm,- pattern TRequirements,- pattern TPair,- pattern TLam,- pattern TApp,- pattern (:$:),- pattern TLet,- pattern TDef,- pattern TBind,- pattern TDelay,- pattern TRcd,- pattern TProj,- pattern TAnnotate,-- -- * Terms- Var,- DelayType (..),- Term' (..),- Term,- mkOp,- mkOp',- unfoldApps,-- -- * Erasure- eraseS,-- -- * Term traversal- freeVarsS,- freeVarsT,- freeVarsV,- mapFreeS,- locVarToSyntax',- asTree,- measureAstSize,-) where--import Control.Lens (Plated (..), Traversal', makeLenses, para, universe, (%~), (^.))-import Control.Monad (void)-import Data.Aeson.Types hiding (Key)-import Data.Data (Data)-import Data.Data.Lens (uniplate)-import Data.Int (Int32)-import Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty qualified as NonEmpty-import Data.Map.Strict (Map)-import Data.Set qualified as S-import Data.String (IsString (fromString))-import Data.Text hiding (filter, length, map)-import Data.Text qualified as T-import Data.Tree-import GHC.Generics (Generic)-import Swarm.Language.Direction-import Swarm.Language.Types-import Swarm.Util qualified as Util-import Witch.From (from)---- | Maximum perception distance for--- 'Chirp' and 'Sniff' commands-maxSniffRange :: Int32-maxSniffRange = 256--maxScoutRange :: Int-maxScoutRange = 64--maxStrideRange :: Int-maxStrideRange = 64--maxPathRange :: Integer-maxPathRange = 128----------------------------------------------------------------- Constants----------------------------------------------------------------- | Constants, representing various built-in functions and commands.------ IF YOU ADD A NEW CONSTANT, be sure to also update:--- 1. the 'constInfo' function (below)--- 2. the capability checker ("Swarm.Language.Capability")--- 3. the type checker ("Swarm.Language.Typecheck")--- 4. the runtime ("Swarm.Game.Step")--- 5. the emacs mode syntax highlighter (@contribs/swarm-mode.el@)------ GHC will warn you about incomplete pattern matches for the first--- four, and CI will warn you about the last, so in theory it's not--- really possible to forget. Note you do not need to update the--- parser or pretty-printer, since they are auto-generated from--- 'constInfo'.-data Const- = -- Trivial actions-- -- | Do nothing. This is different than 'Wait'- -- in that it does not take up a time step.- Noop- | -- | Wait for a number of time steps without doing anything.- Wait- | -- | Self-destruct.- Selfdestruct- | -- Basic actions-- -- | Move forward one step.- Move- | -- | Move backward one step.- Backup- | -- | Describe a path to the destination.- Path- | -- | Push an entity forward one step.- Push- | -- | Move forward multiple steps.- Stride- | -- | Turn in some direction.- Turn- | -- | Grab an item from the current location.- Grab- | -- | Harvest an item from the current location.- Harvest- | -- | Ignite a combustible item- Ignite- | -- | Try to place an item at the current location.- Place- | -- | Obtain the relative location of another robot.- Ping- | -- | Give an item to another robot at the current location.- Give- | -- | Equip a device on oneself.- Equip- | -- | Unequip an equipped device, returning to inventory.- Unequip- | -- | Make an item.- Make- | -- | Sense whether we have a certain item.- Has- | -- | Sense whether we have a certain device equipped.- Equipped- | -- | Sense how many of a certain item we have.- Count- | -- | Drill through an entity.- Drill- | -- | Use an entity with another.- Use- | -- | Construct a new robot.- Build- | -- | Deconstruct an old robot.- Salvage- | -- | Reprogram a robot that has executed it's command- -- with a new command- Reprogram- | -- | Emit a message.- Say- | -- | Listen for a message from other robots.- Listen- | -- | Emit a log message.- Log- | -- | View a certain robot.- View- | -- | Set what characters are used for display.- Appear- | -- | Create an entity out of thin air. Only- -- available in creative mode.- Create- | -- | Tell a robot to halt.- Halt- | -- Sensing / generation-- -- | Get current time- Time- | -- Detect whether a robot is within line-of-sight in a direction- Scout- | -- | Get the current x, y coordinates- Whereami- | -- | Get the x, y coordinates of a named waypoint, by index- Waypoint- | -- | Locate the closest instance of a given entity within the rectangle- -- specified by opposite corners, relative to the current location.- Detect- | -- | Count the number of a given entity within the rectangle- -- specified by opposite corners, relative to the current location.- Resonate- | -- | Count the number entities within the rectangle- -- specified by opposite corners, relative to the current location.- Density- | -- | Get the distance to the closest instance of the specified entity.- Sniff- | -- | Get the direction to the closest instance of the specified entity.- Chirp- | -- | Register a location to interrupt a `wait` upon changes- Watch- | -- | Register a (remote) location to interrupt a `wait` upon changes- Surveil- | -- | Get the current heading.- Heading- | -- | See if we can move forward or not.- Blocked- | -- | Scan a nearby cell- Scan- | -- | Upload knowledge to another robot- Upload- | -- | See if a specific entity is here.- Ishere- | -- | Check whether the current cell is empty- Isempty- | -- | Get a reference to oneself- Self- | -- | Get the robot's parent- Parent- | -- | Get a reference to the base- Base- | -- | Meet a nearby robot- Meet- | -- | Meet all nearby robots- MeetAll- | -- | Get the robot's display name- Whoami- | -- | Set the robot's display name- Setname- | -- | Get a uniformly random integer.- Random- | -- Modules-- -- | Run a program loaded from a file.- Run- | -- Language built-ins-- -- | If-expressions.- If- | -- | Left injection.- Inl- | -- | Right injection.- Inr- | -- | Case analysis on a sum type.- Case- | -- | First projection.- Fst- | -- | Second projection.- Snd- | -- | Force a delayed evaluation.- Force- | -- | Return for the cmd monad.- Return- | -- | Try/catch block- Try- | -- | Undefined- Undefined- | -- | User error- Fail- | -- Arithmetic unary operators-- -- | Logical negation.- Not- | -- | Arithmetic negation.- Neg- | -- Comparison operators-- -- | Logical equality comparison- Eq- | -- | Logical unequality comparison- Neq- | -- | Logical lesser-then comparison- Lt- | -- | Logical greater-then comparison- Gt- | -- | Logical lesser-or-equal comparison- Leq- | -- | Logical greater-or-equal comparison- Geq- | -- Arithmetic binary operators-- -- | Logical or.- Or- | -- | Logical and.- And- | -- | Arithmetic addition operator- Add- | -- | Arithmetic subtraction operator- Sub- | -- | Arithmetic multiplication operator- Mul- | -- | Arithmetic division operator- Div- | -- | Arithmetic exponentiation operator- Exp- | -- String operators-- -- | Turn an arbitrary value into a string- Format- | -- | Concatenate string values- Concat- | -- | Count number of characters.- Chars- | -- | Split string into two parts.- Split- | -- | Get the character at an index.- CharAt- | -- | Create a singleton text value with the given character code.- ToChar- | -- Function composition with nice operators-- -- | Application operator - helps to avoid parentheses:- -- @f $ g $ h x = f (g (h x))@- AppF- | -- Concurrency-- -- | Swap placed entity with one in inventory. Essentially atomic grab and place.- Swap- | -- | When executing @atomic c@, a robot will not be interrupted,- -- that is, no other robots will execute any commands while- -- the robot is executing @c@.- Atomic- | -- | Like @atomic@, but with no restriction on program size.- Instant- | -- Keyboard input-- -- | Create `key` values.- Key- | -- | Install a new keyboard input handler.- InstallKeyHandler- | -- God-like commands that are omnipresent or omniscient.-- -- | Teleport a robot to the given position.- Teleport- | -- | Run a command as if you were another robot.- As- | -- | Find an actor by name.- RobotNamed- | -- | Find an actor by number.- RobotNumbered- | -- | Check if an entity is known.- Knows- deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, FromJSON, ToJSON, FromJSONKey, ToJSONKey)--allConst :: [Const]-allConst = Util.listEnums--data ConstInfo = ConstInfo- { syntax :: Text- , fixity :: Int- , constMeta :: ConstMeta- , constDoc :: ConstDoc- , tangibility :: Tangibility- }- deriving (Eq, Ord, Show)--data ConstDoc = ConstDoc {briefDoc :: Text, longDoc :: Text}- deriving (Eq, Ord, Show)--instance IsString ConstDoc where- fromString = flip ConstDoc "" . T.pack--data ConstMeta- = -- | Function with arity of which some are commands- ConstMFunc Int Bool- | -- | Unary operator with fixity and associativity.- ConstMUnOp MUnAssoc- | -- | Binary operator with fixity and associativity.- ConstMBinOp MBinAssoc- deriving (Eq, Ord, Show)---- | The meta type representing associativity of binary operator.-data MBinAssoc- = -- | Left associative binary operator (see 'Control.Monad.Combinators.Expr.InfixL')- L- | -- | Non-associative binary operator (see 'Control.Monad.Combinators.Expr.InfixN')- N- | -- | Right associative binary operator (see 'Control.Monad.Combinators.Expr.InfixR')- R- deriving (Eq, Ord, Show)---- | The meta type representing associativity of unary operator.-data MUnAssoc- = -- | Prefix unary operator (see 'Control.Monad.Combinators.Expr.Prefix')- P- | -- | Suffix unary operator (see 'Control.Monad.Combinators.Expr.Suffix')- S- deriving (Eq, Ord, Show)---- | Whether a command is tangible or not. Tangible commands have--- some kind of effect on the external world; at most one tangible--- command can be executed per tick. Intangible commands are things--- like sensing commands, or commands that solely modify a robot's--- internal state; multiple intangible commands may be executed per--- tick. In addition, tangible commands can have a 'Length' (either--- 'Short' or 'Long') indicating whether they require only one, or--- possibly more than one, tick to execute. Long commands are--- excluded from @atomic@ blocks to avoid freezing the game.-data Tangibility = Intangible | Tangible Length- deriving (Eq, Ord, Show, Read)---- | For convenience, @short = Tangible Short@.-short :: Tangibility-short = Tangible Short---- | For convenience, @long = Tangible Long@.-long :: Tangibility-long = Tangible Long---- | The length of a tangible command. Short commands take exactly--- one tick to execute. Long commands may require multiple ticks.-data Length = Short | Long- deriving (Eq, Ord, Show, Read, Bounded, Enum)---- | The arity of a constant, /i.e./ how many arguments it expects.--- The runtime system will collect arguments to a constant (see--- 'Swarm.Language.Value.VCApp') until it has enough, then dispatch--- the constant's behavior.-arity :: Const -> Int-arity c = case constMeta $ constInfo c of- ConstMUnOp {} -> 1- ConstMBinOp {} -> 2- ConstMFunc a _ -> a---- | Whether a constant represents a /command/. Constants which are--- not commands are /functions/ which are interpreted as soon as--- they are evaluated. Commands, on the other hand, are not--- interpreted until being /executed/, that is, when meeting an--- 'FExec' frame. When evaluated, commands simply turn into a--- 'VCApp'.-isCmd :: Const -> Bool-isCmd c = case constMeta $ constInfo c of- ConstMFunc _ cmd -> cmd- _ -> False---- | Function constants user can call with reserved words ('wait',...).-isUserFunc :: Const -> Bool-isUserFunc c = case constMeta $ constInfo c of- ConstMFunc {} -> True- _ -> False---- | Whether the constant is an operator. Useful predicate for documentation.-isOperator :: Const -> Bool-isOperator c = case constMeta $ constInfo c of- ConstMUnOp {} -> True- ConstMBinOp {} -> True- ConstMFunc {} -> False---- | Whether the constant is a /function/ which is interpreted as soon--- as it is evaluated, but *not* including operators.------ Note: This is used for documentation purposes and complements 'isCmd'--- and 'isOperator' in that exactly one will accept a given constant.-isBuiltinFunction :: Const -> Bool-isBuiltinFunction c = case constMeta $ constInfo c of- ConstMFunc _ cmd -> not cmd- _ -> False---- | Whether the constant is a /tangible/ command, that has an--- external effect on the world. At most one tangible command may be--- executed per tick.-isTangible :: Const -> Bool-isTangible c = case tangibility (constInfo c) of- Tangible {} -> True- _ -> False---- | Whether the constant is a /long/ command, that is, a tangible--- command which could require multiple ticks to execute. Such--- commands cannot be allowed in @atomic@ blocks.-isLong :: Const -> Bool-isLong c = case tangibility (constInfo c) of- Tangible Long -> True- _ -> False---- | Information about constants used in parsing and pretty printing.------ It would be more compact to represent the information by testing--- whether the constants are in certain sets, but using pattern--- matching gives us warning if we add more constants.-constInfo :: Const -> ConstInfo-constInfo c = case c of- Wait -> command 0 long "Wait for a number of time steps."- Noop ->- command 0 Intangible . doc "Do nothing." $- [ "This is different than `Wait` in that it does not take up a time step."- , "It is useful for commands like if, which requires you to provide both branches."- , "Usually it is automatically inserted where needed, so you do not have to worry about it."- ]- Selfdestruct ->- command 0 short . doc "Self-destruct a robot." $- [ "Useful to not clutter the world."- , "This destroys the robot's inventory, so consider `salvage` as an alternative."- ]- Move -> command 0 short "Move forward one step."- Backup -> command 0 short "Move backward one step."- Path ->- command 2 short . doc "Obtain shortest path to the destination." $- [ "Optionally supply a distance limit as the first argument."- , "Supply either a location (`inL`) or an entity (`inR`) as the second argument."- , "If a path exists, returns the direction to proceed along."- ]- Push ->- command 1 short . doc "Push an entity forward one step." $- [ "Both entity and robot moves forward one step."- , "Destination must not contain an entity."- ]- Stride ->- command 1 short . doc "Move forward multiple steps." $- [ T.unwords ["Has a max range of", T.pack $ show maxStrideRange, "units."]- ]- Turn -> command 1 short "Turn in some direction."- Grab -> command 0 short "Grab an item from the current location."- Harvest ->- command 0 short . doc "Harvest an item from the current location." $- [ "Leaves behind a growing seed if the harvested item is growable."- , "Otherwise it works exactly like `grab`."- ]- Ignite ->- command 1 short . doc "Ignite a combustible item in the specified direction." $- [ "Combustion persists for a random duration and may spread."- ]- Place ->- command 1 short . doc "Place an item at the current location." $- ["The current location has to be empty for this to work."]- Ping ->- command 1 short . doc "Obtain the relative location of another robot." $- [ "The other robot must be within transmission range, accounting for antennas installed on either end, and the invoking robot must be oriented in a cardinal direction."- , "The location (x, y) is given relative to one's current orientation:"- , "Positive x value is to the right, negative left. Likewise, positive y value is forward, negative back."- ]- Give -> command 2 short "Give an item to another actor nearby."- Equip -> command 1 short "Equip a device on oneself."- Unequip -> command 1 short "Unequip an equipped device, returning to inventory."- Make -> command 1 long "Make an item using a recipe."- Has -> command 1 Intangible "Sense whether the robot has a given item in its inventory."- Equipped -> command 1 Intangible "Sense whether the robot has a specific device equipped."- Count -> command 1 Intangible "Get the count of a given item in a robot's inventory."- Reprogram ->- command 2 long . doc "Reprogram another robot with a new command." $- ["The other robot has to be nearby and idle."]- Drill ->- command 1 long . doc "Drill through an entity." $- [ "Usually you want to `drill forward` when exploring to clear out obstacles."- , "When you have found a source to drill, you can stand on it and `drill down`."- , "See what recipes with drill you have available."- , "The `drill` command may return the name of an entity added to your inventory."- ]- Use ->- command 2 long . doc "Use one entity upon another." $- [ "Which entities you can `use` with others depends on the available recipes."- , "The object being used must be a 'required' entity in a recipe."- ]- Build ->- command 1 long . doc "Construct a new robot." $- [ "You can specify a command for the robot to execute."- , "If the command requires devices they will be taken from your inventory and "- <> "equipped on the new robot."- ]- Salvage ->- command 0 long . doc "Deconstruct an old robot." $- ["Salvaging a robot will give you its inventory, equipped devices and log."]- Say ->- command 1 short . doc "Emit a message." $- [ "The message will be in the robot's log (if it has one) and the global log."- , "You can view the message that would be picked by `listen` from the global log "- <> "in the messages panel, along with your own messages and logs."- , "This means that to see messages from other robots you have to be able to listen for them, "- <> "so once you have a listening device equipped messages will be added to your log."- , "In creative mode, there is of course no such limitation."- ]- Listen ->- command 1 long . doc "Listen for a message from other actors." $- [ "It will take the first message said by the closest actor."- , "You do not need to actively listen for the message to be logged though, "- <> "that is done automatically once you have a listening device equipped."- , "Note that you can see the messages either in your logger device or the message panel."- ]- Log -> command 1 short "Log the string in the robot's logger."- View ->- command 1 short . doc "View the given actor." $- [ "This will recenter the map on the target robot and allow its inventory and logs to be inspected."- ]- Appear ->- command 1 short . doc "Set how the robot is displayed." $- [ "You can either specify one character or five (for each direction)."- , "The default is \"X^>v<\"."- ]- Create ->- command 1 short . doc "Create an item out of thin air." $- ["Only available in creative mode."]- Halt -> command 1 short "Tell a robot to halt."- Time -> command 0 Intangible "Get the current time."- Scout ->- command 1 short . doc "Detect whether a robot is within line-of-sight in a direction." $- [ "Perception is blocked by 'Opaque' entities."- , T.unwords ["Has a max range of", T.pack $ show maxScoutRange, "units."]- ]- Whereami -> command 0 Intangible "Get the current x and y coordinates."- Waypoint ->- command 2 Intangible . doc "Get the x, y coordinates of a named waypoint, by index" $- [ "Return only the waypoints in the same subworld as the calling robot."- , "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))."- , "The supplied index will be wrapped automatically, modulo the waypoint count."- , "A robot can use the count to know whether they have iterated over the full waypoint circuit."- ]- 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."]- Resonate ->- command 2 Intangible . doc "Count specific entities within a rectangle." $- [ "Applies a strong magnetic field over a given area and stimulates the matter within, generating a non-directional radio signal. A receiver tuned to the resonant frequency of the target entity is able to measure its quantity."- , "Counts the entities within the rectangle specified by opposite corners, relative to the current location."- ]- Density ->- command 1 Intangible . doc "Count all entities within a rectangle." $- [ "Applies a strong magnetic field over a given area and stimulates the matter within, generating a non-directional radio signal. A receiver measured the signal intensity to measure the quantity."- , "Counts the entities within the rectangle specified by opposite corners, relative to the current location."- ]- Sniff ->- command 1 short . doc "Determine distance to entity." $- [ "Measures concentration of airborne particles to infer distance to a certain kind of entity."- , "If none is detected, returns (-1)."- , T.unwords ["Has a max range of", T.pack $ show maxSniffRange, "units."]- ]- Chirp ->- command 1 short . doc "Determine direction to entity." $- [ "Uses a directional sonic emitter and microphone tuned to the acoustic signature of a specific entity to determine its direction."- , "Returns 'down' if out of range or the direction is indeterminate."- , "Provides absolute directions if \"compass\" equipped, relative directions otherwise."- , T.unwords ["Has a max range of", T.pack $ show maxSniffRange, "units."]- ]- Watch ->- command 1 short . doc "Interrupt `wait` upon location changes." $- [ "Place seismic detectors to alert upon entity changes to the specified location."- , "Supply a direction, as with the `scan` command, to specify a nearby location."- , "Can be invoked more than once until the next `wait` command, at which time the only the registered locations that are currently nearby are preserved."- , "Any change to entities at the monitored locations will cause the robot to wake up before the `wait` timeout."- ]- Surveil ->- command 1 short . doc "Interrupt `wait` upon (remote) location changes." $- [ "Like `watch`, but with no restriction on distance."- ]- Heading -> command 0 Intangible "Get the current heading."- Blocked -> command 0 Intangible "See if the robot can move forward."- Scan ->- command 1 Intangible . doc "Scan a nearby location for entities." $- [ "Adds the entity (not actor) to your inventory with count 0 if there is any."- , "If you can use sum types, you can also inspect the result directly."- ]- Upload -> command 1 short "Upload a robot's known entities and log to another robot."- Ishere -> command 1 Intangible "See if a specific entity is in the current location."- Isempty ->- command 0 Intangible . doc "Check if the current location is empty." $- [ "Detects whether or not the current location contains an entity."- , "Does not detect robots or other actors."- ]- Self -> function 0 "Get a reference to the current robot."- Parent -> function 0 "Get a reference to the robot's parent."- Base -> function 0 "Get a reference to the base."- Meet -> command 0 Intangible "Get a reference to a nearby actor, if there is one."- MeetAll -> command 0 long "Run a command for each nearby actor."- Whoami -> command 0 Intangible "Get the robot's display name."- Setname -> command 1 short "Set the robot's display name."- Random ->- command 1 Intangible . doc "Get a uniformly random integer." $- ["The random integer will be chosen from the range 0 to n-1, exclusive of the argument."]- Run -> command 1 long "Run a program loaded from a file."- Return -> command 1 Intangible "Make the value a result in `cmd`."- Try -> command 2 Intangible "Execute a command, catching errors."- Undefined -> function 0 "A value of any type, that is evaluated as error."- Fail -> function 1 "A value of any type, that is evaluated as error with message."- If ->- function 3 . doc "If-Then-Else function." $- ["If the bool predicate is true then evaluate the first expression, otherwise the second."]- Inl -> function 1 "Put the value into the left component of a sum type."- Inr -> function 1 "Put the value into the right component of a sum type."- Case -> function 3 "Evaluate one of the given functions on a value of sum type."- Fst -> function 1 "Get the first value of a pair."- Snd -> function 1 "Get the second value of a pair."- Force -> function 1 "Force the evaluation of a delayed value."- Not -> function 1 "Negate the boolean value."- Neg -> unaryOp "-" 7 P "Negate the given integer value."- Add -> binaryOp "+" 6 L "Add the given integer values."- And -> binaryOp "&&" 3 R "Logical and (true if both values are true)."- Or -> binaryOp "||" 2 R "Logical or (true if either value is true)."- Sub -> binaryOp "-" 6 L "Subtract the given integer values."- Mul -> binaryOp "*" 7 L "Multiply the given integer values."- Div -> binaryOp "/" 7 L "Divide the left integer value by the right one, rounding down."- Exp -> binaryOp "^" 8 R "Raise the left integer value to the power of the right one."- Eq -> binaryOp "==" 4 N "Check that the left value is equal to the right one."- Neq -> binaryOp "!=" 4 N "Check that the left value is not equal to the right one."- Lt -> binaryOp "<" 4 N "Check that the left value is lesser than the right one."- Gt -> binaryOp ">" 4 N "Check that the left value is greater than the right one."- Leq -> binaryOp "<=" 4 N "Check that the left value is lesser or equal to the right one."- Geq -> binaryOp ">=" 4 N "Check that the left value is greater or equal to the right one."- Format -> function 1 "Turn an arbitrary value into a string."- Concat -> binaryOp "++" 6 R "Concatenate the given strings."- Chars -> function 1 "Counts the number of characters in the text."- Split ->- function 2 . doc "Split the text into two at given position." $- [ "To be more specific, the following holds for all `text` values `s1` and `s2`:"- , "`(s1,s2) == split (chars s1) (s1 ++ s2)`"- , "So split can be used to undo concatenation if you know the length of the original string."- ]- CharAt ->- function 2 . doc "Get the character at a given index." $- [ "Gets the character (as an `int` representing a Unicode codepoint) at a specific index in a `text` value. Valid indices are 0 through `chars t - 1`."- , "Throws an exception if given an out-of-bounds index."- ]- ToChar ->- function 1 . doc "Create a singleton `text` value from the given character code." $- [ "That is, `chars (toChar c) == 1` and `charAt 0 (toChar c) == c`."- ]- AppF ->- binaryOp "$" 0 R . doc "Apply the function on the left to the value on the right." $- [ "This operator is useful to avoid nesting parentheses."- , "For exaple:"- , "`f $ g $ h x = f (g (h x))`"- ]- Swap ->- command 1 short . doc "Swap placed entity with one in inventory." $- [ "This essentially works like atomic grab and place."- , "Use this to avoid race conditions where more robots grab, scan or place in one location."- ]- Atomic ->- command 1 Intangible . doc "Execute a block of commands atomically." $- [ "When executing `atomic c`, a robot will not be interrupted, that is, no other robots will execute any commands while the robot is executing @c@."- ]- Instant ->- command 1 Intangible . doc "Execute a block of commands instantly." $- [ "Like `atomic`, but with no restriction on program size."- ]- Key ->- function 1 . doc "Create a key value from a text description." $- [ "The key description can optionally start with modifiers like 'C-', 'M-', 'A-', or 'S-', followed by either a regular key, or a special key name like 'Down' or 'End'"- , "For example, 'M-C-x', 'Down', or 'S-4'."- , "Which key combinations are actually possible to type may vary by keyboard and terminal program."- ]- InstallKeyHandler ->- command 2 Intangible . doc "Install a keyboard input handler." $- [ "The first argument is a hint line that will be displayed when the input handler is active."- , "The second argument is a function to handle keyboard inputs."- ]- Teleport -> command 2 short "Teleport a robot to the given location."- As -> command 2 Intangible "Hypothetically run a command as if you were another robot."- RobotNamed -> command 1 Intangible "Find an actor by name."- RobotNumbered -> command 1 Intangible "Find an actor by number."- Knows -> command 1 Intangible "Check if the robot knows about an entity."- where- doc b ls = ConstDoc b (T.unlines ls)- unaryOp s p side d =- ConstInfo- { syntax = s- , fixity = p- , constMeta = ConstMUnOp side- , constDoc = d- , tangibility = Intangible- }- binaryOp s p side d =- ConstInfo- { syntax = s- , fixity = p- , constMeta = ConstMBinOp side- , constDoc = d- , tangibility = Intangible- }- command a f d =- ConstInfo- { syntax = lowShow c- , fixity = 11- , constMeta = ConstMFunc a True- , constDoc = d- , tangibility = f- }- function a d =- ConstInfo- { syntax = lowShow c- , fixity = 11- , constMeta = ConstMFunc a False- , constDoc = d- , tangibility = Intangible- }-- lowShow :: Show a => a -> Text- lowShow a = toLower (from (show a))----------------------------------------------------------------- Basic terms----------------------------------------------------------------- | Different runtime behaviors for delayed expressions.-data DelayType- = -- | A simple delay, implemented via a (non-memoized) @VDelay@- -- holding the delayed expression.- SimpleDelay- | -- | A memoized delay, implemented by allocating a mutable cell- -- with the delayed expression and returning a reference to it.- -- When the @Maybe Var@ is @Just@, a recursive binding of the- -- variable with a reference to the delayed expression will be- -- provided while evaluating the delayed expression itself. Note- -- that there is no surface syntax for binding a variable within- -- a recursive delayed expression; the only way we can get- -- @Just@ here is when we automatically generate a delayed- -- expression while interpreting a recursive @let@ or @def@.- MemoizedDelay (Maybe Var)- deriving (Eq, Show, Data, Generic, FromJSON, ToJSON)---- | A variable with associated source location, used for variable--- binding sites. (Variable occurrences are a bare TVar which gets--- wrapped in a Syntax node, so we don't need LocVar for those.)-data LocVar = LV {lvSrcLoc :: SrcLoc, lvVar :: Var}- deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)--locVarToSyntax' :: LocVar -> ty -> Syntax' ty-locVarToSyntax' (LV s v) = Syntax' s (TVar v)---- | Terms of the Swarm language.-data Term' ty- = -- | The unit value.- TUnit- | -- | A constant.- TConst Const- | -- | A direction literal.- TDir Direction- | -- | An integer literal.- TInt Integer- | -- | An antiquoted Haskell variable name of type Integer.- TAntiInt Text- | -- | A text literal.- TText Text- | -- | An antiquoted Haskell variable name of type Text.- TAntiText Text- | -- | A Boolean literal.- TBool Bool- | -- | A robot reference. These never show up in surface syntax, but are- -- here so we can factor pretty-printing for Values through- -- pretty-printing for Terms.- TRobot Int- | -- | A memory reference. These likewise never show up in surface syntax,- -- but are here to facilitate pretty-printing.- TRef Int- | -- | Require a specific device to be installed.- TRequireDevice Text- | -- | Require a certain number of an entity.- TRequire Int Text- | -- | Primitive command to log requirements of a term. The Text- -- field is to store the unaltered original text of the term, for use- -- in displaying the log message (since once we get to execution time the- -- original term may have been elaborated, e.g. `force` may have been added- -- around some variables, etc.)- SRequirements Text (Syntax' ty)- | -- | A variable.- TVar Var- | -- | A pair.- SPair (Syntax' ty) (Syntax' ty)- | -- | A lambda expression, with or without a type annotation on the- -- binder.- SLam LocVar (Maybe Type) (Syntax' ty)- | -- | Function application.- SApp (Syntax' ty) (Syntax' ty)- | -- | A (recursive) let expression, with or without a type- -- annotation on the variable. The @Bool@ indicates whether- -- it is known to be recursive.- SLet Bool LocVar (Maybe Polytype) (Syntax' ty) (Syntax' ty)- | -- | A (recursive) definition command, which binds a variable to a- -- value in subsequent commands. The @Bool@ indicates whether the- -- definition is known to be recursive.- SDef Bool LocVar (Maybe Polytype) (Syntax' ty)- | -- | A monadic bind for commands, of the form @c1 ; c2@ or @x <- c1; c2@.- SBind (Maybe LocVar) (Syntax' ty) (Syntax' ty)- | -- | Delay evaluation of a term, written @{...}@. Swarm is an- -- eager language, but in some cases (e.g. for @if@ statements- -- and recursive bindings) we need to delay evaluation. The- -- counterpart to @{...}@ is @force@, where @force {t} = t@.- -- Note that 'Force' is just a constant, whereas 'SDelay' has to- -- be a special syntactic form so its argument can get special- -- treatment during evaluation.- SDelay DelayType (Syntax' ty)- | -- | Record literals @[x1 = e1, x2 = e2, x3, ...]@ Names @x@- -- without an accompanying definition are sugar for writing- -- @x=x@.- SRcd (Map Var (Maybe (Syntax' ty)))- | -- | Record projection @e.x@- SProj (Syntax' ty) Var- | -- | Annotate a term with a type- SAnnotate (Syntax' ty) Polytype- deriving- ( Eq- , Show- , Functor- , Foldable- , Data- , Generic- , FromJSON- , ToJSON- , -- | The Traversable instance for Term (and for Syntax') is used during- -- typechecking: during intermediate type inference, many of the type- -- annotations placed on AST nodes will have unification variables in- -- them. Once we have finished solving everything we need to do a- -- final traversal over all the types in the AST to substitute away- -- all the unification variables (and generalize, i.e. stick 'forall'- -- on, as appropriate). See the call to 'mapM' in- -- Swarm.Language.Typecheck.runInfer.- Traversable- )--type Term = Term' ()--instance Data ty => Plated (Term' ty) where- plate = uniplate----------------------------------------------------------------- Syntax: annotation on top of Terms with SrcLoc and type----------------------------------------------------------------- | The surface syntax for the language, with location and type annotations.-data Syntax' ty = Syntax'- { _sLoc :: SrcLoc- , _sTerm :: Term' ty- , _sType :: ty- }- deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON)--instance Data ty => Plated (Syntax' ty) where- plate = uniplate--data SrcLoc- = NoLoc- | -- | Half-open interval from start (inclusive) to end (exclusive)- SrcLoc Int Int- deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)--instance Semigroup SrcLoc where- NoLoc <> l = l- l <> NoLoc = l- SrcLoc s1 e1 <> SrcLoc s2 e2 = SrcLoc (min s1 s2) (max e1 e2)--instance Monoid SrcLoc where- mempty = NoLoc----------------------------------------------------------------- Pattern synonyms for untyped terms---------------------------------------------------------------type Syntax = Syntax' ()--pattern Syntax :: SrcLoc -> Term -> Syntax-pattern Syntax l t = Syntax' l t ()--{-# COMPLETE Syntax #-}--makeLenses ''Syntax'--noLoc :: Term -> Syntax-noLoc = Syntax mempty---- | Match an untyped term without its 'SrcLoc'.-pattern STerm :: Term -> Syntax-pattern STerm t <-- Syntax _ t- where- STerm t = Syntax mempty t--pattern TRequirements :: Text -> Term -> Term-pattern TRequirements x t = SRequirements x (STerm t)---- | Match a TPair without syntax-pattern TPair :: Term -> Term -> Term-pattern TPair t1 t2 = SPair (STerm t1) (STerm t2)---- | Match a TLam without syntax-pattern TLam :: Var -> Maybe Type -> Term -> Term-pattern TLam v ty t <- SLam (lvVar -> v) ty (STerm t)- where- TLam v ty t = SLam (LV NoLoc v) ty (STerm t)---- | Match a TApp without syntax-pattern TApp :: Term -> Term -> Term-pattern TApp t1 t2 = SApp (STerm t1) (STerm t2)--infixl 0 :$:---- | Convenient infix pattern synonym for application.-pattern (:$:) :: Term -> Syntax -> Term-pattern (:$:) t1 s2 = SApp (STerm t1) s2---- | Match a TLet without syntax-pattern TLet :: Bool -> Var -> Maybe Polytype -> Term -> Term -> Term-pattern TLet r v pt t1 t2 <- SLet r (lvVar -> v) pt (STerm t1) (STerm t2)- where- TLet r v pt t1 t2 = SLet r (LV NoLoc v) pt (STerm t1) (STerm t2)---- | Match a TDef without syntax-pattern TDef :: Bool -> Var -> Maybe Polytype -> Term -> Term-pattern TDef r v pt t <- SDef r (lvVar -> v) pt (STerm t)- where- TDef r v pt t = SDef r (LV NoLoc v) pt (STerm t)---- | Match a TBind without syntax-pattern TBind :: Maybe Var -> Term -> Term -> Term-pattern TBind mv t1 t2 <- SBind (fmap lvVar -> mv) (STerm t1) (STerm t2)- where- TBind mv t1 t2 = SBind (LV NoLoc <$> mv) (STerm t1) (STerm t2)---- | Match a TDelay without syntax-pattern TDelay :: DelayType -> Term -> Term-pattern TDelay m t = SDelay m (STerm t)---- | Match a TRcd without syntax-pattern TRcd :: Map Var (Maybe Term) -> Term-pattern TRcd m <- SRcd ((fmap . fmap) _sTerm -> m)- where- TRcd m = SRcd ((fmap . fmap) STerm m)--pattern TProj :: Term -> Var -> Term-pattern TProj t x = SProj (STerm t) x---- | Match a TAnnotate without syntax-pattern TAnnotate :: Term -> Polytype -> Term-pattern TAnnotate t pt = SAnnotate (STerm t) pt---- | COMPLETE pragma tells GHC using this set of pattern is complete for Term-{-# COMPLETE TUnit, TConst, TDir, TInt, TAntiInt, TText, TAntiText, TBool, TRequireDevice, TRequire, TRequirements, TVar, TPair, TLam, TApp, TLet, TDef, TBind, TDelay, TRcd, TProj, TAnnotate #-}---- | Make infix operation (e.g. @2 + 3@) a curried function--- application (@((+) 2) 3@).-mkOp :: Const -> Syntax -> Syntax -> Syntax-mkOp c s1@(Syntax l1 _) s2@(Syntax l2 _) = Syntax newLoc newTerm- where- -- The new syntax span both terms- newLoc = l1 <> l2- -- We don't assign a source location for the operator since it is- -- usually provided as-is and it is not likely to be useful.- sop = noLoc (TConst c)- newTerm = SApp (Syntax l1 $ SApp sop s1) s2---- | Make infix operation, discarding any syntax related location-mkOp' :: Const -> Term -> Term -> Term-mkOp' c t1 = TApp (TApp (TConst c) t1)---- $setup--- >>> import Control.Lens ((^.))---- | Turn function application chain into a list.------ >>> syntaxWrap f = fmap (^. sTerm) . f . Syntax NoLoc--- >>> syntaxWrap unfoldApps (mkOp' Mul (TInt 1) (TInt 2)) -- 1 * 2--- TConst Mul :| [TInt 1,TInt 2]-unfoldApps :: Syntax' ty -> NonEmpty (Syntax' ty)-unfoldApps trm = NonEmpty.reverse . flip NonEmpty.unfoldr trm $ \case- Syntax' _ (SApp s1 s2) _ -> (s2, Just s1)- s -> (s, Nothing)------------------------------------------------------- Erasure---- | Erase a 'Syntax' tree annotated with type--- information to a bare unannotated 'Term'.-eraseS :: Syntax' ty -> Term-eraseS (Syntax' _ t _) = void t----------------------------------------------------------------- Free variable traversals----------------------------------------------------------------- | Traversal over those subterms of a term which represent free--- variables. The S suffix indicates that it is a `Traversal' over--- the `Syntax` nodes (which contain type and source location info)--- containing free variables inside a larger `Syntax` value. Note--- that if you want to get the list of all `Syntax` nodes--- representing free variables, you can do so via @'toListOf'--- 'freeVarsS'@.-freeVarsS :: forall ty. Traversal' (Syntax' ty) (Syntax' ty)-freeVarsS f = go S.empty- where- -- go :: Applicative f => Set Var -> Syntax' ty -> f (Syntax' ty)- go bound s@(Syntax' l t ty) = case t of- TUnit -> pure s- TConst {} -> pure s- TDir {} -> pure s- TInt {} -> pure s- TAntiInt {} -> pure s- TText {} -> pure s- TAntiText {} -> pure s- TBool {} -> pure s- TRobot {} -> pure s- TRef {} -> pure s- TRequireDevice {} -> pure s- TRequire {} -> pure s- SRequirements x s1 -> rewrap $ SRequirements x <$> go bound s1- TVar x- | x `S.member` bound -> pure s- | otherwise -> f s- SLam x xty s1 -> rewrap $ SLam x xty <$> go (S.insert (lvVar x) bound) s1- SApp s1 s2 -> rewrap $ SApp <$> go bound s1 <*> go bound s2- SLet r x xty s1 s2 ->- let bound' = S.insert (lvVar x) bound- in rewrap $ SLet r x xty <$> go bound' s1 <*> go bound' s2- SPair s1 s2 -> rewrap $ SPair <$> go bound s1 <*> go bound s2- SDef r x xty s1 -> rewrap $ SDef r x xty <$> go (S.insert (lvVar x) bound) s1- SBind mx s1 s2 -> rewrap $ SBind mx <$> go bound s1 <*> go (maybe id (S.insert . lvVar) mx bound) s2- SDelay m s1 -> rewrap $ SDelay m <$> go bound s1- SRcd m -> rewrap $ SRcd <$> (traverse . traverse) (go bound) m- SProj s1 x -> rewrap $ SProj <$> go bound s1 <*> pure x- SAnnotate s1 pty -> rewrap $ SAnnotate <$> go bound s1 <*> pure pty- where- rewrap s' = Syntax' l <$> s' <*> pure ty---- | Like 'freeVarsS', but traverse over the 'Term's containing free--- variables. More direct if you don't need to know the types or--- source locations of the variables. Note that if you want to get--- the list of all `Term`s representing free variables, you can do so via--- @'toListOf' 'freeVarsT'@.-freeVarsT :: forall ty. Traversal' (Syntax' ty) (Term' ty)-freeVarsT = freeVarsS . sTerm---- | Traversal over the free variables of a term. Like 'freeVarsS'--- and 'freeVarsT', but traverse over the variable names--- themselves. Note that if you want to get the set of all free--- variable names, you can do so via @'Data.Set.Lens.setOf'--- 'freeVarsV'@.-freeVarsV :: Traversal' (Syntax' ty) Var-freeVarsV = freeVarsT . (\f -> \case TVar x -> TVar <$> f x; t -> pure t)---- | Apply a function to all free occurrences of a particular variable.-mapFreeS :: Var -> (Syntax' ty -> Syntax' ty) -> Syntax' ty -> Syntax' ty-mapFreeS x f = freeVarsS %~ (\t -> case t ^. sTerm of TVar y | y == x -> f t; _ -> t)---- | Transform the AST into a Tree datatype.--- Useful for pretty-printing (e.g. via "Data.Tree.drawTree").-asTree :: Data a => Syntax' a -> Tree (Syntax' a)-asTree = para Node---- | Each constructor is a assigned a value of 1, plus--- any recursive syntax it entails.-measureAstSize :: Data a => Syntax' a -> Int-measureAstSize = length . universe
@@ -1,342 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Simple Markdown AST and related utilities.------ Parametrising 'Document' with the type of--- inline code and code blocks allows us to--- inspect and validate Swarm code in descriptions.------ See 'Swarm.TUI.View.Util.drawMarkdown' for--- rendering the descriptions as brick widgets.-module Swarm.Language.Text.Markdown (- -- ** Markdown document- Document (..),- Paragraph (..),- Node (..),- TxtAttr (..),- fromTextM,- fromText,- docToText,- docToMark,-- -- ** Token stream- StreamNode' (..),- StreamNode,- ToStream (..),- toText,-- -- ** Utilities- findCode,- chunksOf,-) where--import Commonmark qualified as Mark-import Commonmark.Extensions qualified as Mark (rawAttributeSpec)-import Control.Applicative ((<|>))-import Control.Arrow (left)-import Control.Lens ((%~), (&), _head, _last)-import Data.Char (isSpace)-import Data.Functor.Identity (Identity (..))-import Data.List.Split (chop)-import Data.Maybe (catMaybes)-import Data.Set (Set)-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Data.Tuple.Extra (both, first)-import Data.Vector (toList)-import Data.Yaml-import GHC.Exts qualified (IsList (..), IsString (..))-import Swarm.Language.Parse (readTerm)-import Swarm.Language.Pipeline (processParsedTerm)-import Swarm.Language.Pretty (PrettyPrec (..), prettyText, prettyTextLine, prettyTypeErrText)-import Swarm.Language.Syntax (Syntax)---- | The top-level markdown document.-newtype Document c = Document {paragraphs :: [Paragraph c]}- deriving (Eq, Show, Functor, Foldable, Traversable)- deriving (Semigroup, Monoid) via [Paragraph c]---- | Markdown paragraphs that contain inline leaf nodes.------ The idea is that paragraphs do not have line breaks,--- and so the inline elements follow each other.--- In particular inline code can be followed by text without--- space between them (e.g. @\`logger\`s@).-newtype Paragraph c = Paragraph {nodes :: [Node c]}- deriving (Eq, Show, Functor, Foldable, Traversable)- deriving (Semigroup, Monoid) via [Node c]--mapP :: (Node c -> Node c) -> Paragraph c -> Paragraph c-mapP f (Paragraph ns) = Paragraph (map f ns)--pureP :: Node c -> Paragraph c-pureP = Paragraph . (: [])---- | Inline leaf nodes.------ The raw node is from the raw_annotation extension,--- and can be used for types/entities/invalid code.-data Node c- = LeafText (Set TxtAttr) Text- | LeafRaw String Text- | LeafCode c- | LeafCodeBlock String c- deriving (Eq, Show, Functor, Foldable, Traversable)--txt :: Text -> Node c-txt = LeafText mempty--addTextAttribute :: TxtAttr -> Node c -> Node c-addTextAttribute a (LeafText as t) = LeafText (Set.insert a as) t-addTextAttribute _ n = n--normalise :: (Eq c, Semigroup c) => Paragraph c -> Paragraph c-normalise (Paragraph a) = Paragraph $ go a- where- go = \case- [] -> []- (n : ns) -> let (n', ns') = mergeSame n ns in n' : go ns'- mergeSame = \case- l@(LeafText attrs1 t1) -> \case- (LeafText attrs2 t2 : rss) | attrs1 == attrs2 -> mergeSame (LeafText attrs1 $ t1 <> t2) rss- rs -> (l, rs)- l -> (l,)---- | Simple text attributes that make it easier to find key info in descriptions.-data TxtAttr = Strong | Emphasis- deriving (Eq, Show, Ord)--instance Mark.Rangeable (Paragraph c) where- ranged _ = id--instance Mark.HasAttributes (Paragraph c) where- addAttributes _ = id--instance Mark.Rangeable (Document c) where- ranged _ = id--instance Mark.HasAttributes (Document c) where- addAttributes _ = id--instance GHC.Exts.IsList (Document a) where- type Item (Document a) = Paragraph a- toList = paragraphs- fromList = Document--instance GHC.Exts.IsString (Document Syntax) where- fromString = fromText . T.pack--instance GHC.Exts.IsString (Paragraph Syntax) where- fromString s = case paragraphs $ GHC.Exts.fromString s of- [] -> mempty- [p] -> p- ps -> error $ "Error: expected one paragraph, but found " <> show (length ps)---- | Surround some text in double quotes if it is not empty.-quoteMaybe :: Text -> Text-quoteMaybe t = if T.null t then t else T.concat ["\"", t, "\""]--instance Mark.IsInline (Paragraph Text) where- lineBreak = pureP $ txt "\n"- softBreak = pureP $ txt " "- str = pureP . txt- entity = Mark.str- escapedChar c = Mark.str $ T.pack ['\\', c]- emph = mapP $ addTextAttribute Emphasis- strong = mapP $ addTextAttribute Strong- link dest title desc = pureP (txt "[") <> desc <> pureP (txt $ "](" <> dest <> quoteMaybe title <> ")")- image dest title desc = pureP (txt "!") <> Mark.link dest title desc- code = pureP . LeafCode- rawInline (Mark.Format f) = pureP . LeafRaw (T.unpack f)--instance Mark.IsBlock (Paragraph Text) (Document Text) where- paragraph = Document . (: [])- plain = Mark.paragraph- thematicBreak = mempty- blockQuote (Document ns) = Document $ map Mark.emph ns- codeBlock f = Mark.plain . pureP . LeafCodeBlock (T.unpack f)- heading _lvl = Mark.plain . Mark.strong- rawBlock (Mark.Format f) t = error . T.unpack $ "Unsupported raw " <> f <> " block:\n" <> t- referenceLinkDefinition = mempty- list _type _spacing = mconcat--parseSyntax :: Text -> Either String Syntax-parseSyntax t = case readTerm t of- Left e -> Left (T.unpack e)- Right Nothing -> Left "empty code"- Right (Just s) -> case processParsedTerm s of- -- Just run the typechecker etc. to make sure the term typechecks- Left e -> Left (T.unpack $ prettyTypeErrText t e)- -- ...but if it does, we just go back to using the original parsed- -- (*unelaborated*) AST. See #1496.- Right _ -> Right s--findCode :: Document Syntax -> [Syntax]-findCode = catMaybes . concatMap (map codeOnly . nodes) . paragraphs- where- codeOnly = \case- LeafCode s -> Just s- LeafCodeBlock _i s -> Just s- _l -> Nothing--instance ToJSON (Paragraph Syntax) where- toJSON = String . toText--instance ToJSON (Document Syntax) where- toJSON = String . docToMark--instance FromJSON (Document Syntax) where- parseJSON v = parseDoc v <|> parsePars v- where- parseDoc = withText "markdown" fromTextM- parsePars = withArray "markdown paragraphs" $ \a -> do- (ts :: [Text]) <- mapM parseJSON $ toList a- fromTextM $ T.intercalate "\n\n" ts---- | Parse Markdown document, but throw on invalid code.-fromText :: Text -> Document Syntax-fromText = either error id . fromTextE---- | Read Markdown document and parse&validate the code.------ If you want only the document with code as `Text`,--- use the 'fromTextPure' function.-fromTextM :: MonadFail m => Text -> m (Document Syntax)-fromTextM = either fail pure . fromTextE--fromTextE :: Text -> Either String (Document Syntax)-fromTextE t = fromTextPure t >>= traverse parseSyntax---- | Read Markdown document without code validation.-fromTextPure :: Text -> Either String (Document Text)-fromTextPure t = do- let spec = Mark.rawAttributeSpec <> Mark.defaultSyntaxSpec <> Mark.rawAttributeSpec- let runSimple = left show . runIdentity- Document tokenizedDoc <- runSimple $ Mark.commonmarkWith spec "markdown" t- return . Document $ normalise <$> tokenizedDoc------------------------------------------------------------------- DIY STREAM------------------------------------------------------------------- | Convert 'Document' to 'Text'.------ Note that this will strip some markdown, emphasis and bold marks.--- If you want to get markdown again, use 'docToMark'.-docToText :: PrettyPrec a => Document a -> Text-docToText = T.intercalate "\n\n" . map toText . paragraphs---- | This is the naive and easy way to get text from markdown document.-toText :: ToStream a => a -> Text-toText = streamToText . toStream---- | Token stream that can be easily converted to text or brick widgets.------ TODO: #574 Code blocks should probably be handled separately.-data StreamNode' t- = TextNode (Set TxtAttr) t- | CodeNode t- | RawNode String t- deriving (Eq, Show, Functor)--type StreamNode = StreamNode' Text--unStream :: StreamNode' t -> (t -> StreamNode' t, t)-unStream = \case- TextNode a t -> (TextNode a, t)- CodeNode t -> (CodeNode, t)- RawNode a t -> (RawNode a, t)---- | Get chunks of nodes not exceeding length and broken at word boundary.-chunksOf :: Int -> [StreamNode] -> [[StreamNode]]-chunksOf n = chop (splitter True n)- where- nodeLength :: StreamNode -> Int- nodeLength = T.length . snd . unStream- splitter :: Bool -> Int -> [StreamNode] -> ([StreamNode], [StreamNode])- splitter start i = \case- [] -> ([], [])- (tn : ss) ->- let l = nodeLength tn- in if l <= i- then first (tn :) $ splitter False (i - l) ss- else let (tn1, tn2) = cut start i tn in ([tn1], tn2 : ss)- cut :: Bool -> Int -> StreamNode -> (StreamNode, StreamNode)- cut start i tn =- let (con, t) = unStream tn- endSpace = T.takeWhileEnd isSpace t- startSpace = T.takeWhile isSpace t- twords = T.words t & _head %~ (startSpace <>) & _last %~ (<> endSpace)- in case splitWordsAt i twords of- ([], []) -> (con "", con "")- ([], ws@(ww : wws)) ->- both (con . T.unwords) $- -- In case single word (e.g. web link) does not fit on line we must put- -- it there and guarantee progress (otherwise chop will cycle)- if start then ([T.take i ww], T.drop i ww : wws) else ([], ws)- splitted -> both (con . T.unwords) splitted--splitWordsAt :: Int -> [Text] -> ([Text], [Text])-splitWordsAt i = \case- [] -> ([], [])- (w : ws) ->- let l = T.length w- in if l < i- then first (w :) $ splitWordsAt (i - l - 1) ws- else ([], w : ws)--streamToText :: [StreamNode] -> Text-streamToText = T.concat . map nodeToText- where- nodeToText = \case- TextNode _a t -> t- RawNode _s t -> t- CodeNode stx -> stx---- | Convert elements to one dimensional stream of nodes,--- that is easy to format and layout.------ If you want to split the stream at line length, use--- the 'chunksOf' function afterward.-class ToStream a where- toStream :: a -> [StreamNode]--instance PrettyPrec a => ToStream (Node a) where- toStream = \case- LeafText a t -> [TextNode a t]- LeafCode t -> [CodeNode (prettyTextLine t)]- LeafRaw s t -> [RawNode s t]- LeafCodeBlock _i t -> [CodeNode (prettyText t)]--instance PrettyPrec a => ToStream (Paragraph a) where- toStream = concatMap toStream . nodes------------------------------------------------------------------- Markdown-----------------------------------------------------------------nodeToMark :: PrettyPrec a => Node a -> Text-nodeToMark = \case- LeafText a t -> foldl attr t a- LeafRaw _ c -> wrap "`" c- LeafCode c -> wrap "`" (prettyText c)- LeafCodeBlock f c -> codeBlock f $ prettyText c- where- codeBlock f t = wrap "```" $ T.pack f <> "\n" <> t <> "\n"- wrap c t = c <> t <> c- attr t a = case a of- Emphasis -> wrap "_" t- Strong -> wrap "**" t--paragraphToMark :: PrettyPrec a => Paragraph a -> Text-paragraphToMark = foldMap nodeToMark . nodes---- | Convert 'Document' to markdown text.-docToMark :: PrettyPrec a => Document a -> Text-docToMark = T.intercalate "\n\n" . map paragraphToMark . paragraphs
@@ -1,1122 +0,0 @@-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- For 'Ord IntVar' instance---- |--- SPDX-License-Identifier: BSD-3-Clause------ Type inference for the Swarm language. For the approach used here,--- see--- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ .-module Swarm.Language.Typecheck (- -- * Type errors- ContextualTypeErr (..),- TypeErr (..),- InvalidAtomicReason (..),-- -- * Type provenance- Source (..),- withSource,- Join,- getJoin,-- -- * Typechecking stack- TCFrame (..),- LocatedTCFrame (..),- TCStack,- withFrame,- getTCStack,-- -- * Typechecking monad- TC,- runTC,- fresh,-- -- * Unification- substU,- unify,- HasBindings (..),- instantiate,- skolemize,- generalize,-- -- * Type inference- inferTop,- inferModule,- infer,- inferConst,- check,- isSimpleUType,-) where--import Control.Arrow ((***))-import Control.Category ((>>>))-import Control.Lens ((^.))-import Control.Lens.Indexed (itraverse)-import Control.Monad (forM_, void, when, (<=<))-import Control.Monad.Except (- ExceptT,- MonadError (catchError, throwError),- runExceptT,- )-import Control.Monad.Reader (- MonadReader (ask, local),- ReaderT (runReaderT),- mapReaderT,- )-import Control.Monad.Trans.Class (MonadTrans (lift))-import Control.Unification hiding (applyBindings, unify, (=:=))-import Control.Unification qualified as U-import Control.Unification.IntVar-import Data.Data (Data, gmapM)-import Data.Foldable (fold)-import Data.Functor.Identity-import Data.Generics (mkM)-import Data.Map (Map, (!))-import Data.Map qualified as M-import Data.Maybe-import Data.Set (Set, (\\))-import Data.Set qualified as S-import Data.Text qualified as T-import Swarm.Language.Context hiding (lookup)-import Swarm.Language.Context qualified as Ctx-import Swarm.Language.Module-import Swarm.Language.Parse.QQ (tyQ)-import Swarm.Language.Syntax-import Swarm.Language.Typecheck.Unify-import Swarm.Language.Types-import Prelude hiding (lookup)----------------------------------------------------------------- Typechecking stack---- | A frame to keep track of something we were in the middle of doing--- during typechecking.-data TCFrame where- -- | Checking a definition.- TCDef :: Var -> TCFrame- -- | Inferring the LHS of a bind.- TCBindL :: TCFrame- -- | Inferring the RHS of a bind.- TCBindR :: TCFrame- deriving (Show)---- | A typechecking stack frame together with the relevant @SrcLoc@.-data LocatedTCFrame = LocatedTCFrame SrcLoc TCFrame- deriving (Show)---- | A typechecking stack keeps track of what we are currently in the--- middle of doing during typechecking.-type TCStack = [LocatedTCFrame]----------------------------------------------------------------- Type source---- | The source of a type during typechecking.-data Source- = -- | An expected type that was "pushed down" from the context.- Expected- | -- | An actual/inferred type that was "pulled up" from a term.- Actual- deriving (Show, Eq, Ord, Bounded, Enum)---- | Generic eliminator for 'Source'. Choose the first argument if--- the 'Source' is 'Expected', and the second argument if 'Actual'.-withSource :: Source -> a -> a -> a-withSource Expected e _ = e-withSource Actual _ a = a---- | A value along with its source (expected vs actual).-type Sourced a = (Source, a)---- | A "join" where an expected thing meets an actual thing.-newtype Join a = Join (Source -> a)--instance (Show a) => Show (Join a) where- show (getJoin -> (e, a)) = "(expected: " <> show e <> ", actual: " <> show a <> ")"--type TypeJoin = Join UType---- | Create a 'Join' from an expected thing and an actual thing (in that order).-joined :: a -> a -> Join a-joined expect actual = Join (\case Expected -> expect; Actual -> actual)---- | Create a 'Join' from a 'Sourced' thing together with another--- thing (which is assumed to have the opposite 'Source').-mkJoin :: Sourced a -> a -> Join a-mkJoin (src, a1) a2 = Join $ \s -> if s == src then a1 else a2---- | Convert a 'Join' into a pair of (expected, actual).-getJoin :: Join a -> (a, a)-getJoin (Join j) = (j Expected, j Actual)----------------------------------------------------------------- Type checking monad---- | The concrete monad used for type checking. 'IntBindingT' is a--- monad transformer provided by the @unification-fd@ library which--- supports various operations such as generating fresh variables--- and unifying things.------ Note that we are sort of constrained to use a concrete monad stack by--- @unification-fd@, which has some strange types on some of its exported--- functions that actually require various monad transformers to be stacked--- in certain ways. For example, see <https://hackage.haskell.org/package/unification-fd-0.11.2/docs/Control-Unification.html#v:unify>. I don't really see a way--- to use "capability style" like we do elsewhere in the codebase.-type TC = ReaderT UCtx (ReaderT TCStack (ExceptT ContextualTypeErr (IntBindingT TypeF Identity)))---- | Push a frame on the typechecking stack within a local 'TC'--- computation.-withFrame :: SrcLoc -> TCFrame -> TC a -> TC a-withFrame l f = mapReaderT (local (LocatedTCFrame l f :))---- | Get the current typechecking stack.-getTCStack :: TC TCStack-getTCStack = lift ask------------------------------------------------------------------ | Run a top-level inference computation, returning either a--- 'TypeErr' or a fully resolved 'TModule'.-runTC :: TCtx -> TC UModule -> Either ContextualTypeErr TModule-runTC ctx =- (>>= applyBindings)- >>> ( >>=- \(Module u uctx) ->- Module- <$> mapM (checkPredicative <=< (fmap fromU . generalize)) u- <*> checkPredicative (fromU uctx)- )- >>> flip runReaderT (toU ctx)- >>> flip runReaderT []- >>> runExceptT- >>> evalIntBindingT- >>> runIdentity--checkPredicative :: Maybe a -> TC a-checkPredicative = maybe (throwError (mkRawTypeErr Impredicative)) pure---- | Look up a variable in the ambient type context, either throwing--- an 'UnboundVar' error if it is not found, or opening its--- associated 'UPolytype' with fresh unification variables via--- 'instantiate'.-lookup :: SrcLoc -> Var -> TC UType-lookup loc x = do- ctx <- getCtx- maybe (throwTypeErr loc $ UnboundVar x) instantiate (Ctx.lookup x ctx)---- | Get the current type context.-getCtx :: TC UCtx-getCtx = ask---- | Catch any thrown type errors and re-throw them with an added source--- location.-addLocToTypeErr :: SrcLoc -> TC a -> TC a-addLocToTypeErr l m =- m `catchError` \case- CTE NoLoc _ te -> throwTypeErr l te- te -> throwError te----------------------------------------------------------------- Dealing with variables: free variables, fresh variables,--- substitution---- | @unification-fd@ does not provide an 'Ord' instance for 'IntVar',--- so we must provide our own, in order to be able to store--- 'IntVar's in a 'Set'.-deriving instance Ord IntVar---- | A class for getting the free unification variables of a thing.-class FreeVars a where- freeVars :: a -> TC (Set IntVar)---- | We can get the free unification variables of a 'UType'.-instance FreeVars UType where- freeVars ut = fmap S.fromList . lift . lift . lift $ getFreeVars ut---- | We can also get the free variables of a polytype.-instance (FreeVars t) => FreeVars (Poly t) where- freeVars (Forall _ t) = freeVars t---- | We can get the free variables in any polytype in a context.-instance FreeVars UCtx where- freeVars = fmap S.unions . mapM freeVars . M.elems . unCtx---- | Generate a fresh unification variable.-fresh :: TC UType-fresh = UVar <$> (lift . lift . lift $ freeVar)---- | Perform a substitution over a 'UType', substituting for both type--- and unification variables. Note that since 'UType's do not have--- any binding constructs, we don't have to worry about ignoring--- bound variables; all variables in a 'UType' are free.-substU :: Map (Either Var IntVar) UType -> UType -> UType-substU m =- ucata- (\v -> fromMaybe (UVar v) (M.lookup (Right v) m))- ( \case- TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m)- f -> UTerm f- )---- | Make sure no skolem variables escape.-noSkolems :: SrcLoc -> UPolytype -> TC ()-noSkolems l (Forall xs upty) = do- upty' <- applyBindings upty- let tyvs =- ucata- (const S.empty)- (\case TyVarF v -> S.singleton v; f -> fold f)- upty'- ftyvs = tyvs `S.difference` S.fromList xs- forM_ (S.lookupMin ftyvs) $ throwTypeErr l . EscapedSkolem---- ~~~~ Note [lookupMin to get an arbitrary element]------ `S.lookupMin :: Set a -> Maybe a` returns the smallest--- element of a set, or Nothing if the set is empty. We don't--- actually care about getting the *smallest* type variable, but--- lookupMin is a convenient way to say "just get one element if--- any exist". The forM_ is actually over the Maybe so it represents--- doing the throwTypeErr either zero or one time, depending on--- whether lookupMin returns Nothing or Just.----------------------------------------------------------------- Lifted stuff from unification-fd--infix 4 =:=---- | @unify t expTy actTy@ ensures that the given two types are equal.--- If we know the actual term @t@ which is supposed to have these--- types, we can use it to generate better error messages.------ We first do a quick-and-dirty check to see whether we know for--- sure the types either are or cannot be equal, generating an--- equality constraint for the unifier as a last resort.-unify :: Maybe Syntax -> TypeJoin -> TC UType-unify ms j = case unifyCheck expected actual of- Apart -> throwTypeErr NoLoc $ Mismatch ms j- Equal -> return expected- MightUnify -> lift . lift $ expected U.=:= actual- where- (expected, actual) = getJoin j---- | Ensure two types are the same.-(=:=) :: UType -> UType -> TC UType-ty1 =:= ty2 = unify Nothing (joined ty1 ty2)---- | @unification-fd@ provides a function 'U.applyBindings' which--- fully substitutes for any bound unification variables (for--- efficiency, it does not perform such substitution as it goes--- along). The 'HasBindings' class is for anything which has--- unification variables in it and to which we can usefully apply--- 'U.applyBindings'.-class HasBindings u where- applyBindings :: u -> TC u--instance HasBindings UType where- applyBindings = lift . lift . U.applyBindings--instance HasBindings UPolytype where- applyBindings (Forall xs u) = Forall xs <$> applyBindings u--instance HasBindings UCtx where- applyBindings = mapM applyBindings--instance (HasBindings u, Data u) => HasBindings (Term' u) where- applyBindings = gmapM (mkM (applyBindings @(Syntax' u)))--instance (HasBindings u, Data u) => HasBindings (Syntax' u) where- applyBindings (Syntax' l t u) = Syntax' l <$> applyBindings t <*> applyBindings u--instance HasBindings UModule where- applyBindings (Module u uctx) = Module <$> applyBindings u <*> applyBindings uctx----------------------------------------------------------------- Converting between mono- and polytypes---- | To 'instantiate' a 'UPolytype', we generate a fresh unification--- variable for each variable bound by the `Forall`, and then--- substitute them throughout the type.-instantiate :: UPolytype -> TC UType-instantiate (Forall xs uty) = do- xs' <- mapM (const fresh) xs- return $ substU (M.fromList (zip (map Left xs) xs')) uty---- | 'skolemize' is like 'instantiate', except we substitute fresh--- /type/ variables instead of unification variables. Such--- variables cannot unify with anything other than themselves. This--- is used when checking something with a polytype explicitly--- specified by the user.-skolemize :: UPolytype -> TC UType-skolemize (Forall xs uty) = do- xs' <- mapM (const fresh) xs- return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty- where- toSkolem (UVar v) = UTyVar (mkVarName "s" v)- toSkolem x = error $ "Impossible! Non-UVar in skolemize.toSkolem: " ++ show x---- | 'generalize' is the opposite of 'instantiate': add a 'Forall'--- which closes over all free type and unification variables.------ Pick nice type variable names instead of reusing whatever fresh--- names happened to be used for the free variables.-generalize :: UType -> TC UPolytype-generalize uty = do- uty' <- applyBindings uty- ctx <- getCtx- tmfvs <- freeVars uty'- ctxfvs <- freeVars ctx- let fvs = S.toList $ tmfvs \\ ctxfvs- alphabet = ['a' .. 'z']- -- Infinite supply of pretty names a, b, ..., z, a0, ... z0, a1, ... z1, ...- prettyNames = map T.pack (map (: []) alphabet ++ [x : show n | n <- [0 :: Int ..], x <- alphabet])- -- Associate each free variable with a new pretty name- renaming = zip fvs prettyNames- return $- Forall- (map snd renaming)- (substU (M.fromList . map (Right *** UTyVar) $ renaming) uty')----------------------------------------------------------------- Type errors---- | A type error along with various contextual information to help us--- generate better error messages.-data ContextualTypeErr = CTE {cteSrcLoc :: SrcLoc, cteStack :: TCStack, cteTypeErr :: TypeErr}- deriving (Show)---- | Create a raw 'ContextualTypeErr' with no context information.-mkRawTypeErr :: TypeErr -> ContextualTypeErr-mkRawTypeErr = CTE NoLoc []---- | Create a 'ContextualTypeErr' value from a 'TypeErr' and context.-mkTypeErr :: SrcLoc -> TCStack -> TypeErr -> ContextualTypeErr-mkTypeErr = CTE---- | Throw a 'ContextualTypeErr'.-throwTypeErr :: SrcLoc -> TypeErr -> TC a-throwTypeErr l te = do- stk <- getTCStack- throwError $ mkTypeErr l stk te---- | Errors that can occur during type checking. The idea is that--- each error carries information that can be used to help explain--- what went wrong (though the amount of information carried can and--- should be very much improved in the future); errors can then--- separately be pretty-printed to display them to the user.-data TypeErr- = -- | An undefined variable was encountered.- UnboundVar Var- | -- | A Skolem variable escaped its local context.- EscapedSkolem Var- | -- | Occurs check failure, i.e. infinite type.- Infinite IntVar UType- | -- | Error generated by the unifier.- UnifyErr (TypeF UType) (TypeF UType)- | -- | Type mismatch caught by 'unifyCheck'. The given term was- -- expected to have a certain type, but has a different type- -- instead.- Mismatch (Maybe Syntax) TypeJoin- | -- | Lambda argument type mismatch.- LambdaArgMismatch TypeJoin- | -- | Record field mismatch, i.e. based on the expected type we- -- were expecting a record with certain fields, but found one with- -- a different field set.- FieldsMismatch (Join (Set Var))- | -- | A definition was encountered not at the top level.- DefNotTopLevel Term- | -- | A term was encountered which we cannot infer the type of.- -- This should never happen.- CantInfer Term- | -- | We can't infer the type of a record projection @r.x@ if we- -- don't concretely know the type of the record @r@.- CantInferProj Term- | -- | An attempt to project out a nonexistent field- UnknownProj Var Term- | -- | An invalid argument was provided to @atomic@.- InvalidAtomic InvalidAtomicReason Term- | -- | Some unification variables ended up in a type, probably due to- -- impredicativity. See https://github.com/swarm-game/swarm/issues/351 .- Impredicative- deriving (Show)---- | Various reasons the body of an @atomic@ might be invalid.-data InvalidAtomicReason- = -- | The argument has too many tangible commands.- TooManyTicks Int- | -- | The argument uses some way to duplicate code: @def@, @let@, or lambda.- AtomicDupingThing- | -- | The argument referred to a variable with a non-simple type.- NonSimpleVarType Var UPolytype- | -- | The argument had a nested @atomic@- NestedAtomic- | -- | The argument contained a long command- LongConst- deriving (Show)--instance Fallible TypeF IntVar ContextualTypeErr where- occursFailure v t = mkRawTypeErr (Infinite v t)- mismatchFailure t1 t2 = mkRawTypeErr (UnifyErr t1 t2)----------------------------------------------------------------- Type decomposition---- | Decompose a type that is supposed to be a delay type. Also take--- the term which is supposed to have that type, for use in error--- messages.-decomposeDelayTy :: Syntax -> Sourced UType -> TC UType-decomposeDelayTy _ (_, UTyDelay a) = return a-decomposeDelayTy t ty = do- a <- fresh- _ <- unify (Just t) (mkJoin ty (UTyDelay a))- return a---- | Decompose a type that is supposed to be a command type. Also take--- the term which is supposed to have that type, for use in error--- messages.-decomposeCmdTy :: Syntax -> Sourced UType -> TC UType-decomposeCmdTy _ (_, UTyCmd a) = return a-decomposeCmdTy t ty = do- a <- fresh- _ <- unify (Just t) (mkJoin ty (UTyCmd a))- return a---- | Decompose a type that is supposed to be a function type. Also take--- the term which is supposed to have that type, for use in error--- messages.-decomposeFunTy :: Syntax -> Sourced UType -> TC (UType, UType)-decomposeFunTy _ (_, UTyFun ty1 ty2) = return (ty1, ty2)-decomposeFunTy t ty = do- ty1 <- fresh- ty2 <- fresh- _ <- unify (Just t) (mkJoin ty (UTyFun ty1 ty2))- return (ty1, ty2)---- | Decompose a type that is supposed to be a product type. Also take--- the term which is supposed to have that type, for use in error--- messages.-decomposeProdTy :: Syntax -> Sourced UType -> TC (UType, UType)-decomposeProdTy _ (_, UTyProd ty1 ty2) = return (ty1, ty2)-decomposeProdTy t ty = do- ty1 <- fresh- ty2 <- fresh- _ <- unify (Just t) (mkJoin ty (UTyProd ty1 ty2))- return (ty1, ty2)----------------------------------------------------------------- Type inference / checking---- | Top-level type inference function: given a context of definition--- types and a top-level term, either return a type error or its--- type as a 'TModule'.-inferTop :: TCtx -> Syntax -> Either ContextualTypeErr TModule-inferTop ctx = runTC ctx . inferModule---- | Infer the signature of a top-level expression which might--- contain definitions.-inferModule :: Syntax -> TC UModule-inferModule s@(Syntax l t) = addLocToTypeErr l $ case t of- -- For definitions with no type signature, make up a fresh type- -- variable for the body, infer the body under an extended context,- -- and unify the two. Then generalize the type and return an- -- appropriate context.- SDef r x Nothing t1 -> withFrame l (TCDef (lvVar x)) $ do- xTy <- fresh- t1' <- withBinding (lvVar x) (Forall [] xTy) $ infer t1- _ <- unify (Just t1) (joined xTy (t1' ^. sType))- pty <- generalize (t1' ^. sType)- return $ Module (Syntax' l (SDef r x Nothing t1') (UTyCmd UTyUnit)) (singleton (lvVar x) pty)-- -- If a (poly)type signature has been provided, skolemize it and- -- check the definition.- SDef r x (Just pty) t1 -> withFrame l (TCDef (lvVar x)) $ do- let upty = toU pty- uty <- skolemize upty- t1' <- withBinding (lvVar x) upty $ check t1 uty- return $ Module (Syntax' l (SDef r x (Just pty) t1') (UTyCmd UTyUnit)) (singleton (lvVar x) upty)-- -- To handle a 'TBind', infer the types of both sides, combining the- -- returned modules appropriately. Have to be careful to use the- -- correct context when checking the right-hand side in particular.- SBind mx c1 c2 -> do- -- First, infer the left side.- Module c1' ctx1 <- withFrame l TCBindL $ inferModule c1- a <- decomposeCmdTy c1 (Actual, c1' ^. sType)-- -- Note we generalize here, similar to how we generalize at let- -- bindings, since the result type of the LHS will be the type of- -- the variable (if there is one). In many cases this doesn't- -- matter, but variables bound by top-level bind expressions can- -- end up in the top-level context (e.g. if someone writes `x <-- -- blah` at the REPL). We must generalize here, before adding the- -- variable to the context, since afterwards it will be too late:- -- we cannot generalize over any unification variables occurring- -- in the context.- --- -- This is safe since it is always safe to generalize at any point.- --- -- See #351, #1501.- genA <- generalize a-- -- Now infer the right side under an extended context: things in- -- scope on the right-hand side include both any definitions- -- created by the left-hand side, as well as a variable as in @x- -- <- c1; c2@. The order of extensions here matters: in theory,- -- c1 could define something with the same name as x, in which- -- case the bound x should shadow the defined one; hence, we apply- -- that binding /after/ (i.e. /within/) the application of @ctx1@.- withBindings ctx1 $- maybe id ((`withBinding` genA) . lvVar) mx $ do- Module c2' ctx2 <- withFrame l TCBindR $ inferModule c2-- -- We don't actually need the result type since we're just- -- going to return the entire type, but it's important to- -- ensure it's a command type anyway. Otherwise something- -- like 'move; 3' would be accepted with type int.- _ <- decomposeCmdTy c2 (Actual, c2' ^. sType)-- -- Ctx.union is right-biased, so ctx1 `union` ctx2 means later- -- definitions will shadow previous ones. Include the binder- -- (if any) as well, since binders are made available at the top- -- level, just like definitions. e.g. if the user writes `r <- build {move}`,- -- then they will be able to refer to r again later.- let ctxX = maybe Ctx.empty ((`Ctx.singleton` genA) . lvVar) mx- return $- Module- (Syntax' l (SBind mx c1' c2') (c2' ^. sType))- (ctx1 `Ctx.union` ctxX `Ctx.union` ctx2)-- -- In all other cases, there can no longer be any definitions in the- -- term, so delegate to 'infer'.- _anyOtherTerm -> trivMod <$> infer s---- | Infer the type of a term which does not contain definitions,--- returning a type-annotated term.------ The only cases explicitly handled in 'infer' are those where--- pushing an expected type down into the term can't possibly help,--- e.g. most primitives, function application, and binds.------ For most everything else we prefer 'check' because it can often--- result in better and more localized type error messages.-infer :: Syntax -> TC (Syntax' UType)-infer s@(Syntax l t) = addLocToTypeErr l $ case t of- -- Primitives, i.e. things for which we immediately know the only- -- possible correct type, and knowing an expected type would provide- -- no extra information.- TUnit -> return $ Syntax' l TUnit UTyUnit- TConst c -> Syntax' l (TConst c) <$> (instantiate . toU $ inferConst c)- TDir d -> return $ Syntax' l (TDir d) UTyDir- TInt n -> return $ Syntax' l (TInt n) UTyInt- TAntiInt x -> return $ Syntax' l (TAntiInt x) UTyInt- TText x -> return $ Syntax' l (TText x) UTyText- TAntiText x -> return $ Syntax' l (TAntiText x) UTyText- TBool b -> return $ Syntax' l (TBool b) UTyBool- TRobot r -> return $ Syntax' l (TRobot r) UTyActor- TRequireDevice d -> return $ Syntax' l (TRequireDevice d) (UTyCmd UTyUnit)- TRequire n d -> return $ Syntax' l (TRequire n d) (UTyCmd UTyUnit)- SRequirements x t1 -> do- t1' <- infer t1- return $ Syntax' l (SRequirements x t1') (UTyCmd UTyUnit)-- -- We should never encounter a TRef since they do not show up in- -- surface syntax, only as values while evaluating (*after*- -- typechecking).- TRef _ -> throwTypeErr l $ CantInfer t- -- Just look up variables in the context.- TVar x -> Syntax' l (TVar x) <$> lookup l x- -- It is helpful to handle lambdas in inference mode as well as- -- checking mode; in particular, we can handle lambdas with an- -- explicit type annotation on the argument. Just infer the body- -- under an extended context and return the appropriate function- -- type.- SLam x (Just argTy) body -> do- let uargTy = toU argTy- body' <- withBinding (lvVar x) (Forall [] uargTy) $ infer body- return $ Syntax' l (SLam x (Just argTy) body') (UTyFun uargTy (body' ^. sType))-- -- Need special case here for applying 'atomic' or 'instant' so we- -- don't handle it with the case for generic type application.- -- This must come BEFORE the SApp case.- TConst c :$: _- | c `elem` [Atomic, Instant] -> fresh >>= check s- -- It works better to handle applications in *inference* mode.- -- Knowing the expected result type of an application does not- -- really help much. In the typical case, the function being- -- applied is either (1) a primitive or variable whose type we can- -- easily infer, or (2) a nested application; in the second case in- -- particular, handling applications in inference mode means we can- -- stay in inference mode the whole way down the left-hand side of- -- the chain of applications. If we handled applications in- -- checking mode, we would constantly flip back and forth between- -- inference & checking and generate a fresh unification variable- -- each time.- SApp f x -> do- -- Infer the type of the left-hand side and make sure it has a function type.- f' <- infer f- (argTy, resTy) <- decomposeFunTy f (Actual, f' ^. sType)-- -- Then check that the argument has the right type.- x' <- check x argTy-- -- Call applyBindings explicitly, so that anything we learned- -- about unification variables while checking the type of the- -- argument can flow to later steps. This is especially helpful- -- while checking applications of polymorphic multi-argument- -- functions such as 'if'. Without this call to 'applyBindings',- -- type mismatches between the branches of an 'if' tend to get- -- caught in the unifier, resulting in vague "can't unify"- -- messages (for example, "if true {3} {move}" yields "can't- -- unify int and cmd unit"). With this 'applyBindings' call, we- -- get more specific errors about how the second branch was- -- expected to have the same type as the first (e.g. "expected- -- `move` to have type `int`, but it actually has type `cmd- -- unit`).- resTy' <- applyBindings resTy-- return $ Syntax' l (SApp f' x') resTy'-- -- We handle binds in inference mode for a similar reason to- -- application.- SBind mx c1 c2 -> do- c1' <- withFrame l TCBindL $ infer c1- a <- decomposeCmdTy c1 (Actual, c1' ^. sType)- genA <- generalize a- c2' <-- maybe id ((`withBinding` genA) . lvVar) mx- . withFrame l TCBindR- $ infer c2- _ <- decomposeCmdTy c2 (Actual, c2' ^. sType)- return $ Syntax' l (SBind mx c1' c2') (c2' ^. sType)-- -- Handle record projection in inference mode. Knowing the expected- -- type of r.x doesn't really help since we must infer the type of r- -- first anyway.- SProj t1 x -> do- t1' <- infer t1- case t1' ^. sType of- UTyRcd m -> case M.lookup x m of- Just xTy -> return $ Syntax' l (SProj t1' x) xTy- Nothing -> throwTypeErr l $ UnknownProj x (SProj t1 x)- _ -> throwTypeErr l $ CantInferProj (SProj t1 x)-- -- See Note [Checking and inference for record literals]- SRcd m -> do- m' <- itraverse (\x -> infer . fromMaybe (STerm (TVar x))) m- return $ Syntax' l (SRcd (Just <$> m')) (UTyRcd (fmap (^. sType) m'))-- -- To infer a type-annotated term, switch into checking mode.- -- However, we must be careful to deal properly with polymorphic- -- type annotations.- SAnnotate c pty -> do- let upty = toU pty- -- Typecheck against skolemized polytype.- uty <- skolemize upty- _ <- check c uty- -- Make sure no skolem variables have escaped.- getCtx >>= mapM_ (noSkolems l)- -- If check against skolemized polytype is successful,- -- instantiate polytype with unification variables.- -- Free variables should be able to unify with anything in- -- following typechecking steps.- iuty <- instantiate upty- c' <- check c iuty- return $ Syntax' l (SAnnotate c' pty) (c' ^. sType)-- -- Fallback: to infer the type of anything else, make up a fresh unification- -- variable for its type and check against it.- _ -> do- sTy <- fresh- check s sTy---- | Infer the type of a constant.-inferConst :: Const -> Polytype-inferConst c = case c of- Wait -> [tyQ| int -> cmd unit |]- Noop -> [tyQ| cmd unit |]- Selfdestruct -> [tyQ| cmd unit |]- Move -> [tyQ| cmd unit |]- Backup -> [tyQ| cmd unit |]- Path -> [tyQ| (unit + int) -> ((int * int) + text) -> cmd (unit + dir) |]- Push -> [tyQ| cmd unit |]- Stride -> [tyQ| int -> cmd unit |]- Turn -> [tyQ| dir -> cmd unit |]- Grab -> [tyQ| cmd text |]- Harvest -> [tyQ| cmd text |]- Ignite -> [tyQ| dir -> cmd unit |]- Place -> [tyQ| text -> cmd unit |]- Ping -> [tyQ| actor -> cmd (unit + (int * int)) |]- Give -> [tyQ| actor -> text -> cmd unit |]- Equip -> [tyQ| text -> cmd unit |]- Unequip -> [tyQ| text -> cmd unit |]- Make -> [tyQ| text -> cmd unit |]- Has -> [tyQ| text -> cmd bool |]- Equipped -> [tyQ| text -> cmd bool |]- Count -> [tyQ| text -> cmd int |]- Reprogram -> [tyQ| actor -> {cmd a} -> cmd unit |]- Build -> [tyQ| {cmd a} -> cmd actor |]- Drill -> [tyQ| dir -> cmd (unit + text) |]- Use -> [tyQ| text -> dir -> cmd (unit + text) |]- Salvage -> [tyQ| cmd unit |]- Say -> [tyQ| text -> cmd unit |]- Listen -> [tyQ| cmd text |]- Log -> [tyQ| text -> cmd unit |]- View -> [tyQ| actor -> cmd unit |]- Appear -> [tyQ| text -> cmd unit |]- Create -> [tyQ| text -> cmd unit |]- Halt -> [tyQ| actor -> cmd unit |]- Time -> [tyQ| cmd int |]- Scout -> [tyQ| dir -> cmd bool |]- Whereami -> [tyQ| cmd (int * int) |]- Waypoint -> [tyQ| text -> int -> cmd (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 |]- Sniff -> [tyQ| text -> cmd int |]- Chirp -> [tyQ| text -> cmd dir |]- Watch -> [tyQ| dir -> cmd unit |]- Surveil -> [tyQ| (int * int) -> cmd unit |]- Heading -> [tyQ| cmd dir |]- Blocked -> [tyQ| cmd bool |]- Scan -> [tyQ| dir -> cmd (unit + text) |]- Upload -> [tyQ| actor -> cmd unit |]- Ishere -> [tyQ| text -> cmd bool |]- Isempty -> [tyQ| cmd bool |]- Self -> [tyQ| actor |]- Parent -> [tyQ| actor |]- Base -> [tyQ| actor |]- Meet -> [tyQ| cmd (unit + actor) |]- MeetAll -> [tyQ| (b -> actor -> cmd b) -> b -> cmd b |]- Whoami -> [tyQ| cmd text |]- Setname -> [tyQ| text -> cmd unit |]- Random -> [tyQ| int -> cmd int |]- Run -> [tyQ| text -> cmd unit |]- If -> [tyQ| bool -> {a} -> {a} -> a |]- Inl -> [tyQ| a -> a + b |]- Inr -> [tyQ| b -> a + b |]- Case -> [tyQ|a + b -> (a -> c) -> (b -> c) -> c |]- Fst -> [tyQ| a * b -> a |]- Snd -> [tyQ| a * b -> b |]- Force -> [tyQ| {a} -> a |]- Return -> [tyQ| a -> cmd a |]- Try -> [tyQ| {cmd a} -> {cmd a} -> cmd a |]- Undefined -> [tyQ| a |]- Fail -> [tyQ| text -> a |]- Not -> [tyQ| bool -> bool |]- Neg -> [tyQ| int -> int |]- Eq -> cmpBinT- Neq -> cmpBinT- Lt -> cmpBinT- Gt -> cmpBinT- Leq -> cmpBinT- Geq -> cmpBinT- And -> [tyQ| bool -> bool -> bool|]- Or -> [tyQ| bool -> bool -> bool|]- Add -> arithBinT- Sub -> arithBinT- Mul -> arithBinT- Div -> arithBinT- Exp -> arithBinT- Format -> [tyQ| a -> text |]- Concat -> [tyQ| text -> text -> text |]- Chars -> [tyQ| text -> int |]- Split -> [tyQ| int -> text -> (text * text) |]- CharAt -> [tyQ| int -> text -> int |]- ToChar -> [tyQ| int -> text |]- AppF -> [tyQ| (a -> b) -> a -> b |]- Swap -> [tyQ| text -> cmd text |]- Atomic -> [tyQ| cmd a -> cmd a |]- Instant -> [tyQ| cmd a -> cmd a |]- Key -> [tyQ| text -> key |]- InstallKeyHandler -> [tyQ| text -> (key -> cmd unit) -> cmd unit |]- Teleport -> [tyQ| actor -> (int * int) -> cmd unit |]- As -> [tyQ| actor -> {cmd a} -> cmd a |]- RobotNamed -> [tyQ| text -> cmd actor |]- RobotNumbered -> [tyQ| int -> cmd actor |]- Knows -> [tyQ| text -> cmd bool |]- where- cmpBinT = [tyQ| a -> a -> bool |]- arithBinT = [tyQ| int -> int -> int |]---- | @check t ty@ checks that @t@ has type @ty@, returning a--- type-annotated AST if so.------ We try to stay in checking mode as far as possible, decomposing--- the expected type as we go and pushing it through the recursion.-check :: Syntax -> UType -> TC (Syntax' UType)-check s@(Syntax l t) expected = addLocToTypeErr l $ case t of- -- if t : ty, then {t} : {ty}.- -- Note that in theory, if the @Maybe Var@ component of the @SDelay@- -- is @Just@, we should typecheck the body under a context extended- -- with a type binding for the variable, and ensure that the type of- -- the variable is the same as the type inferred for the overall- -- @SDelay@. However, we rely on the invariant that such recursive- -- @SDelay@ nodes are never generated from the surface syntax, only- -- dynamically at runtime when evaluating recursive let or def expressions,- -- so we don't have to worry about typechecking them here.- SDelay d s1 -> do- ty1 <- decomposeDelayTy s (Expected, expected)- s1' <- check s1 ty1- return $ Syntax' l (SDelay d s1') (UTyDelay ty1)-- -- To check the type of a pair, make sure the expected type is a- -- product type, and push the two types down into the left and right.- SPair s1 s2 -> do- (ty1, ty2) <- decomposeProdTy s (Expected, expected)- s1' <- check s1 ty1- s2' <- check s2 ty2- return $ Syntax' l (SPair s1' s2') (UTyProd ty1 ty2)-- -- To check a lambda, make sure the expected type is a function type.- SLam x mxTy body -> do- (argTy, resTy) <- decomposeFunTy s (Expected, expected)- case toU mxTy of- Just xTy -> case unifyCheck argTy xTy of- -- Generate a special error when the explicit type annotation- -- on a lambda doesn't match the expected type,- -- e.g. (\x:int. x + 2) : text -> int, since the usual- -- "expected/but got" language would probably be confusing.- Apart -> throwTypeErr l $ LambdaArgMismatch (joined argTy xTy)- -- Otherwise, make sure to unify the annotation with the- -- expected argument type.- _ -> void $ argTy =:= xTy- Nothing -> return ()- body' <- withBinding (lvVar x) (Forall [] argTy) $ check body resTy- return $ Syntax' l (SLam x mxTy body') (UTyFun argTy resTy)-- -- Special case for checking the argument to 'atomic' (or- -- 'instant'). 'atomic t' has the same type as 't', which must have- -- a type of the form 'cmd a' for some 'a'.-- TConst c :$: at- | c `elem` [Atomic, Instant] -> do- argTy <- decomposeCmdTy s (Expected, expected)- at' <- check at (UTyCmd argTy)- atomic' <- infer (Syntax l (TConst c))- -- It's important that we typecheck the subterm @at@ *before* we- -- check that it is a valid argument to @atomic@: this way we can- -- ensure that we have already inferred the types of any variables- -- referenced.- --- -- When c is Atomic we validate that the argument to atomic is- -- guaranteed to operate within a single tick. When c is Instant- -- we skip this check.- when (c == Atomic) $ validAtomic at- return $ Syntax' l (SApp atomic' at') (UTyCmd argTy)- -- Checking the type of a let-expression.- SLet r x mxTy t1 t2 -> do- (upty, t1') <- case mxTy of- -- No type annotation was provided for the let binding, so infer its type.- Nothing -> do- -- The let could be recursive, so we must generate a fresh- -- unification variable for the type of x and infer the type- -- of t1 with x in the context.- xTy <- fresh- t1' <- withBinding (lvVar x) (Forall [] xTy) $ infer t1- let uty = t1' ^. sType- _ <- xTy =:= uty- upty <- generalize uty- return (upty, t1')- -- An explicit polytype annotation has been provided. Skolemize it and check- -- definition and body under an extended context.- Just pty -> do- let upty = toU pty- uty <- skolemize upty- t1' <- withBinding (lvVar x) upty $ check t1 uty- return (upty, t1')-- -- Now check the type of the body.- t2' <- withBinding (lvVar x) upty $ check t2 expected-- -- Make sure no skolem variables have escaped.- getCtx >>= mapM_ (noSkolems l)-- -- Return the annotated let.- return $ Syntax' l (SLet r x mxTy t1' t2') expected-- -- Definitions can only occur at the top level.- SDef {} -> throwTypeErr l $ DefNotTopLevel t- -- To check a record, ensure the expected type is a record type,- -- ensure all the right fields are present, and push the expected- -- types of all the fields down into recursive checks.- --- -- We have to be careful here --- if the expected type is not- -- manifestly a record type but might unify with one (i.e. if the- -- expected type is a variable) then we can't generate type- -- variables for its subparts and push them, we have to switch- -- completely into inference mode. See Note [Checking and inference- -- for record literals].- SRcd fields- | UTyRcd tyMap <- expected -> do- let expectedFields = M.keysSet tyMap- actualFields = M.keysSet fields- when (actualFields /= expectedFields) $- throwTypeErr l $- FieldsMismatch (joined expectedFields actualFields)- m' <- itraverse (\x ms -> check (fromMaybe (STerm (TVar x)) ms) (tyMap ! x)) fields- return $ Syntax' l (SRcd (Just <$> m')) expected-- -- Fallback: switch into inference mode, and check that the type we- -- get is what we expected.- _ -> do- Syntax' l' t' actual <- infer s- Syntax' l' t' <$> unify (Just s) (joined expected actual)---- ~~~~ Note [Checking and inference for record literals]------ We need to handle record literals in both inference and checking--- mode. By way of contrast, with a pair, if we are in checking--- mode and the expected type is not manifestly a product type, we--- can just generate fresh unification variables for the types of--- the two components, generate a constraint that the expected type--- is equal to a product type of these two fresh types, and continue--- in checking mode on both sides. With records, however, we cannot--- do that; if we are checking a record and the expected type is not--- manifestly a record type, we must simply switch into inference--- mode. However, it is still helpful to be able to handle records--- in checking mode too, since if we know a record type it is--- helpful to be able to push the field types down into the fields.----------------------------------------------------------------- Special atomic checking---- | Ensure a term is a valid argument to @atomic@. Valid arguments--- may not contain @def@, @let@, or lambda. Any variables which are--- referenced must have a primitive, first-order type such as--- @text@ or @int@ (in particular, no functions, @cmd@, or--- @delay@). We simply assume that any locally bound variables are--- OK without checking their type: the only way to bind a variable--- locally is with a binder of the form @x <- c1; c2@, where @c1@ is--- some primitive command (since we can't refer to external--- variables of type @cmd a@). If we wanted to do something more--- sophisticated with locally bound variables we would have to--- inline this analysis into typechecking proper, instead of having--- it be a separate, out-of-band check.------ The goal is to ensure that any argument to @atomic@ is guaranteed--- to evaluate and execute in some small, finite amount of time, so--- that it's impossible to write a term which runs atomically for an--- indefinite amount of time and freezes the rest of the game. Of--- course, nothing prevents one from writing a large amount of code--- inside an @atomic@ block; but we want the execution time to be--- linear in the size of the code.------ We also ensure that the atomic block takes at most one tick,--- i.e. contains at most one tangible command. For example, @atomic--- (move; move)@ is invalid, since that would allow robots to move--- twice as fast as usual by doing both actions in one tick.-validAtomic :: Syntax -> TC ()-validAtomic s@(Syntax l t) = do- n <- analyzeAtomic S.empty s- when (n > 1) $ throwTypeErr l $ InvalidAtomic (TooManyTicks n) t---- | Analyze an argument to @atomic@: ensure it contains no nested--- atomic blocks and no references to external variables, and count--- how many tangible commands it will execute.-analyzeAtomic :: Set Var -> Syntax -> TC Int-analyzeAtomic locals (Syntax l t) = case t of- -- Literals, primitives, etc. that are fine and don't require a tick- -- to evaluate- TUnit {} -> return 0- TDir {} -> return 0- TInt {} -> return 0- TAntiInt {} -> return 0- TText {} -> return 0- TAntiText {} -> return 0- TBool {} -> return 0- TRobot {} -> return 0- TRequireDevice {} -> return 0- TRequire {} -> return 0- SRequirements {} -> return 0- -- Constants.- TConst c- -- Nested 'atomic' is not allowed.- | c == Atomic -> throwTypeErr l $ InvalidAtomic NestedAtomic t- -- We cannot allow long commands (commands that may require more- -- than one tick to execute) since that could freeze the game.- | isLong c -> throwTypeErr l $ InvalidAtomic LongConst t- -- Otherwise, return 1 or 0 depending on whether the command is- -- tangible.- | otherwise -> return $ if isTangible c then 1 else 0- -- Special case for if: number of tangible commands is the *max* of- -- the branches instead of the sum, since exactly one of them will be- -- executed.- TConst If :$: tst :$: thn :$: els ->- (+) <$> analyzeAtomic locals tst <*> (max <$> analyzeAtomic locals thn <*> analyzeAtomic locals els)- -- Pairs, application, and delay are simple: just recurse and sum the results.- SPair s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2- SApp s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic locals s2- SDelay _ s1 -> analyzeAtomic locals s1- -- Bind is similarly simple except that we have to keep track of a local variable- -- bound in the RHS.- SBind mx s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic (maybe id (S.insert . lvVar) mx locals) s2- SRcd m -> sum <$> mapM analyzeField (M.assocs m)- where- analyzeField :: (Var, Maybe Syntax) -> TC Int- analyzeField (x, Nothing) = analyzeAtomic locals (STerm (TVar x))- analyzeField (_, Just s) = analyzeAtomic locals s- SProj {} -> return 0- -- Variables are allowed if bound locally, or if they have a simple type.- TVar x- | x `S.member` locals -> return 0- | otherwise -> do- mxTy <- Ctx.lookup x <$> getCtx- case mxTy of- -- If the variable is undefined, return 0 to indicate the- -- atomic block is valid, because we'd rather have the error- -- caught by the real name+type checking.- Nothing -> return 0- Just xTy -> do- -- Use applyBindings to make sure that we apply as much- -- information as unification has learned at this point. In- -- theory, continuing to typecheck other terms elsewhere in- -- the program could give us further information about xTy,- -- so we might have incomplete information at this point.- -- However, since variables referenced in an atomic block- -- must necessarily have simple types, it's unlikely this- -- will really make a difference. The alternative, more- -- "correct" way to do this would be to simply emit some- -- constraints at this point saying that xTy must be a- -- simple type, and check later that the constraint holds,- -- after performing complete type inference. However, since- -- the current approach is much simpler, we'll stick with- -- this until such time as we have concrete examples showing- -- that the more correct, complex way is necessary.- xTy' <- applyBindings xTy- if isSimpleUPolytype xTy'- then return 0- else throwTypeErr l $ InvalidAtomic (NonSimpleVarType x xTy') t- -- No lambda, `let` or `def` allowed!- SLam {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t- SLet {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t- SDef {} -> throwTypeErr l $ InvalidAtomic AtomicDupingThing t- -- We should never encounter a TRef since they do not show up in- -- surface syntax, only as values while evaluating (*after*- -- typechecking).- TRef {} -> throwTypeErr l $ CantInfer t- -- An explicit type annotation doesn't change atomicity- SAnnotate s _ -> analyzeAtomic locals s---- | A simple polytype is a simple type with no quantifiers.-isSimpleUPolytype :: UPolytype -> Bool-isSimpleUPolytype (Forall [] ty) = isSimpleUType ty-isSimpleUPolytype _ = False---- | A simple type is a sum or product of base types.-isSimpleUType :: UType -> Bool-isSimpleUType = \case- UTyBase {} -> True- UTyVar {} -> False- UTySum ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2- UTyProd ty1 ty2 -> isSimpleUType ty1 && isSimpleUType ty2- UTyFun {} -> False- UTyCmd {} -> False- UTyDelay {} -> False- -- Make the pattern-match coverage checker happy- UVar {} -> False- UTerm {} -> False
@@ -1,90 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Utilities related to type unification.-module Swarm.Language.Typecheck.Unify (- UnifyStatus (..),- unifyCheck,-) where--import Control.Unification-import Data.Foldable qualified as F-import Data.Function (on)-import Data.Map qualified as M-import Data.Map.Merge.Lazy qualified as M-import Swarm.Language.Types---- | The result of doing a unification check on two types.-data UnifyStatus- = -- | The two types are definitely not equal; they will never unify- -- no matter how any unification variables get filled in. For- -- example, (int * u0) and (u1 -> u2) are apart: the first is a- -- product type and the second is a function type.- Apart- | -- | The two types might unify, depending on how unification- -- variables get filled in, but we're not sure. For example,- -- (int * u0) and (u1 * bool).- MightUnify- | -- | The two types are most definitely equal, and we don't need to- -- bother generating a constraint to make them so. For example,- -- (int * text) and (int * text).- Equal- deriving (Eq, Ord, Read, Show)---- | The @Semigroup@ instance for @UnifyStatus@ is used to combine--- results for compound types.-instance Semigroup UnifyStatus where- -- If either part of a compound type is apart, then the whole thing is.- Apart <> _ = Apart- _ <> Apart = Apart- -- Otherwise, if we're unsure about either part of a compound type,- -- then we're unsure about the whole thing.- MightUnify <> _ = MightUnify- _ <> MightUnify = MightUnify- -- Finally, if both parts are definitely equal then the whole thing is.- Equal <> Equal = Equal--instance Monoid UnifyStatus where- mempty = Equal---- | Given two types, try hard to prove either that (1) they are--- 'Apart', i.e. cannot possibly unify, or (2) they are definitely--- 'Equal'. In case (1), we can generate a much better error--- message at the instant the two types come together than we could--- if we threw a constraint into the unifier. In case (2), we don't--- have to bother with generating a trivial constraint. If we don't--- know for sure whether they will unify, return 'MightUnify'.-unifyCheck :: UType -> UType -> UnifyStatus-unifyCheck ty1 ty2 = case (ty1, ty2) of- (UVar x, UVar y)- | x == y -> Equal- | otherwise -> MightUnify- (UVar _, _) -> MightUnify- (_, UVar _) -> MightUnify- (UTerm t1, UTerm t2) -> unifyCheckF t1 t2--unifyCheckF :: TypeF UType -> TypeF UType -> UnifyStatus-unifyCheckF t1 t2 = case (t1, t2) of- (TyBaseF b1, TyBaseF b2) -> case b1 == b2 of- True -> Equal- False -> Apart- (TyBaseF {}, _) -> Apart- (TyVarF v1, TyVarF v2) -> case v1 == v2 of- True -> Equal- False -> Apart- (TyVarF {}, _) -> Apart- (TySumF t11 t12, TySumF t21 t22) -> unifyCheck t11 t21 <> unifyCheck t12 t22- (TySumF {}, _) -> Apart- (TyProdF t11 t12, TyProdF t21 t22) -> unifyCheck t11 t21 <> unifyCheck t12 t22- (TyProdF {}, _) -> Apart- (TyRcdF m1, TyRcdF m2) ->- case ((==) `on` M.keysSet) m1 m2 of- False -> Apart- _ -> F.fold (M.merge M.dropMissing M.dropMissing (M.zipWithMatched (const unifyCheck)) m1 m2)- (TyRcdF {}, _) -> Apart- (TyCmdF c1, TyCmdF c2) -> unifyCheck c1 c2- (TyCmdF {}, _) -> Apart- (TyDelayF c1, TyDelayF c2) -> unifyCheck c1 c2- (TyDelayF {}, _) -> Apart- (TyFunF t11 t12, TyFunF t21 t22) -> unifyCheck t11 t21 <> unifyCheck t12 t22- (TyFunF {}, _) -> Apart
@@ -1,22 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.Language.Typed (Typed (..), value, polytype, requires) where--import Control.Lens (makeLenses)-import Data.Aeson (ToJSON)-import Data.Aeson.Types (FromJSON)-import GHC.Generics (Generic)-import Swarm.Language.Requirement (Requirements)-import Swarm.Language.Types (Polytype)---- | A value, or a hole, or something else that has its type & requirements fixed-data Typed v = Typed- { _value :: v- , _polytype :: Polytype- , _requires :: Requirements- }- deriving (Show, Eq, Generic, FromJSON, ToJSON)--makeLenses ''Typed
@@ -1,389 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- for the Data IntVar instance---- |--- SPDX-License-Identifier: BSD-3-Clause------ Types for the Swarm programming language and related utilities.-module Swarm.Language.Types (- -- * Basic definitions- BaseTy (..),- Var,- TypeF (..),-- -- * @Type@- Type,- tyVars,- pattern TyBase,- pattern TyVar,- pattern TyVoid,- pattern TyUnit,- pattern TyInt,- pattern TyText,- pattern TyDir,- pattern TyBool,- pattern TyActor,- pattern TyKey,- pattern (:+:),- pattern (:*:),- pattern (:->:),- pattern TyRcd,- pattern TyCmd,- pattern TyDelay,-- -- * @UType@- UType,- pattern UTyBase,- pattern UTyVar,- pattern UTyVoid,- pattern UTyUnit,- pattern UTyInt,- pattern UTyText,- pattern UTyDir,- pattern UTyBool,- pattern UTyActor,- pattern UTyKey,- pattern UTySum,- pattern UTyProd,- pattern UTyFun,- pattern UTyRcd,- pattern UTyCmd,- pattern UTyDelay,-- -- ** Utilities- ucata,- mkVarName,-- -- * Polytypes- Poly (..),- Polytype,- pattern PolyUnit,- UPolytype,-- -- * Contexts- TCtx,- UCtx,-- -- * The 'WithU' class- WithU (..),-) where--import Control.Monad (guard)-import Control.Unification-import Control.Unification.IntVar-import Data.Aeson (FromJSON, ToJSON)-import Data.Data (Data)-import Data.Foldable (fold)-import Data.Function (on)-import Data.Functor.Fixedpoint-import Data.Kind qualified-import Data.Map.Merge.Strict qualified as M-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as M-import Data.Set (Set)-import Data.Set qualified as S-import Data.String (IsString (..))-import Data.Text (Text)-import Data.Text qualified as T-import GHC.Generics (Generic, Generic1)-import Swarm.Language.Context-import Witch----------------------------------------------------------------- Types----------------------------------------------------------------- | Base types.-data BaseTy- = -- | The void type, with no inhabitants.- BVoid- | -- | The unit type, with a single inhabitant.- BUnit- | -- | Signed, arbitrary-size integers.- BInt- | -- | Unicode strings.- BText- | -- | Directions.- BDir- | -- | Booleans.- BBool- | -- | "Actors", i.e. anything that can do stuff. Internally, these- -- are all just "robots", but we give them a more generic- -- in-game name because they could represent other things like- -- aliens, animals, seeds, ...- BActor- | -- | Keys, i.e. things that can be pressed on the keyboard- BKey- deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)---- | A "structure functor" encoding the shape of type expressions.--- Actual types are then represented by taking a fixed point of this--- functor. We represent types in this way, via a "two-level type",--- so that we can work with the @unification-fd@ package (see--- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/).-data TypeF t- = -- | A base type.- TyBaseF BaseTy- | -- | A type variable.- TyVarF Var- | -- | Commands, with return type. Note that- -- commands form a monad.- TyCmdF t- | -- | Type of delayed computations.- TyDelayF t- | -- | Sum type.- TySumF t t- | -- | Product type.- TyProdF t t- | -- | Function type.- TyFunF t t- | -- | Record type.- TyRcdF (Map Var t)- deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Generic1, Unifiable, Data, FromJSON, ToJSON)---- | Unify two Maps by insisting they must have exactly the same keys,--- and if so, simply matching up corresponding values to be--- recursively unified. There could be other reasonable--- implementations, but in our case we will use this for unifying--- record types, and we do not have any subtyping, so record types--- will only unify if they have exactly the same keys.-instance Ord k => Unifiable (Map k) where- zipMatch m1 m2 = do- guard $ ((==) `on` M.keysSet) m1 m2- pure $ M.merge M.dropMissing M.dropMissing (M.zipWithMatched (\_ a1 a2 -> Right (a1, a2))) m1 m2---- | @Type@ is now defined as the fixed point of 'TypeF'. It would be--- annoying to manually apply and match against 'Fix' constructors--- everywhere, so we provide pattern synonyms that allow us to work--- with 'Type' as if it were defined in a directly recursive way.-type Type = Fix TypeF---- | Get all the type variables contained in a 'Type'.-tyVars :: Type -> Set Var-tyVars = cata (\case TyVarF x -> S.singleton x; f -> fold f)---- The derived Data instance is so we can make a quasiquoter for types.-deriving instance Data Type---- | 'UType's are like 'Type's, but also contain unification--- variables. 'UType' is defined via 'UTerm', which is also a kind--- of fixed point (in fact, 'UType' is the /free monad/ over 'TypeF').------ Just as with 'Type', we provide a bunch of pattern synonyms for--- working with 'UType' as if it were defined directly.-type UType = UTerm TypeF IntVar---- The derived Data instances are so we can make a quasiquoter for--- types.-deriving instance Data UType-deriving instance Data IntVar---- | A generic /fold/ for things defined via 'UTerm' (including, in--- particular, 'UType'). This probably belongs in the--- @unification-fd@ package, but since it doesn't provide one, we--- define it here.-ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a-ucata f _ (UVar v) = f v-ucata f g (UTerm t) = g (fmap (ucata f g) t)---- | A quick-and-dirty method for turning an 'IntVar' (used internally--- as a unification variable) into a unique variable name, by--- appending a number to the given name.-mkVarName :: Text -> IntVar -> Var-mkVarName nm (IntVar v) = T.append nm (from @String (show (v + (maxBound :: Int) + 1)))---- | For convenience, so we can write /e.g./ @"a"@ instead of @TyVar "a"@.-instance IsString Type where- fromString x = TyVar (from @String x)--instance IsString UType where- fromString x = UTyVar (from @String x)----------------------------------------------------------------- Contexts----------------------------------------------------------------- | A @TCtx@ is a mapping from variables to polytypes. We generally--- get one of these at the end of the type inference process.-type TCtx = Ctx Polytype---- | A @UCtx@ is a mapping from variables to polytypes with--- unification variables. We generally have one of these while we--- are in the midst of the type inference process.-type UCtx = Ctx UPolytype----------------------------------------------------------------- Polytypes----------------------------------------------------------------- | A @Poly t@ is a universally quantified @t@. The variables in the--- list are bound inside the @t@. For example, the type @forall--- a. a -> a@ would be represented as @Forall ["a"] (TyFun "a" "a")@.-data Poly t = Forall [Var] t- deriving (Show, Eq, Functor, Foldable, Traversable, Data, Generic, FromJSON, ToJSON)---- | A polytype without unification variables.-type Polytype = Poly Type---- | A polytype with unification variables.-type UPolytype = Poly UType----------------------------------------------------------------- WithU----------------------------------------------------------------- | In several cases we have two versions of something: a "normal"--- version, and a @U@ version with unification variables in it--- (/e.g./ 'Type' vs 'UType', 'Polytype' vs 'UPolytype', 'TCtx' vs--- 'UCtx'). This class abstracts over the process of converting back--- and forth between them.------ In particular, @'WithU' t@ represents the fact that the type @t@--- also has a @U@ counterpart, with a way to convert back and forth.--- Note, however, that converting back may be "unsafe" in the sense--- that it requires an extra burden of proof to guarantee that it is--- used only on inputs that are safe.-class WithU t where- -- | The associated "@U@-version" of the type @t@.- type U t :: Data.Kind.Type-- -- | Convert from @t@ to its associated "@U@-version". This- -- direction is always safe (we simply have no unification- -- variables even though the type allows it).- toU :: t -> U t-- -- | Convert from the associated "@U@-version" back to @t@.- -- Generally, this direction requires somehow knowing that there- -- are no longer any unification variables in the value being- -- converted.- fromU :: U t -> Maybe t---- | 'Type' is an instance of 'WithU', with associated type 'UType'.-instance WithU Type where- type U Type = UType- toU = unfreeze- fromU = freeze---- | A 'WithU' instance can be lifted through any functor (including,--- in particular, 'Ctx' and 'Poly').-instance (WithU t, Traversable f) => WithU (f t) where- type U (f t) = f (U t)- toU = fmap toU- fromU = traverse fromU----------------------------------------------------------------- Pattern synonyms---------------------------------------------------------------pattern TyBase :: BaseTy -> Type-pattern TyBase b = Fix (TyBaseF b)--pattern TyVar :: Var -> Type-pattern TyVar v = Fix (TyVarF v)--pattern TyVoid :: Type-pattern TyVoid = Fix (TyBaseF BVoid)--pattern TyUnit :: Type-pattern TyUnit = Fix (TyBaseF BUnit)--pattern TyInt :: Type-pattern TyInt = Fix (TyBaseF BInt)--pattern TyText :: Type-pattern TyText = Fix (TyBaseF BText)--pattern TyDir :: Type-pattern TyDir = Fix (TyBaseF BDir)--pattern TyBool :: Type-pattern TyBool = Fix (TyBaseF BBool)--pattern TyActor :: Type-pattern TyActor = Fix (TyBaseF BActor)--pattern TyKey :: Type-pattern TyKey = Fix (TyBaseF BKey)--infixr 5 :+:--pattern (:+:) :: Type -> Type -> Type-pattern ty1 :+: ty2 = Fix (TySumF ty1 ty2)--infixr 6 :*:--pattern (:*:) :: Type -> Type -> Type-pattern ty1 :*: ty2 = Fix (TyProdF ty1 ty2)--infixr 1 :->:--pattern (:->:) :: Type -> Type -> Type-pattern ty1 :->: ty2 = Fix (TyFunF ty1 ty2)--pattern TyRcd :: Map Var Type -> Type-pattern TyRcd m = Fix (TyRcdF m)--pattern TyCmd :: Type -> Type-pattern TyCmd ty1 = Fix (TyCmdF ty1)--pattern TyDelay :: Type -> Type-pattern TyDelay ty1 = Fix (TyDelayF ty1)--pattern UTyBase :: BaseTy -> UType-pattern UTyBase b = UTerm (TyBaseF b)--pattern UTyVar :: Var -> UType-pattern UTyVar v = UTerm (TyVarF v)--pattern UTyVoid :: UType-pattern UTyVoid = UTerm (TyBaseF BVoid)--pattern UTyUnit :: UType-pattern UTyUnit = UTerm (TyBaseF BUnit)--pattern UTyInt :: UType-pattern UTyInt = UTerm (TyBaseF BInt)--pattern UTyText :: UType-pattern UTyText = UTerm (TyBaseF BText)--pattern UTyDir :: UType-pattern UTyDir = UTerm (TyBaseF BDir)--pattern UTyBool :: UType-pattern UTyBool = UTerm (TyBaseF BBool)--pattern UTyActor :: UType-pattern UTyActor = UTerm (TyBaseF BActor)--pattern UTyKey :: UType-pattern UTyKey = UTerm (TyBaseF BKey)--pattern UTySum :: UType -> UType -> UType-pattern UTySum ty1 ty2 = UTerm (TySumF ty1 ty2)--pattern UTyProd :: UType -> UType -> UType-pattern UTyProd ty1 ty2 = UTerm (TyProdF ty1 ty2)--pattern UTyFun :: UType -> UType -> UType-pattern UTyFun ty1 ty2 = UTerm (TyFunF ty1 ty2)--pattern UTyRcd :: Map Var UType -> UType-pattern UTyRcd m = UTerm (TyRcdF m)--pattern UTyCmd :: UType -> UType-pattern UTyCmd ty1 = UTerm (TyCmdF ty1)--pattern UTyDelay :: UType -> UType-pattern UTyDelay ty1 = UTerm (TyDelayF ty1)--pattern PolyUnit :: Polytype-pattern PolyUnit = Forall [] (TyCmd TyUnit)---- Derive aeson instances for type serialization-deriving instance Generic Type-deriving instance ToJSON Type-deriving instance FromJSON Type
@@ -1,128 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GADTs #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Values and environments used for interpreting the Swarm language.-module Swarm.Language.Value (- -- * Values- Value (..),- stripVResult,- prettyValue,- valueToTerm,-- -- * Environments- Env,-) where--import Data.Aeson (FromJSON, ToJSON)-import Data.Bool (bool)-import Data.List (foldl')-import Data.Map (Map)-import Data.Map qualified as M-import Data.Set qualified as S-import Data.Set.Lens (setOf)-import Data.Text (Text)-import GHC.Generics (Generic)-import Swarm.Language.Context-import Swarm.Language.Key (KeyCombo, prettyKeyCombo)-import Swarm.Language.Pretty (prettyText)-import Swarm.Language.Syntax---- | A /value/ is a term that cannot (or does not) take any more--- evaluation steps on its own.-data Value where- -- | The unit value.- VUnit :: Value- -- | An integer.- VInt :: Integer -> Value- -- | Literal text.- VText :: Text -> Value- -- | A direction.- VDir :: Direction -> Value- -- | A boolean.- VBool :: Bool -> Value- -- | A reference to a robot.- VRobot :: Int -> Value- -- | An injection into a sum type. False = left, True = right.- VInj :: Bool -> Value -> Value- -- | A pair.- VPair :: Value -> Value -> Value- -- | A /closure/, representing a lambda term along with an- -- environment containing bindings for any free variables in the- -- body of the lambda.- VClo :: Var -> Term -> Env -> Value- -- | An application of a constant to some value arguments,- -- potentially waiting for more arguments. If a constant- -- application is fully saturated (as defined by its 'arity'),- -- whether it is a value or not depends on whether or not it- -- represents a command (as defined by 'isCmd'). If a command- -- (e.g. 'Build'), it is a value, and awaits an 'Swarm.Game.CESK.FExec' frame- -- which will cause it to execute. Otherwise (e.g. 'If'), it is- -- not a value, and will immediately reduce.- VCApp :: Const -> [Value] -> Value- -- | A definition, which does not take effect until executed.- -- The @Bool@ indicates whether the definition is recursive.- VDef :: Bool -> Var -> Term -> Env -> Value- -- | The result of a command, consisting of the result of the- -- command as well as an environment of bindings from 'TDef'- -- commands.- VResult :: Value -> Env -> Value- -- | An unevaluated bind expression, waiting to be executed, of the- -- form /i.e./ @c1 ; c2@ or @x <- c1; c2@. We also store an 'Env'- -- in which to interpret the commands.- VBind :: Maybe Var -> Term -> Term -> Env -> Value- -- | A (non-recursive) delayed term, along with its environment. If- -- a term would otherwise be evaluated but we don't want it to be- -- (/e.g./ as in the case of arguments to an 'if', or a recursive- -- binding), we can stick a 'TDelay' on it, which turns it into a- -- value. Delayed terms won't be evaluated until 'Force' is- -- applied to them.- VDelay :: Term -> Env -> Value- -- | A reference to a memory cell in the store.- VRef :: Int -> Value- -- | A record value.- VRcd :: Map Var Value -> Value- -- | A keyboard input.- VKey :: KeyCombo -> Value- -- | A 'requirements' command awaiting execution.- VRequirements :: Text -> Term -> Env -> Value- deriving (Eq, Show, Generic, FromJSON, ToJSON)---- | Ensure that a value is not wrapped in 'VResult'.-stripVResult :: Value -> Value-stripVResult (VResult v _) = stripVResult v-stripVResult v = v---- | Pretty-print a value.-prettyValue :: Value -> Text-prettyValue = prettyText . valueToTerm---- | Inject a value back into a term.-valueToTerm :: Value -> Term-valueToTerm VUnit = TUnit-valueToTerm (VInt n) = TInt n-valueToTerm (VText s) = TText s-valueToTerm (VDir d) = TDir d-valueToTerm (VBool b) = TBool b-valueToTerm (VRobot r) = TRobot r-valueToTerm (VInj s v) = TApp (TConst (bool Inl Inr s)) (valueToTerm v)-valueToTerm (VPair v1 v2) = TPair (valueToTerm v1) (valueToTerm v2)-valueToTerm (VClo x t e) =- M.foldrWithKey- (\y v -> TLet False y Nothing (valueToTerm v))- (TLam x Nothing t)- (M.restrictKeys (unCtx e) (S.delete x (setOf freeVarsV (Syntax' NoLoc t ()))))-valueToTerm (VCApp c vs) = foldl' TApp (TConst c) (reverse (map valueToTerm vs))-valueToTerm (VDef r x t _) = TDef r x Nothing t-valueToTerm (VResult v _) = valueToTerm v-valueToTerm (VBind mx c1 c2 _) = TBind mx c1 c2-valueToTerm (VDelay t _) = TDelay SimpleDelay t-valueToTerm (VRef n) = TRef n-valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m)-valueToTerm (VKey kc) = TApp (TConst Key) (TText (prettyKeyCombo kc))-valueToTerm (VRequirements x t _) = TRequirements x t---- | An environment is a mapping from variable names to values.-type Env = Ctx Value
@@ -1,70 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ A data type to represent log messages, both for robot logs and--- the system log.-module Swarm.Log (- Severity (..),- RobotLogSource (..),- LogSource (..),- LogEntry (..),- leTime,- leSource,- leSeverity,- leName,- leText,-) where--import Control.Lens (makeLenses)-import Data.Aeson (FromJSON, ToJSON)-import Data.Text (Text)-import GHC.Generics (Generic)-import Swarm.Game.CESK (TickNumber)-import Swarm.Game.Location (Location)-import Swarm.Game.Universe (Cosmic)---- | Severity of the error - critical errors are bugs--- and should be reported as Issues.-data Severity = Info | Debug | Warning | Error | Critical- deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)---- | How a robot log entry was produced.-data RobotLogSource- = -- | Produced by 'Swarm.Language.Syntax.Say'- Said- | -- | Produced by 'Swarm.Language.Syntax.Log'- Logged- | -- | Produced as the result of an error.- RobotError- deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)---- | Source of a log entry.-data LogSource- = -- | Log produced by a robot. Stores information about which- -- command was used and the ID and location of the producing- -- robot.- RobotLog RobotLogSource Int (Cosmic Location)- | -- | Log produced by an exception or system.- SystemLog- deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)---- | A log entry.-data LogEntry = LogEntry- { _leTime :: TickNumber- -- ^ The time at which the entry was created.- -- Note that this is the first field we sort on.- , _leSource :: LogSource- -- ^ Where this log message came from.- , _leSeverity :: Severity- -- ^ Severity level of this log message.- , _leName :: Text- -- ^ Name of the robot or subsystem that generated this log entry.- , _leText :: Text- -- ^ The text of the log entry.- }- deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)--makeLenses ''LogEntry
@@ -1,17 +0,0 @@--- |--- SPDX-License-Identifier: BSD-3-Clause------ Ensures that access to an 'IORef' is read-only--- by hiding behind a newtype.-module Swarm.ReadableIORef (mkReadonly, ReadableIORef, readIORef) where--import Data.IORef (IORef)-import Data.IORef qualified as R (readIORef)--newtype ReadableIORef a = ReadableIORef (IORef a)--mkReadonly :: IORef a -> ReadableIORef a-mkReadonly = ReadableIORef--readIORef :: ReadableIORef a -> IO a-readIORef (ReadableIORef ref) = R.readIORef ref
@@ -1,129 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Special border drawing functions that can include labels in more--- places than just the top center.-module Swarm.TUI.Border (- -- * Horizontal border labels- HBorderLabels,- plainHBorder,- leftLabel,- centerLabel,- rightLabel,-- -- * Rectangular border labels- BorderLabels,- plainBorder,- topLabels,- bottomLabels,-- -- * Border-drawing functions- hBorderWithLabels,- borderWithLabels,-) where--import Brick-import Brick.Widgets.Border-import Control.Lens (makeLenses, to, (^.))-import Data.Function ((&))-import Graphics.Vty qualified as V---- | Labels for a horizontal border, with optional left, middle, and--- right labels.-data HBorderLabels n = HBorderLabels- { _leftLabel :: Maybe (Widget n)- , _centerLabel :: Maybe (Widget n)- , _rightLabel :: Maybe (Widget n)- }---- | A plain horizontal border with no labels.-plainHBorder :: HBorderLabels n-plainHBorder = HBorderLabels Nothing Nothing Nothing---- | Labels for a rectangular border, with optional left, middle, and--- right labels on the top and bottom.-data BorderLabels n = BorderLabels- { _topLabels :: HBorderLabels n- , _bottomLabels :: HBorderLabels n- }---- | A plain rectangular border with no labels.-plainBorder :: BorderLabels n-plainBorder = BorderLabels plainHBorder plainHBorder--makeLenses ''HBorderLabels-makeLenses ''BorderLabels---- | Draw a horizontal border with three optional labels. The left--- label (if present) will be placed two units away from the left--- end of the border, and the right label will be placed two units--- away from the right end. The center label, if present, will--- always be centered in the border overall, regardless of the width--- of the left and right labels. This ensures that when the labels--- change width, they do not cause the other labels to wiggle.-hBorderWithLabels ::- HBorderLabels n -> Widget n-hBorderWithLabels (HBorderLabels l c r) =- Widget Greedy Fixed $ do- let renderLabel = render . maybe emptyWidget (vLimit 1)- rl <- renderLabel l- rc <- renderLabel c- rr <- renderLabel r-- -- Figure out how wide the whole border is supposed to be- ctx <- getContext- let w = ctx ^. availWidthL-- -- Get the widths of the labels- lw = V.imageWidth (image rl)- cw = V.imageWidth (image rc)-- -- Now render the border with labels.- render $- hBox- [ hLimit 2 hBorder- , Widget Fixed Fixed (return rl)- , -- We calculate the specific width of border between the left- -- and center labels needed to ensure that the center label is- -- in the right place. Note, using (cw + 1) `div` 2, as- -- opposed to cw `div` 2, means that the placement of the- -- center label will be left-biased: if it does not fit- -- exactly at the center it will be placed just to the left of- -- center.- hLimit (w `div` 2 - 2 - lw - (cw + 1) `div` 2) hBorder- , Widget Fixed Fixed (return rc)- , -- The border between center and right greedily fills up any- -- remaining width.- hBorder- , Widget Fixed Fixed (return rr)- , hLimit 2 hBorder- ]---- | Put a rectangular border around the specified widget with the--- specified label widgets placed around the border.-borderWithLabels :: BorderLabels n -> Widget n -> Widget n-borderWithLabels labels wrapped =- Widget (hSize wrapped) (vSize wrapped) $ do- c <- getContext-- middleResult <-- wrapped- & vLimit (c ^. availHeightL - 2)- & hLimit (c ^. availWidthL - 2)- & render-- let tl = joinableBorder (Edges False True False True)- tr = joinableBorder (Edges False True True False)- bl = joinableBorder (Edges True False False True)- br = joinableBorder (Edges True False True False)- top = tl <+> hBorderWithLabels (labels ^. topLabels) <+> tr- bottom = bl <+> hBorderWithLabels (labels ^. bottomLabels) <+> br- middle = vBorder <+> Widget Fixed Fixed (return middleResult) <+> vBorder- total = top <=> middle <=> bottom-- total- & vLimit (middleResult ^. imageL . to V.imageHeight + 2)- & hLimit (middleResult ^. imageL . to V.imageWidth + 2)- & render
@@ -1,1477 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}---- |--- SPDX-License-Identifier: BSD-3-Clause------ Event handlers for the TUI.-module Swarm.TUI.Controller (- -- * Event handling- handleEvent,- quitGame,-- -- ** Handling 'Swarm.TUI.Model.Frame' events- runFrameUI,- runFrame,- ticksPerFrameCap,- runFrameTicks,- runGameTickUI,- runGameTick,- updateUI,-- -- ** REPL panel- runBaseWebCode,- handleREPLEvent,- validateREPLForm,- adjReplHistIndex,- TimeDir (..),-- -- ** World panel- handleWorldEvent,- keyToDir,- scrollView,- adjustTPS,-- -- ** Info panel- handleInfoPanelEvent,-- -- ** Utils- getTutorials,-) where--import Brick hiding (Direction, Location)-import Brick.Focus-import Brick.Widgets.Dialog-import Brick.Widgets.Edit (handleEditorEvent)-import Brick.Widgets.List (handleListEvent)-import Brick.Widgets.List qualified as BL-import Control.Applicative (liftA2, pure)-import Control.Carrier.Lift qualified as Fused-import Control.Carrier.State.Lazy qualified as Fused-import Control.Lens as Lens-import Control.Lens.Extras as Lens (is)-import Control.Monad (forM_, unless, void, when)-import Control.Monad.Extra (whenJust)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.State (MonadState, execState)-import Data.Bits-import Data.Either (isRight)-import Data.Foldable (toList)-import Data.Int (Int32)-import Data.List.NonEmpty (NonEmpty (..))-import Data.List.NonEmpty qualified as NE-import Data.Map qualified as M-import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)-import Data.String (fromString)-import Data.Text qualified as T-import Data.Text.IO qualified as T-import Data.Time (getZonedTime)-import Data.Vector qualified as V-import Graphics.Vty qualified as V-import Linear-import Swarm.Game.Achievement.Definitions-import Swarm.Game.Achievement.Persistence-import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine)-import Swarm.Game.Entity hiding (empty)-import Swarm.Game.Location-import Swarm.Game.ResourceLoading (getSwarmHistoryPath)-import Swarm.Game.Robot-import Swarm.Game.ScenarioInfo-import Swarm.Game.State-import Swarm.Game.Step (finishGameTick, gameTick)-import Swarm.Language.Capability (Capability (CDebug, CMake))-import Swarm.Language.Context-import Swarm.Language.Key (KeyCombo, mkKeyCombo)-import Swarm.Language.Module-import Swarm.Language.Parse (reservedWords)-import Swarm.Language.Pipeline-import Swarm.Language.Pipeline.QQ (tmQ)-import Swarm.Language.Pretty-import Swarm.Language.Requirement qualified as R-import Swarm.Language.Syntax hiding (Key)-import Swarm.Language.Typed (Typed (..))-import Swarm.Language.Types-import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult)-import Swarm.Log-import Swarm.TUI.Controller.Util-import Swarm.TUI.Editor.Controller qualified as EC-import Swarm.TUI.Editor.Model-import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder)-import Swarm.TUI.Launch.Controller-import Swarm.TUI.Launch.Model-import Swarm.TUI.Launch.Prep (prepareLaunchDialog)-import Swarm.TUI.List-import Swarm.TUI.Model-import Swarm.TUI.Model.Goal-import Swarm.TUI.Model.Name-import Swarm.TUI.Model.Repl-import Swarm.TUI.Model.StateUpdate-import Swarm.TUI.Model.UI-import Swarm.TUI.View.Objective qualified as GR-import Swarm.TUI.View.Util (generateModal)-import Swarm.Util hiding (both, (<<.=))-import Swarm.Version (NewReleaseFailure (..))-import System.Clock-import System.FilePath (splitDirectories)-import Witch (into)-import Prelude hiding (Applicative (..)) -- See Note [liftA2 re-export from Prelude]---- ~~~~ Note [liftA2 re-export from Prelude]------ As of base-4.18 (GHC 9.6), liftA2 is re-exported from Prelude. See--- https://github.com/haskell/core-libraries-committee/issues/50 . In--- order to compile warning-free on both GHC 9.6 and older versions,--- we hide the import of Applicative functions from Prelude and import--- explicitly from Control.Applicative. In theory, if at some point--- in the distant future we end up dropping support for GHC < 9.6 then--- we could get rid of both explicit imports and just get liftA2 and--- pure implicitly from Prelude.--tutorialsDirname :: FilePath-tutorialsDirname = "Tutorials"---- | The top-level event handler for the TUI.-handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleEvent = \case- -- the query for upstream version could finish at any time, so we have to handle it here- AppEvent (UpstreamVersion ev) -> do- let logReleaseEvent l sev e = runtimeState . eventLog %= logEvent l sev "Release" (T.pack $ show e)- case ev of- Left e ->- let sev = case e of- FailedReleaseQuery {} -> Error- OnDevelopmentBranch {} -> Info- _ -> Warning- in logReleaseEvent SystemLog sev e- Right _ -> pure ()- runtimeState . upstreamRelease .= ev- e -> do- s <- get- if s ^. uiState . uiPlaying- then handleMainEvent e- else- e & case s ^. uiState . uiMenu of- -- If we reach the NoMenu case when uiPlaying is False, just- -- quit the app. We should actually never reach this code (the- -- quitGame function would have already halted the app).- NoMenu -> const halt- MainMenu l -> handleMainMenuEvent l- NewGameMenu l ->- if s ^. uiState . uiLaunchConfig . controls . fileBrowser . fbIsDisplayed- then handleFBEvent- else case s ^. uiState . uiLaunchConfig . controls . isDisplayedFor of- Nothing -> handleNewGameMenuEvent l- Just siPair -> handleLaunchOptionsEvent siPair- MessagesMenu -> handleMainMessagesEvent- AchievementsMenu l -> handleMainAchievementsEvent l- AboutMenu -> pressAnyKey (MainMenu (mainMenu About))---- | The event handler for the main menu.-handleMainMenuEvent ::- BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState ()-handleMainMenuEvent menu = \case- Key V.KEnter ->- case snd <$> BL.listSelectedElement menu of- Nothing -> continueWithoutRedraw- Just x0 -> case x0 of- NewGame -> do- cheat <- use $ uiState . uiCheatMode- ss <- use $ runtimeState . scenarios- uiState . uiMenu .= NewGameMenu (pure $ mkScenarioList cheat ss)- Tutorial -> do- -- Set up the menu stack as if the user had chosen "New Game > Tutorials"- cheat <- use $ uiState . uiCheatMode- ss <- use $ runtimeState . scenarios- let tutorialCollection = getTutorials ss- topMenu =- BL.listFindBy- ((== tutorialsDirname) . T.unpack . scenarioItemName)- (mkScenarioList cheat ss)- tutorialMenu = mkScenarioList cheat tutorialCollection- menuStack = tutorialMenu :| pure topMenu- uiState . uiMenu .= NewGameMenu menuStack-- -- Extract the first tutorial challenge and run it- let firstTutorial = case scOrder tutorialCollection of- Just (t : _) -> case M.lookup t (scMap tutorialCollection) of- Just (SISingle siPair) -> siPair- _ -> error "No first tutorial found!"- _ -> error "No first tutorial found!"- startGame firstTutorial Nothing- Achievements -> uiState . uiMenu .= AchievementsMenu (BL.list AchievementList (V.fromList listAchievements) 1)- Messages -> do- runtimeState . eventLog . notificationsCount .= 0- uiState . uiMenu .= MessagesMenu- About -> do- uiState . uiMenu .= AboutMenu- attainAchievement $ GlobalAchievement LookedAtAboutScreen- Quit -> halt- CharKey 'q' -> halt- ControlChar 'q' -> halt- VtyEvent ev -> do- menu' <- nestEventM' menu (handleListEvent ev)- uiState . uiMenu .= MainMenu menu'- _ -> continueWithoutRedraw--getTutorials :: ScenarioCollection -> ScenarioCollection-getTutorials sc = case M.lookup tutorialsDirname (scMap sc) of- Just (SICollection _ c) -> c- _ -> error $ "No tutorials exist: " ++ show sc---- | If we are in a New Game menu, advance the menu to the next item in order.------ NOTE: be careful to maintain the invariant that the currently selected--- menu item is always the same as the currently played scenario! `quitGame`--- is the only place this function should be called.-advanceMenu :: Menu -> Menu-advanceMenu = _NewGameMenu . ix 0 %~ BL.listMoveDown--handleMainAchievementsEvent ::- BL.List Name CategorizedAchievement ->- BrickEvent Name AppEvent ->- EventM Name AppState ()-handleMainAchievementsEvent l e = case e of- Key V.KEsc -> returnToMainMenu- CharKey 'q' -> returnToMainMenu- ControlChar 'q' -> returnToMainMenu- VtyEvent ev -> do- l' <- nestEventM' l (handleListEvent ev)- uiState . uiMenu .= AchievementsMenu l'- _ -> continueWithoutRedraw- where- returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages)--handleMainMessagesEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleMainMessagesEvent = \case- Key V.KEsc -> returnToMainMenu- CharKey 'q' -> returnToMainMenu- ControlChar 'q' -> returnToMainMenu- _ -> return ()- where- returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages)--handleNewGameMenuEvent ::- NonEmpty (BL.List Name ScenarioItem) ->- BrickEvent Name AppEvent ->- EventM Name AppState ()-handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case- Key V.KEnter ->- case snd <$> BL.listSelectedElement curMenu of- Nothing -> continueWithoutRedraw- Just (SISingle siPair) -> invalidateCache >> startGame siPair Nothing- Just (SICollection _ c) -> do- cheat <- use $ uiState . uiCheatMode- uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack)- CharKey 'o' -> showLaunchDialog- CharKey 'O' -> showLaunchDialog- Key V.KEsc -> exitNewGameMenu scenarioStack- CharKey 'q' -> exitNewGameMenu scenarioStack- ControlChar 'q' -> halt- VtyEvent ev -> do- menu' <- nestEventM' curMenu (handleListEvent ev)- uiState . uiMenu .= NewGameMenu (menu' :| rest)- _ -> continueWithoutRedraw- where- showLaunchDialog = case snd <$> BL.listSelectedElement curMenu of- Just (SISingle siPair) -> Brick.zoom (uiState . uiLaunchConfig) $ prepareLaunchDialog siPair- _ -> continueWithoutRedraw--exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState ()-exitNewGameMenu stk = do- uiState- . uiMenu- .= case snd (NE.uncons stk) of- Nothing -> MainMenu (mainMenu NewGame)- Just stk' -> NewGameMenu stk'--pressAnyKey :: Menu -> BrickEvent Name AppEvent -> EventM Name AppState ()-pressAnyKey m (VtyEvent (V.EvKey _ _)) = uiState . uiMenu .= m-pressAnyKey _ _ = continueWithoutRedraw---- | The top-level event handler while we are running the game itself.-handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleMainEvent ev = do- s <- get- mt <- preuse $ uiState . uiModal . _Just . modalType- let isRunning = maybe True isRunningModal mt- let isPaused = s ^. gameState . temporal . paused- let isCreative = s ^. gameState . creativeMode- let hasDebug = fromMaybe isCreative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug- case ev of- AppEvent ae -> case ae of- Frame- | s ^. gameState . temporal . paused -> continueWithoutRedraw- | otherwise -> runFrameUI- Web (RunWebCode c) -> runBaseWebCode c- _ -> continueWithoutRedraw- -- ctrl-q works everywhere- ControlChar 'q' ->- case s ^. gameState . winCondition of- WinConditions (Won _) _ -> toggleModal $ ScenarioEndModal WinModal- WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal- _ -> toggleModal QuitModal- VtyEvent (V.EvResize _ _) -> invalidateCache- Key V.KEsc- | Just m <- s ^. uiState . uiModal -> do- safeAutoUnpause- uiState . uiModal .= Nothing- -- message modal is not autopaused, so update notifications when leaving it- case m ^. modalType of- MessagesModal -> do- gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks- _ -> return ()- FKey 1 -> toggleModal HelpModal- FKey 2 -> toggleModal RobotsModal- FKey 3 | not (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) -> do- toggleModal RecipesModal- gameState . discovery . availableRecipes . notificationsCount .= 0- FKey 4 | not (null (s ^. gameState . discovery . availableCommands . notificationsContent)) -> do- toggleModal CommandsModal- gameState . discovery . availableCommands . notificationsCount .= 0- FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do- toggleModal MessagesModal- gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks- -- show goal- ControlChar 'g' ->- if hasAnythingToShow $ s ^. uiState . uiGoal . goalsContent- then toggleModal GoalModal- else continueWithoutRedraw- -- hide robots- MetaChar 'h' -> do- t <- liftIO $ getTime Monotonic- h <- use $ uiState . uiHideRobotsUntil- if h >= t- then -- ignore repeated keypresses- continueWithoutRedraw- else -- hide for two seconds- do- uiState . uiHideRobotsUntil .= t + TimeSpec 2 0- invalidateCacheEntry WorldCache- -- debug focused robot- MetaChar 'd' | isPaused && hasDebug -> do- debug <- uiState . uiShowDebug Lens.<%= not- if debug- then gameState . temporal . gameStep .= RobotStep SBefore- else zoomGameState finishGameTick >> void updateUI- -- pausing and stepping- ControlChar 'p' | isRunning -> safeTogglePause- ControlChar 'o' | isRunning -> do- gameState . temporal . runStatus .= ManualPause- runGameTickUI- -- speed controls- ControlChar 'x' | isRunning -> modify $ adjustTPS (+)- ControlChar 'z' | isRunning -> modify $ adjustTPS (-)- -- special keys that work on all panels- MetaChar 'w' -> setFocus WorldPanel- MetaChar 'e' -> setFocus RobotPanel- MetaChar 'r' -> setFocus REPLPanel- MetaChar 't' -> setFocus InfoPanel- -- pass keys on to modal event handler if a modal is open- VtyEvent vev- | isJust (s ^. uiState . uiModal) -> handleModalEvent vev- -- toggle creative mode if in "cheat mode"-- MouseDown (TerrainListItem pos) V.BLeft _ _ ->- uiState . uiWorldEditor . terrainList %= BL.listMoveTo pos- MouseDown (EntityPaintListItem pos) V.BLeft _ _ ->- uiState . uiWorldEditor . entityPaintList %= BL.listMoveTo pos- ControlChar 'v'- | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not- -- toggle world editor mode if in "cheat mode"- ControlChar 'e'- | s ^. uiState . uiCheatMode -> do- uiState . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not- setFocus WorldEditorPanel- MouseDown WorldPositionIndicator _ _ _ -> uiState . uiWorldCursor .= Nothing- MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc ->- -- Eye Dropper tool- EC.handleMiddleClick mouseLoc- MouseDown (FocusablePanel WorldPanel) V.BRight _ mouseLoc ->- -- Eraser tool- EC.handleRightClick mouseLoc- MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc ->- -- Paint with the World Editor- EC.handleCtrlLeftClick mouseLoc- -- toggle collapse/expand REPL- MetaChar ',' -> do- invalidateCacheEntry WorldCache- uiState . uiShowREPL %= not- MouseDown n _ _ mouseLoc ->- case n of- FocusablePanel WorldPanel -> do- mouseCoordsM <- Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc- shouldUpdateCursor <- EC.updateAreaBounds mouseCoordsM- when shouldUpdateCursor $- uiState . uiWorldCursor .= mouseCoordsM- REPLInput -> handleREPLEvent ev- _ -> continueWithoutRedraw- MouseUp n _ _mouseLoc -> do- case n of- InventoryListItem pos -> uiState . uiInventory . traverse . _2 %= BL.listMoveTo pos- x@(WorldEditorPanelControl y) -> do- uiState . uiWorldEditor . editorFocusRing %= focusSetCurrent x- EC.activateWorldEditorFunction y- _ -> return ()- flip whenJust setFocus $ case n of- -- Adapt click event origin to their right panel.- -- For the REPL and the World view, using 'Brick.Widgets.Core.clickable' correctly set the origin.- -- However this does not seems to work for the robot and info panel.- -- Thus we force the destination focus here.- InventoryList -> Just RobotPanel- InventoryListItem _ -> Just RobotPanel- InfoViewport -> Just InfoPanel- REPLInput -> Just REPLPanel- WorldEditorPanelControl _ -> Just WorldEditorPanel- _ -> Nothing- case n of- FocusablePanel x -> setFocus x- _ -> return ()- -- dispatch any other events to the focused panel handler- _ev -> do- fring <- use $ uiState . uiFocusRing- case focusGetCurrent fring of- Just (FocusablePanel x) -> ($ ev) $ case x of- REPLPanel -> handleREPLEvent- WorldPanel -> handleWorldEvent- WorldEditorPanel -> EC.handleWorldEditorPanelEvent- RobotPanel -> handleRobotPanelEvent- InfoPanel -> handleInfoPanelEvent infoScroll- _ -> continueWithoutRedraw---- | Set the game to Running if it was (auto) paused otherwise to paused.------ Also resets the last frame time to now. If we are pausing, it--- doesn't matter; if we are unpausing, this is critical to--- ensure the next frame doesn't think it has to catch up from--- whenever the game was paused!-safeTogglePause :: EventM Name AppState ()-safeTogglePause = do- curTime <- liftIO $ getTime Monotonic- uiState . lastFrameTime .= curTime- uiState . uiShowDebug .= False- p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus- when (p == Running) $ zoomGameState finishGameTick---- | Only unpause the game if leaving autopaused modal.------ Note that the game could have been paused before opening--- the modal, in that case, leave the game paused.-safeAutoUnpause :: EventM Name AppState ()-safeAutoUnpause = do- runs <- use $ gameState . temporal . runStatus- when (runs == AutoPause) safeTogglePause--toggleModal :: ModalType -> EventM Name AppState ()-toggleModal mt = do- modal <- use $ uiState . uiModal- case modal of- Nothing -> openModal mt- Just _ -> uiState . uiModal .= Nothing >> safeAutoUnpause--handleModalEvent :: V.Event -> EventM Name AppState ()-handleModalEvent = \case- V.EvKey V.KEnter [] -> do- mdialog <- preuse $ uiState . uiModal . _Just . modalDialog- toggleModal QuitModal- case dialogSelection =<< mdialog of- Just (Button QuitButton, _) -> quitGame- Just (Button KeepPlayingButton, _) -> toggleModal KeepPlayingModal- Just (Button StartOverButton, StartOver currentSeed siPair) -> do- invalidateCache- restartGame currentSeed siPair- Just (Button NextButton, Next siPair) -> do- quitGame- invalidateCache- startGame siPair Nothing- _ -> return ()- ev -> do- Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev)- modal <- preuse $ uiState . uiModal . _Just . modalType- case modal of- Just TerrainPaletteModal ->- refreshList $ uiState . uiWorldEditor . terrainList- Just EntityPaletteModal -> do- refreshList $ uiState . uiWorldEditor . entityPaintList- Just GoalModal -> case ev of- V.EvKey (V.KChar '\t') [] -> uiState . uiGoal . focus %= focusNext- _ -> do- focused <- use $ uiState . uiGoal . focus- case focusGetCurrent focused of- Just (GoalWidgets w) -> case w of- ObjectivesList -> do- lw <- use $ uiState . uiGoal . listWidget- newList <- refreshGoalList lw- uiState . uiGoal . listWidget .= newList- GoalSummary -> handleInfoPanelEvent modalScroll (VtyEvent ev)- _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)- _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)- where- refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection- refreshList z = Brick.zoom z $ BL.handleListEvent ev--getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath)-getNormalizedCurrentScenarioPath =- -- the path should be normalized and good to search in scenario collection- use (gameState . currentScenarioPath) >>= \case- Nothing -> return Nothing- Just p' -> do- gs <- use $ runtimeState . scenarios- Just <$> liftIO (normalizeScenarioPath gs p')--saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo)-saveScenarioInfoOnFinish p = do- initialRunCode <- use $ gameState . gameControls . initiallyRunCode- t <- liftIO getZonedTime- wc <- use $ gameState . winCondition- let won = case wc of- WinConditions (Won _) _ -> True- _ -> False- ts <- use $ gameState . temporal . ticks-- -- NOTE: This traversal is apparently not the same one as used by- -- the scenario selection menu, so the menu needs to be updated separately.- -- See Note [scenario menu update]- let currentScenarioInfo :: Traversal' AppState ScenarioInfo- currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2-- replHist <- use $ uiState . uiREPL . replHistory- let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput- currentScenarioInfo- %= updateScenarioInfoOnFinish determinator t ts won- status <- preuse currentScenarioInfo- case status of- Nothing -> return ()- Just si -> do- let segments = splitDirectories p- case segments of- firstDir : _ -> do- when (won && firstDir == tutorialsDirname) $- attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial)- _ -> return ()- liftIO $ saveScenarioInfo p si- return status---- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit).-saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m ()-saveScenarioInfoOnFinishNocheat = do- -- Don't save progress if we are in cheat mode- cheat <- use $ uiState . uiCheatMode- unless cheat $ do- -- the path should be normalized and good to search in scenario collection- getNormalizedCurrentScenarioPath >>= \case- Nothing -> return ()- Just p -> void $ saveScenarioInfoOnFinish p---- | Write the @ScenarioInfo@ out to disk when exiting a game.-saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m ()-saveScenarioInfoOnQuit = do- -- Don't save progress if we are in cheat mode- -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat"- cheat <- use $ uiState . uiCheatMode- unless cheat $ do- getNormalizedCurrentScenarioPath >>= \case- Nothing -> return ()- Just p -> do- maybeSi <- saveScenarioInfoOnFinish p- -- Note [scenario menu update]- -- Ensures that the scenario selection menu gets updated- -- with the high score/completion status- forM_- maybeSi- ( uiState- . uiMenu- . _NewGameMenu- . ix 0- . BL.listSelectedElementL- . _SISingle- . _2- .=- )-- -- See what scenario is currently focused in the menu. Depending on how the- -- previous scenario ended (via quit vs. via win), it might be the same as- -- currentScenarioPath or it might be different.- curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath- -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo,- -- being sure to preserve the same focused scenario.- sc <- use $ runtimeState . scenarios- forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=)---- | Quit a game.------ * writes out the updated REPL history to a @.swarm_history@ file--- * saves current scenario status (InProgress/Completed)--- * advances the menu to the next scenario IF the current one was won--- * returns to the previous menu-quitGame :: EventM Name AppState ()-quitGame = do- -- Write out REPL history.- history <- use $ uiState . uiREPL . replHistory- let hist = mapMaybe getREPLEntry $ getLatestREPLHistoryItems maxBound history- liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True-- -- Save scenario status info.- saveScenarioInfoOnQuit-- -- Automatically advance the menu to the next scenario iff the- -- player has won the current one.- wc <- use $ gameState . winCondition- case wc of- WinConditions (Won _) _ -> uiState . uiMenu %= advanceMenu- _ -> return ()-- -- Either quit the entire app (if the scenario was chosen directly- -- from the command line) or return to the menu (if the scenario was- -- chosen from the menu).- menu <- use $ uiState . uiMenu- case menu of- NoMenu -> halt- _ -> uiState . uiPlaying .= False----------------------------------------------------------------- Handling Frame events----------------------------------------------------------------- | Run the game for a single /frame/ (/i.e./ screen redraw), then--- update the UI. Depending on how long it is taking to draw each--- frame, and how many ticks per second we are trying to achieve,--- this may involve stepping the game any number of ticks (including--- zero).-runFrameUI :: EventM Name AppState ()-runFrameUI = do- runFrame- redraw <- updateUI- unless redraw continueWithoutRedraw---- | Run the game for a single frame, without updating the UI.-runFrame :: EventM Name AppState ()-runFrame = do- -- Reset the needsRedraw flag. While processing the frame and stepping the robots,- -- the flag will get set to true if anything changes that requires redrawing the- -- world (e.g. a robot moving or disappearing).- gameState . needsRedraw .= False-- -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ .-- -- Find out how long the previous frame took, by subtracting the- -- previous time from the current time.- prevTime <- use (uiState . lastFrameTime)- curTime <- liftIO $ getTime Monotonic- let frameTime = diffTimeSpec curTime prevTime-- -- Remember now as the new previous time.- uiState . lastFrameTime .= curTime-- -- We now have some additional accumulated time to play with. The- -- idea is to now "catch up" by doing as many ticks as are supposed- -- to fit in the accumulated time. Some accumulated time may be- -- left over, but it will roll over to the next frame. This way we- -- deal smoothly with things like a variable frame rate, the frame- -- rate not being a nice multiple of the desired ticks per second,- -- etc.- uiState . accumulatedTime += frameTime-- -- Figure out how many ticks per second we're supposed to do,- -- and compute the timestep `dt` for a single tick.- lgTPS <- use (uiState . lgTicksPerSecond)- let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds- dt- | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS)- | otherwise = oneSecond * (1 `shiftL` abs lgTPS)-- -- Update TPS/FPS counters every second- infoUpdateTime <- use (uiState . lastInfoTime)- let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime- when (updateTime >= oneSecond) $ do- -- Wait for at least one second to have elapsed- when (infoUpdateTime /= 0) $ do- -- set how much frame got processed per second- frames <- use (uiState . frameCount)- uiState . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime-- -- set how much ticks got processed per frame- uiTicks <- use (uiState . tickCount)- uiState . uiTPF .= fromIntegral uiTicks / fromIntegral frames-- -- ensure this frame gets drawn- gameState . needsRedraw .= True-- -- Reset the counter and wait another seconds for the next update- uiState . tickCount .= 0- uiState . frameCount .= 0- uiState . lastInfoTime .= curTime-- -- Increment the frame count- uiState . frameCount += 1-- -- Now do as many ticks as we need to catch up.- uiState . frameTickCount .= 0- runFrameTicks (fromNanoSecs dt)--ticksPerFrameCap :: Int-ticksPerFrameCap = 30---- | Do zero or more ticks, with each tick notionally taking the given--- timestep, until we have used up all available accumulated time,--- OR until we have hit the cap on ticks per frame, whichever comes--- first.-runFrameTicks :: TimeSpec -> EventM Name AppState ()-runFrameTicks dt = do- a <- use (uiState . accumulatedTime)- t <- use (uiState . frameTickCount)-- -- Ensure there is still enough time left, and we haven't hit the- -- tick limit for this frame.- when (a >= dt && t < ticksPerFrameCap) $ do- -- If so, do a tick, count it, subtract dt from the accumulated time,- -- and loop!- runGameTick- uiState . tickCount += 1- uiState . frameTickCount += 1- uiState . accumulatedTime -= dt- runFrameTicks dt---- | Run the game for a single tick, and update the UI.-runGameTickUI :: EventM Name AppState ()-runGameTickUI = runGameTick >> void updateUI---- | Modifies the game state using a fused-effect state action.-zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (Fused.LiftC IO) a -> m a-zoomGameState f = do- gs <- use gameState- (gs', a) <- liftIO (Fused.runM (Fused.runState gs f))- gameState .= gs'- return a--updateAchievements :: EventM Name AppState ()-updateAchievements = do- -- Merge the in-game achievements with the master list in UIState- achievementsFromGame <- use $ gameState . discovery . gameAchievements- let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame-- oldMasterAchievementsList <- use $ uiState . uiAchievements- uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements-- -- Don't save to disk unless there was a change in the attainment list.- let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList- unless (null incrementalAchievements) $ do- -- TODO: #916 This is where new achievements would be displayed in a popup- newAchievements <- use $ uiState . uiAchievements- liftIO $ saveAchievementsInfo $ M.elems newAchievements---- | Run the game for a single tick (/without/ updating the UI).--- Every robot is given a certain amount of maximum computation to--- perform a single world action (like moving, turning, grabbing,--- etc.).-runGameTick :: EventM Name AppState ()-runGameTick = do- ticked <- zoomGameState gameTick- when ticked updateAchievements---- | Update the UI. This function is used after running the--- game for some number of ticks.-updateUI :: EventM Name AppState Bool-updateUI = do- loadVisibleRegion-- -- If the game state indicates a redraw is needed, invalidate the- -- world cache so it will be redrawn.- g <- use gameState- when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache-- -- The hash of the robot whose inventory is currently displayed (if any)- listRobotHash <- fmap fst <$> use (uiState . uiInventory)-- -- The hash of the focused robot (if any)- fr <- use (gameState . to focusedRobot)- let focusedRobotHash = view inventoryHash <$> fr-- -- Check if the inventory list needs to be updated.- shouldUpdate <- use (uiState . uiInventoryShouldUpdate)-- -- Whether the focused robot is too far away to sense, & whether- -- that has recently changed- dist <- use (gameState . to focusedRange)- farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable))- let tooFar = not farOK && dist == Just Far- farChanged = tooFar /= isNothing listRobotHash-- -- If the robot moved in or out of range, or hashes don't match- -- (either because which robot (or whether any robot) is focused- -- changed, or the focused robot's inventory changed), or the- -- inventory was flagged to be updated, regenerate the inventory list.- inventoryUpdated <-- if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate- then do- Brick.zoom uiState $ populateInventoryList (if tooFar then Nothing else fr)- (uiState . uiInventoryShouldUpdate) .= False- pure True- else pure False-- -- Now check if the base finished running a program entered at the REPL.- replUpdated <- case g ^. gameControls . replStatus of- -- It did, and the result was the unit value. Just reset replStatus.- REPLWorking (Typed (Just VUnit) typ reqs) -> do- gameState . gameControls . replStatus .= REPLDone (Just $ Typed VUnit typ reqs)- pure True-- -- It did, and returned some other value. Pretty-print the- -- result as a REPL output, with its type, and reset the replStatus.- REPLWorking (Typed (Just v) pty reqs) -> do- let finalType = stripCmd pty- let val = Typed (stripVResult v) finalType reqs- itIx <- use (gameState . gameControls . replNextValueIndex)- let itName = fromString $ "it" ++ show itIx- let out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)]- uiState . uiREPL . replHistory %= addREPLItem (REPLOutput out)- invalidateCacheEntry REPLHistoryCache- vScrollToEnd replScroll- gameState . gameControls . replStatus .= REPLDone (Just val)- gameState . baseRobot . robotContext . at itName .= Just val- gameState . gameControls . replNextValueIndex %= (+ 1)- pure True-- -- Otherwise, do nothing.- _ -> pure False-- -- If the focused robot's log has been updated and the UI focus- -- isn't currently on the inventory or info panels, attempt to- -- automatically switch to the logger and scroll all the way down so- -- the new message can be seen.- uiState . uiScrollToEnd .= False- logUpdated <- do- -- If the inventory or info panels are currently focused, it would- -- be rude to update them right under the user's nose, so consider- -- them "sticky". They will be updated as soon as the player moves- -- the focus away.- fring <- use $ uiState . uiFocusRing- let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel]-- -- Check if the robot log was updated and we are allowed to change- -- the inventory+info panels.- case maybe False (view robotLogUpdated) fr && not sticky of- False -> pure False- True -> do- -- Reset the log updated flag- zoomGameState clearFocusedRobotLogUpdated-- -- Find and focus an equipped "logger" device in the inventory list.- let isLogger (EquippedEntry e) = e ^. entityName == "logger"- isLogger _ = False- focusLogger = BL.listFindBy isLogger-- uiState . uiInventory . _Just . _2 %= focusLogger-- -- Now inform the UI that it should scroll the info panel to- -- the very end.- uiState . uiScrollToEnd .= True- pure True-- goalOrWinUpdated <- doGoalUpdates-- let redraw =- g ^. needsRedraw- || inventoryUpdated- || replUpdated- || logUpdated- || goalOrWinUpdated- pure redraw---- | Either pops up the updated Goals modal--- or pops up the Congratulations (Win) modal, or pops--- up the Condolences (Lose) modal.--- The Win modal will take precedence if the player--- has met the necessary conditions to win the game.------ If the player chooses to "Keep Playing" from the Win modal, the--- updated Goals will then immediately appear.--- This is desirable for:--- * feedback as to the final goal the player accomplished,--- * as a summary of all of the goals of the game--- * shows the player more "optional" goals they can continue to pursue-doGoalUpdates :: EventM Name AppState Bool-doGoalUpdates = do- curGoal <- use (uiState . uiGoal . goalsContent)- isCheating <- use (uiState . uiCheatMode)- curWinCondition <- use (gameState . winCondition)- announcementsSeq <- use (gameState . messageInfo . announcementQueue)- let announcementsList = toList announcementsSeq-- -- Decide whether we need to update the current goal text and pop- -- up a modal dialog.- case curWinCondition of- NoWinCondition -> return False- WinConditions (Unwinnable False) x -> do- -- This clears the "flag" that the Lose dialog needs to pop up- gameState . winCondition .= WinConditions (Unwinnable True) x- openModal $ ScenarioEndModal LoseModal- saveScenarioInfoOnFinishNocheat- return True- WinConditions (Won False) x -> do- -- This clears the "flag" that the Win dialog needs to pop up- gameState . winCondition .= WinConditions (Won True) x- openModal $ ScenarioEndModal WinModal- saveScenarioInfoOnFinishNocheat- -- We do NOT advance the New Game menu to the next item here (we- -- used to!), because we do not know if the user is going to- -- select 'keep playing' or 'next challenge'. We maintain the- -- invariant that the current menu item is always the same as- -- the scenario currently being played. If the user either (1)- -- quits to the menu or (2) selects 'next challenge' we will- -- advance the menu at that point.- return True- WinConditions _ oc -> do- let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc- -- The "uiGoal" field is initialized with empty members, so we know that- -- this will be the first time showing it if it will be nonempty after previously- -- being empty.- isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal)- goalWasUpdated = isFirstGoalDisplay || not (null announcementsList)-- -- Decide whether to show a pop-up modal congratulating the user on- -- successfully completing the current challenge.- when goalWasUpdated $ do- let hasMultiple = hasMultipleGoals newGoalTracking- defaultFocus =- if hasMultiple- then ObjectivesList- else GoalSummary-- ring =- focusRing $- map GoalWidgets $- if hasMultiple- then listEnums- else [GoalSummary]-- -- The "uiGoal" field is necessary at least to "persist" the data that is needed- -- if the player chooses to later "recall" the goals dialog with CTRL+g.- uiState- . uiGoal- .= GoalDisplay- newGoalTracking- (GR.makeListWidget newGoalTracking)- (focusSetCurrent (GoalWidgets defaultFocus) ring)-- -- This clears the "flag" that indicate that the goals dialog needs to be- -- automatically popped up.- gameState . messageInfo . announcementQueue .= mempty-- hideGoals <- use $ uiState . uiHideGoals- unless hideGoals $- openModal GoalModal-- return goalWasUpdated---- | Strips top-level `cmd` from type (in case of REPL evaluation),--- and returns a boolean to indicate if it happened-stripCmd :: Polytype -> Polytype-stripCmd (Forall xs (TyCmd ty)) = Forall xs ty-stripCmd pty = pty----------------------------------------------------------------- REPL events----------------------------------------------------------------- | Set the REPL to the given text and REPL prompt type.-resetREPL :: T.Text -> REPLPrompt -> UIState -> UIState-resetREPL t r ui =- ui- & uiREPL . replPromptText .~ t- & uiREPL . replPromptType .~ r---- | Handle a user input event for the REPL.-handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleREPLEvent x = do- s <- get- let theRepl = s ^. uiState . uiREPL- controlMode = theRepl ^. replControlMode- uinput = theRepl ^. replPromptText- case x of- -- Handle Ctrl-c here so we can always cancel the currently running- -- base program no matter what REPL control mode we are in.- ControlChar 'c' -> do- gameState . baseRobot . machine %= cancel- uiState . uiREPL . replPromptType .= CmdPrompt []- uiState . uiREPL . replPromptText .= ""-- -- Handle M-p and M-k, shortcuts for toggling pilot + key handler modes.- MetaChar 'p' ->- onlyCreative $ do- curMode <- use $ uiState . uiREPL . replControlMode- case curMode of- Piloting -> uiState . uiREPL . replControlMode .= Typing- _ ->- if T.null uinput- then uiState . uiREPL . replControlMode .= Piloting- else do- let err = REPLError "Please clear the REPL before engaging pilot mode."- uiState . uiREPL . replHistory %= addREPLItem err- invalidateCacheEntry REPLHistoryCache- MetaChar 'k' -> do- when (isJust (s ^. gameState . gameControls . inputHandler)) $ do- curMode <- use $ uiState . uiREPL . replControlMode- (uiState . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling-- -- Handle other events in a way appropriate to the current REPL- -- control mode.- _ -> case controlMode of- Typing -> handleREPLEventTyping x- Piloting -> handleREPLEventPiloting x- Handling -> case x of- -- Handle keypresses using the custom installed handler- VtyEvent (V.EvKey k mods) -> runInputHandler (mkKeyCombo mods k)- -- Handle all other events normally- _ -> handleREPLEventTyping x---- | Run the installed input handler on a key combo entered by the user.-runInputHandler :: KeyCombo -> EventM Name AppState ()-runInputHandler kc = do- mhandler <- use $ gameState . gameControls . inputHandler- case mhandler of- -- Shouldn't be possible to get here if there is no input handler, but- -- if we do somehow, just do nothing.- Nothing -> return ()- Just (_, handler) -> do- -- Make sure the base is currently idle; if so, apply the- -- installed input handler function to a `key` value- -- representing the typed input.- working <- use $ gameState . gameControls . replWorking- unless working $ do- s <- get- let topCtx = topContext s- handlerCESK = Out (VKey kc) (topCtx ^. defStore) [FApp handler, FExec]- gameState . baseRobot . machine .= handlerCESK- gameState %= execState (activateRobot 0)---- | Handle a user "piloting" input event for the REPL.-handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleREPLEventPiloting x = case x of- Key V.KUp -> inputCmd "move"- Key V.KDown -> inputCmd "turn back"- Key V.KLeft -> inputCmd "turn left"- Key V.KRight -> inputCmd "turn right"- ShiftKey V.KUp -> inputCmd "turn north"- ShiftKey V.KDown -> inputCmd "turn south"- ShiftKey V.KLeft -> inputCmd "turn west"- ShiftKey V.KRight -> inputCmd "turn east"- Key V.KDel -> inputCmd "selfdestruct"- CharKey 'g' -> inputCmd "grab"- CharKey 'h' -> inputCmd "harvest"- CharKey 'd' -> inputCmd "drill forward"- CharKey 'x' -> inputCmd "drill down"- CharKey 's' -> inputCmd "scan forward"- CharKey 'b' -> inputCmd "blocked"- CharKey 'u' -> inputCmd "upload base"- CharKey 'p' -> inputCmd "push"- _ -> inputCmd "noop"- where- inputCmd cmdText = do- uiState . uiREPL %= setCmd (cmdText <> ";")- modify validateREPLForm- handleREPLEventTyping $ Key V.KEnter-- setCmd nt theRepl =- theRepl- & replPromptText .~ nt- & replPromptType .~ CmdPrompt []--runBaseWebCode :: (MonadState AppState m) => T.Text -> m ()-runBaseWebCode uinput = do- s <- get- let topCtx = topContext s- unless (s ^. gameState . gameControls . replWorking) $- runBaseCode topCtx uinput--runBaseCode :: (MonadState AppState m) => RobotContext -> T.Text -> m ()-runBaseCode topCtx uinput = do- uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput)- uiState %= resetREPL "" (CmdPrompt [])- case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of- Right mt -> do- uiState . uiREPL . replHistory . replHasExecutedManualInput .= True- runBaseTerm topCtx mt- Left err -> do- uiState . uiREPL . replHistory %= addREPLItem (REPLError err)--runBaseTerm :: (MonadState AppState m) => RobotContext -> Maybe ProcessedTerm -> m ()-runBaseTerm topCtx =- modify . maybe id startBaseProgram- where- -- The player typed something at the REPL and hit Enter; this- -- function takes the resulting ProcessedTerm (if the REPL- -- input is valid) and sets up the base robot to run it.- startBaseProgram t@(ProcessedTerm (Module tm _) reqs reqCtx) =- -- Set the REPL status to Working- (gameState . gameControls . replStatus .~ REPLWorking (Typed Nothing (tm ^. sType) reqs))- -- The `reqCtx` maps names of variables defined in the- -- term (by `def` statements) to their requirements.- -- E.g. if we had `def m = move end`, the reqCtx would- -- record the fact that `m` needs the `move` capability.- -- We simply add the entire `reqCtx` to the robot's- -- context, so we can look up requirements if we later- -- need to requirements-check an argument to `build` or- -- `reprogram` at runtime. See the discussion at- -- https://github.com/swarm-game/swarm/pull/827 for more- -- details.- . (gameState . baseRobot . robotContext . defReqs <>~ reqCtx)- -- Set up the robot's CESK machine to evaluate/execute the- -- given term, being sure to initialize the CESK machine- -- environment and store from the top-level context.- . (gameState . baseRobot . machine .~ initMachine t (topCtx ^. defVals) (topCtx ^. defStore))- -- Finally, be sure to activate the base robot.- . (gameState %~ execState (activateRobot 0))---- | Handle a user input event for the REPL.-handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleREPLEventTyping = \case- -- Scroll the REPL on PageUp or PageDown- Key V.KPageUp -> vScrollPage replScroll Brick.Up- Key V.KPageDown -> vScrollPage replScroll Brick.Down- k -> do- -- On any other key event, jump to the bottom of the REPL then handle the event- vScrollToEnd replScroll- case k of- Key V.KEnter -> do- s <- get- let topCtx = topContext s- theRepl = s ^. uiState . uiREPL- uinput = theRepl ^. replPromptText-- if not $ s ^. gameState . gameControls . replWorking- then case theRepl ^. replPromptType of- CmdPrompt _ -> do- runBaseCode topCtx uinput- invalidateCacheEntry REPLHistoryCache- SearchPrompt hist ->- case lastEntry uinput hist of- Nothing -> uiState %= resetREPL "" (CmdPrompt [])- Just found- | T.null uinput -> uiState %= resetREPL "" (CmdPrompt [])- | otherwise -> do- uiState %= resetREPL found (CmdPrompt [])- modify validateREPLForm- else continueWithoutRedraw- Key V.KUp -> modify $ adjReplHistIndex Older- Key V.KDown -> modify $ adjReplHistIndex Newer- ControlChar 'r' -> do- s <- get- let uinput = s ^. uiState . uiREPL . replPromptText- case s ^. uiState . uiREPL . replPromptType of- CmdPrompt _ -> uiState . uiREPL . replPromptType .= SearchPrompt (s ^. uiState . uiREPL . replHistory)- SearchPrompt rh -> case lastEntry uinput rh of- Nothing -> pure ()- Just found -> uiState . uiREPL . replPromptType .= SearchPrompt (removeEntry found rh)- CharKey '\t' -> do- s <- get- let names = s ^.. gameState . baseRobot . robotContext . defTypes . to assocs . traverse . _1- uiState . uiREPL %= tabComplete names (s ^. gameState . landscape . entityMap)- modify validateREPLForm- EscapeKey -> do- formSt <- use $ uiState . uiREPL . replPromptType- case formSt of- CmdPrompt {} -> continueWithoutRedraw- SearchPrompt _ ->- uiState %= resetREPL "" (CmdPrompt [])- ControlChar 'd' -> do- text <- use $ uiState . uiREPL . replPromptText- if text == T.empty- then toggleModal QuitModal- else continueWithoutRedraw- -- finally if none match pass the event to the editor- ev -> do- Brick.zoom (uiState . uiREPL . replPromptEditor) (handleEditorEvent ev)- uiState . uiREPL . replPromptType %= \case- CmdPrompt _ -> CmdPrompt [] -- reset completions on any event passed to editor- SearchPrompt a -> SearchPrompt a- modify validateREPLForm--data CompletionType- = FunctionName- | EntityName- deriving (Eq)---- | Try to complete the last word in a partially-entered REPL prompt using--- reserved words and names in scope (in the case of function names) or--- entity names (in the case of string literals).-tabComplete :: [Var] -> EntityMap -> REPLState -> REPLState-tabComplete names em theRepl = case theRepl ^. replPromptType of- SearchPrompt _ -> theRepl- CmdPrompt mms- -- Case 1: If completion candidates have already been- -- populated via case (3), cycle through them.- -- Note that tabbing through the candidates *does* update the value- -- of "t", which one might think would narrow the candidate list- -- to only that match and therefore halt the cycling.- -- However, the candidate list only gets recomputed (repopulated)- -- if the user subsequently presses a non-Tab key. Thus the current- -- value of "t" is ignored for all Tab presses subsequent to the- -- first.- | (m : ms) <- mms -> setCmd (replacementFunc m) (ms ++ [m])- -- Case 2: Require at least one letter to be typed in order to offer completions for- -- function names.- -- We allow suggestions for Entity Name strings without anything having been typed.- | T.null lastWord && completionType == FunctionName -> setCmd t []- -- Case 3: Typing another character in the REPL clears the completion candidates from- -- the CmdPrompt, so when Tab is pressed again, this case then gets executed and- -- repopulates them.- | otherwise -> case candidateMatches of- [] -> setCmd t []- [m] -> setCmd (completeWith m) []- -- Perform completion with the first candidate, then populate the list- -- of all candidates with the current completion moved to the back- -- of the queue.- (m : ms) -> setCmd (completeWith m) (ms ++ [m])- where- -- checks the "parity" of the number of quotes. If odd, then there is an open quote.- hasOpenQuotes = (== 1) . (`mod` 2) . T.count "\""-- completionType =- if hasOpenQuotes t- then EntityName- else FunctionName-- replacementFunc = T.append $ T.dropWhileEnd replacementBoundaryPredicate t- completeWith m = T.append t $ T.drop (T.length lastWord) m- lastWord = T.takeWhileEnd replacementBoundaryPredicate t- candidateMatches = filter (lastWord `T.isPrefixOf`) replacementCandidates-- (replacementCandidates, replacementBoundaryPredicate) = case completionType of- EntityName -> (entityNames, (/= '"'))- FunctionName -> (possibleWords, isIdentChar)-- possibleWords = reservedWords ++ names-- entityNames = M.keys $ entitiesByName em-- t = theRepl ^. replPromptText- setCmd nt ms =- theRepl- & replPromptText .~ nt- & replPromptType .~ CmdPrompt ms---- | Validate the REPL input when it changes: see if it parses and--- typechecks, and set the color accordingly.-validateREPLForm :: AppState -> AppState-validateREPLForm s =- case replPrompt of- CmdPrompt _- | T.null uinput ->- let theType = s ^. gameState . gameControls . replStatus . replActiveType- in s & uiState . uiREPL . replType .~ theType- CmdPrompt _- | otherwise ->- let result = processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput- theType = case result of- Right (Just (ProcessedTerm (Module tm _) _ _)) -> Just (tm ^. sType)- _ -> Nothing- in s- & uiState . uiREPL . replValid .~ isRight result- & uiState . uiREPL . replType .~ theType- SearchPrompt _ -> s- where- uinput = s ^. uiState . uiREPL . replPromptText- replPrompt = s ^. uiState . uiREPL . replPromptType- topCtx = topContext s---- | Update our current position in the REPL history.-adjReplHistIndex :: TimeDir -> AppState -> AppState-adjReplHistIndex d s =- s- & uiState . uiREPL %~ moveREPL- & validateREPLForm- where- moveREPL :: REPLState -> REPLState- moveREPL theRepl =- newREPL- & (if replIndexIsAtInput (theRepl ^. replHistory) then saveLastEntry else id)- & (if oldEntry /= newEntry then showNewEntry else id)- where- -- new AppState after moving the repl index- newREPL :: REPLState- newREPL = theRepl & replHistory %~ moveReplHistIndex d oldEntry-- saveLastEntry = replLast .~ (theRepl ^. replPromptText)- showNewEntry = (replPromptEditor .~ newREPLEditor newEntry) . (replPromptType .~ CmdPrompt [])- -- get REPL data- getCurrEntry = fromMaybe (theRepl ^. replLast) . getCurrentItemText . view replHistory- oldEntry = getCurrEntry theRepl- newEntry = getCurrEntry newREPL----------------------------------------------------------------- World events---------------------------------------------------------------worldScrollDist :: Int32-worldScrollDist = 8--onlyCreative :: (MonadState AppState m) => m () -> m ()-onlyCreative a = do- c <- use $ gameState . creativeMode- when c a---- | Handle a user input event in the world view panel.-handleWorldEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleWorldEvent = \case- Key k- | k `elem` moveKeys -> do- c <- use $ gameState . creativeMode- s <- use $ gameState . landscape . worldScrollable- when (c || s) $ scrollView (.+^ (worldScrollDist *^ keyToDir k))- CharKey 'c' -> do- invalidateCacheEntry WorldCache- gameState . viewCenterRule .= VCRobot 0- -- show fps- CharKey 'f' -> uiState . uiShowFPS %= not- -- Fall-through case: don't do anything.- _ -> continueWithoutRedraw- where- moveKeys =- [ V.KUp- , V.KDown- , V.KLeft- , V.KRight- , V.KChar 'h'- , V.KChar 'j'- , V.KChar 'k'- , V.KChar 'l'- ]---- | Manually scroll the world view.-scrollView :: (Location -> Location) -> EventM Name AppState ()-scrollView update = do- -- Manually invalidate the 'WorldCache' instead of just setting- -- 'needsRedraw'. I don't quite understand why the latter doesn't- -- always work, but there seems to be some sort of race condition- -- where 'needsRedraw' gets reset before the UI drawing code runs.- invalidateCacheEntry WorldCache- gameState %= modifyViewCenter (fmap update)---- | Convert a directional key into a direction.-keyToDir :: V.Key -> Heading-keyToDir V.KUp = north-keyToDir V.KDown = south-keyToDir V.KRight = east-keyToDir V.KLeft = west-keyToDir (V.KChar 'h') = west-keyToDir (V.KChar 'j') = south-keyToDir (V.KChar 'k') = north-keyToDir (V.KChar 'l') = east-keyToDir _ = zero---- | Adjust the ticks per second speed.-adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState-adjustTPS (+/-) = uiState . lgTicksPerSecond %~ (+/- 1)----------------------------------------------------------------- Robot panel events----------------------------------------------------------------- | Handle user input events in the robot panel.-handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleRobotPanelEvent bev = do- search <- use (uiState . uiInventorySearch)- case search of- Just _ -> handleInventorySearchEvent bev- Nothing -> case bev of- Key V.KEnter ->- gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal- CharKey 'm' ->- gets focusedEntity >>= maybe continueWithoutRedraw makeEntity- CharKey '0' -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiShowZero %= not- CharKey ';' -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySort %= cycleSortOrder- CharKey ':' -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySort %= cycleSortDirection- CharKey '/' -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySearch .= Just ""- VtyEvent ev -> handleInventoryListEvent ev- _ -> continueWithoutRedraw---- | Handle an event to navigate through the inventory list.-handleInventoryListEvent :: V.Event -> EventM Name AppState ()-handleInventoryListEvent ev = do- -- Note, refactoring like this is tempting:- --- -- Brick.zoom (uiState . uiInventory . _Just . _2) (handleListEventWithSeparators ev (is _Separator))- --- -- However, this does not work since we want to skip redrawing in the no-list case!-- mList <- preuse $ uiState . uiInventory . _Just . _2- case mList of- Nothing -> continueWithoutRedraw- Just l -> do- l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator))- uiState . uiInventory . _Just . _2 .= l'---- | Handle a user input event in the robot/inventory panel, while in--- inventory search mode.-handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()-handleInventorySearchEvent = \case- -- Escape: stop filtering and go back to regular inventory mode- EscapeKey -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySearch .= Nothing- -- Enter: return to regular inventory mode, and pop out the selected item- Key V.KEnter -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySearch .= Nothing- gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal- -- Any old character: append to the current search string- CharKey c -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySearch %= fmap (`snoc` c)- -- Backspace: chop the last character off the end of the current search string- BackspaceKey -> do- uiState . uiInventoryShouldUpdate .= True- uiState . uiInventorySearch %= fmap (T.dropEnd 1)- -- Handle any other event as list navigation, so we can look through- -- the filtered inventory using e.g. arrow keys- VtyEvent ev -> handleInventoryListEvent ev- _ -> continueWithoutRedraw---- | Attempt to make an entity selected from the inventory, if the--- base is not currently busy.-makeEntity :: Entity -> EventM Name AppState ()-makeEntity e = do- s <- get- let name = e ^. entityName- mkPT = [tmQ| make $str:name |]- topStore =- fromMaybe emptyStore $- s ^? gameState . baseRobot . robotContext . defStore-- case isActive <$> (s ^? gameState . baseRobot) of- Just False -> do- gameState . gameControls . replStatus .= REPLWorking (Typed Nothing PolyUnit (R.singletonCap CMake))- gameState . baseRobot . machine .= initMachine mkPT empty topStore- gameState %= execState (activateRobot 0)- _ -> continueWithoutRedraw---- | Display a modal window with the description of an entity.-descriptionModal :: Entity -> EventM Name AppState ()-descriptionModal e = do- s <- get- uiState . uiModal ?= generateModal s (DescriptionModal e)----------------------------------------------------------------- Info panel events----------------------------------------------------------------- | Handle user events in the info panel (just scrolling).-handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState ()-handleInfoPanelEvent vs = \case- Key V.KDown -> vScrollBy vs 1- Key V.KUp -> vScrollBy vs (-1)- CharKey 'k' -> vScrollBy vs 1- CharKey 'j' -> vScrollBy vs (-1)- Key V.KPageDown -> vScrollPage vs Brick.Down- Key V.KPageUp -> vScrollPage vs Brick.Up- Key V.KHome -> vScrollToBeginning vs- Key V.KEnd -> vScrollToEnd vs- _ -> return ()
@@ -1,96 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}---- |--- SPDX-License-Identifier: BSD-3-Clause-module Swarm.TUI.Controller.Util where--import Brick hiding (Direction)-import Brick.Focus-import Control.Lens-import Control.Monad (forM_, unless)-import Control.Monad.IO.Class (liftIO)-import Data.Map qualified as M-import Graphics.Vty qualified as V-import Swarm.Game.State-import Swarm.Game.Universe-import Swarm.Game.World qualified as W-import Swarm.TUI.Model-import Swarm.TUI.Model.UI-import Swarm.TUI.View.Util (generateModal)---- | Pattern synonyms to simplify brick event handler-pattern Key :: V.Key -> BrickEvent n e-pattern Key k = VtyEvent (V.EvKey k [])--pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e-pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) [])-pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl])-pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])--pattern ShiftKey :: V.Key -> BrickEvent n e-pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift])--pattern EscapeKey :: BrickEvent n e-pattern EscapeKey = VtyEvent (V.EvKey V.KEsc [])--pattern BackspaceKey :: BrickEvent n e-pattern BackspaceKey = VtyEvent (V.EvKey V.KBS [])--pattern FKey :: Int -> BrickEvent n e-pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])--openModal :: ModalType -> EventM Name AppState ()-openModal mt = do- newModal <- gets $ flip generateModal mt- ensurePause- uiState . uiModal ?= newModal- -- Beep- case mt of- ScenarioEndModal _ -> do- vty <- getVtyHandle- liftIO $ V.ringTerminalBell $ V.outputIface vty- _ -> return ()- where- -- Set the game to AutoPause if needed- ensurePause = do- pause <- use $ gameState . temporal . paused- unless (pause || isRunningModal mt) $ do- gameState . temporal . runStatus .= AutoPause---- | The running modals do not autopause the game.-isRunningModal :: ModalType -> Bool-isRunningModal = \case- RobotsModal -> True- MessagesModal -> True- _ -> False--setFocus :: FocusablePanel -> EventM Name AppState ()-setFocus name = uiState . uiFocusRing %= focusSetCurrent (FocusablePanel name)--immediatelyRedrawWorld :: EventM Name AppState ()-immediatelyRedrawWorld = do- invalidateCacheEntry WorldCache- loadVisibleRegion---- | Make sure all tiles covering the visible part of the world are--- loaded.-loadVisibleRegion :: EventM Name AppState ()-loadVisibleRegion = do- mext <- lookupExtent WorldExtent- forM_ mext $ \(Extent _ _ size) -> do- gs <- use gameState- let vr = viewingRegion (gs ^. viewCenter) (over both fromIntegral size)- gameState . landscape . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld)--mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmic W.Coords))-mouseLocToWorldCoords (Brick.Location mouseLoc) = do- mext <- lookupExtent WorldExtent- case mext of- Nothing -> pure Nothing- Just ext -> do- region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext)) . view viewCenter- let regionStart = W.unCoords (fst $ region ^. planar)- mouseLoc' = bimap fromIntegral fromIntegral mouseLoc- mx = snd mouseLoc' + fst regionStart- my = fst mouseLoc' + snd regionStart- in pure . Just $ Cosmic (region ^. subworld) $ W.Coords (mx, my)
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff
file too large to diff