diff --git a/.github/workflows/check_todos.yml b/.github/workflows/check_todos.yml index 9097b29f9..6afdd1382 100644 --- a/.github/workflows/check_todos.yml +++ b/.github/workflows/check_todos.yml @@ -17,4 +17,4 @@ jobs: steps: - uses: actions/checkout@v2 - run: | - scripts/enforce-todo-issues.sh + scripts/validate/issues-for-todos.sh diff --git a/.github/workflows/scenario-schema.yml b/.github/workflows/scenario-schema.yml index 3a81ccc01..41db9cad8 100644 --- a/.github/workflows/scenario-schema.yml +++ b/.github/workflows/scenario-schema.yml @@ -25,4 +25,4 @@ jobs: python -m pip install --upgrade pip pip install check-jsonschema - run: | - scripts/validate-json-schemas.sh + scripts/validate/json-schemas.sh diff --git a/.github/workflows/yaml-normalization.yml b/.github/workflows/yaml-normalization.yml index d9d42125b..dd62f503e 100644 --- a/.github/workflows/yaml-normalization.yml +++ b/.github/workflows/yaml-normalization.yml @@ -23,5 +23,5 @@ jobs: - uses: actions/checkout@v3 - name: Normalize run: | - scripts/normalize-all-yaml.sh + scripts/normalize/yaml.sh git diff --name-only --exit-code diff --git a/.gitignore b/.gitignore index e8e8e452d..a61330eb0 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,7 @@ stan.html .swarm_history +*.db *.orig *.aux *.log diff --git a/.vscode/settings.json b/.vscode/settings.json index 734e8f7e7..4b2ddce5c 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -4,6 +4,9 @@ "data/scenarios/**/*.yaml", "scenarios/**/*.yaml" ], + "data/schema/terrains.json": [ + "data/terrains.yaml" + ], "data/schema/entities.json": [ "data/entities.yaml" ], diff --git a/app/doc/Main.hs b/app/doc/Main.hs index cb3accf5c..0fe5d26f1 100644 --- a/app/doc/Main.hs +++ b/app/doc/Main.hs @@ -47,6 +47,7 @@ cliParser = Data.Foldable.asum [ pure Nothing , Just Entities <$ switch (long "entities" <> help "Generate entities page (uses data from entities.yaml)") + , Just Terrain <$ switch (long "terrain" <> help "Generate terrain page (uses data from terrains.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)") diff --git a/app/doc/Swarm/Doc/Gen.hs b/app/doc/Swarm/Doc/Gen.hs index d2bf8d963..6759306af 100644 --- a/app/doc/Swarm/Doc/Gen.hs +++ b/app/doc/Swarm/Doc/Gen.hs @@ -35,9 +35,10 @@ import Swarm.Doc.Util import Swarm.Doc.Wiki.Cheatsheet import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName) import Swarm.Game.Entity qualified as E +import Swarm.Game.Land import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs) import Swarm.Game.Robot (Robot, equippedDevices, robotInventory) -import Swarm.Game.Scenario (GameStateInputs (..), loadStandaloneScenario, scenarioLandscape) +import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..), loadStandaloneScenario, scenarioLandscape) import Swarm.Game.World.Gen (extractEntities) import Swarm.Game.World.Typecheck (Some (..), TTerm) import Swarm.Language.Key (specialKeyNames) @@ -135,7 +136,7 @@ generateSpecialKeyNames = generateRecipe :: IO String generateRecipe = simpleErrorHandle $ do - (classic, GameStateInputs worlds entities recipes) <- loadStandaloneScenario "data/scenarios/classic.yaml" + (classic, GameStateInputs (ScenarioInputs worlds (TerrainEntityMaps _ entities)) recipes) <- loadStandaloneScenario "data/scenarios/classic.yaml" baseRobot <- instantiateBaseRobot $ classic ^. scenarioLandscape return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes diff --git a/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs b/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs index b7c4a5102..363a8c054 100644 --- a/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs +++ b/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs @@ -31,6 +31,7 @@ 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.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight) +import Swarm.Game.Terrain (loadTerrain, terrainByName) import Swarm.Language.Capability (Capability) import Swarm.Language.Capability qualified as Capability import Swarm.Language.Pretty (prettyText, prettyTextLine) @@ -38,7 +39,7 @@ 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 (listEnums) +import Swarm.Util (listEnums, showT) import Swarm.Util.Effect (simpleErrorHandle) -- * Types @@ -54,7 +55,7 @@ data PageAddress = PageAddress deriving (Eq, Show) -- | An enumeration of the kinds of cheat sheets we can produce. -data SheetType = Entities | Commands | CommandMatrix | Capabilities | Recipes | Scenario +data SheetType = Entities | Terrain | Commands | CommandMatrix | Capabilities | Recipes | Scenario deriving (Eq, Show, Enum, Bounded) -- * Functions @@ -73,6 +74,9 @@ makeWikiPage address s = case s of Entities -> simpleErrorHandle $ do entities <- loadEntities sendIO $ T.putStrLn $ entitiesPage address (Map.elems $ entitiesByName entities) + Terrain -> simpleErrorHandle $ do + terrains <- loadTerrain + sendIO . T.putStrLn . T.unlines . map showT . Map.elems $ terrainByName terrains Recipes -> simpleErrorHandle $ do entities <- loadEntities recipes <- loadRecipes entities diff --git a/data/scenarios/Challenges/Ranching/gated-paddock.yaml b/data/scenarios/Challenges/Ranching/gated-paddock.yaml index 40bb5f70a..825a9eb91 100644 --- a/data/scenarios/Challenges/Ranching/gated-paddock.yaml +++ b/data/scenarios/Challenges/Ranching/gated-paddock.yaml @@ -224,8 +224,9 @@ robots: dir: north inventory: - [4, wool] - unwalkable: - - gate + walkable: + never: + - gate program: | run "scenarios/Challenges/Ranching/_gated-paddock/meandering-sheep.sw"; entities: diff --git a/data/scenarios/Challenges/Sokoban/_foresight/solution.sw b/data/scenarios/Challenges/Sokoban/_foresight/solution.sw index 9f167392d..fd00deb37 100644 --- a/data/scenarios/Challenges/Sokoban/_foresight/solution.sw +++ b/data/scenarios/Challenges/Sokoban/_foresight/solution.sw @@ -139,7 +139,7 @@ def firstLeg = pushUntilBarrier; wait 4; - move; + moveUntilBlocked; doN 5 (turn left; moveUntilBlocked); turn right; diff --git a/data/scenarios/Challenges/_combo-lock/solution.sw b/data/scenarios/Challenges/_combo-lock/solution.sw index a51af436a..3483ff327 100644 --- a/data/scenarios/Challenges/_combo-lock/solution.sw +++ b/data/scenarios/Challenges/_combo-lock/solution.sw @@ -4,7 +4,6 @@ def moveToLock = end; def cycleCombos = \n. - wait 1; entityNorth <- scan north; let hasGate = case entityNorth (\_. false) (\x. x == "gate") in if hasGate { diff --git a/data/scenarios/Challenges/_word-search/create-puzzle.sw b/data/scenarios/Challenges/_word-search/create-puzzle.sw index 48023b1f9..8b748a48f 100644 --- a/data/scenarios/Challenges/_word-search/create-puzzle.sw +++ b/data/scenarios/Challenges/_word-search/create-puzzle.sw @@ -153,7 +153,7 @@ def singleTile = \expectedFwdOrdinal. \expectedBkwdOrdinal. return letterIndex; end; -def crossBack = \n. +def crossBack = \_n. currentLoc <- whereami; teleport self (0, snd currentLoc - 1); end; diff --git a/data/scenarios/Challenges/_word-search/verify-solution.sw b/data/scenarios/Challenges/_word-search/verify-solution.sw deleted file mode 100644 index 40405badb..000000000 --- a/data/scenarios/Challenges/_word-search/verify-solution.sw +++ /dev/null @@ -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}; \ No newline at end of file diff --git a/data/scenarios/Challenges/word-search.yaml b/data/scenarios/Challenges/word-search.yaml index 1cafa1230..d873f5c90 100644 --- a/data/scenarios/Challenges/word-search.yaml +++ b/data/scenarios/Challenges/word-search.yaml @@ -14,189 +14,8 @@ objectives: 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: @@ -301,6 +120,16 @@ entities: description: - Ink for marking found words 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] diff --git a/data/scenarios/README.md b/data/scenarios/README.md index 23f3dccd9..4bbbacdde 100644 --- a/data/scenarios/README.md +++ b/data/scenarios/README.md @@ -67,7 +67,7 @@ You can also check the files from the command line: # install latest check-jsonschema executable version pip install check-jsonschema # try it on provided scenarios -scripts/validate-json-schemas.sh +scripts/validate/json-schemas.sh ``` ### YAML schema diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index d7d06b4b6..31aa77126 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -46,12 +46,17 @@ Achievements 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 +1775-custom-terrain.yaml diff --git a/data/scenarios/Testing/1322-wait-with-instant.yaml b/data/scenarios/Testing/1322-wait-with-instant.yaml new file mode 100644 index 000000000..17309e73c --- /dev/null +++ b/data/scenarios/Testing/1322-wait-with-instant.yaml @@ -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. diff --git a/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml b/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml index 9065f2ce8..919bec3d4 100644 --- a/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml +++ b/data/scenarios/Testing/1536-custom-unwalkable-entities.yaml @@ -31,8 +31,9 @@ robots: - treads - dictionary - net - unwalkable: - - tree + walkable: + never: + - tree known: [tree, flower, bitcoin] world: palette: diff --git a/data/scenarios/Testing/1598-detect-entity-change.yaml b/data/scenarios/Testing/1598-detect-entity-change.yaml new file mode 100644 index 000000000..bddcdefe8 --- /dev/null +++ b/data/scenarios/Testing/1598-detect-entity-change.yaml @@ -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 diff --git a/data/scenarios/Testing/1721-custom-walkable-entities.yaml b/data/scenarios/Testing/1721-custom-walkable-entities.yaml new file mode 100644 index 000000000..a8d590a6f --- /dev/null +++ b/data/scenarios/Testing/1721-custom-walkable-entities.yaml @@ -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. diff --git a/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml b/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml new file mode 100644 index 000000000..2d3910b1e --- /dev/null +++ b/data/scenarios/Testing/1721-walkability-whitelist-path-cache.yaml @@ -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..... diff --git a/data/scenarios/Testing/1775-custom-terrain.yaml b/data/scenarios/Testing/1775-custom-terrain.yaml new file mode 100644 index 000000000..6fa9e93e3 --- /dev/null +++ b/data/scenarios/Testing/1775-custom-terrain.yaml @@ -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 diff --git a/data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml b/data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml new file mode 100644 index 000000000..ed7739ec0 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1775-invalid-terrain-attr.yaml @@ -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. + .. diff --git a/data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml b/data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml new file mode 100644 index 000000000..6897a1424 --- /dev/null +++ b/data/scenarios/Testing/_Validation/1775-invalid-terrain-reference.yaml @@ -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. + .. diff --git a/data/schema/robot.json b/data/schema/robot.json index 526c702c6..525761a1b 100644 --- a/data/schema/robot.json +++ b/data/schema/robot.json @@ -77,13 +77,28 @@ "type": "boolean", "description": "Whether the robot is heavy. Heavy robots require `tank treads` to `move` (rather than just `treads` for other robots)." }, - "unwalkable": { - "default": [], - "type": "array", - "items": { - "type": "string" - }, - "description": "A list of entities that this robot cannot walk across." + "walkable": { + "type": "object", + "additionalProperties": false, + "description": "Blacklist/whitelist of walkable entities", + "properties": { + "never": { + "default": [], + "type": "array", + "items": { + "type": "string" + }, + "description": "A list of entities that this robot cannot walk across." + }, + "only": { + "default": [], + "type": "array", + "items": { + "type": "string" + }, + "description": "An exclusive list of entities that this robot can walk across." + } + } } }, "required": [ diff --git a/data/schema/scenario.json b/data/schema/scenario.json index 07f881f58..8aa793701 100644 --- a/data/schema/scenario.json +++ b/data/schema/scenario.json @@ -32,6 +32,13 @@ "default": null, "type": "number" }, + "terrains": { + "description": "An optional list of custom terrain, to be used in addition to the built-in terrain.", + "default": [], + "items": { + "$ref": "terrain.json" + } + }, "entities": { "description": "An optional list of custom entities, to be used in addition to the built-in entities.", "default": [], diff --git a/data/schema/terrain.json b/data/schema/terrain.json new file mode 100644 index 000000000..972804ce2 --- /dev/null +++ b/data/schema/terrain.json @@ -0,0 +1,27 @@ +{ + "$schema": "http://json-schema.org/draft-07/schema#", + "$id": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/terrain.json", + "title": "Terrain", + "description": "Description of a terrain in the Swarm game", + "type": "object", + "additionalProperties": false, + "properties": { + "name": { + "type": "string", + "description": "The name of the terrain." + }, + "description": { + "type": "string", + "description": "A description of the terrain." + }, + "attr": { + "type": "string", + "examples": [ + "red", + "ice", + "dirt" + ], + "description": "The name of the attribute that should be used to style the robot or entity. A list of currently valid attributes can be found [here](https://github.com/swarm-game/swarm/blob/main/src/Swarm/TUI/View/Attribute/Attr.hs)." + } + } +} diff --git a/data/schema/terrains.json b/data/schema/terrains.json new file mode 100644 index 000000000..2c1d629c7 --- /dev/null +++ b/data/schema/terrains.json @@ -0,0 +1,10 @@ +{ + "$schema": "http://json-schema.org/draft-07/schema#", + "$id": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/terrains.json", + "title": "Terrains", + "description": "Description of terrains in the Swarm game", + "type": "array", + "items": { + "$ref": "terrain.json" + } +} diff --git a/data/terrains.yaml b/data/terrains.yaml new file mode 100644 index 000000000..9468d9b10 --- /dev/null +++ b/data/terrains.yaml @@ -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. diff --git a/scripts/benchmark-against-ancestor.sh b/scripts/benchmark-against-ancestor.sh new file mode 100755 index 000000000..12fb8a6b8 --- /dev/null +++ b/scripts/benchmark-against-ancestor.sh @@ -0,0 +1,25 @@ +#!/bin/bash -xe + +# Requires that the working tree be clean. + +REFERENCE_COMMIT=${1:-HEAD~} + +SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) +cd $SCRIPT_DIR/.. + +if git diff --quiet --exit-code +then + echo "Working tree is clean. Starting benchmarks..." +else + echo "Working tree is dirty! Quitting." + exit 1 +fi + +BASELINE_OUTPUT=baseline.csv + +git checkout $REFERENCE_COMMIT + +scripts/run-benchmarks.sh "--csv $BASELINE_OUTPUT" + +git switch - +scripts/run-benchmarks.sh "--baseline $BASELINE_OUTPUT --fail-if-slower 3" \ No newline at end of file diff --git a/scripts/benchmark-against-parent.sh b/scripts/benchmark-against-parent.sh index d530d1155..2a9a63a3a 100755 --- a/scripts/benchmark-against-parent.sh +++ b/scripts/benchmark-against-parent.sh @@ -1,23 +1,6 @@ #!/bin/bash -xe -# Requires that the working tree be clean. - SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) cd $SCRIPT_DIR/.. -if git diff --quiet --exit-code -then - echo "Working tree is clean. Starting benchmarks..." -else - echo "Working tree is dirty! Quitting." - exit 1 -fi - -BASELINE_OUTPUT=baseline.csv - -git checkout HEAD~ - -scripts/run-benchmarks.sh "--csv $BASELINE_OUTPUT" - -git switch - -scripts/run-benchmarks.sh "--baseline $BASELINE_OUTPUT --fail-if-slower 3" \ No newline at end of file +scripts/benchmark-against-ancestor.sh HEAD~ \ No newline at end of file diff --git a/scripts/autopopulate-spellchecker.sh b/scripts/gen/autopopulate-spellchecker.sh similarity index 98% rename from scripts/autopopulate-spellchecker.sh rename to scripts/gen/autopopulate-spellchecker.sh index 31aa7bf2c..b642c3c2a 100755 --- a/scripts/autopopulate-spellchecker.sh +++ b/scripts/gen/autopopulate-spellchecker.sh @@ -3,7 +3,7 @@ # This script lives 1 level deep in the directory structure. # Ensure its commands get run at the toplevel. SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. # First, install hiedb: diff --git a/scripts/view-haddocks.sh b/scripts/gen/haddocks.sh similarity index 93% rename from scripts/view-haddocks.sh rename to scripts/gen/haddocks.sh index 5c9fc2f04..c50b3b8ff 100755 --- a/scripts/view-haddocks.sh +++ b/scripts/gen/haddocks.sh @@ -1,7 +1,7 @@ #!/bin/bash -ex SCRIPT_DIR=$(cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. cabal haddock diff --git a/scripts/gen/list-sublibraries.sh b/scripts/gen/list-sublibraries.sh new file mode 100755 index 000000000..367c2a329 --- /dev/null +++ b/scripts/gen/list-sublibraries.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +cd $(git rev-parse --show-toplevel) + +grep '^library \w' swarm.cabal | cut -d' ' -f2 diff --git a/scripts/render-sublibrary-dependencies.sh b/scripts/gen/render-sublibrary-dependencies.sh similarity index 96% rename from scripts/render-sublibrary-dependencies.sh rename to scripts/gen/render-sublibrary-dependencies.sh index 13c5dc919..25e8e2f59 100755 --- a/scripts/render-sublibrary-dependencies.sh +++ b/scripts/gen/render-sublibrary-dependencies.sh @@ -1,7 +1,7 @@ #!/bin/bash -ex SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. # First, install cabal-plan: # diff --git a/scripts/regenerate-schema-docs.sh b/scripts/gen/schema-docs.sh similarity index 88% rename from scripts/regenerate-schema-docs.sh rename to scripts/gen/schema-docs.sh index 0bc3b9ffd..e97c07365 100755 --- a/scripts/regenerate-schema-docs.sh +++ b/scripts/gen/schema-docs.sh @@ -1,6 +1,6 @@ #!/bin/bash -e SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. stack build --fast && stack exec -- swarm generate cheatsheet --scenario \ No newline at end of file diff --git a/scripts/normalize-cabal.sh b/scripts/normalize/cabal.sh similarity index 89% rename from scripts/normalize-cabal.sh rename to scripts/normalize/cabal.sh index a4cdce725..aac7d8113 100755 --- a/scripts/normalize-cabal.sh +++ b/scripts/normalize/cabal.sh @@ -1,7 +1,7 @@ #!/bin/bash -ex SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. CABAL_FILE=swarm.cabal cabal-gild --input $CABAL_FILE --output $CABAL_FILE --mode format diff --git a/scripts/reformat-code.sh b/scripts/normalize/code-format.sh similarity index 87% rename from scripts/reformat-code.sh rename to scripts/normalize/code-format.sh index c4cc8e7e5..c1b88bf9c 100755 --- a/scripts/reformat-code.sh +++ b/scripts/normalize/code-format.sh @@ -1,6 +1,6 @@ #!/bin/bash -e SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. fourmolu --mode=inplace src app test scripts \ No newline at end of file diff --git a/scripts/normalize-all-yaml.sh b/scripts/normalize/yaml.sh similarity index 92% rename from scripts/normalize-all-yaml.sh rename to scripts/normalize/yaml.sh index 265112ec7..975117020 100755 --- a/scripts/normalize-all-yaml.sh +++ b/scripts/normalize/yaml.sh @@ -1,7 +1,7 @@ #!/bin/bash -e SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. find data -type f -name '*.yaml' -print0 | xargs -0 --max-args 1 sed -i -e 's/[[:blank:]]\+$//' diff --git a/scripts/enforce-todo-issues.sh b/scripts/validate/issues-for-todos.sh similarity index 83% rename from scripts/enforce-todo-issues.sh rename to scripts/validate/issues-for-todos.sh index 1d0fdfcad..fb87397bb 100755 --- a/scripts/enforce-todo-issues.sh +++ b/scripts/validate/issues-for-todos.sh @@ -1,10 +1,10 @@ #!/bin/bash -e SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. -if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\b' src 2>&1 | grep -vP '#\d+'; then +if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\b' src app 2>&1 | grep -vP '#\d+'; then echo "Please add a link to Issue, for example: TODO: #123" exit 1 else diff --git a/scripts/validate-json-schemas.sh b/scripts/validate/json-schemas.sh similarity index 77% rename from scripts/validate-json-schemas.sh rename to scripts/validate/json-schemas.sh index 8287d6780..95bf25a14 100755 --- a/scripts/validate-json-schemas.sh +++ b/scripts/validate/json-schemas.sh @@ -1,9 +1,10 @@ #!/bin/bash -e SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $SCRIPT_DIR/../.. find data/scenarios -name "*.yaml" -type f -print0 | xargs -0 check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/scenario.json --schemafile data/schema/scenario.json +check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/terrains.json --schemafile data/schema/terrains.json data/terrains.yaml check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/entities.json --schemafile data/schema/entities.json data/entities.yaml check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/recipes.json --schemafile data/schema/recipes.json data/recipes.yaml \ No newline at end of file diff --git a/src/Swarm/Doc/Pedagogy.hs b/src/Swarm/Doc/Pedagogy.hs index 0727150ed..110ba86c1 100644 --- a/src/Swarm/Doc/Pedagogy.hs +++ b/src/Swarm/Doc/Pedagogy.hs @@ -31,10 +31,11 @@ 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.Land import Swarm.Game.Scenario ( Scenario, + ScenarioInputs (..), scenarioDescription, scenarioMetadata, scenarioName, @@ -174,13 +175,14 @@ generateIntroductionsSequence = -- For unit tests, can instead access the scenarios via the GameState. loadScenarioCollection :: IO ScenarioCollection loadScenarioCollection = simpleErrorHandle $ do - entities <- loadEntities + tem <- loadEntitiesAndTerrain + -- 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 + worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem + ignoreWarnings @(Seq SystemFailure) $ loadScenarios $ ScenarioInputs worlds tem renderUsagesMarkdown :: CoverageInfo -> Text renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) = diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 506a6992e..d8db13871 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -75,11 +75,13 @@ 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.Land import Swarm.Game.Location import Swarm.Game.ResourceLoading (getSwarmHistoryPath) import Swarm.Game.Robot import Swarm.Game.Robot.Concrete import Swarm.Game.Robot.Context +import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.ScenarioInfo @@ -318,7 +320,7 @@ handleMainEvent ev = do -- ctrl-q works everywhere ControlChar 'q' -> case s ^. gameState . winCondition of - WinConditions (Won _) _ -> toggleModal $ ScenarioEndModal WinModal + WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal _ -> toggleModal QuitModal VtyEvent (V.EvResize _ _) -> invalidateCache @@ -546,7 +548,7 @@ saveScenarioInfoOnFinish p = do t <- liftIO getZonedTime wc <- use $ gameState . winCondition let won = case wc of - WinConditions (Won _) _ -> True + WinConditions (Won _ _) _ -> True _ -> False ts <- use $ gameState . temporal . ticks @@ -639,7 +641,7 @@ quitGame = do -- player has won the current one. wc <- use $ gameState . winCondition case wc of - WinConditions (Won _) _ -> uiState . uiMenu %= advanceMenu + WinConditions (Won _ _) _ -> uiState . uiMenu %= advanceMenu _ -> return () -- Either quit the entire app (if the scenario was chosen directly @@ -931,9 +933,9 @@ doGoalUpdates = do openModal $ ScenarioEndModal LoseModal saveScenarioInfoOnFinishNocheat return True - WinConditions (Won False) x -> do + WinConditions (Won False ts) x -> do -- This clears the "flag" that the Win dialog needs to pop up - gameState . winCondition .= WinConditions (Won True) x + gameState . winCondition .= WinConditions (Won True ts) x openModal $ ScenarioEndModal WinModal saveScenarioInfoOnFinishNocheat -- We do NOT advance the New Game menu to the next item here (we @@ -1191,7 +1193,7 @@ handleREPLEventTyping = \case CharKey '\t' -> do s <- get let names = s ^.. gameState . baseRobot . robotContext . defTypes . to assocs . traverse . _1 - uiState . uiGameplay . uiREPL %= tabComplete (CompletionContext (s ^. gameState . creativeMode)) names (s ^. gameState . landscape . entityMap) + uiState . uiGameplay . uiREPL %= tabComplete (CompletionContext (s ^. gameState . creativeMode)) names (s ^. gameState . landscape . terrainAndEntities . entityMap) modify validateREPLForm EscapeKey -> do formSt <- use $ uiState . uiGameplay . uiREPL . replPromptType diff --git a/src/Swarm/TUI/Editor/Controller.hs b/src/Swarm/TUI/Editor/Controller.hs index 1b0cfe33a..19d20c9e8 100644 --- a/src/Swarm/TUI/Editor/Controller.hs +++ b/src/Swarm/TUI/Editor/Controller.hs @@ -16,6 +16,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Map qualified as M import Data.Yaml qualified as Y import Graphics.Vty qualified as V +import Swarm.Game.Land import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State import Swarm.Game.State.Landscape @@ -83,9 +84,11 @@ handleMiddleClick mouseLoc = do worldEditor <- use $ uiState . uiGameplay . uiWorldEditor when (worldEditor ^. worldOverdraw . isWorldEditorEnabled) $ do w <- use $ gameState . landscape . multiWorld + tm <- use $ gameState . landscape . terrainAndEntities . terrainMap let setTerrainPaint coords = do let (terrain, maybeElementPaint) = EU.getEditorContentAt + tm (worldEditor ^. worldOverdraw) w coords @@ -142,7 +145,8 @@ saveMapFile = do worldEditor <- use $ uiState . uiGameplay . uiWorldEditor maybeBounds <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsRect w <- use $ gameState . landscape . multiWorld - let mapCellGrid = EU.getEditedMapRectangle (worldEditor ^. worldOverdraw) maybeBounds w + tm <- use $ gameState . landscape . terrainAndEntities . terrainMap + let mapCellGrid = EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w let fp = worldEditor ^. outputFilePath maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef diff --git a/src/Swarm/TUI/Editor/Model.hs b/src/Swarm/TUI/Editor/Model.hs index 6b60d7bd5..a9bdd7698 100644 --- a/src/Swarm/TUI/Editor/Model.hs +++ b/src/Swarm/TUI/Editor/Model.hs @@ -79,7 +79,7 @@ initialWorldEditor :: TimeSpec -> WorldEditor Name initialWorldEditor ts = WorldEditor (WorldOverdraw False mempty) - (BL.list TerrainList (V.fromList listEnums) 1) + (BL.list TerrainList (V.fromList []) 1) (BL.list EntityPaintList (V.fromList []) 1) bounds (focusRing $ map WorldEditorPanelControl listEnums) diff --git a/src/Swarm/TUI/Editor/Palette.hs b/src/Swarm/TUI/Editor/Palette.hs index bbdd76de0..c8d3c9218 100644 --- a/src/Swarm/TUI/Editor/Palette.hs +++ b/src/Swarm/TUI/Editor/Palette.hs @@ -20,6 +20,7 @@ import Data.Text qualified as T import Data.Tuple (swap) import Swarm.Game.Display (Display, defaultChar) import Swarm.Game.Entity (Entity, EntityName, entitiesByName) +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Scenario import Swarm.Game.Scenario.Topography.Area @@ -27,19 +28,19 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Game.Terrain (TerrainType, getTerrainDefaultPaletteChar) +import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName) import Swarm.Game.Universe import Swarm.Language.Text.Markdown (fromText) import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario)) import Swarm.Util (binTuples, histogram) -import Swarm.Util qualified as U import Swarm.Util.Erasable makeSuggestedPalette :: + TerrainMap -> KM.KeyMap (AugmentedCell Entity) -> [[CellPaintDisplay]] -> KM.KeyMap (AugmentedCell EntityFacade) -makeSuggestedPalette originalScenarioPalette cellGrid = +makeSuggestedPalette tm originalScenarioPalette cellGrid = KM.fromMapText . M.map (AugmentedCell Nothing) . M.fromList @@ -109,7 +110,7 @@ makeSuggestedPalette originalScenarioPalette cellGrid = -- TODO (#1153): Filter out terrain-only palette entries that aren't actually -- used in the map. terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) - terrainOnlyPalette = M.fromList $ map f U.listEnums + terrainOnlyPalette = M.fromList . map f . M.keys $ terrainByName tm where f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) @@ -126,7 +127,8 @@ constructScenario maybeOriginalScenario (Grid cellGrid) = wd [] -- robots where - customEntities = maybe mempty (^. scenarioLandscape . scenarioEntities) maybeOriginalScenario + tem = maybe mempty (^. scenarioLandscape . scenarioTerrainAndEntities) maybeOriginalScenario + customEntities = tem ^. entityMap wd = WorldDescription { offsetOrigin = False @@ -142,7 +144,7 @@ constructScenario maybeOriginalScenario (Grid cellGrid) = extractPalette = unPalette . palette . NE.head . (^. scenarioLandscape . scenarioWorlds) originalPalette = maybe mempty extractPalette maybeOriginalScenario - suggestedPalette = makeSuggestedPalette originalPalette cellGrid + suggestedPalette = makeSuggestedPalette (tem ^. terrainMap) originalPalette cellGrid upperLeftCoord = Location diff --git a/src/Swarm/TUI/Editor/Util.hs b/src/Swarm/TUI/Editor/Util.hs index 3e2ada770..9b2b2c45c 100644 --- a/src/Swarm/TUI/Editor/Util.hs +++ b/src/Swarm/TUI/Editor/Util.hs @@ -14,7 +14,7 @@ import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.WorldDescription -import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Terrain (TerrainMap, TerrainType) import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Editor.Model @@ -37,11 +37,12 @@ getEditingBounds myWorld = lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc getEditorContentAt :: + TerrainMap -> WorldOverdraw -> W.MultiWorld Int Entity -> Cosmic W.Coords -> (TerrainType, Maybe EntityPaint) -getEditorContentAt editorOverdraw w coords = +getEditorContentAt tm editorOverdraw w coords = (terrainWithOverride, entityWithOverride) where terrainWithOverride = Maybe.fromMaybe underlyingCellTerrain $ do @@ -60,15 +61,16 @@ getEditorContentAt editorOverdraw w coords = pm = editorOverdraw ^. paintedTerrain entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride - (underlyingCellTerrain, underlyingCellEntity) = getContentAt w coords + (underlyingCellTerrain, underlyingCellEntity) = getContentAt tm w coords getEditorTerrainAt :: + TerrainMap -> WorldOverdraw -> W.MultiWorld Int Entity -> Cosmic W.Coords -> TerrainType -getEditorTerrainAt editor w coords = - fst $ getEditorContentAt editor w coords +getEditorTerrainAt tm editor w coords = + fst $ getEditorContentAt tm editor w coords isOutsideTopLeftCorner :: -- | top left corner coords @@ -98,12 +100,13 @@ isOutsideRegion (tl, br) coord = isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord getEditedMapRectangle :: + TerrainMap -> WorldOverdraw -> Maybe (Cosmic W.BoundsRectangle) -> W.MultiWorld Int Entity -> EA.Grid CellPaintDisplay -getEditedMapRectangle _ Nothing _ = EA.Grid [] -getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w = +getEditedMapRectangle _ _ Nothing _ = EA.Grid [] +getEditedMapRectangle tm worldEditor (Just (Cosmic subworldName coords)) w = getMapRectangle toFacade getContent coords where - getContent = getEditorContentAt worldEditor w . Cosmic subworldName + getContent = getEditorContentAt tm worldEditor w . Cosmic subworldName diff --git a/src/Swarm/TUI/Editor/View.hs b/src/Swarm/TUI/Editor/View.hs index 4408e1961..94fcd21bd 100644 --- a/src/Swarm/TUI/Editor/View.hs +++ b/src/Swarm/TUI/Editor/View.hs @@ -8,9 +8,11 @@ import Brick.Widgets.Center (hCenter) import Brick.Widgets.List qualified as BL import Control.Lens hiding (Const, from) import Data.List qualified as L +import Swarm.Game.Land +import Swarm.Game.Scenario import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Terrain (TerrainType) +import Swarm.Game.Terrain (TerrainMap, TerrainType) import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.TUI.Border @@ -22,7 +24,11 @@ import Swarm.TUI.Panel import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay (renderDisplay) import Swarm.TUI.View.Util qualified as VU -import Swarm.Util (listEnums) + +extractTerrainMap :: UIState -> TerrainMap +extractTerrainMap uis = + maybe mempty (view (scenarioLandscape . scenarioTerrainAndEntities . terrainMap) . fst) $ + uis ^. uiGameplay . scenarioRef drawWorldEditor :: FocusRing Name -> UIState -> Widget Name drawWorldEditor toplevelFocusRing uis = @@ -73,10 +79,12 @@ drawWorldEditor toplevelFocusRing uis = where selectedThing = snd <$> BL.listSelectedElement list + tm = extractTerrainMap uis + brushWidget = mkFormControl (WorldEditorPanelControl BrushSelector) $ padRight (Pad 1) (str "Brush:") - <+> swatchContent (worldEditor ^. terrainList) VU.drawLabeledTerrainSwatch + <+> swatchContent (worldEditor ^. terrainList) (VU.drawLabeledTerrainSwatch tm) entityWidget = mkFormControl (WorldEditorPanelControl EntitySelector) $ @@ -141,13 +149,13 @@ drawTerrainSelector :: AppState -> Widget Name drawTerrainSelector s = padAll 1 . hCenter - . vLimit (length (listEnums :: [TerrainType])) - . BL.renderListWithIndex listDrawTerrainElement True + . vLimit 8 + . BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap $ s ^. uiState) True $ s ^. uiState . uiGameplay . uiWorldEditor . terrainList -listDrawTerrainElement :: Int -> Bool -> TerrainType -> Widget Name -listDrawTerrainElement pos _isSelected a = - clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch a +listDrawTerrainElement :: TerrainMap -> Int -> Bool -> TerrainType -> Widget Name +listDrawTerrainElement tm pos _isSelected a = + clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch tm a drawEntityPaintSelector :: AppState -> Widget Name drawEntityPaintSelector s = diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index 88847b003..f9cc3a228 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -45,7 +45,10 @@ import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Persistence import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.Land import Swarm.Game.Scenario ( + ScenarioInputs (..), + gsiScenarioInputs, loadScenario, scenarioAttrs, scenarioLandscape, @@ -137,11 +140,15 @@ constructAppState :: AppOpts -> m AppState constructAppState rs ui opts@(AppOpts {..}) = do - let gs = initGameState (mkGameStateConfig rs) + let gs = initGameState $ rs ^. stdGameConfigInputs case skipMenu opts of False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs True -> do - (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. landscape . entityMap) (rs ^. worlds) + let tem = gs ^. landscape . terrainAndEntities + (scenario, path) <- + loadScenario + (fromMaybe "classic" userScenario) + (ScenarioInputs (initWorldMap . gsiScenarioInputs . initState $ rs ^. stdGameConfigInputs) tem) maybeRunScript <- traverse parseCodeFile scriptToRun let maybeAutoplay = do @@ -213,7 +220,7 @@ scenarioToAppState :: m () scenarioToAppState siPair@(scene, _) lp = do rs <- use runtimeState - gs <- liftIO $ scenarioToGameState scene lp $ mkGameStateConfig rs + gs <- liftIO $ scenarioToGameState scene lp $ rs ^. stdGameConfigInputs gameState .= gs void $ withLensIO uiState $ scenarioToUIState isAutoplaying siPair gs where @@ -260,8 +267,14 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do return $ u & uiPlaying .~ True - & uiGameplay . uiGoal .~ emptyGoalDisplay & uiCheatMode ||~ isAutoplaying + & uiAttrMap + .~ applyAttrMappings + ( map (first getWorldAttrName . toAttrPair) $ + fst siPair ^. scenarioLandscape . scenarioAttrs + ) + swarmAttrMap + & uiGameplay . uiGoal .~ emptyGoalDisplay & uiGameplay . uiHideGoals .~ (isAutoplaying && not (u ^. uiCheatMode)) & uiGameplay . uiFocusRing .~ initFocusRing & uiGameplay . uiInventory . uiInventoryList .~ Nothing @@ -270,12 +283,6 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do & uiGameplay . uiTiming . uiShowFPS .~ False & uiGameplay . uiREPL .~ initREPLState (u ^. uiGameplay . uiREPL . replHistory) & uiGameplay . uiREPL . replHistory %~ restartREPLHistory - & uiAttrMap - .~ applyAttrMappings - ( map (first getWorldAttrName . toAttrPair) $ - fst siPair ^. scenarioLandscape . scenarioAttrs - ) - swarmAttrMap & uiGameplay . scenarioRef ?~ siPair & uiGameplay . uiTiming . lastFrameTime .~ curTime & uiGameplay . uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing @@ -285,7 +292,7 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do (SR.makeListWidget . M.elems $ gs ^. discovery . structureRecognition . automatons . originalStructureDefinitions) (focusSetCurrent (StructureWidgets StructuresList) $ focusRing $ map StructureWidgets listEnums) where - entityList = EU.getEntitiesForList $ gs ^. landscape . entityMap + entityList = EU.getEntitiesForList $ gs ^. landscape . terrainAndEntities . entityMap (isEmptyArea, newBounds) = EU.getEditingBounds $ diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 1ac1a62a4..b7271c69e 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -75,6 +75,7 @@ import Swarm.Constant import Swarm.Game.CESK (CESK (..)) import Swarm.Game.Display import Swarm.Game.Entity as E +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.Robot @@ -91,6 +92,7 @@ import Swarm.Game.Scenario ( scenarioObjectives, scenarioOperation, scenarioSeed, + scenarioTerrainAndEntities, ) import Swarm.Game.Scenario.Scoring.Best import Swarm.Game.Scenario.Scoring.CodeSize @@ -263,14 +265,17 @@ drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of fromMaybe 0 $ s ^. scenarioLandscape . scenarioSeed - ri = - RenderingInput theWorlds $ - getEntityIsKnown $ - EntityKnowledgeDependencies - { isCreativeMode = s ^. scenarioOperation . scenarioCreative - , globallyKnownEntities = s ^. scenarioLandscape . scenarioKnown - , theFocusedRobot = Nothing - } + entIsKnown = + getEntityIsKnown $ + EntityKnowledgeDependencies + { isCreativeMode = s ^. scenarioOperation . scenarioCreative + , globallyKnownEntities = s ^. scenarioLandscape . scenarioKnown + , theFocusedRobot = Nothing + } + + tm = s ^. scenarioLandscape . scenarioTerrainAndEntities . terrainMap + ri = RenderingInput theWorlds entIsKnown tm + renderCoord = renderDisplay . displayLocRaw (WorldOverdraw False mempty) ri [] worldPeek = worldWidget renderCoord vc @@ -520,7 +525,12 @@ drawWorldCursorInfo worldEditor g cCoords = where f cell preposition = [renderDisplay cell, txt preposition] - ri = RenderingInput (g ^. landscape . multiWorld) (getEntityIsKnown $ mkEntityKnowledge g) + ri = + RenderingInput + (g ^. landscape . multiWorld) + (getEntityIsKnown $ mkEntityKnowledge g) + (g ^. landscape . terrainAndEntities . terrainMap) + terrain = displayTerrainCell worldEditor ri cCoords entity = displayEntityCell worldEditor ri cCoords robot = displayRobotCell g cCoords diff --git a/src/Swarm/TUI/View/Attribute/Attr.hs b/src/Swarm/TUI/View/Attribute/Attr.hs index 5f89381bd..23e24528c 100644 --- a/src/Swarm/TUI/View/Attribute/Attr.hs +++ b/src/Swarm/TUI/View/Attribute/Attr.hs @@ -19,7 +19,6 @@ module Swarm.TUI.View.Attribute.Attr ( messageAttributeNames, toAttrName, getWorldAttrName, - getTerrainAttrName, mkBrickColor, -- ** Common attributes @@ -69,7 +68,6 @@ toAttrName = \case ARobot -> robotAttr AEntity -> entityAttr AWorld n -> worldPrefix <> attrName (unpack n) - ATerrain n -> terrainPrefix <> attrName (unpack n) ADefault -> defAttr toVtyAttr :: PreservableColor -> V.Attr @@ -98,7 +96,6 @@ swarmAttrMap = $ NE.toList activityMeterAttributes <> NE.toList robotMessageAttributes <> map (getWorldAttrName *** toVtyAttr) (M.toList worldAttributes) - <> map (getTerrainAttrName *** toVtyAttr) (M.toList terrainAttributes) <> [ -- Robot attribute (robotAttr, fg V.white `V.withStyle` V.bold) , -- UI rendering attributes @@ -126,12 +123,6 @@ swarmAttrMap = (defAttr, V.defAttr) ] -terrainPrefix :: AttrName -terrainPrefix = attrName "terrain" - -getTerrainAttrName :: TerrainAttr -> AttrName -getTerrainAttrName (TerrainAttr n) = terrainPrefix <> attrName n - worldPrefix :: AttrName worldPrefix = attrName "world" diff --git a/src/Swarm/TUI/View/CellDisplay.hs b/src/Swarm/TUI/View/CellDisplay.hs index 704271ff3..d0013737b 100644 --- a/src/Swarm/TUI/View/CellDisplay.hs +++ b/src/Swarm/TUI/View/CellDisplay.hs @@ -30,6 +30,7 @@ import Swarm.Game.Display ( hidden, ) import Swarm.Game.Entity +import Swarm.Game.Land import Swarm.Game.Robot import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) @@ -76,6 +77,7 @@ drawLoc ui g cCoords@(Cosmic _ coords) = data RenderingInput = RenderingInput { multiworldInfo :: W.MultiWorld Int Entity , isKnownFunc :: EntityPaint -> Bool + , terrMap :: TerrainMap } displayTerrainCell :: @@ -84,7 +86,10 @@ displayTerrainCell :: Cosmic W.Coords -> Display displayTerrainCell worldEditor ri coords = - terrainMap M.! EU.getEditorTerrainAt worldEditor (multiworldInfo ri) coords + maybe mempty terrainDisplay $ M.lookup t tm + where + tm = terrainByName $ terrMap ri + t = EU.getEditorTerrainAt (terrMap ri) worldEditor (multiworldInfo ri) coords displayRobotCell :: GameState -> @@ -136,7 +141,7 @@ displayEntityCell :: displayEntityCell worldEditor ri coords = maybeToList $ displayForEntity <$> maybeEntity where - (_, maybeEntity) = EU.getEditorContentAt worldEditor (multiworldInfo ri) coords + (_, maybeEntity) = EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri) coords displayForEntity :: EntityPaint -> Display displayForEntity e = (if isKnownFunc ri e then id else hidden) $ getDisplay e @@ -150,7 +155,12 @@ displayLoc showRobots we g cCoords@(Cosmic _ coords) = staticDisplay g coords <> displayLocRaw we ri robots cCoords where - ri = RenderingInput (g ^. landscape . multiWorld) (getEntityIsKnown $ mkEntityKnowledge g) + ri = + RenderingInput + (g ^. landscape . multiWorld) + (getEntityIsKnown $ mkEntityKnowledge g) + (g ^. landscape . terrainAndEntities . terrainMap) + robots = if showRobots then displayRobotCell g cCoords diff --git a/src/Swarm/TUI/View/Logo.hs b/src/Swarm/TUI/View/Logo.hs index d7dc02a4b..5ea290ec9 100644 --- a/src/Swarm/TUI/View/Logo.hs +++ b/src/Swarm/TUI/View/Logo.hs @@ -39,4 +39,4 @@ drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws) plantAttr = getWorldAttrName $ fst plant dirtAttr :: AttrName - dirtAttr = getTerrainAttrName $ fst dirt + dirtAttr = getWorldAttrName $ fst dirt diff --git a/src/Swarm/TUI/View/Util.hs b/src/Swarm/TUI/View/Util.hs index 81ac38c86..adc65c962 100644 --- a/src/Swarm/TUI/View/Util.hs +++ b/src/Swarm/TUI/View/Util.hs @@ -16,10 +16,12 @@ import Data.Text (Text) import Data.Text qualified as T import Graphics.Vty qualified as V import Swarm.Game.Entity as E +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Scenario (scenarioMetadata, scenarioName) import Swarm.Game.ScenarioInfo (scenarioItemName) import Swarm.Game.State +import Swarm.Game.State.Landscape import Swarm.Game.State.Substate import Swarm.Game.Terrain import Swarm.Language.Pretty (prettyTextLine) @@ -30,7 +32,6 @@ import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay -import Swarm.Util (listEnums) import Witch (from, into) -- | Generate a fresh modal window of the requested type. @@ -110,7 +111,8 @@ generateModal s mt = Modal mt (dialog (Just $ str title) buttons (maxModalWindow KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80) TerrainPaletteModal -> ("Terrain", Nothing, w) where - wordLength = maximum $ map (length . show) (listEnums :: [TerrainType]) + tm = s ^. gameState . landscape . terrainAndEntities . terrainMap + wordLength = maximum $ map (T.length . getTerrainWord) (M.keys $ terrainByName tm) w = wordLength + 6 EntityPaletteModal -> ("Entity", Nothing, 30) @@ -150,11 +152,16 @@ drawMarkdown d = do "type" -> magentaAttr _snippet -> highlightAttr -- same as plain code -drawLabeledTerrainSwatch :: TerrainType -> Widget Name -drawLabeledTerrainSwatch a = +drawLabeledTerrainSwatch :: TerrainMap -> TerrainType -> Widget Name +drawLabeledTerrainSwatch tm a = tile <+> str materialName where - tile = padRight (Pad 1) $ renderDisplay $ terrainMap M.! a + tile = + padRight (Pad 1) + . renderDisplay + . maybe mempty terrainDisplay + $ M.lookup a (terrainByName tm) + materialName = init $ show a descriptionTitle :: Entity -> String diff --git a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs index 3604deed6..2bc384ef1 100644 --- a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs +++ b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs @@ -42,6 +42,7 @@ import Swarm.Game.Entity hiding (empty) import Swarm.Game.Robot import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Context +import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Tick import Swarm.Game.Universe import Swarm.Language.Pipeline (ProcessedTerm) @@ -109,7 +110,7 @@ instance ToSample Robot where [] False False - mempty + emptyExceptions 0 mkMachine :: Maybe ProcessedTerm -> C.CESK diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs index f3f04edad..6bbfc9cec 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs @@ -7,6 +7,7 @@ module Swarm.Game.Scenario.Scoring.CodeSize where import Control.Monad (guard) import Data.Aeson +import Data.Data (Data) import GHC.Generics (Generic) import Swarm.Language.Module import Swarm.Language.Pipeline @@ -24,12 +25,19 @@ data ScenarioCodeMetrics = ScenarioCodeMetrics } 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) +codeMetricsFromSyntax :: + Data a => + Syntax' a -> + ScenarioCodeMetrics +codeMetricsFromSyntax s@(Syntax' srcLoc _ _) = + ScenarioCodeMetrics (charCount srcLoc) (measureAstSize s) where charCount :: SrcLoc -> Int charCount NoLoc = 0 charCount (SrcLoc start end) = end - start + +codeSizeFromDeterminator :: CodeSizeDeterminators -> Maybe ScenarioCodeMetrics +codeSizeFromDeterminator (CodeSizeDeterminators maybeInitialCode usedRepl) = do + guard $ not usedRepl + ProcessedTerm (Module s _) _ _ <- maybeInitialCode + return $ codeMetricsFromSyntax s diff --git a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs index f2344562e..af8171e5e 100644 --- a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs +++ b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs @@ -15,7 +15,6 @@ module Swarm.Game.ScenarioInfo ( scenarioPath, scenarioStatus, CodeSizeDeterminators (CodeSizeDeterminators), - updateScenarioInfoOnFinish, ScenarioInfoPair, -- * Scenario collection @@ -55,13 +54,11 @@ 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, (-<.>), ()) @@ -137,16 +134,15 @@ 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 -> + ScenarioInputs -> m ScenarioCollection -loadScenarios em worldMap = do +loadScenarios scenarioInputs = 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 + Right dataDir -> loadScenarioDir scenarioInputs dataDir -- | The name of the special file which indicates the order of -- scenarios in a folder. @@ -161,11 +157,10 @@ readOrderFile orderFile = -- 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 -> + ScenarioInputs -> FilePath -> m ScenarioCollection -loadScenarioDir em worldMap dir = do +loadScenarioDir scenarioInputs dir = do let orderFile = dir orderFileName dirName = takeBaseName dir orderExists <- sendIO $ doesFileExist orderFile @@ -196,7 +191,7 @@ loadScenarioDir em worldMap dir = do -- Only keep the files from 00-ORDER.txt that actually exist. let morder' = filter (`elem` itemPaths) <$> morder loadItem filepath = do - item <- loadScenarioItem em worldMap (dir filepath) + item <- loadScenarioItem scenarioInputs (dir filepath) return (filepath, item) scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths let (failures, successes) = partitionEithers scenarios @@ -257,17 +252,16 @@ loadScenarioItem :: , Has (Accum (Seq SystemFailure)) sig m , Has (Lift IO) sig m ) => - EntityMap -> - WorldMap -> + ScenarioInputs -> FilePath -> m ScenarioItem -loadScenarioItem em worldMap path = do +loadScenarioItem scenarioInputs path = do isDir <- sendIO $ doesDirectoryExist path let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path case isDir of - True -> SICollection collectionName <$> loadScenarioDir em worldMap path + True -> SICollection collectionName <$> loadScenarioDir scenarioInputs path False -> do - s <- loadScenarioFile em worldMap path + s <- loadScenarioFile scenarioInputs path eitherSi <- runThrow @SystemFailure (loadScenarioInfo path) case eitherSi of Right si -> return $ SISingle (s, si) diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs index 1973f812b..15927070a 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -76,6 +76,7 @@ import Control.Effect.State (State) import Control.Effect.Throw import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) import Control.Monad (forM, join) +import Data.Aeson (ToJSON) import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Foldable (toList) import Data.Foldable.Extra (allM) @@ -97,10 +98,12 @@ 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 GHC.Generics (Generic) import Linear (V2 (..)) import Swarm.Game.CESK (emptyStore, finalValue, initMachine) import Swarm.Game.Entity import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Recipe ( catRecipeMap, @@ -139,6 +142,7 @@ import System.Clock qualified as Clock import System.Random (mkStdGen) newtype Sha1 = Sha1 String + deriving (Show, Eq, Ord, Generic, ToJSON) data SolutionSource = ScenarioSuggested @@ -577,7 +581,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc = & randomness . seed .~ theSeed & randomness . randGen .~ mkStdGen theSeed & recipesInfo %~ modifyRecipesInfo - & landscape .~ mkLandscape sLandscape em worldTuples theSeed + & landscape .~ mkLandscape sLandscape worldTuples theSeed & 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) @@ -593,7 +597,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc = & recipesIn %~ addRecipesWith inRecipeMap & recipesCat %~ addRecipesWith catRecipeMap - em = integrateScenarioEntities (initState gsc) sLandscape + TerrainEntityMaps _ em = sLandscape ^. scenarioTerrainAndEntities baseID = 0 (things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em)) diff --git a/src/swarm-engine/Swarm/Game/State/Robot.hs b/src/swarm-engine/Swarm/Game/State/Robot.hs index 590e2ea7c..51e71732c 100644 --- a/src/swarm-engine/Swarm/Game/State/Robot.hs +++ b/src/swarm-engine/Swarm/Game/State/Robot.hs @@ -25,6 +25,7 @@ module Swarm.Game.State.Robot ( robotsWatching, activeRobots, waitingRobots, + currentTickWakeableBots, viewCenterRule, viewCenter, focusedRobotID, @@ -60,6 +61,7 @@ import Data.IntMap qualified as IM import Data.IntSet (IntSet) import Data.IntSet qualified as IS import Data.IntSet.Lens (setOf) +import Data.List (partition) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M @@ -120,11 +122,12 @@ data Robots = Robots -- 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] + , _currentTickWakeableBots :: [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) + _robotsWatching :: Map (Cosmic Location) IntSet , _robotNaming :: RobotNaming , _viewCenterRule :: ViewCenterRule , _viewCenter :: Cosmic Location @@ -154,6 +157,9 @@ activeRobots = internalActiveRobots waitingRobots :: Getter Robots (Map TickNumber [RID]) waitingRobots = internalWaitingRobots +-- | Get a list of all the robots that are \"watching\" by location. +currentTickWakeableBots :: Lens' Robots [RID] + -- | 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 @@ -166,7 +172,7 @@ waitingRobots = internalWaitingRobots robotsByLocation :: Lens' Robots (Map SubworldName (Map Location IntSet)) -- | Get a list of all the robots that are \"watching\" by location. -robotsWatching :: Lens' Robots (Map (Cosmic Location) (S.Set RID)) +robotsWatching :: Lens' Robots (Map (Cosmic Location) IntSet) -- | State and data for assigning identifiers to robots robotNaming :: Lens' Robots RobotNaming @@ -196,11 +202,12 @@ initRobots gsc = { _robotMap = IM.empty , _activeRobots = IS.empty , _waitingRobots = M.empty + , _currentTickWakeableBots = mempty , _robotsByLocation = M.empty , _robotsWatching = mempty , _robotNaming = RobotNaming - { _nameGenerator = initNameParts gsc + { _nameGenerator = nameParts gsc , _gensym = 0 } , _viewCenterRule = VCRobot 0 @@ -294,6 +301,15 @@ 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'. +-- +-- = Mutations +-- +-- This function modifies: +-- +-- * 'wakeLog' +-- * 'robotsWatching' +-- * 'internalWaitingRobots' +-- * 'internalActiveRobots' (aka 'activeRobots') wakeUpRobotsDoneSleeping :: (Has (State Robots) sig m) => TickNumber -> m () wakeUpRobotsDoneSleeping time = do mrids <- internalWaitingRobots . at time <<.= Nothing @@ -301,29 +317,34 @@ wakeUpRobotsDoneSleeping time = do Nothing -> return () Just rids -> do robots <- use robotMap - let aliveRids = filter (`IM.member` robots) rids - internalActiveRobots %= IS.union (IS.fromList aliveRids) + let robotIdSet = IM.keysSet robots + wakeableRIDsSet = IS.fromList rids + + -- Limit ourselves to the robots that have not expired in their sleep + newlyAlive = IS.intersection robotIdSet wakeableRIDsSet + + internalActiveRobots %= IS.union newlyAlive -- These robots' wake times may have been moved "forward" -- by 'wakeWatchingRobots'. - clearWatchingRobots rids + clearWatchingRobots wakeableRIDsSet -- | Clear the "watch" state of all of the -- awakened robots clearWatchingRobots :: (Has (State Robots) sig m) => - [RID] -> + IntSet -> m () clearWatchingRobots rids = do - robotsWatching %= M.map (`S.difference` S.fromList rids) + robotsWatching %= M.map (`IS.difference` 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 Robots) sig m) => TickNumber -> Cosmic Location -> m () -wakeWatchingRobots currentTick loc = do +wakeWatchingRobots :: (Has (State Robots) sig m) => RID -> TickNumber -> Cosmic Location -> m () +wakeWatchingRobots myID currentTick loc = do waitingMap <- use waitingRobots rMap <- use robotMap watchingMap <- use robotsWatching @@ -335,7 +356,7 @@ wakeWatchingRobots currentTick loc = do botsWatchingThisLoc :: [Robot] botsWatchingThisLoc = mapMaybe (`IM.lookup` rMap) $ - S.toList $ + IS.toList $ M.findWithDefault mempty loc watchingMap -- Step 2: Get the target wake time for each of these robots @@ -356,10 +377,23 @@ wakeWatchingRobots currentTick loc = do -- 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: + -- Step 4: Re-add the watching bots to be awakened ASAP: wakeableBotIds = map fst wakeTimes - newWakeTime = addTicks 1 currentTick - newInsertions = M.singleton newWakeTime wakeableBotIds + + -- It is crucial that only robots with a larger RID than the current robot + -- be scheduled for the *same* tick, since within a given tick we iterate over + -- robots in increasing order of RID. + -- See note in 'iterateRobots'. + (currTickWakeable, nextTickWakeable) = partition (> myID) wakeableBotIds + wakeTimeGroups = + [ (currentTick, currTickWakeable) + , (addTicks 1 currentTick, nextTickWakeable) + ] + newInsertions = M.filter (not . null) $ M.fromList wakeTimeGroups + + -- Contract: This must be emptied immediately + -- in 'iterateRobots' + currentTickWakeableBots .= currTickWakeable -- NOTE: There are two "sources of truth" for the waiting state of robots: -- 1. In the GameState via "internalWaitingRobots" @@ -369,10 +403,11 @@ wakeWatchingRobots currentTick loc = do 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 + forM_ wakeTimeGroups $ \(newWakeTime, wakeableBots) -> + forM_ wakeableBots $ \rid -> + robotMap . at rid . _Just . machine %= \case + Waiting _ c -> Waiting newWakeTime c + x -> x deleteRobot :: (Has (State Robots) sig m) => RID -> m () deleteRobot rn = do diff --git a/src/swarm-engine/Swarm/Game/State/Runtime.hs b/src/swarm-engine/Swarm/Game/State/Runtime.hs index 1c7a9be63..97c943d8e 100644 --- a/src/swarm-engine/Swarm/Game/State/Runtime.hs +++ b/src/swarm-engine/Swarm/Game/State/Runtime.hs @@ -11,16 +11,14 @@ module Swarm.Game.State.Runtime ( webPort, upstreamRelease, eventLog, - worlds, scenarios, - stdEntityMap, - stdRecipes, appData, - nameParts, + stdGameConfigInputs, -- ** Utility + initScenarioInputs, initRuntimeState, - mkGameStateConfig, + initGameStateConfig, ) where @@ -32,15 +30,14 @@ import Data.Map (Map) import Data.Sequence (Seq) import Data.Text (Text) import Network.Wai.Handler.Warp (Port) -import Swarm.Game.Entity (Entity, EntityMap, loadEntities) import Swarm.Game.Failure (SystemFailure) -import Swarm.Game.Recipe (Recipe, loadRecipes) -import Swarm.Game.ResourceLoading (NameGenerator, initNameGenerator, readAppData) -import Swarm.Game.Scenario (GameStateInputs (..)) +import Swarm.Game.Land +import Swarm.Game.Recipe (loadRecipes) +import Swarm.Game.ResourceLoading (initNameGenerator, readAppData) +import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..)) import Swarm.Game.ScenarioInfo (ScenarioCollection, loadScenarios) import Swarm.Game.State.Substate import Swarm.Game.World.Load (loadWorlds) -import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Log import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Version (NewReleaseFailure (..)) @@ -49,14 +46,45 @@ data RuntimeState = RuntimeState { _webPort :: Maybe Port , _upstreamRelease :: Either NewReleaseFailure String , _eventLog :: Notifications LogEntry - , _worlds :: WorldMap , _scenarios :: ScenarioCollection - , _stdEntityMap :: EntityMap - , _stdRecipes :: [Recipe Entity] + , _stdGameConfigInputs :: GameStateConfig , _appData :: Map Text Text - , _nameParts :: NameGenerator } +initScenarioInputs :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m ScenarioInputs +initScenarioInputs = do + tem <- loadEntitiesAndTerrain + worlds <- loadWorlds tem + return $ ScenarioInputs worlds tem + +initGameStateInputs :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m GameStateInputs +initGameStateInputs = do + scenarioInputs <- initScenarioInputs + recipes <- loadRecipes $ initEntityTerrain scenarioInputs ^. entityMap + return $ GameStateInputs scenarioInputs recipes + +initGameStateConfig :: + ( Has (Throw SystemFailure) sig m + , Has (Accum (Seq SystemFailure)) sig m + , Has (Lift IO) sig m + ) => + m GameStateConfig +initGameStateConfig = do + gsi <- initGameStateInputs + appDataMap <- readAppData + nameGen <- initNameGenerator appDataMap + return $ GameStateConfig appDataMap nameGen gsi + initRuntimeState :: ( Has (Throw SystemFailure) sig m , Has (Accum (Seq SystemFailure)) sig m @@ -64,23 +92,17 @@ initRuntimeState :: ) => m RuntimeState initRuntimeState = do - entities <- loadEntities - recipes <- loadRecipes entities - worlds <- loadWorlds entities - scenarios <- loadScenarios entities worlds - appDataMap <- readAppData - nameGen <- initNameGenerator appDataMap + gsc <- initGameStateConfig + scenarios <- loadScenarios $ gsiScenarioInputs $ initState gsc + return $ RuntimeState { _webPort = Nothing , _upstreamRelease = Left (NoMainUpstreamRelease []) , _eventLog = mempty - , _worlds = worlds , _scenarios = scenarios - , _stdEntityMap = entities - , _stdRecipes = recipes - , _appData = appDataMap - , _nameParts = nameGen + , _appData = initAppDataMap gsc + , _stdGameConfigInputs = gsc } makeLensesNoSigs ''RuntimeState @@ -98,39 +120,12 @@ upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String) -- place to log it. eventLog :: Lens' RuntimeState (Notifications LogEntry) --- | A collection of typechecked world DSL terms that are available to --- be used in scenario definitions. -worlds :: Lens' RuntimeState WorldMap - -- | The collection of scenarios that comes with the game. scenarios :: Lens' RuntimeState ScenarioCollection --- | The standard entity map loaded from disk. Individual scenarios --- may define additional entities which will get added to this map --- when loading the scenario. -stdEntityMap :: Lens' RuntimeState EntityMap - --- | The standard list of recipes loaded from disk. Individual scenarios --- may define additional recipes which will get added to this list --- when loading the scenario. -stdRecipes :: Lens' RuntimeState [Recipe Entity] +-- | Built-in resources for loading games +stdGameConfigInputs :: Lens' RuntimeState GameStateConfig -- | Free-form data loaded from the @data@ directory, for things like -- the logo, about page, tutorial story, etc. appData :: Lens' RuntimeState (Map Text Text) - --- | Lists of words/adjectives for use in building random robot names. -nameParts :: Lens' RuntimeState NameGenerator - --- | Create a 'GameStateConfig' record from the 'RuntimeState'. -mkGameStateConfig :: RuntimeState -> GameStateConfig -mkGameStateConfig rs = - GameStateConfig - { initNameParts = rs ^. nameParts - , initState = - GameStateInputs - { initEntities = rs ^. stdEntityMap - , initRecipes = rs ^. stdRecipes - , initWorldMap = rs ^. worlds - } - } diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs index 93d99d65d..ae91d47ce 100644 --- a/src/swarm-engine/Swarm/Game/State/Substate.hs +++ b/src/swarm-engine/Swarm/Game/State/Substate.hs @@ -140,7 +140,7 @@ data WinStatus | -- | The player has won. -- The boolean indicates whether they have -- already been congratulated. - Won Bool + Won Bool TickNumber | -- | The player has completed certain "goals" that preclude -- (via negative prerequisites) the completion of all of the -- required goals. @@ -448,4 +448,4 @@ initRecipeMaps gsc = , _recipesCat = catRecipeMap recipeList } where - recipeList = initRecipes $ initState gsc + recipeList = gsiRecipes $ initState gsc diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index 8c011cbee..a59dee95c 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -48,10 +48,12 @@ import Swarm.Game.CESK import Swarm.Game.Display import Swarm.Game.Entity hiding (empty, lookup, singleton, union) import Swarm.Game.Exception +import Swarm.Game.Land import Swarm.Game.Robot import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete import Swarm.Game.Robot.Context +import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Scenario.Objective qualified as OB import Swarm.Game.Scenario.Objective.WinCheck qualified as WC import Swarm.Game.State @@ -82,7 +84,7 @@ import Prelude hiding (Applicative (..), lookup) -- -- 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, Has Effect.Time sig m) => m Bool +gameTick :: HasGameStepState sig m => m Bool gameTick = do time <- use $ temporal . ticks zoomRobots $ wakeUpRobotsDoneSleeping time @@ -123,7 +125,7 @@ gameTick = do case wc of WinConditions winState oc -> do g <- get @GameState - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap hypotheticalWinCheck em g winState oc _ -> pure () return ticked @@ -131,14 +133,14 @@ gameTick = do -- | 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, Has Effect.Time sig m) => m () +finishGameTick :: HasGameStepState 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. +-- | 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 @@ -156,16 +158,72 @@ insertBackRobot rn rob = do 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, Has Effect.Time sig m) => IS.IntSet -> m () -runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do - mr <- uses (robotInfo . robotMap) (IM.lookup rn) - forM_ mr (stepOneRobot rn) +-- | GameState with support for IO and Time effect +type HasGameStepState sig m = (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) + +-- | Run a set of robots - this is used to run robots before/after the focused one. +-- +-- Note that during the iteration over the supplied robot IDs, it is possible +-- that a robot that may have been present in 'robotMap' at the outset +-- of the iteration to be removed before the iteration comes upon it. +-- This is why we must perform a 'robotMap' lookup at each iteration, rather +-- than looking up elements from 'robotMap' in bulk up front with something like +-- 'restrictKeys'. +-- +-- = Invariants +-- +-- * Every tick, every active robot shall have exactly one opportunity to run. +-- * The sequence in which robots are chosen to run is by increasing order of 'RID'. +runRobotIDs :: HasGameStepState sig m => IS.IntSet -> m () +runRobotIDs robotNames = do + time <- use $ temporal . ticks + flip (iterateRobots time) robotNames $ \rn -> do + mr <- uses (robotInfo . robotMap) (IM.lookup rn) + forM_ mr (stepOneRobot rn) where + stepOneRobot :: HasGameStepState sig m => RID -> Robot -> m () 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, Has Effect.Time sig m) => SingleStep -> RID -> IS.IntSet -> m Bool +-- | +-- Runs the given robots in increasing order of 'RID'. +-- +-- Running a given robot _may_ cause another robot +-- with a higher 'RID' to be inserted into the runnable set. +-- +-- Note that the behavior we desire is described precisely by a +-- . +-- +-- A priority queue allows O(1) access to the lowest priority item. However, +-- /splitting/ the min item from rest of the queue is still an O(log N) operation, +-- and therefore is not any better than the 'minView' function from 'IntSet'. +-- +-- Tail-recursive. +iterateRobots :: HasGameStepState sig m => TickNumber -> (RID -> m ()) -> IS.IntSet -> m () +iterateRobots time f runnableBots = + forM_ (IS.minView runnableBots) $ \(thisRobotId, remainingBotIDs) -> do + f thisRobotId + + -- We may have awakened new robots in the current robot's iteration, + -- so we add them to the list + poolAugmentation <- do + -- NOTE: We could use 'IS.split thisRobotId activeRIDsThisTick' + -- to ensure that we only insert RIDs greater than 'thisRobotId' + -- into the queue. + -- However, we already ensure in 'wakeWatchingRobots' that only + -- robots with a larger RID are scheduled for the current tick; + -- robots with smaller RIDs will be scheduled for the next tick. + robotsToAdd <- use $ robotInfo . currentTickWakeableBots + if null robotsToAdd + then return id + else do + zoomRobots $ wakeUpRobotsDoneSleeping time + robotInfo . currentTickWakeableBots .= [] + return $ IS.union $ IS.fromList robotsToAdd + + iterateRobots time f $ poolAugmentation remainingBotIDs + +-- | This is a helper function to do one robot step or run robots before/after. +singleStep :: HasGameStepState sig m => SingleStep -> RID -> IS.IntSet -> m Bool singleStep ss focRID robotSet = do let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet case ss of @@ -275,8 +333,9 @@ hypotheticalWinCheck em g ws oc = do foldM foldFunc initialAccumulator $ reverse incompleteGoals + ts <- use $ temporal . ticks let newWinState = case ws of - Ongoing -> getNextWinState $ completions finalAccumulator + Ongoing -> getNextWinState ts $ completions finalAccumulator _ -> ws winCondition .= WinConditions newWinState (completions finalAccumulator) @@ -289,8 +348,8 @@ hypotheticalWinCheck em g ws oc = do mapM_ handleException $ exceptions finalAccumulator where - getNextWinState completedObjs - | WC.didWin completedObjs = Won False + getNextWinState ts completedObjs + | WC.didWin completedObjs = Won False ts | WC.didLose completedObjs = Unwinnable False | otherwise = Ongoing @@ -375,7 +434,7 @@ hypotheticalRobot m = [] True False - mempty + emptyExceptions evaluateCESK :: ( Has Effect.Time sig m @@ -422,7 +481,7 @@ traceLogShow = void . traceLog Logged Info . from . show -- | 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, Has Effect.Time sig m) => Robot -> m Robot +tickRobot :: HasGameStepState sig m => Robot -> m Robot tickRobot r = do steps <- use $ temporal . robotStepsPerTick tickRobotRec (r & activityCounts . tickStepBudget .~ steps) @@ -431,7 +490,7 @@ tickRobot r = do -- 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, Has Effect.Time sig m) => Robot -> m Robot +tickRobotRec :: HasGameStepState sig m => Robot -> m Robot tickRobotRec r = do time <- use $ temporal . ticks case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of @@ -440,7 +499,7 @@ tickRobotRec r = do -- | 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, Has Effect.Time sig m) => Robot -> m Robot +stepRobot :: HasGameStepState 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") @@ -620,7 +679,7 @@ stepCESK cesk = case cesk of -- listing the requirements of the given expression. Out (VRequirements src t _) s (FExec : k) -> do currentContext <- use $ robotContext . defReqs - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap let (R.Requirements caps devs inv, _) = R.requirements currentContext t devicesForCaps, requiredDevices :: Set (Set Text) @@ -780,7 +839,7 @@ stepCESK cesk = case cesk of -- cells which were in the middle of being evaluated will be reset. let s' = resetBlackholes s h <- hasCapability CLog - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap if h then do void $ traceLog RobotError Error (formatExn em exn) diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs index 17513fdac..d71a16511 100644 --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -28,8 +28,10 @@ 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.Land import Swarm.Game.Location import Swarm.Game.Robot +import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot @@ -91,7 +93,7 @@ addCombustionBot inputEntity combustibility ts loc = do botInventory <- case maybeCombustionProduct of Nothing -> return [] Just n -> do - maybeE <- uses (landscape . entityMap) (lookupEntityName n) + maybeE <- uses (landscape . terrainAndEntities . entityMap) (lookupEntityName n) return $ maybe [] (pure . (1,)) maybeE combustionDurationRand <- uniform durationRange let combustionProg = combustionProgram combustionDurationRand combustibility @@ -112,7 +114,7 @@ addCombustionBot inputEntity combustibility ts loc = do botInventory True False - mempty + emptyExceptions ts return combustionDurationRand where @@ -224,5 +226,5 @@ addIgnitionBot ignitionDelay inputEntity ts loc = [] True False - mempty + emptyExceptions ts diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index db9cfed9e..3bb88deba 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -18,7 +18,7 @@ import Control.Effect.Error import Control.Effect.Lens import Control.Effect.Lift import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (forM, forM_, guard, msum, unless, when) +import Control.Monad (filterM, forM, forM_, guard, msum, unless, when) import Data.Bifunctor (second) import Data.Bool (bool) import Data.Char (chr, ord) @@ -52,6 +52,7 @@ 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.Land import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.ResourceLoading (getDataFileNameSafe) @@ -59,6 +60,7 @@ import Swarm.Game.Robot import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete import Swarm.Game.Robot.Context +import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Scenario.Topography.Area (getAreaDimensions) import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.Navigation.Util @@ -84,7 +86,6 @@ import Swarm.Game.Step.Util.Inspect import Swarm.Game.Tick import Swarm.Game.Universe import Swarm.Game.Value -import Swarm.Game.World (locToCoords) import Swarm.Language.Capability import Swarm.Language.Context hiding (delete) import Swarm.Language.Key (parseKeyComboFull) @@ -97,7 +98,6 @@ import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Language.Value import Swarm.Log import Swarm.Util hiding (both) -import Swarm.Util.Content (getContentAt) import Swarm.Util.Effect (throwToMaybe) import Swarm.Util.Lens (inherit) import Witch (From (from), into) @@ -260,8 +260,8 @@ execConst runChildProg c vs s k = do let maybeFirstFailure = asum failureMaybes applyMoveFailureEffect maybeFirstFailure $ \case - PathBlocked -> ThrowExn - PathLiquid -> Destroy + PathBlockedBy _ -> ThrowExn + PathLiquid _ -> Destroy let maybeLastLoc = do guard $ null maybeFirstFailure @@ -281,8 +281,8 @@ execConst runChildProg c vs s k = do onTarget rid $ do checkMoveAhead nextLoc $ \case - PathBlocked -> Destroy - PathLiquid -> Destroy + PathBlockedBy _ -> Destroy + PathLiquid _ -> Destroy updateRobotLocation oldLoc nextLoc -- Privileged robots can teleport without causing any @@ -291,11 +291,10 @@ execConst runChildProg c vs s k = do -- to spawn near the target location. omni <- isPrivilegedBot unless omni $ do - w <- use (landscape . multiWorld) let area = map (<$ nextLoc) $ getLocsInArea (nextLoc ^. planar) 5 - emptyLocs = filter (\cl -> isNothing . snd $ getContentAt w (locToCoords <$> cl)) area + emptyLocs <- filterM (fmap isNothing . entityAt) area randomLoc <- weightedChoice (const 1) emptyLocs - es <- uses (landscape . entityMap) allEntities + es <- uses (landscape . terrainAndEntities . entityMap) allEntities randomEntity <- weightedChoice (const 1) es case (randomLoc, randomEntity) of (Just loc, Just e) -> updateEntityAt loc (const (Just e)) @@ -430,7 +429,7 @@ execConst runChildProg c vs s k = do [VText name] -> do inv <- use robotInventory ins <- use equippedDevices - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap e <- lookupEntityName name em `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."] @@ -573,7 +572,7 @@ execConst runChildProg c vs s k = do _ -> badConst HasTag -> case vs of [VText eName, VText tName] -> do - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap e <- lookupEntityName eName em `isJustOrFail` ["I've never heard of", indefiniteQ eName <> "."] @@ -848,7 +847,7 @@ execConst runChildProg c vs s k = do _ -> badConst Create -> case vs of [VText name] -> do - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap e <- lookupEntityName name em `isJustOrFail` ["I've never heard of", indefiniteQ name <> "."] @@ -1107,7 +1106,7 @@ execConst runChildProg c vs s k = do [] isSystemRobot False - mempty + emptyExceptions createdAt -- Provision the new robot with the necessary devices and inventory. @@ -1135,7 +1134,7 @@ execConst runChildProg c vs s k = do -- Copy over the salvaged robot's log, if we have one inst <- use equippedDevices - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap isPrivileged <- isPrivilegedBot logger <- lookupEntityName "logger" em @@ -1470,7 +1469,7 @@ execConst runChildProg c vs s k = do m (Set Entity, Inventory) checkRequirements parentInventory childInventory childDevices cmd subject fixI = do currentContext <- use $ robotContext . defReqs - em <- use $ landscape . entityMap + em <- use $ landscape . terrainAndEntities . entityMap creative <- use creativeMode let -- Note that _capCtx must be empty: at least at the -- moment, definitions are only allowed at the top level, @@ -1613,28 +1612,30 @@ execConst runChildProg c vs s k = do loc <- use robotLocation let nextLoc = loc `offsetBy` orientation checkMoveAhead nextLoc $ \case - PathBlocked -> ThrowExn - PathLiquid -> Destroy + PathBlockedBy _ -> ThrowExn + PathLiquid _ -> Destroy updateRobotLocation loc nextLoc return $ mkReturn () applyMoveFailureEffect :: (HasRobotStepState sig m, Has (Lift IO) sig m) => - Maybe MoveFailureDetails -> + Maybe MoveFailureMode -> MoveFailureHandler -> m () applyMoveFailureEffect maybeFailure failureHandler = case maybeFailure of Nothing -> return () - Just (MoveFailureDetails e failureMode) -> case failureHandler failureMode of + Just failureMode -> case failureHandler failureMode of IgnoreFail -> return () Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of - (True, PathLiquid) -> Just RobotIntoWater -- achievement for drowning + (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!"] + PathBlockedBy ent -> case ent of + Just e -> ["There is a", e ^. entityName, "in the way!"] + Nothing -> ["There is nothing to travel on!"] + PathLiquid e -> ["There is a dangerous liquid", e ^. entityName, "in the way!"] -- Determine the move failure mode and apply the corresponding effect. checkMoveAhead :: @@ -1737,7 +1738,7 @@ execConst runChildProg c vs s k = do let yieldName = e ^. entityYields e' <- case yieldName of Nothing -> return e - Just n -> fromMaybe e <$> uses (landscape . entityMap) (lookupEntityName n) + Just n -> fromMaybe e <$> uses (landscape . terrainAndEntities . entityMap) (lookupEntityName n) robotInventory %= insert e' updateDiscoveredEntities e' diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs index 229256fd2..7ff3138f0 100644 --- a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs @@ -32,15 +32,18 @@ module Swarm.Game.Step.Path.Cache ( import Control.Arrow (left, (&&&)) import Control.Carrier.State.Lazy import Control.Effect.Lens +import Control.Lens ((^.)) import Control.Monad (unless) import Data.Either.Extra (maybeToEither) import Data.IntMap qualified as IM import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M +import Data.Tuple.Extra (both) import Swarm.Game.Entity import Swarm.Game.Location import Swarm.Game.Robot +import Swarm.Game.Robot.Walk import Swarm.Game.State import Swarm.Game.Step.Path.Cache.DistanceLimit import Swarm.Game.Step.Path.Type @@ -126,28 +129,17 @@ mkTailMap pathLocs = TailMap locsMap -- | -- Returns either a 'Left' which mandates cache invalidation (with a reason), -- or a 'Right' containing a 'Maybe'; 'Nothing' indicates the cache should --- remain unchanged, while 'Just' supplies a modified cache. +-- remain unchanged, while 'Just' supplies a modified cache entry. -- -- Cache is affected by modification of: -- --- * "unwalkable" entities (an entity is placed or removed that is "unwalkable" with respect to the invoking robot) --- * "target" entities (if the `path` command had been invoked with the modified entity as a target) --- --- === Removed entity --- --- * If an __unwalkable__ entity is removed from the map, the computed path shall be invalidated. --- * If a __target__ entity is removed... --- --- * ...that is the destination of the computed path, invalidate the cache --- * ...that is /not/ the destination of the computed path, the cache is unaffected --- --- === Added entity --- --- * If an __unwalkable__ entity is added to the map, the computed path shall only be invalidated /if the new entity lies on the path/. --- * If a __target__ entity is added... --- --- * ...that lies on the computed path, the computed path is truncated to that entity's location --- * ...that does /not/ lie on the computed path, invalidate the cache +-- * cell walkability (i.e., an entity is placed or removed +-- that is "unwalkable" (blacklist) or "exclusively walkable" (whitelist) +-- with respect to the invoking robot +-- * "target" entities (if the `path` command had been invoked +-- with the modified entity as a target). Note that it is impossible +-- to find a path to an "unwalkable" target, so this nonsensical case +-- is ignored for the purpose of cache invalidation. perhapsInvalidateForRobot :: WalkabilityContext -> -- | location of modified cell @@ -163,33 +155,43 @@ perhapsInvalidateForRobot oldCache@(PathfindingCache parms _previousWalkabilityInfo destLoc p) | swn /= pathSubworld = Right Nothing | otherwise = case entityModification of - Swap oldEntity newEntity -> - handleRemovedEntity oldEntity >> handleNewEntity newEntity - Remove oldEntity -> handleRemovedEntity oldEntity - Add newEntity -> handleNewEntity newEntity + Swap oldEntity newEntity -> deriveBarrierModification $ both Just (oldEntity, newEntity) + Remove oldEntity -> deriveBarrierModification (Just oldEntity, Nothing) + Add newEntity -> deriveBarrierModification (Nothing, Just newEntity) where PathfindingParameters _distLimit pathSubworld tgt = parms CachedPath origPath (TailMap locmap) = p - isUnwalkable = not . null . checkUnwalkable walkInfo + isWalkable = null . checkUnwalkable walkInfo isOnPath = entityLoc `M.member` locmap - handleRemovedEntity oldEntity - | destLoc == entityLoc = Left TargetEntityRemoved - | isUnwalkable oldEntity = Left UnwalkableRemoved - | otherwise = Right Nothing - - handleNewEntity newEntity - | isUnwalkable newEntity && isOnPath = Left UnwalkableOntoPath - | otherwise = case tgt of - LocationTarget _locTarget -> Right Nothing - EntityTarget targetEntityName -> handleNewEntityWithEntityTarget newEntity targetEntityName - - -- If the pathfinding target is an Entity rather than a specific location - handleNewEntityWithEntityTarget newEntity targetEntityName - | view entityName newEntity /= targetEntityName = Right Nothing - | isOnPath = Right $ Just $ truncatePath origPath entityLoc oldCache - | otherwise = Left TargetEntityAddedOutsidePath + -- NOTE: oldContent and newContent are guaranteed to be different, + -- because the 'Swap' constructor enforces such. + deriveBarrierModification change@(_oldContent, newContent) = + case tgt of + LocationTarget _locTarget -> barrierChange + -- If the location of the changed entity was the terminus + -- of the path, and the path search is "by entity", then + -- we know that the path must be invalidated due to removal + -- of the goal. + -- Also, we know that a "target entity" on the path will + -- only ever exist the path's terminus; otherwise the + -- terminus would have been earlier! + EntityTarget targetEntityName -> handleEntityTarget targetEntityName + where + handleEntityTarget targetEntityName + | destLoc == entityLoc = Left TargetEntityRemoved + | maybe True ((/= targetEntityName) . (^. entityName)) newContent = barrierChange + | isOnPath = Right $ Just $ truncatePath origPath entityLoc oldCache + | otherwise = Left TargetEntityAddedOutsidePath + + walkabilityPair = both isWalkable change + barrierChange + | uncurry (==) walkabilityPair = Right Nothing + | snd walkabilityPair = Left UnwalkableRemoved + | isOnPath = Left UnwalkableOntoPath + -- addition of a barrier outside of the path is irrelevant. + | otherwise = Right Nothing -- | If the newly-added target entity lies on the existing path, -- truncate the path to set it as the goal. diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Type.hs b/src/swarm-engine/Swarm/Game/Step/Path/Type.hs index 6dfbdf5f5..b2ce05bab 100644 --- a/src/swarm-engine/Swarm/Game/Step/Path/Type.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Type.hs @@ -25,7 +25,8 @@ import Data.Map qualified as M import GHC.Generics (Generic) import Swarm.Game.Entity import Swarm.Game.Location -import Swarm.Game.Robot (RID, WalkabilityContext) +import Swarm.Game.Robot (RID) +import Swarm.Game.Robot.Walk (WalkabilityContext) import Swarm.Game.Universe (SubworldName) import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Util.RingBuffer diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs b/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs index 0f4b6fbef..0c6950ecf 100644 --- a/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Walkability.hs @@ -7,28 +7,35 @@ module Swarm.Game.Step.Path.Walkability where import Control.Lens import Data.Set qualified as S import Swarm.Game.Entity hiding (empty, lookup, singleton, union) -import Swarm.Game.Robot +import Swarm.Game.Robot.Walk import Swarm.Language.Capability -data MoveFailureMode = PathBlocked | PathLiquid - -data MoveFailureDetails - = MoveFailureDetails - -- | Occupies the destination cell - Entity - MoveFailureMode +data MoveFailureMode + = -- | If the robot has a path Whitelist, + -- then the absence of an entity could prevent walkability (represented by `PathBlockedBy Nothing`). + PathBlockedBy (Maybe Entity) + | PathLiquid Entity -- | Pure logic used inside of -- 'Swarm.Game.Step.Util.checkMoveFailureUnprivileged' checkUnwalkable :: WalkabilityContext -> - Entity -> - Maybe MoveFailureDetails -checkUnwalkable (WalkabilityContext caps unwalkables) e + Maybe Entity -> + Maybe MoveFailureMode +checkUnwalkable (WalkabilityContext _ walkExceptions) Nothing = + case walkExceptions of + Whitelist _ -> Just $ PathBlockedBy Nothing + Blacklist _ -> Nothing +checkUnwalkable (WalkabilityContext caps walkExceptions) (Just e) -- robots can not walk through walls - | e `hasProperty` Unwalkable || (e ^. entityName) `S.member` unwalkables = - Just $ MoveFailureDetails e PathBlocked + | isUnwalkableEntity = + Just $ PathBlockedBy $ Just e -- robots drown if they walk over liquid without boat | e `hasProperty` Liquid && CFloat `S.notMember` caps = - Just $ MoveFailureDetails e PathLiquid + Just $ PathLiquid e | otherwise = Nothing + where + eName = e ^. entityName + isUnwalkableEntity = case walkExceptions of + Whitelist onlyWalkables -> eName `S.notMember` onlyWalkables + Blacklist unwalkables -> e `hasProperty` Unwalkable || eName `S.member` unwalkables diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs index eef6ec334..aba1d0f33 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util.hs @@ -60,7 +60,7 @@ lookInDirection d = do -- | Modify the entity (if any) at a given location. updateEntityAt :: - (Has (State GameState) sig m) => + (Has (State Robot) sig m, Has (State GameState) sig m) => Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m () @@ -71,7 +71,8 @@ updateEntityAt cLoc@(Cosmic subworldName loc) upd = do forM_ (WM.getModification =<< someChange) $ \modType -> do currentTick <- use $ temporal . ticks - zoomRobots $ wakeWatchingRobots currentTick cLoc + myID <- use robotID + zoomRobots $ wakeWatchingRobots myID currentTick cLoc SRT.entityModified modType cLoc pcr <- use $ pathCaching . pathCachingRobots @@ -163,17 +164,15 @@ randomName = do checkMoveFailureUnprivileged :: HasRobotStepState sig m => Cosmic Location -> - m (Maybe MoveFailureDetails) + m (Maybe MoveFailureMode) checkMoveFailureUnprivileged nextLoc = do me <- entityAt nextLoc wc <- use walkabilityContext - return $ do - e <- me - checkUnwalkable wc e + return $ checkUnwalkable wc me -- | 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 :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureMode) checkMoveFailure nextLoc = do systemRob <- use systemRobot runMaybeT $ do diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index 7b62dbdc2..8c9bbae9f 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -20,6 +20,7 @@ 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_, unless, when) +import Data.IntSet qualified as IS import Data.Map qualified as M import Data.Sequence qualified as Seq import Data.Set (Set) @@ -40,6 +41,7 @@ import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.Robot import Swarm.Game.Robot.Concrete +import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation) import Swarm.Game.State import Swarm.Game.State.Landscape @@ -88,10 +90,10 @@ purgeFarAwayWatches = do let isNearby = isNearbyOrExempt privileged myLoc f loc = if not $ isNearby loc - then S.delete rid + then IS.delete rid else id - robotInfo . robotsWatching %= M.filter (not . null) . M.mapWithKey f + robotInfo . robotsWatching %= M.filter (not . IS.null) . M.mapWithKey f verbedGrabbingCmd :: GrabbingCmd -> Text verbedGrabbingCmd = \case @@ -152,6 +154,8 @@ onTarget rid act = do then deleteRobot rid else robotMap . ix rid .= tgt' +-- | Enforces validity of the robot's privileged status to receive +-- an achievement. grantAchievementForRobot :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GameplayAchievement -> @@ -174,6 +178,8 @@ checkGameModeAchievementValidity a = do where ValidityConditions _ gameplayModeRequired = getValidityRequirements a +-- | NOTE: When possible, one should use the +-- 'grantAchievementForRobot' function instead of this one. grantAchievement :: (Has (State GameState) sig m, Has (Lift IO) sig m) => GameplayAchievement -> @@ -267,7 +273,7 @@ addWatchedLocation :: m () addWatchedLocation loc = do rid <- use robotID - robotInfo . robotsWatching %= M.insertWith (<>) loc (S.singleton rid) + robotInfo . robotsWatching %= M.insertWith (<>) loc (IS.singleton rid) -- | Give some entities from a parent robot (the robot represented by -- the ambient @State Robot@ effect) to a child robot (represented @@ -366,7 +372,7 @@ createLogEntry source sev msg = do -- | replace some entity in the world with another entity updateWorld :: - (Has (State GameState) sig m, Has (Throw Exn) sig m) => + HasRobotStepState sig m => Const -> WorldUpdate Entity -> m () @@ -416,7 +422,7 @@ addSeedBot e (minT, maxT) loc ts = [(1, e)] True False - mempty + emptyExceptions ts -- | A system program for a "seed robot", to regrow a growable entity diff --git a/src/swarm-lang/Swarm/Language/Direction.hs b/src/swarm-lang/Swarm/Language/Direction.hs index 481745da3..e6e7d0970 100644 --- a/src/swarm-lang/Swarm/Language/Direction.hs +++ b/src/swarm-lang/Swarm/Language/Direction.hs @@ -26,7 +26,6 @@ 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) @@ -114,7 +113,7 @@ data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir -- | 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 +directionSyntax d = from $ directionJsonModifier $ case d of DAbsolute x -> show x DRelative x -> case x of DPlanar y -> show y diff --git a/src/swarm-lang/Swarm/Language/Syntax.hs b/src/swarm-lang/Swarm/Language/Syntax.hs index 0e34624e2..57c58ca57 100644 --- a/src/swarm-lang/Swarm/Language/Syntax.hs +++ b/src/swarm-lang/Swarm/Language/Syntax.hs @@ -598,7 +598,7 @@ constInfo c = case c of "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 and the remaining distance." + , "If a path exists, returns the immediate direction to proceed along and the remaining distance." ] Push -> command 1 short @@ -827,9 +827,13 @@ constInfo c = case c of , "Any change to entities at the monitored locations will cause the robot to wake up before the `wait` timeout." ] Surveil -> - command 1 short . doc (Set.singleton $ Query $ Sensing EntitySensing) "Interrupt `wait` upon (remote) location changes." $ - [ "Like `watch`, but with no restriction on distance." - ] + command 1 Intangible $ + doc + (Set.singleton $ Query $ Sensing EntitySensing) + "Interrupt `wait` upon (remote) location changes." + [ "Like `watch`, but instantaneous and with no restriction on distance." + , "Supply absolute coordinates." + ] Heading -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing RobotSensing) "Get the current heading." Blocked -> command 0 Intangible $ shortDoc (Set.singleton $ Query $ Sensing EntitySensing) "See if the robot can move forward." Scan -> diff --git a/src/swarm-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs index 3665ab608..aac8d57fa 100644 --- a/src/swarm-scenario/Swarm/Game/Display.hs +++ b/src/swarm-scenario/Swarm/Game/Display.hs @@ -54,12 +54,9 @@ import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) type Priority = Int -- | An internal attribute name. -data Attribute = ADefault | ARobot | AEntity | AWorld Text | ATerrain Text +data Attribute = ADefault | ARobot | AEntity | AWorld Text deriving (Eq, Ord, Show, Generic, Hashable) -terrainPrefix :: Text -terrainPrefix = "terrain_" - instance FromJSON Attribute where parseJSON = withText "attribute" $ @@ -67,7 +64,6 @@ instance FromJSON Attribute where "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 @@ -76,7 +72,6 @@ instance ToJSON Attribute where 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 diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 00775837b..6513891d2 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -47,7 +47,7 @@ module Swarm.Game.Entity ( -- ** Entity map EntityMap (..), buildEntityMap, - validateAttrRefs, + validateEntityAttrRefs, loadEntities, allEntities, lookupEntityName, @@ -403,8 +403,8 @@ deviceForCap :: Capability -> EntityMap -> [Entity] deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap -- | Validates references to 'Display' attributes -validateAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m () -validateAttrRefs validAttrs es = +validateEntityAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m () +validateEntityAttrRefs validAttrs es = forM_ namedEntities $ \(eName, ent) -> case ent ^. entityDisplay . displayAttr of AWorld n -> @@ -496,7 +496,7 @@ loadEntities = do withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ decodeFileEither fileName - withThrow entityFailure $ validateAttrRefs (M.keysSet worldAttributes) decoded + withThrow entityFailure $ validateEntityAttrRefs (M.keysSet worldAttributes) decoded withThrow entityFailure $ buildEntityMap decoded ------------------------------------------------------------ diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs index 8d8455de6..2f6c3758c 100644 --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs @@ -69,6 +69,3 @@ flattenBg = \case newtype WorldAttr = WorldAttr String deriving (Eq, Ord, Show) - -newtype TerrainAttr = TerrainAttr String - deriving (Eq, Ord, Show) diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs index 70a566823..3df7d90d5 100644 --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs @@ -15,7 +15,7 @@ import Data.Map (Map) import Data.Map qualified as M import Swarm.Game.Entity.Cosmetic --- * Entities +-- * Entities and Terrain entity :: (WorldAttr, PreservableColor) entity = (WorldAttr "entity", FgOnly $ AnsiColor White) @@ -29,13 +29,33 @@ rock = (WorldAttr "rock", FgOnly $ Triple $ RGB 80 80 80) plant :: (WorldAttr, PreservableColor) plant = (WorldAttr "plant", FgOnly $ AnsiColor Green) +dirt :: (WorldAttr, PreservableColor) +dirt = (WorldAttr "dirt", BgOnly $ Triple $ RGB 87 47 47) + +grass :: (WorldAttr, PreservableColor) +grass = (WorldAttr "grass", BgOnly $ Triple $ RGB 0 47 0) -- dark green + +stone :: (WorldAttr, PreservableColor) +stone = (WorldAttr "stone", BgOnly $ Triple $ RGB 47 47 47) + +ice :: (WorldAttr, PreservableColor) +ice = (WorldAttr "ice", BgOnly $ AnsiColor White) + -- | Colors of entities in the world. worldAttributes :: Map WorldAttr PreservableColor worldAttributes = M.fromList $ - -- these four are referenced elsewhere, + -- these few are referenced elsewhere, -- so they have their own toplevel definition - [entity, water, rock, plant] + [ entity + , water + , rock + , plant + , dirt + , grass + , stone + , ice + ] <> map (bimap WorldAttr FgOnly) [ ("device", AnsiColor BrightYellow) @@ -56,26 +76,3 @@ worldAttributes = , ("green", AnsiColor Green) , ("blue", AnsiColor Blue) ] - --- * Terrain - -dirt :: (TerrainAttr, PreservableColor) -dirt = (TerrainAttr "dirt", BgOnly $ Triple $ RGB 87 47 47) - -grass :: (TerrainAttr, PreservableColor) -grass = (TerrainAttr "grass", BgOnly $ Triple $ RGB 0 47 0) -- dark green - -stone :: (TerrainAttr, PreservableColor) -stone = (TerrainAttr "stone", BgOnly $ Triple $ RGB 47 47 47) - -ice :: (TerrainAttr, PreservableColor) -ice = (TerrainAttr "ice", BgOnly $ AnsiColor White) - -terrainAttributes :: M.Map TerrainAttr PreservableColor -terrainAttributes = - M.fromList - [ dirt - , grass - , stone - , ice - ] diff --git a/src/swarm-scenario/Swarm/Game/Failure.hs b/src/swarm-scenario/Swarm/Game/Failure.hs index ec109702e..6893ae217 100644 --- a/src/swarm-scenario/Swarm/Game/Failure.hs +++ b/src/swarm-scenario/Swarm/Game/Failure.hs @@ -33,7 +33,7 @@ import Witch (into) -- Failure descriptions -- | Enumeration of various assets we can attempt to load. -data AssetData = AppAsset | NameGeneration | Entities | Recipes | Worlds | Scenarios | Script +data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worlds | Scenarios | Script deriving (Eq, Show) -- | Overarching enumeration of various assets we can attempt to load. diff --git a/src/swarm-scenario/Swarm/Game/Land.hs b/src/swarm-scenario/Swarm/Game/Land.hs new file mode 100644 index 000000000..be50387e7 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Land.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Terrain and Entities +module Swarm.Game.Land ( + TerrainEntityMaps (TerrainEntityMaps), + terrainMap, + entityMap, + loadEntitiesAndTerrain, +) where + +import Control.Algebra (Has) +import Control.Effect.Lift (Lift) +import Control.Effect.Throw (Throw) +import Control.Lens (makeLenses) +import GHC.Generics (Generic) +import Swarm.Game.Entity +import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.Terrain + +data TerrainEntityMaps = TerrainEntityMaps + { _terrainMap :: TerrainMap + , _entityMap :: EntityMap + } + deriving (Show, Generic) + +makeLenses ''TerrainEntityMaps + +instance Semigroup TerrainEntityMaps where + TerrainEntityMaps tm1 em1 <> TerrainEntityMaps tm2 em2 = + TerrainEntityMaps (tm1 <> tm2) (em1 <> em2) + +instance Monoid TerrainEntityMaps where + mempty = TerrainEntityMaps mempty mempty + +loadEntitiesAndTerrain :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m TerrainEntityMaps +loadEntitiesAndTerrain = + TerrainEntityMaps <$> loadTerrain <*> loadEntities diff --git a/src/swarm-scenario/Swarm/Game/Robot.hs b/src/swarm-scenario/Swarm/Game/Robot.hs index b6d4e3a8b..6d39bf774 100644 --- a/src/swarm-scenario/Swarm/Game/Robot.hs +++ b/src/swarm-scenario/Swarm/Game/Robot.hs @@ -33,7 +33,6 @@ module Swarm.Game.Robot ( TRobot, -- * Robot context - WalkabilityContext (..), -- ** Lenses robotEntity, @@ -70,7 +69,6 @@ module Swarm.Game.Robot ( import Control.Applicative ((<|>)) import Control.Lens hiding (Const, contains) -import Data.Aeson qualified as Ae (ToJSON (..)) import Data.Hashable (hashWithSalt) import Data.Kind qualified import Data.Set (Set) @@ -80,7 +78,9 @@ import GHC.Generics (Generic) import Linear import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible) import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Land import Swarm.Game.Location (Heading, Location, toDirection, toHeading) +import Swarm.Game.Robot.Walk import Swarm.Game.Universe import Swarm.Language.Capability (Capability) import Swarm.Language.Pipeline (ProcessedTerm) @@ -149,7 +149,7 @@ data RobotR (phase :: RobotPhase) = RobotR , _selfDestruct :: Bool , _activityCounts :: RobotActivity phase , _runningAtomic :: Bool - , _unwalkableEntities :: Set EntityName + , _unwalkableEntities :: WalkabilityExceptions EntityName , _robotCreatedAt :: TimeSpec } deriving (Generic) @@ -186,7 +186,7 @@ type Robot = RobotR 'ConcreteRobot robotEntity :: Lens' (RobotR phase) Entity -- | Entities that the robot cannot move onto -unwalkableEntities :: Lens' Robot (Set EntityName) +unwalkableEntities :: Lens' Robot (WalkabilityExceptions EntityName) -- | The creation date of the robot. robotCreatedAt :: Lens' Robot TimeSpec @@ -301,15 +301,6 @@ selfDestruct :: Lens' Robot Bool -- | Is the robot currently running an atomic block? runningAtomic :: Lens' Robot Bool - --- | Properties of a robot used to determine whether an entity is walkable -data WalkabilityContext - = WalkabilityContext - (Set Capability) - -- | which entities are unwalkable by this robot - (Set EntityName) - deriving (Show, Eq, Generic, Ae.ToJSON) - walkabilityContext :: Getter Robot WalkabilityContext walkabilityContext = to $ \x -> WalkabilityContext (_robotCapabilities x) (_unwalkableEntities x) @@ -338,7 +329,7 @@ mkRobot :: -- | Is this robot heavy? Bool -> -- | Unwalkable entities - Set EntityName -> + WalkabilityExceptions EntityName -> -- | Creation date TimeSpec -> TRobot @@ -377,7 +368,7 @@ instance FromJSON HeadingSpec where -- | 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 +instance FromJSONE TerrainEntityMaps 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 @@ -392,11 +383,11 @@ instance FromJSONE EntityMap TRobot where <*> liftE (fmap getHeading $ v .:? "dir" .!= HeadingSpec zero) <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay) <*> liftE (v .:? "program") - <*> v ..:? "devices" ..!= [] - <*> v ..:? "inventory" ..!= [] + <*> localE (view entityMap) (v ..:? "devices" ..!= []) + <*> localE (view entityMap) (v ..:? "inventory" ..!= []) <*> pure sys <*> liftE (v .:? "heavy" .!= False) - <*> liftE (v .:? "unwalkable" ..!= mempty) + <*> liftE (v .:? "walkable" ..!= emptyExceptions) <*> pure 0 hearingDistance :: (Num i) => i diff --git a/src/swarm-scenario/Swarm/Game/Robot/Walk.hs b/src/swarm-scenario/Swarm/Game/Robot/Walk.hs new file mode 100644 index 000000000..97961b768 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Robot/Walk.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Walkability exceptions +module Swarm.Game.Robot.Walk where + +import Control.Monad (unless) +import Data.Aeson +import Data.List.NonEmpty qualified as NE +import Data.Set (Set) +import Data.Set qualified as S +import GHC.Generics (Generic) +import Swarm.Game.Entity (EntityName) +import Swarm.Language.Capability (Capability) + +-- | A 'Blacklist' that is empty is the typical behavior, +-- in which walkability is +-- fully determined by an entity's 'Unwalkable' or 'Liquid' property. +-- A 'Whitelist' ignores those properties, and even blank terrain +-- is considered unwalkable. +-- Note that a 'Whitelist' that is empty would allow no movement whatsoever. +data Inclusions a + = Whitelist a + | Blacklist a + deriving (Show, Eq, Functor, Generic, ToJSON) + +emptyExceptions :: Monoid a => Inclusions a +emptyExceptions = Blacklist mempty + +type WalkabilityExceptions a = Inclusions (Set a) + +instance (FromJSON a, Ord a) => FromJSON (WalkabilityExceptions a) where + parseJSON = withObject "walkable" $ \v -> do + whitelist <- v .:? "only" .!= [] + blacklist <- v .:? "never" .!= [] + + unless (null whitelist || null blacklist) $ + fail "Cannot specify both a whitelist and blacklist" + + let exceptionList = + maybe + (Blacklist blacklist) -- Note: empty blacklist is the typical case + (Whitelist . NE.toList) + (NE.nonEmpty whitelist) + + return $ S.fromList <$> exceptionList + +-- | Properties of a robot used to determine whether an entity is walkable +data WalkabilityContext + = WalkabilityContext + (Set Capability) + -- | which entities are unwalkable by this robot + (WalkabilityExceptions EntityName) + deriving (Show, Eq, Generic, ToJSON) diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index cd9c81e8c..ff7e2a3ac 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -24,6 +24,7 @@ module Swarm.Game.Scenario ( Scenario (..), ScenarioLandscape (..), StaticStructureInfo (..), + ScenarioMetadata (ScenarioMetadata), staticPlacements, structureDefs, @@ -38,7 +39,7 @@ module Swarm.Game.Scenario ( scenarioCreative, scenarioSeed, scenarioAttrs, - scenarioEntities, + scenarioTerrainAndEntities, scenarioCosmetics, scenarioRecipes, scenarioKnown, @@ -56,9 +57,9 @@ module Swarm.Game.Scenario ( getScenarioPath, loadStandaloneScenario, GameStateInputs (..), + ScenarioInputs (..), -- * Utilities - integrateScenarioEntities, arbitrateSeed, ) where @@ -79,10 +80,12 @@ 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.Game.Entity import Swarm.Game.Entity.Cosmetic import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes) import Swarm.Game.Failure +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Recipe import Swarm.Game.ResourceLoading (getDataFileNameSafe) @@ -99,6 +102,7 @@ import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..)) import Swarm.Game.Scenario.Topography.WorldDescription +import Swarm.Game.Terrain import Swarm.Game.Universe import Swarm.Game.World.Gen (Seed) import Swarm.Game.World.Load (loadWorlds) @@ -139,7 +143,14 @@ data ScenarioMetadata = ScenarioMetadata , _scenarioName :: Text , _scenarioAuthor :: Maybe Text } - deriving (Show) + deriving (Show, Generic) + +instance ToJSON ScenarioMetadata where + toEncoding = + genericToEncoding + defaultOptions + { fieldLabelModifier = drop 1 -- drops leading underscore + } makeLensesNoSigs ''ScenarioMetadata @@ -197,7 +208,7 @@ scenarioStepsPerTick :: Lens' ScenarioOperation (Maybe Int) data ScenarioLandscape = ScenarioLandscape { _scenarioSeed :: Maybe Int , _scenarioAttrs :: [CustomAttr] - , _scenarioEntities :: EntityMap + , _scenarioTerrainAndEntities :: TerrainEntityMaps , _scenarioCosmetics :: M.Map WorldAttr PreservableColor , _scenarioKnown :: Set EntityName , _scenarioWorlds :: NonEmpty WorldDescription @@ -216,8 +227,9 @@ scenarioSeed :: Lens' ScenarioLandscape (Maybe Int) -- | Custom attributes defined in the scenario. scenarioAttrs :: Lens' ScenarioLandscape [CustomAttr] --- | Any custom entities used for this scenario. -scenarioEntities :: Lens' ScenarioLandscape EntityMap +-- | Any custom terrain and entities used for this scenario, +-- combined with the default system terrain and entities. +scenarioTerrainAndEntities :: Lens' ScenarioLandscape TerrainEntityMaps -- | High-fidelity color map for entities scenarioCosmetics :: Lens' ScenarioLandscape (M.Map WorldAttr PreservableColor) @@ -263,8 +275,11 @@ scenarioLandscape :: Lens' Scenario ScenarioLandscape -- * Parsing -instance FromJSONE (EntityMap, WorldMap) Scenario where +instance FromJSONE ScenarioInputs Scenario where parseJSONE = withObjectE "scenario" $ \v -> do + -- parse custom terrain + tmRaw <- liftE (v .:? "terrains" .!= []) + -- parse custom entities emRaw <- liftE (v .:? "entities" .!= []) @@ -272,20 +287,29 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where let mergedCosmetics = worldAttributes <> M.fromList (mapMaybe toHifiPair parsedAttrs) attrsUnion = M.keysSet mergedCosmetics - runValidation $ validateAttrRefs attrsUnion emRaw + validatedTerrainObjects <- runValidation $ validateTerrainAttrRefs attrsUnion tmRaw + + let tm = mkTerrainMap validatedTerrainObjects + + runValidation $ validateEntityAttrRefs attrsUnion emRaw em <- runValidation $ buildEntityMap emRaw + let scenarioSpecificTerrainEntities = TerrainEntityMaps tm em + -- Save the passed in WorldMap for later - worldMap <- snd <$> getE + worldMap <- initWorldMap <$> getE - -- Get rid of WorldMap from context locally, and combine EntityMap - -- with any custom entities parsed above - localE fst $ withE em $ do + -- Get rid of WorldMap from context locally, and combine + -- the default system TerrainMap and EntityMap + -- with any custom terrain/entities parsed above + localE initEntityTerrain $ withE scenarioSpecificTerrainEntities $ do -- parse 'known' entity names and make sure they exist known <- liftE (v .:? "known" .!= mempty) - em' <- getE - case filter (isNothing . (`lookupEntityName` em')) known of + combinedTEM <- getE + + let TerrainEntityMaps _tm emCombined = combinedTEM + case filter (isNothing . (`lookupEntityName` emCombined)) known of [] -> return () unk -> failT ["Unknown entities in 'known' list:", T.intercalate ", " unk] @@ -314,7 +338,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> Grid s <$ ns) mergedStructures - allWorlds <- localE (worldMap,rootLevelSharedStructures,,rsMap) $ do + allWorlds <- localE (WorldParseDependencies worldMap rootLevelSharedStructures rsMap) $ do rootWorld <- v ..: "world" subworlds <- v ..:? "subworlds" ..!= [] return $ rootWorld :| subworlds @@ -355,7 +379,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where ScenarioLandscape seed parsedAttrs - em + combinedTEM mergedCosmetics (Set.fromList known) allWorlds @@ -375,7 +399,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where <*> liftE (v .:? "description" .!= "") <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives) <*> liftE (v .:? "solution") - <*> v ..:? "recipes" ..!= [] + <*> localE (view entityMap) (v ..:? "recipes" ..!= []) <*> liftE (v .:? "stepsPerTick") return $ Scenario metadata playInfo landscape @@ -402,24 +426,22 @@ getScenarioPath scenario = do loadScenario :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => FilePath -> - EntityMap -> - WorldMap -> + ScenarioInputs -> m (Scenario, FilePath) -loadScenario scenario em worldMap = do +loadScenario scenario scenarioInputs = do mfileName <- getScenarioPath scenario fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName - (,fileName) <$> loadScenarioFile em worldMap fileName + (,fileName) <$> loadScenarioFile scenarioInputs fileName -- | Load a scenario from a file. loadScenarioFile :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - EntityMap -> - WorldMap -> + ScenarioInputs -> FilePath -> m Scenario -loadScenarioFile em worldMap fileName = +loadScenarioFile scenarioInputs fileName = (withThrow adaptError . (liftEither <=< sendIO)) $ - decodeFileEitherE (em, worldMap) fileName + decodeFileEitherE scenarioInputs fileName where adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml @@ -428,21 +450,30 @@ loadStandaloneScenario :: FilePath -> m (Scenario, GameStateInputs) loadStandaloneScenario fp = do - entities <- loadEntities - recipes <- loadRecipes entities - worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities - scene <- fst <$> loadScenario fp entities worlds - return (scene, GameStateInputs worlds entities recipes) - -data GameStateInputs = GameStateInputs + tem <- loadEntitiesAndTerrain + worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem + let scenarioInputs = ScenarioInputs worlds tem + recipes <- loadRecipes $ tem ^. entityMap + scene <- fst <$> loadScenario fp scenarioInputs + return (scene, GameStateInputs scenarioInputs recipes) + +data ScenarioInputs = ScenarioInputs { initWorldMap :: WorldMap - , initEntities :: EntityMap - , initRecipes :: [Recipe Entity] + -- ^ A collection of typechecked world DSL terms that are available to + -- be used in scenario definitions. + , initEntityTerrain :: TerrainEntityMaps + -- ^ The standard terrain/entity maps loaded from disk. Individual scenarios + -- may define additional terrain/entities which will get added to this map + -- when loading the scenario. } -integrateScenarioEntities :: GameStateInputs -> ScenarioLandscape -> EntityMap -integrateScenarioEntities gsi sLandscape = - initEntities gsi <> sLandscape ^. scenarioEntities +data GameStateInputs = GameStateInputs + { gsiScenarioInputs :: ScenarioInputs + , gsiRecipes :: [Recipe Entity] + -- ^ The standard list of recipes loaded from disk. Individual scenarios + -- may define additional recipes which will get added to this list + -- when loading the scenario. + } -- | -- Decide on a seed. In order of preference, we will use: diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs index 50f693aa3..e1b7c37be 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs @@ -11,17 +11,21 @@ module Swarm.Game.Scenario.Topography.Cell ( ) where import Control.Lens hiding (from, (.=), (<.>)) -import Control.Monad.Extra (mapMaybeM) +import Control.Monad.Extra (mapMaybeM, unless) import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as M import Data.Maybe (catMaybes, listToMaybe) import Data.Text (Text) +import Data.Text qualified as T import Data.Vector qualified as V import Data.Yaml as Y import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Land 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 (quote, showT) import Swarm.Util.Erasable (Erasable (..)) import Swarm.Util.Yaml @@ -67,14 +71,24 @@ instance ToJSON Cell where ENothing -> Nothing EJust e -> Just (e ^. entityName) -instance FromJSONE (EntityMap, RobotMap) Cell where +instance FromJSONE (TerrainEntityMaps, 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 + (TerrainEntityMaps tm _, _) <- getE terr <- liftE $ parseJSON (NE.head tup) + unless (M.member terr $ terrainByName tm) + . fail + . T.unpack + $ T.unwords + [ "Unrecognized terrain type" + , quote $ getTerrainWord terr + , "Avaliable:" + , showT $ M.keys $ terrainByName tm + ] ent <- case tup ^? ix 1 of Nothing -> return ENothing @@ -83,7 +97,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where case meName of Nothing -> return ENothing Just "erase" -> return EErase - Just name -> fmap EJust . localE fst $ getEntity name + Just name -> fmap EJust . localE (view entityMap . fst) $ getEntity name let name2rob r = do mrName <- liftE $ parseJSON @(Maybe RobotName) r @@ -97,7 +111,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where -- 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 +instance FromJSONE (TerrainEntityMaps, RobotMap) (AugmentedCell Entity) where parseJSONE x = case x of Object v -> objParse v z -> AugmentedCell Nothing <$> parseJSONE z diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs index 035d4a28d..516845829 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs @@ -22,7 +22,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Yaml as Y -import Swarm.Game.Entity +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.Area @@ -58,7 +58,7 @@ type NamedStructure c = NamedArea (PStructure c) type InheritedStructureDefs = [NamedStructure (Maybe Cell)] -instance FromJSONE (EntityMap, RobotMap) (NamedArea (PStructure (Maybe Cell))) where +instance FromJSONE (TerrainEntityMaps, RobotMap) (NamedArea (PStructure (Maybe Cell))) where parseJSONE = withObjectE "named structure" $ \v -> do NamedArea <$> liftE (v .: "name") @@ -211,15 +211,17 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct where renderDir = quote . T.pack . directionJsonModifier . show -instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe Cell)) where +instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) 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 + + liftE $ do + placementDefs <- v .:? "placements" .!= [] + waypointDefs <- v .:? "waypoints" .!= [] + maybeMaskChar <- v .:? "mask" + (maskedArea, mapWaypoints) <- (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 diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 9c77dcd35..b8591373d 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -15,6 +15,7 @@ import Data.Maybe (catMaybes) import Data.Text qualified as T import Data.Yaml as Y import Swarm.Game.Entity +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.Cell @@ -61,10 +62,18 @@ data PWorldDescription e = WorldDescription type WorldDescription = PWorldDescription Entity -instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) WorldDescription where +data WorldParseDependencies + = WorldParseDependencies + WorldMap + InheritedStructureDefs + RobotMap + -- | last for the benefit of partial application + TerrainEntityMaps + +instance FromJSONE WorldParseDependencies WorldDescription where parseJSONE = withObjectE "world description" $ \v -> do - (worldMap, scenarioLevelStructureDefs, em, rm) <- getE - (pal, rootWorldStructureDefs) <- localE (const (em, rm)) $ do + WorldParseDependencies worldMap scenarioLevelStructureDefs rm tem <- getE + (pal, rootWorldStructureDefs) <- localE (const (tem, rm)) $ do pal <- v ..:? "palette" ..!= WorldPalette mempty rootWorldStructs <- v ..:? "structures" ..!= [] return (pal, rootWorldStructs) @@ -97,7 +106,7 @@ instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) World mwexp <- liftE (v .:? "dsl") dslTerm <- forM mwexp $ \wexp -> do let checkResult = - run . runThrow @CheckErr . runReader worldMap . runReader em $ + run . runThrow @CheckErr . runReader worldMap . runReader tem $ check CNil (TTyWorld TTyCell) wexp either (fail . prettyString) return checkResult WorldDescription diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs index 236384856..a0373b430 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -14,6 +14,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Tuple (swap) import Swarm.Game.Entity +import Swarm.Game.Land import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade @@ -26,7 +27,7 @@ newtype WorldPalette e = WorldPalette {unPalette :: KeyMap (AugmentedCell e)} deriving (Eq, Show) -instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where +instance FromJSONE (TerrainEntityMaps, RobotMap) (WorldPalette Entity) where parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE type TerrainWith a = (TerrainType, Erasable a) diff --git a/src/swarm-scenario/Swarm/Game/State/Config.hs b/src/swarm-scenario/Swarm/Game/State/Config.hs index fa5859ab5..7ad9b79fc 100644 --- a/src/swarm-scenario/Swarm/Game/State/Config.hs +++ b/src/swarm-scenario/Swarm/Game/State/Config.hs @@ -5,12 +5,16 @@ -- 'Swarm.Game.State.GameState' record and its subrecords. module Swarm.Game.State.Config where +import Data.Map (Map) +import Data.Text (Text) import Swarm.Game.ResourceLoading (NameGenerator) import Swarm.Game.Scenario (GameStateInputs) -- | Record to pass information needed to create an initial -- 'GameState' record when starting a scenario. data GameStateConfig = GameStateConfig - { initNameParts :: NameGenerator + { initAppDataMap :: Map Text Text + , nameParts :: NameGenerator + -- ^ Lists of words/adjectives for use in building random robot names. , initState :: GameStateInputs } diff --git a/src/swarm-scenario/Swarm/Game/State/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs index be1efc304..5db9aa3bb 100644 --- a/src/swarm-scenario/Swarm/Game/State/Landscape.hs +++ b/src/swarm-scenario/Swarm/Game/State/Landscape.hs @@ -12,7 +12,7 @@ module Swarm.Game.State.Landscape ( worldNavigation, multiWorld, worldScrollable, - entityMap, + terrainAndEntities, -- ** Utilities initLandscape, @@ -34,12 +34,13 @@ import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (isJust, listToMaybe) import Swarm.Game.Entity +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Robot (TRobot, trobotLocation) import Swarm.Game.Scenario import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.State.Config -import Swarm.Game.Terrain (TerrainType (..)) +import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName) import Swarm.Game.Universe as U import Swarm.Game.World import Swarm.Game.World.Eval (runWorld) @@ -53,7 +54,7 @@ type SubworldDescription = (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int data Landscape = Landscape { _worldNavigation :: Navigation (M.Map SubworldName) Location , _multiWorld :: MultiWorld Int Entity - , _entityMap :: EntityMap + , _terrainAndEntities :: TerrainEntityMaps , _worldScrollable :: Bool } @@ -69,8 +70,8 @@ worldNavigation :: Lens' Landscape (Navigation (M.Map SubworldName) Location) -- unboxed tile arrays. multiWorld :: Lens' Landscape (MultiWorld Int Entity) --- | The catalog of all entities that the game knows about. -entityMap :: Lens' Landscape EntityMap +-- | The catalogs of all terrain and entities that the game knows about. +terrainAndEntities :: Lens' Landscape TerrainEntityMaps -- | Whether the world map is supposed to be scrollable or not. worldScrollable :: Lens' Landscape Bool @@ -82,16 +83,16 @@ initLandscape gsc = Landscape { _worldNavigation = Navigation mempty mempty , _multiWorld = mempty - , _entityMap = initEntities $ initState gsc + , _terrainAndEntities = initEntityTerrain $ gsiScenarioInputs $ initState gsc , _worldScrollable = True } -mkLandscape :: ScenarioLandscape -> EntityMap -> NonEmpty SubworldDescription -> Seed -> Landscape -mkLandscape sLandscape em worldTuples theSeed = +mkLandscape :: ScenarioLandscape -> NonEmpty SubworldDescription -> Seed -> Landscape +mkLandscape sLandscape worldTuples theSeed = Landscape - { _entityMap = em - , _worldNavigation = sLandscape ^. scenarioNavigation + { _worldNavigation = sLandscape ^. scenarioNavigation , _multiWorld = genMultiWorld worldTuples theSeed + , _terrainAndEntities = sLandscape ^. scenarioTerrainAndEntities , -- 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. @@ -100,7 +101,7 @@ mkLandscape sLandscape em worldTuples theSeed = buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription buildWorldTuples sLandscape = - NE.map (worldName &&& buildWorld) $ + NE.map (worldName &&& buildWorld (sLandscape ^. scenarioTerrainAndEntities)) $ sLandscape ^. scenarioWorlds genMultiWorld :: NonEmpty SubworldDescription -> Seed -> MultiWorld Int Entity @@ -114,9 +115,11 @@ genMultiWorld worldTuples s = -- | 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) +buildWorld :: TerrainEntityMaps -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) +buildWorld tem WorldDescription {..} = + (robots worldName, first getTerrainIndex . wf) where + getTerrainIndex t = M.findWithDefault 0 t $ terrainIndexByName $ tem ^. terrainMap rs = fromIntegral $ length area cs = fromIntegral $ maybe 0 length $ listToMaybe area Coords (ulr, ulc) = locToCoords ul diff --git a/src/swarm-scenario/Swarm/Game/Terrain.hs b/src/swarm-scenario/Swarm/Game/Terrain.hs index d10d27a00..e2a0e1d16 100644 --- a/src/swarm-scenario/Swarm/Game/Terrain.hs +++ b/src/swarm-scenario/Swarm/Game/Terrain.hs @@ -5,36 +5,60 @@ -- -- Terrain types and properties. module Swarm.Game.Terrain ( - -- * Terrain TerrainType (..), - readTerrain, - terrainMap, + TerrainObj (..), + TerrainMap (..), + blankTerrainIndex, getTerrainDefaultPaletteChar, getTerrainWord, + terrainFromText, + loadTerrain, + mkTerrainMap, + validateTerrainAttrRefs, ) where -import Data.Aeson (FromJSON (..), withText) -import Data.List.NonEmpty qualified as NE +import Control.Algebra (Has) +import Control.Arrow (first, (&&&)) +import Control.Effect.Lift (Lift, sendIO) +import Control.Effect.Throw (Throw, liftEither, throwError) +import Control.Monad (forM, unless, (<=<)) +import Data.Char (toUpper) +import Data.IntMap (IntMap) +import Data.IntMap qualified as IM import Data.Map (Map) import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) import Data.Text qualified as T +import Data.Tuple (swap) +import Data.Yaml +import GHC.Generics (Generic) 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") +import Swarm.Game.Entity.Cosmetic (WorldAttr (..)) +import Swarm.Game.Failure +import Swarm.Game.ResourceLoading (getDataFileNameSafe) +import Swarm.Util (enumeratedMap, quote) +import Swarm.Util.Effect (withThrow) + +data TerrainType = BlankT | TerrainType Text + deriving (Eq, Ord, Show, Generic, ToJSON) + +blankTerrainIndex :: Int +blankTerrainIndex = 0 + +terrainFromText :: Text -> TerrainType +terrainFromText "blank" = BlankT +terrainFromText x = TerrainType x + +getTerrainWord :: TerrainType -> Text +getTerrainWord BlankT = "blank" +getTerrainWord (TerrainType x) = x + +instance FromJSON TerrainType where + parseJSON = + withText "TerrainType" $ + return . terrainFromText instance Semigroup TerrainType where t <> BlankT = t @@ -43,25 +67,98 @@ instance Semigroup TerrainType where 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) - ] +getTerrainDefaultPaletteChar = toUpper . T.head . getTerrainWord + +-- | Representation for parsing only. Not exported. +data TerrainItem = TerrainItem + { name :: TerrainType + , attr :: Text + , description :: Text + } + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + +data TerrainObj = TerrainObj + { terrainName :: TerrainType + , terrainDesc :: Text + , terrainDisplay :: Display + } + deriving (Show) + +promoteTerrainObjects :: [TerrainItem] -> [TerrainObj] +promoteTerrainObjects = + map (\(TerrainItem n a d) -> TerrainObj n d $ defaultTerrainDisplay (AWorld a)) + +invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int +invertedIndexMap = M.fromList . map (first terrainName . swap) . IM.toList + +-- | Each terrain type shall have a unique +-- integral index. The indices should +-- be consecutive by parse order. +data TerrainMap = TerrainMap + { terrainByName :: Map TerrainType TerrainObj + , terrainByIndex :: IntMap TerrainObj + , terrainIndexByName :: Map TerrainType Int + -- ^ basically the inverse of 'terrainByIndex'. + -- This needs to be (is) recomputed upon every update to + -- the other fields in 'TerrainMap'. + } + deriving (Show) + +instance Semigroup TerrainMap where + TerrainMap oldByName oldByIndex _ <> TerrainMap newByName newByIndex _ = + TerrainMap + (oldByName <> newByName) + combinedTerrainByIndex + (invertedIndexMap combinedTerrainByIndex) + where + combinedTerrainByIndex = oldByIndex <> enumeratedMap (IM.size oldByIndex) (IM.elems newByIndex) + +instance Monoid TerrainMap where + mempty = TerrainMap mempty mempty mempty + +mkTerrainMap :: [TerrainObj] -> TerrainMap +mkTerrainMap items = + TerrainMap + { terrainByName = M.fromList $ map (terrainName &&& id) items + , terrainByIndex = byIndex + , terrainIndexByName = invertedIndexMap byIndex + } + where + byIndex = enumeratedMap blankTerrainIndex items + +-- | Validates references to 'Display' attributes +validateTerrainAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [TerrainItem] -> m [TerrainObj] +validateTerrainAttrRefs validAttrs rawTerrains = + forM rawTerrains $ \(TerrainItem n a d) -> do + unless (Set.member (WorldAttr $ T.unpack a) validAttrs) + . throwError + . CustomMessage + $ T.unwords + [ "Nonexistent attribute" + , quote a + , "referenced by terrain" + , quote $ getTerrainWord n + ] + + return $ TerrainObj n d $ defaultTerrainDisplay (AWorld a) + +-- | Load terrain from a data file called @terrains.yaml@, producing +-- either an 'TerrainMap' or a parse error. +loadTerrain :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m TerrainMap +loadTerrain = do + fileName <- getDataFileNameSafe Terrain terrainFile + decoded <- + withThrow (terrainFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ + decodeFileEither fileName + + let terrainObjs = promoteTerrainObjects decoded + -- Ensures that the blank terrain gets index 0 + return $ mkTerrainMap $ blankTerrainObj : terrainObjs + where + terrainFile = "terrains.yaml" + terrainFailure = AssetNotLoaded (Data Terrain) terrainFile + + blankTerrainObj = TerrainObj BlankT "Blank terrain" $ defaultTerrainDisplay ADefault diff --git a/src/swarm-scenario/Swarm/Game/World.hs b/src/swarm-scenario/Swarm/Game/World.hs index c44542995..3fa269332 100644 --- a/src/swarm-scenario/Swarm/Game/World.hs +++ b/src/swarm-scenario/Swarm/Game/World.hs @@ -61,14 +61,16 @@ import Data.Bifunctor (second) import Data.Bits import Data.Foldable (foldl') import Data.Int (Int32) +import Data.IntMap qualified as IM import Data.Map (Map) import Data.Map.Strict qualified as M +import Data.Maybe (fromMaybe) 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.Terrain (TerrainMap, TerrainType (BlankT), terrainByIndex, terrainName) import Swarm.Game.Universe import Swarm.Game.World.Coords import Swarm.Game.World.Modify @@ -199,12 +201,15 @@ newWorld :: WorldFun t e -> World t e newWorld f = World f M.empty M.empty lookupCosmicTerrain :: - IArray U.UArray Int => + TerrainMap -> Cosmic Coords -> MultiWorld Int e -> TerrainType -lookupCosmicTerrain (Cosmic subworldName i) multiWorld = - maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName multiWorld +lookupCosmicTerrain tm (Cosmic subworldName i) multiWorld = + fromMaybe BlankT $ do + x <- M.lookup subworldName multiWorld + y <- (`IM.lookup` terrainByIndex tm) . lookupTerrain i $ x + return $ terrainName y -- | Look up the terrain value at certain coordinates: try looking it -- up in the tile cache first, and fall back to running the 'WorldFun' diff --git a/src/swarm-scenario/Swarm/Game/World/Load.hs b/src/swarm-scenario/Swarm/Game/World/Load.hs index 67fe131c8..ec0962b3d 100644 --- a/src/swarm-scenario/Swarm/Game/World/Load.hs +++ b/src/swarm-scenario/Swarm/Game/World/Load.hs @@ -16,8 +16,8 @@ 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.Land import Swarm.Game.ResourceLoading (getDataDirSafe) import Swarm.Game.World.Parse (parseWExp, runParser) import Swarm.Game.World.Typecheck @@ -31,15 +31,15 @@ import Witch (into) -- 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 -> + TerrainEntityMaps -> m WorldMap -loadWorlds em = do +loadWorlds tem = 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 + ws <- mapM (throwToWarning @SystemFailure . loadWorld dir tem) worldFiles return . M.fromList . catMaybes $ ws -- | Load a file containing a world DSL term, throwing an exception if @@ -47,16 +47,16 @@ loadWorlds em = do loadWorld :: (Has (Throw SystemFailure) sig m) => FilePath -> - EntityMap -> + TerrainEntityMaps -> (FilePath, String) -> m (Text, Some (TTerm '[])) -loadWorld dir em (fp, src) = do +loadWorld dir tem (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 $ + runReader tem . runReader @WorldMap M.empty $ infer CNil wexp return (into @Text (dropExtension (stripDir dir fp)), t) diff --git a/src/swarm-scenario/Swarm/Game/World/Render.hs b/src/swarm-scenario/Swarm/Game/World/Render.hs index e2ef3e81f..eb67b03ce 100644 --- a/src/swarm-scenario/Swarm/Game/World/Render.hs +++ b/src/swarm-scenario/Swarm/Game/World/Render.hs @@ -20,6 +20,7 @@ import Linear (V2 (..)) import Swarm.Game.Display (defaultChar) import Swarm.Game.Entity.Cosmetic import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Scenario import Swarm.Game.Scenario.Topography.Area @@ -128,7 +129,7 @@ getDisplayGrid :: getDisplayGrid vc sLandscape ls maybeSize = getMapRectangle mkFacade - (getContentAt worlds . mkCosmic) + (getContentAt (sLandscape ^. scenarioTerrainAndEntities . terrainMap) worlds . mkCosmic) (getBoundingBox vc firstScenarioWorld maybeSize) where mkCosmic = Cosmic $ worldName firstScenarioWorld @@ -142,13 +143,12 @@ getRenderableGrid :: FilePath -> m (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor) getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize _) fp = do - (myScenario, gsi) <- loadStandaloneScenario fp + (myScenario, _gsi) <- loadStandaloneScenario fp let sLandscape = myScenario ^. scenarioLandscape theSeed <- sendIO $ arbitrateSeed maybeSeed sLandscape - let em = integrateScenarioEntities gsi sLandscape - worldTuples = buildWorldTuples sLandscape - myLandscape = mkLandscape sLandscape em worldTuples theSeed + let worldTuples = buildWorldTuples sLandscape + myLandscape = mkLandscape sLandscape worldTuples theSeed vc = view planar $ diff --git a/src/swarm-scenario/Swarm/Game/World/Typecheck.hs b/src/swarm-scenario/Swarm/Game/World/Typecheck.hs index 2eaeb549b..47266d644 100644 --- a/src/swarm-scenario/Swarm/Game/World/Typecheck.hs +++ b/src/swarm-scenario/Swarm/Game/World/Typecheck.hs @@ -34,8 +34,9 @@ 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.Entity (lookupEntityName) +import Swarm.Game.Land +import Swarm.Game.Terrain import Swarm.Game.World.Syntax import Swarm.Language.Pretty import Swarm.Util (showT) @@ -448,7 +449,7 @@ lookup x (CCons y ty ctx) -- value (/i.e./ @const 3@). check :: ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m + , Has (Reader TerrainEntityMaps) sig m , Has (Reader WorldMap) sig m ) => Ctx g -> @@ -562,7 +563,7 @@ typeArgsFor _ _ = [] -- a typed, elaborated version of the application. applyOp :: ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m + , Has (Reader TerrainEntityMaps) sig m , Has (Reader WorldMap) sig m ) => Ctx g -> @@ -577,7 +578,7 @@ applyOp ctx op ts = do infer :: forall sig m g. ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m + , Has (Reader TerrainEntityMaps) sig m , Has (Reader WorldMap) sig m ) => Ctx g -> @@ -606,7 +607,9 @@ infer _ctx (WImport key) = do -- 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) => + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + ) => RawCellVal -> m CellVal resolveCell items = do @@ -617,7 +620,9 @@ resolveCell items = do -- entity, robot, etc.). resolveCellItem :: forall sig m. - (Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) => + ( Has (Throw CheckErr) sig m + , Has (Reader TerrainEntityMaps) sig m + ) => (Maybe CellTag, Text) -> m CellVal resolveCellItem (mCellTag, item) = case mCellTag of @@ -635,14 +640,17 @@ resolveCellItem (mCellTag, item) = case mCellTag of 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 + CellTerrain -> \tName -> do + TerrainEntityMaps tm _em <- ask @TerrainEntityMaps + return . fmap (mkTerrain . terrainName) . (`M.lookup` terrainByName tm) $ terrainFromText tName CellEntity -> \eName -> case eName of "erase" -> return $ Just (CellVal mempty EErase mempty) _ -> do - em <- ask @EntityMap + TerrainEntityMaps _tm em <- ask @TerrainEntityMaps return . fmap mkEntity $ lookupEntityName eName em CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots @@ -650,7 +658,7 @@ resolveCellItem (mCellTag, item) = case mCellTag of -- of lambda applications. inferLet :: ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m + , Has (Reader TerrainEntityMaps) sig m , Has (Reader WorldMap) sig m ) => Ctx g -> @@ -667,7 +675,7 @@ inferLet ctx ((x, e) : xs) body = do -- chain of @<>@ (over) operations. inferOverlay :: ( Has (Throw CheckErr) sig m - , Has (Reader EntityMap) sig m + , Has (Reader TerrainEntityMaps) sig m , Has (Reader WorldMap) sig m ) => Ctx g -> diff --git a/src/swarm-scenario/Swarm/Util/Content.hs b/src/swarm-scenario/Swarm/Util/Content.hs index ad1125a33..03ad1a491 100644 --- a/src/swarm-scenario/Swarm/Util/Content.hs +++ b/src/swarm-scenario/Swarm/Util/Content.hs @@ -11,21 +11,20 @@ import Data.Map qualified as M import Data.Text qualified as T import Swarm.Game.Display import Swarm.Game.Entity.Cosmetic -import Swarm.Game.Entity.Cosmetic.Assignment (terrainAttributes) import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.Cell (PCell (..)) import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Terrain (TerrainType, getTerrainWord) +import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainWord) import Swarm.Game.Universe import Swarm.Game.World import Swarm.Util.Erasable (erasableToMaybe, maybeToErasable) -- | Get the terrain and entity at a single cell -getContentAt :: MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e) -getContentAt w coords = (underlyingCellTerrain, underlyingCellEntity) +getContentAt :: TerrainMap -> MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e) +getContentAt tm w coords = (underlyingCellTerrain, underlyingCellEntity) where underlyingCellEntity = lookupCosmicEntity coords w - underlyingCellTerrain = lookupCosmicTerrain coords w + underlyingCellTerrain = lookupCosmicTerrain tm coords w -- * Rendering @@ -60,7 +59,7 @@ getTerrainEntityColor :: getTerrainEntityColor aMap (Cell terr cellEnt _) = (entityColor =<< erasableToMaybe cellEnt) <|> terrainFallback where - terrainFallback = M.lookup (TerrainAttr $ T.unpack $ getTerrainWord terr) terrainAttributes + terrainFallback = M.lookup (WorldAttr $ T.unpack $ getTerrainWord terr) aMap entityColor (EntityFacade _ d) = case d ^. displayAttr of AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap _ -> Nothing diff --git a/src/swarm-util/Swarm/Util.hs b/src/swarm-util/Swarm/Util.hs index da4cc540d..48a1671d6 100644 --- a/src/swarm-util/Swarm/Util.hs +++ b/src/swarm-util/Swarm/Util.hs @@ -13,6 +13,7 @@ module Swarm.Util ( sortPair, maxOn, maximum0, + enumeratedMap, cycleEnum, listEnums, listEnumsNonempty, @@ -90,6 +91,8 @@ import Data.Bifunctor (Bifunctor (bimap), first) import Data.Char (isAlphaNum, toLower) import Data.Either.Validation import Data.Foldable qualified as Foldable +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IM import Data.List (foldl', maximumBy, partition) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty ((:|))) @@ -142,6 +145,9 @@ maximum0 :: (Num a, Ord a) => [a] -> a maximum0 [] = 0 maximum0 xs = maximum xs +enumeratedMap :: Int -> [a] -> IntMap a +enumeratedMap startIdx = IM.fromList . zip [startIdx ..] + -- | Take the successor of an 'Enum' type, wrapping around when it -- reaches the end. cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e diff --git a/swarm.cabal b/swarm.cabal index 1162ed732..2b9c4ec75 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -192,10 +192,12 @@ library swarm-scenario Swarm.Game.Entity.Cosmetic Swarm.Game.Entity.Cosmetic.Assignment Swarm.Game.Failure + Swarm.Game.Land Swarm.Game.Location Swarm.Game.Recipe Swarm.Game.ResourceLoading Swarm.Game.Robot + Swarm.Game.Robot.Walk Swarm.Game.Scenario Swarm.Game.Scenario.Objective Swarm.Game.Scenario.Objective.Graph @@ -540,6 +542,7 @@ library Swarm.Game.Entity.Cosmetic.Assignment, Swarm.Game.Exception, Swarm.Game.Failure, + Swarm.Game.Land, Swarm.Game.Location, Swarm.Game.Recipe, Swarm.Game.ResourceLoading, @@ -547,6 +550,7 @@ library Swarm.Game.Robot.Activity, Swarm.Game.Robot.Concrete, Swarm.Game.Robot.Context, + Swarm.Game.Robot.Walk, Swarm.Game.Scenario, Swarm.Game.Scenario.Objective, Swarm.Game.Scenario.Objective.Graph, @@ -711,7 +715,7 @@ executable swarm build-depends: -- Imports shared with the library don't need bounds base, - blaze-html >=0.9.1 && <0.9.2, + blaze-html >=0.9.1 && <0.10, brick, fused-effects, githash >=0.1.6 && <0.2, diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs index c77e6db7d..5cc3fc292 100644 --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -6,7 +6,7 @@ module Main where import Control.Carrier.Accum.FixedStrict (runAccum) -import Control.Lens ((&), (.~)) +import Control.Lens (view, (&), (.~)) import Control.Monad (replicateM_) import Control.Monad.State (evalStateT, execStateT) import Data.Map qualified as M @@ -19,13 +19,14 @@ import Swarm.Game.Display (defaultRobotDisplay) import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Location import Swarm.Game.Robot (TRobot, mkRobot) +import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Scenario (loadStandaloneScenario) import Swarm.Game.State (GameState, creativeMode, landscape, pureScenarioToGameState, zoomRobots) import Swarm.Game.State.Landscape (multiWorld) import Swarm.Game.State.Robot (addTRobot) -import Swarm.Game.State.Runtime (initRuntimeState, mkGameStateConfig) +import Swarm.Game.State.Runtime (initRuntimeState, stdGameConfigInputs) import Swarm.Game.Step (gameTick) -import Swarm.Game.Terrain (TerrainType (DirtT)) +import Swarm.Game.Terrain (blankTerrainIndex) import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld)) import Swarm.Game.World (WorldFun (..), newWorld) import Swarm.Language.Context qualified as Context @@ -132,7 +133,7 @@ initRobot prog loc = [] False False - mempty + emptyExceptions 0 -- | Creates a GameState with numRobot copies of robot on a blank map, aligned @@ -145,13 +146,13 @@ mkGameState prog robotMaker numRobots = do gs <- simpleErrorHandle $ do (_ :: Seq SystemFailure, initRS) <- runAccum mempty initRuntimeState (scenario, _) <- loadStandaloneScenario "classic" - return $ pureScenarioToGameState scenario 0 0 Nothing $ mkGameStateConfig initRS + return $ pureScenarioToGameState scenario 0 0 Nothing $ view stdGameConfigInputs initRS execStateT (zoomRobots $ mapM_ (addTRobot $ initMachine prog Context.empty emptyStore) robots) ( gs & creativeMode .~ True - & landscape . multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, ENothing))) + & landscape . multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (blankTerrainIndex, ENothing))) ) -- | Runs numGameTicks ticks of the game. diff --git a/test/integration/Main.hs b/test/integration/Main.hs index cbd87e6b6..413187cdb 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -13,7 +13,7 @@ import Control.Carrier.Lift (runM) import Control.Carrier.Throw.Either (runThrow) import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!)) import Control.Monad (forM_, unless, when) -import Control.Monad.State (StateT (runStateT), gets) +import Control.Monad.State (StateT, execStateT, gets) import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (Foldable (toList), find) @@ -31,13 +31,13 @@ import Swarm.Doc.Keyword qualified as Keyword import Swarm.Effect (runTimeIO) import Swarm.Game.Achievement.Definitions (GameplayAchievement (..)) import Swarm.Game.CESK (emptyStore, initMachine) -import Swarm.Game.Entity (EntityMap, lookupByName) +import Swarm.Game.Entity (lookupByName) import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Robot (equippedDevices, systemRobot) import Swarm.Game.Robot.Activity (commandsHistogram, lifetimeStepCount, tangibleCommandCount) import Swarm.Game.Robot.Concrete (activityCounts, machine, robotContext, robotLog, waitingUntil) import Swarm.Game.Robot.Context (defReqs) -import Swarm.Game.Scenario (Scenario) +import Swarm.Game.Scenario (Scenario, ScenarioInputs (..), gsiScenarioInputs) import Swarm.Game.State ( GameState, baseRobot, @@ -57,13 +57,13 @@ import Swarm.Game.State.Robot ( import Swarm.Game.State.Runtime ( RuntimeState, eventLog, - stdEntityMap, - worlds, + stdGameConfigInputs, ) import Swarm.Game.State.Substate ( WinCondition (WinConditions), WinStatus (Won), gameAchievements, + initState, messageQueue, notificationsContent, ticks, @@ -71,7 +71,6 @@ import Swarm.Game.State.Substate ( import Swarm.Game.Step (gameTick) import Swarm.Game.Step.Path.Type import Swarm.Game.Tick (getTickNumber) -import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) import Swarm.Language.Pretty (prettyString) @@ -106,16 +105,16 @@ main = do (rs, ui) <- do out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts either (assertFailure . prettyString) return out - let em = rs ^. stdEntityMap - let rs' = rs & eventLog .~ mempty + let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs + rs' = rs & eventLog .~ mempty defaultMain $ testGroup "Tests" [ testNoLoadingErrors rs , exampleTests examplePaths , exampleTests scenarioPrograms - , scenarioParseTests em (rs ^. worlds) parseableScenarios - , scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios + , scenarioParseTests scenarioInputs parseableScenarios + , scenarioParseInvalidTests scenarioInputs unparseableScenarios , testScenarioSolutions rs' ui , testEditorFiles ] @@ -144,27 +143,27 @@ exampleTest (path, fileContent) = where value = processTerm $ into @Text fileContent -scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree -scenarioParseTests em worldMap inputs = +scenarioParseTests :: ScenarioInputs -> [(FilePath, String)] -> TestTree +scenarioParseTests scenarioInputs inputs = testGroup "Test scenarios parse" - (map (scenarioTest Parsed em worldMap) inputs) + (map (scenarioTest Parsed scenarioInputs) inputs) -scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree -scenarioParseInvalidTests em worldMap inputs = +scenarioParseInvalidTests :: ScenarioInputs -> [(FilePath, String)] -> TestTree +scenarioParseInvalidTests scenarioInputs inputs = testGroup "Test invalid scenarios fail to parse" - (map (scenarioTest Failed em worldMap) inputs) + (map (scenarioTest Failed scenarioInputs) inputs) data ParseResult = Parsed | Failed -scenarioTest :: ParseResult -> EntityMap -> WorldMap -> (FilePath, String) -> TestTree -scenarioTest expRes em worldMap (path, _) = - testCase ("parse scenario " ++ show path) (getScenario expRes em worldMap path) +scenarioTest :: ParseResult -> ScenarioInputs -> (FilePath, String) -> TestTree +scenarioTest expRes scenarioInputs (path, _) = + testCase ("parse scenario " ++ show path) (getScenario expRes scenarioInputs path) -getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO () -getScenario expRes em worldMap p = do - res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario) +getScenario :: ParseResult -> ScenarioInputs -> FilePath -> IO () +getScenario expRes scenarioInputs p = do + res <- decodeFileEitherE scenarioInputs p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of Left err -> assertFailure (prettyPrintParseException err) @@ -225,7 +224,7 @@ testScenarioSolutions rs ui = ] , testGroup "Fun" - [ testSolution (Sec 10) "Fun/snake" + [ testSolution (Sec 20) "Fun/snake" ] , testGroup "Challenges" @@ -233,7 +232,7 @@ testScenarioSolutions rs ui = , testSolution Default "Challenges/teleport" , testSolution Default "Challenges/maypole" , testSolution (Sec 5) "Challenges/2048" - , testSolution (Sec 3) "Challenges/word-search" + , testSolution (Sec 6) "Challenges/word-search" , testSolution (Sec 10) "Challenges/bridge-building" , testSolution (Sec 5) "Challenges/ice-cream" , testSolution (Sec 10) "Challenges/combo-lock" @@ -260,7 +259,7 @@ testScenarioSolutions rs ui = "Ranching" [ testSolution Default "Challenges/Ranching/capture" , testSolution (Sec 60) "Challenges/Ranching/beekeeping" - , testSolution (Sec 10) "Challenges/Ranching/powerset" + , testSolution (Sec 20) "Challenges/Ranching/powerset" , testSolution (Sec 10) "Challenges/Ranching/fishing" , testSolution (Sec 30) "Challenges/Ranching/gated-paddock" ] @@ -362,10 +361,15 @@ testScenarioSolutions rs ui = , testSolution Default "Testing/144-subworlds/subworld-located-robots" , testSolution Default "Testing/1355-combustion" , testSolution Default "Testing/1379-single-world-portal-reorientation" + , testSolution Default "Testing/1322-wait-with-instant" + , testSolution Default "Testing/1598-detect-entity-change" , testSolution Default "Testing/1399-backup-command" , testSolution Default "Testing/1536-custom-unwalkable-entities" + , testSolution Default "Testing/1721-custom-walkable-entities" + , testSolution Default "Testing/1721-walkability-whitelist-path-cache" , testSolution Default "Testing/1631-tags" , testSolution Default "Testing/1747-volume-command" + , testSolution Default "Testing/1775-custom-terrain" , testGroup -- Note that the description of the classic world in -- data/worlds/classic.yaml (automatically tested to some @@ -491,7 +495,7 @@ testScenarioSolutions rs ui = -- hopefully, eventually, go away). & baseRobot . robotContext . defReqs <>~ reqCtx & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore - m <- timeout (time s) (snd <$> runStateT playUntilWin gs') + m <- timeout (time s) (execStateT playUntilWin gs') case m of Nothing -> assertFailure "Timed out - this likely means that the solution did not work." Just g -> do @@ -513,7 +517,7 @@ testScenarioSolutions rs ui = w <- use winCondition b <- gets badErrorsInLogs when (null b) $ case w of - WinConditions (Won _) _ -> return () + WinConditions (Won _ _) _ -> return () _ -> runTimeIO gameTick >> playUntilWin noBadErrors :: GameState -> Assertion diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 2ecdc43b9..7d640d877 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -13,6 +13,8 @@ import Control.Monad.Except (runExceptT) import Data.List (subsequences) import Data.Set (Set) import Data.Set qualified as S +import Swarm.Game.State.Runtime (stdGameConfigInputs) +import Swarm.Game.State.Substate (initState) import Swarm.TUI.Model (AppState, gameState, runtimeState) import Swarm.TUI.Model.StateUpdate (classicGame0) import Swarm.Util (removeSupersets, smallHittingSet) @@ -56,7 +58,7 @@ tests s = , testPrettyConst , testBoolExpr , testCommands - , testDeviceRecipeCoverage (s ^. runtimeState) + , testDeviceRecipeCoverage (initState $ s ^. runtimeState . stdGameConfigInputs) , testHighScores , testEval (s ^. gameState) , testModel diff --git a/test/unit/TestRecipeCoverage.hs b/test/unit/TestRecipeCoverage.hs index 57bbaa423..65391b5db 100644 --- a/test/unit/TestRecipeCoverage.hs +++ b/test/unit/TestRecipeCoverage.hs @@ -12,15 +12,16 @@ import Data.Map qualified as M import Data.Set qualified as Set import Data.Text qualified as T import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName) +import Swarm.Game.Land import Swarm.Game.Recipe (recipeOutputs) -import Swarm.Game.State.Runtime (RuntimeState, stdEntityMap, stdRecipes) +import Swarm.Game.Scenario (GameStateInputs (..), initEntityTerrain) import Swarm.Util (commaList, quote) import Test.Tasty import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit -testDeviceRecipeCoverage :: RuntimeState -> TestTree -testDeviceRecipeCoverage rs = +testDeviceRecipeCoverage :: GameStateInputs -> TestTree +testDeviceRecipeCoverage gsi = testGroup "Recipe coverage" [ expectFailBecause "Need to come up with more recipes" checkCoverage @@ -41,8 +42,10 @@ testDeviceRecipeCoverage rs = ] -- Only include entities that grant a capability: - entityNames = Set.fromList . map (^. entityName) . concat . M.elems . entitiesByCap $ rs ^. stdEntityMap + entityNames = + Set.fromList . map (^. entityName) . concat . M.elems . entitiesByCap $ + initEntityTerrain (gsiScenarioInputs gsi) ^. entityMap getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs - recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes + recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ gsiRecipes gsi nonCoveredEntities = Set.difference entityNames recipeOutputEntities diff --git a/test/unit/TestUtil.hs b/test/unit/TestUtil.hs index 922a2285c..23c9746ae 100644 --- a/test/unit/TestUtil.hs +++ b/test/unit/TestUtil.hs @@ -16,6 +16,7 @@ import Data.Text qualified as T import Swarm.Effect import Swarm.Game.CESK import Swarm.Game.Exception +import Swarm.Game.Land import Swarm.Game.Robot import Swarm.Game.Robot.Concrete (isActive) import Swarm.Game.State @@ -48,7 +49,7 @@ evalCESK g cesk = orderResult ((res, rr), rg) = (rg, rr, res) runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value, Int)) -runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use $ landscape . entityMap) +runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use $ landscape . terrainAndEntities . entityMap) runCESK !steps cesk = case finalValue cesk of Just (v, _) -> return (Right (v, steps)) Nothing -> runTimeIO (stepCESK cesk) >>= runCESK (steps + 1)