diff --git a/.vscode/settings.json b/.vscode/settings.json index 734e8f7e..4b2ddce5 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 cb3accf5..0fe5d26f 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 d2bf8d96..424e9864 100644 --- a/app/doc/Swarm/Doc/Gen.hs +++ b/app/doc/Swarm/Doc/Gen.hs @@ -35,6 +35,7 @@ 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) @@ -135,7 +136,7 @@ generateSpecialKeyNames = generateRecipe :: IO String generateRecipe = simpleErrorHandle $ do - (classic, GameStateInputs worlds entities recipes) <- loadStandaloneScenario "data/scenarios/classic.yaml" + (classic, GameStateInputs 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 b7c4a510..363a8c05 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/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index d7d06b4b..26bf0831 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -55,3 +55,4 @@ Achievements 1634-message-colors.yaml 1681-pushable-entity.yaml 1747-volume-command.yaml +1775-custom-terrain.yaml diff --git a/data/scenarios/Testing/1775-custom-terrain.yaml b/data/scenarios/Testing/1775-custom-terrain.yaml new file mode 100644 index 00000000..6fa9e93e --- /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 00000000..ed7739ec --- /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 00000000..6897a142 --- /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/scenario.json b/data/schema/scenario.json index 07f881f5..8aa79370 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 00000000..972804ce --- /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 00000000..2c1d629c --- /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 00000000..9468d9b1 --- /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/enforce-todo-issues.sh b/scripts/enforce-todo-issues.sh index 1d0fdfca..c7062f43 100755 --- a/scripts/enforce-todo-issues.sh +++ b/scripts/enforce-todo-issues.sh @@ -4,7 +4,7 @@ SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) cd $SCRIPT_DIR/.. -if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\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 index 8287d678..b97e3e1d 100755 --- a/scripts/validate-json-schemas.sh +++ b/scripts/validate-json-schemas.sh @@ -5,5 +5,6 @@ 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 0727150e..7e85e724 100644 --- a/src/Swarm/Doc/Pedagogy.hs +++ b/src/Swarm/Doc/Pedagogy.hs @@ -31,8 +31,8 @@ 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, scenarioDescription, @@ -174,13 +174,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 tem worlds 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 506a6992..1638a23b 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -75,6 +75,7 @@ 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 @@ -1191,7 +1192,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 1b0cfe33..19d20c9e 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 6b60d7bd..a9bdd769 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 bbdd76de..c8d3c921 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 3e2ada77..9b2b2c45 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 4408e196..94fcd21b 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 88847b00..88721d77 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -45,6 +45,7 @@ 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 ( loadScenario, scenarioAttrs, @@ -141,7 +142,12 @@ constructAppState rs ui opts@(AppOpts {..}) = do 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) + tem + (rs ^. worlds) maybeRunScript <- traverse parseCodeFile scriptToRun let maybeAutoplay = do @@ -260,8 +266,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 +282,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 +291,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 1ac1a62a..b7271c69 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 5f89381b..23e24528 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 704271ff..d0013737 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 d7dc02a4..5ea290ec 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 81ac38c8..adc65c96 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/ScenarioInfo.hs b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs index f2344562..bcdf85d2 100644 --- a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs +++ b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs @@ -55,8 +55,8 @@ 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.Land import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath) import Swarm.Game.Scenario import Swarm.Game.Scenario.Scoring.CodeSize @@ -137,16 +137,16 @@ 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 -> + TerrainEntityMaps -> WorldMap -> m ScenarioCollection -loadScenarios em worldMap = do +loadScenarios tem worldMap = do res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios" case res of Left err -> do warn err return $ SC mempty mempty - Right dataDir -> loadScenarioDir em worldMap dataDir + Right dataDir -> loadScenarioDir tem worldMap dataDir -- | The name of the special file which indicates the order of -- scenarios in a folder. @@ -161,11 +161,11 @@ 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 -> + TerrainEntityMaps -> WorldMap -> FilePath -> m ScenarioCollection -loadScenarioDir em worldMap dir = do +loadScenarioDir tem worldMap dir = do let orderFile = dir orderFileName dirName = takeBaseName dir orderExists <- sendIO $ doesFileExist orderFile @@ -196,7 +196,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 tem worldMap (dir filepath) return (filepath, item) scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths let (failures, successes) = partitionEithers scenarios @@ -257,17 +257,17 @@ loadScenarioItem :: , Has (Accum (Seq SystemFailure)) sig m , Has (Lift IO) sig m ) => - EntityMap -> + TerrainEntityMaps -> WorldMap -> FilePath -> m ScenarioItem -loadScenarioItem em worldMap path = do +loadScenarioItem tem worldMap path = do isDir <- sendIO $ doesDirectoryExist path let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path case isDir of - True -> SICollection collectionName <$> loadScenarioDir em worldMap path + True -> SICollection collectionName <$> loadScenarioDir tem worldMap path False -> do - s <- loadScenarioFile em worldMap path + s <- loadScenarioFile tem worldMap 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 1973f812..0adb59ee 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -101,6 +101,7 @@ 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, @@ -577,7 +578,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 +594,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/Runtime.hs b/src/swarm-engine/Swarm/Game/State/Runtime.hs index 1c7a9be6..5c9e5c94 100644 --- a/src/swarm-engine/Swarm/Game/State/Runtime.hs +++ b/src/swarm-engine/Swarm/Game/State/Runtime.hs @@ -13,7 +13,7 @@ module Swarm.Game.State.Runtime ( eventLog, worlds, scenarios, - stdEntityMap, + stdEntityTerrainMap, stdRecipes, appData, nameParts, @@ -32,8 +32,9 @@ 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.Entity (Entity) import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.Land import Swarm.Game.Recipe (Recipe, loadRecipes) import Swarm.Game.ResourceLoading (NameGenerator, initNameGenerator, readAppData) import Swarm.Game.Scenario (GameStateInputs (..)) @@ -51,7 +52,7 @@ data RuntimeState = RuntimeState , _eventLog :: Notifications LogEntry , _worlds :: WorldMap , _scenarios :: ScenarioCollection - , _stdEntityMap :: EntityMap + , _stdEntityTerrainMap :: TerrainEntityMaps , _stdRecipes :: [Recipe Entity] , _appData :: Map Text Text , _nameParts :: NameGenerator @@ -64,10 +65,10 @@ initRuntimeState :: ) => m RuntimeState initRuntimeState = do - entities <- loadEntities - recipes <- loadRecipes entities - worlds <- loadWorlds entities - scenarios <- loadScenarios entities worlds + tem <- loadEntitiesAndTerrain + recipes <- loadRecipes $ tem ^. entityMap + worlds <- loadWorlds tem + scenarios <- loadScenarios tem worlds appDataMap <- readAppData nameGen <- initNameGenerator appDataMap return $ @@ -77,7 +78,7 @@ initRuntimeState = do , _eventLog = mempty , _worlds = worlds , _scenarios = scenarios - , _stdEntityMap = entities + , _stdEntityTerrainMap = tem , _stdRecipes = recipes , _appData = appDataMap , _nameParts = nameGen @@ -105,10 +106,10 @@ 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 +-- | 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. -stdEntityMap :: Lens' RuntimeState EntityMap +stdEntityTerrainMap :: Lens' RuntimeState TerrainEntityMaps -- | The standard list of recipes loaded from disk. Individual scenarios -- may define additional recipes which will get added to this list @@ -129,7 +130,7 @@ mkGameStateConfig rs = { initNameParts = rs ^. nameParts , initState = GameStateInputs - { initEntities = rs ^. stdEntityMap + { initEntityTerrain = rs ^. stdEntityTerrainMap , initRecipes = rs ^. stdRecipes , initWorldMap = rs ^. worlds } diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index 8c011cbe..ebd1050b 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -48,6 +48,7 @@ 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 @@ -123,7 +124,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 @@ -620,7 +621,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 +781,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 17513fda..2354a3ea 100644 --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -28,6 +28,7 @@ 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.State @@ -91,7 +92,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 diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 119671dd..7a76564a 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -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) @@ -292,7 +293,7 @@ execConst runChildProg c vs s k = do let area = map (<$ nextLoc) $ getLocsInArea (nextLoc ^. planar) 5 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)) @@ -427,7 +428,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 <> "."] @@ -570,7 +571,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 <> "."] @@ -845,7 +846,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 <> "."] @@ -1132,7 +1133,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 @@ -1467,7 +1468,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, @@ -1734,7 +1735,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-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs index 3665ab60..aac8d57f 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 00775837..6513891d 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 8d8455de..2f6c3758 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 70a56682..3df7d90d 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 ec109702..6893ae21 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 00000000..be50387e --- /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 b6d4e3a8..9ceec833 100644 --- a/src/swarm-scenario/Swarm/Game/Robot.hs +++ b/src/swarm-scenario/Swarm/Game/Robot.hs @@ -80,6 +80,7 @@ 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.Universe import Swarm.Language.Capability (Capability) @@ -377,7 +378,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,8 +393,8 @@ 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) diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index cd9c81e8..5f62ad33 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -38,7 +38,7 @@ module Swarm.Game.Scenario ( scenarioCreative, scenarioSeed, scenarioAttrs, - scenarioEntities, + scenarioTerrainAndEntities, scenarioCosmetics, scenarioRecipes, scenarioKnown, @@ -58,7 +58,6 @@ module Swarm.Game.Scenario ( GameStateInputs (..), -- * Utilities - integrateScenarioEntities, arbitrateSeed, ) where @@ -83,6 +82,7 @@ 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 +99,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) @@ -197,7 +198,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 +217,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 +265,11 @@ scenarioLandscape :: Lens' Scenario ScenarioLandscape -- * Parsing -instance FromJSONE (EntityMap, WorldMap) Scenario where +instance FromJSONE (TerrainEntityMaps, WorldMap) Scenario where parseJSONE = withObjectE "scenario" $ \v -> do + -- parse custom terrain + tmRaw <- liftE (v .:? "terrains" .!= []) + -- parse custom entities emRaw <- liftE (v .:? "entities" .!= []) @@ -272,20 +277,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 - -- 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 fst $ 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 +328,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 +369,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where ScenarioLandscape seed parsedAttrs - em + combinedTEM mergedCosmetics (Set.fromList known) allWorlds @@ -375,7 +389,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 +416,24 @@ getScenarioPath scenario = do loadScenario :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => FilePath -> - EntityMap -> + TerrainEntityMaps -> WorldMap -> m (Scenario, FilePath) -loadScenario scenario em worldMap = do +loadScenario scenario tem worldMap = do mfileName <- getScenarioPath scenario fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName - (,fileName) <$> loadScenarioFile em worldMap fileName + (,fileName) <$> loadScenarioFile tem worldMap fileName -- | Load a scenario from a file. loadScenarioFile :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - EntityMap -> + TerrainEntityMaps -> WorldMap -> FilePath -> m Scenario -loadScenarioFile em worldMap fileName = +loadScenarioFile tem worldMap fileName = (withThrow adaptError . (liftEither <=< sendIO)) $ - decodeFileEitherE (em, worldMap) fileName + decodeFileEitherE (tem, worldMap) fileName where adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml @@ -428,22 +442,18 @@ 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) + tem <- loadEntitiesAndTerrain + recipes <- loadRecipes $ tem ^. entityMap + worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem + scene <- fst <$> loadScenario fp tem worlds + return (scene, GameStateInputs worlds tem recipes) data GameStateInputs = GameStateInputs { initWorldMap :: WorldMap - , initEntities :: EntityMap + , initEntityTerrain :: TerrainEntityMaps , initRecipes :: [Recipe Entity] } -integrateScenarioEntities :: GameStateInputs -> ScenarioLandscape -> EntityMap -integrateScenarioEntities gsi sLandscape = - initEntities gsi <> sLandscape ^. scenarioEntities - -- | -- Decide on a seed. In order of preference, we will use: -- 1. seed value provided by the user diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs index 50f693aa..e1b7c37b 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 035d4a28..51684582 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 9c77dcd3..b8591373 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 23638485..a0373b43 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/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs index be1efc30..e6dd607b 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 $ 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 d10d27a0..e2a0e1d1 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) +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) --- | 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) +data TerrainType = BlankT | TerrainType Text + deriving (Eq, Ord, Show, Generic, ToJSON) -readTerrain :: T.Text -> Maybe TerrainType -readTerrain t = readMaybe (into @String (T.toTitle t) ++ "T") +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 +getTerrainDefaultPaletteChar = toUpper . T.head . getTerrainWord -getTerrainWord :: TerrainType -> T.Text -getTerrainWord = T.toLower . T.pack . init . show +-- | Representation for parsing only. Not exported. +data TerrainItem = TerrainItem + { name :: TerrainType + , attr :: Text + , description :: Text + } + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) --- | 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) - ] +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 c4454299..3fa26933 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 67fe131c..ec0962b3 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 e2ef3e81..eb67b03c 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 2eaeb549..47266d64 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 ad1125a3..03ad1a49 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 2bac313c..ba8bdd30 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 63b0564c..7b36825e 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -188,6 +188,7 @@ 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 @@ -536,6 +537,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, diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs index c77e6db7..cf957148 100644 --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -25,7 +25,7 @@ import Swarm.Game.State.Landscape (multiWorld) import Swarm.Game.State.Robot (addTRobot) import Swarm.Game.State.Runtime (initRuntimeState, mkGameStateConfig) 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 @@ -151,7 +151,7 @@ mkGameState prog robotMaker numRobots = do (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 cbd87e6b..e8e29a4c 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -31,8 +31,9 @@ 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.Land import Swarm.Game.Robot (equippedDevices, systemRobot) import Swarm.Game.Robot.Activity (commandsHistogram, lifetimeStepCount, tangibleCommandCount) import Swarm.Game.Robot.Concrete (activityCounts, machine, robotContext, robotLog, waitingUntil) @@ -57,7 +58,7 @@ import Swarm.Game.State.Robot ( import Swarm.Game.State.Runtime ( RuntimeState, eventLog, - stdEntityMap, + stdEntityTerrainMap, worlds, ) import Swarm.Game.State.Substate ( @@ -106,16 +107,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 tem = rs ^. stdEntityTerrainMap + rs' = rs & eventLog .~ mempty defaultMain $ testGroup "Tests" [ testNoLoadingErrors rs , exampleTests examplePaths , exampleTests scenarioPrograms - , scenarioParseTests em (rs ^. worlds) parseableScenarios - , scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios + , scenarioParseTests tem (rs ^. worlds) parseableScenarios + , scenarioParseInvalidTests tem (rs ^. worlds) unparseableScenarios , testScenarioSolutions rs' ui , testEditorFiles ] @@ -144,27 +145,27 @@ exampleTest (path, fileContent) = where value = processTerm $ into @Text fileContent -scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree -scenarioParseTests em worldMap inputs = +scenarioParseTests :: TerrainEntityMaps -> WorldMap -> [(FilePath, String)] -> TestTree +scenarioParseTests tem worldMap inputs = testGroup "Test scenarios parse" - (map (scenarioTest Parsed em worldMap) inputs) + (map (scenarioTest Parsed tem worldMap) inputs) -scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree -scenarioParseInvalidTests em worldMap inputs = +scenarioParseInvalidTests :: TerrainEntityMaps -> WorldMap -> [(FilePath, String)] -> TestTree +scenarioParseInvalidTests tem worldMap inputs = testGroup "Test invalid scenarios fail to parse" - (map (scenarioTest Failed em worldMap) inputs) + (map (scenarioTest Failed tem worldMap) 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 -> TerrainEntityMaps -> WorldMap -> (FilePath, String) -> TestTree +scenarioTest expRes tem worldMap (path, _) = + testCase ("parse scenario " ++ show path) (getScenario expRes tem worldMap path) -getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO () -getScenario expRes em worldMap p = do - res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario) +getScenario :: ParseResult -> TerrainEntityMaps -> WorldMap -> FilePath -> IO () +getScenario expRes tem worldMap p = do + res <- decodeFileEitherE (tem, worldMap) p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of Left err -> assertFailure (prettyPrintParseException err) @@ -366,6 +367,7 @@ testScenarioSolutions rs ui = , testSolution Default "Testing/1536-custom-unwalkable-entities" , 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 diff --git a/test/unit/TestRecipeCoverage.hs b/test/unit/TestRecipeCoverage.hs index 57bbaa42..dc73a17e 100644 --- a/test/unit/TestRecipeCoverage.hs +++ b/test/unit/TestRecipeCoverage.hs @@ -12,8 +12,9 @@ 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.State.Runtime (RuntimeState, stdEntityTerrainMap, stdRecipes) import Swarm.Util (commaList, quote) import Test.Tasty import Test.Tasty.ExpectedFailure (expectFailBecause) @@ -41,7 +42,9 @@ 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 $ + rs ^. stdEntityTerrainMap . entityMap getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes diff --git a/test/unit/TestUtil.hs b/test/unit/TestUtil.hs index 922a2285..23c9746a 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)