mirror of
https://github.com/swarm-game/swarm.git
synced 2024-08-16 10:00:27 +03:00
extensible terrain (#1775)
Closes #1641 The `data/terrain.yaml` file is now the authoritative source of terrains, though `BlankT` is still a hard-coded special case. I have not changed the underlying integer representation of terrain in the world function, which means that the `terrainIndexByName` Map in the `TerrainMap` record is needed for translating between `Int` and `TerrainType`. # Demo scripts/play.sh -i data/scenarios/Testing/1775-custom-terrain.yaml ![Screenshot from 2024-02-22 16-51-53](https://github.com/swarm-game/swarm/assets/261693/1d263c8b-4e9c-40bf-bdc8-bf5ba8e33c4d) # Changes * There used to be a function called `integrateScenarioEntities` that combined the `EntityMap` stored in the `Scenario` record with the global entity map. However, the global entity map is accessible at parse time of the `Scenario`, so we do the combining there and only ever store the combined map in the `Scenario` record. * JSON Schema for terrain * Removed the distinction between "World" attributes and "Terrain" attributes * Unit tests for scenario-defined terrain and related validations * Validate existence of referenced terrain at scenario parse time * Validate attributes referenced by terrains at parse time
This commit is contained in:
parent
0d65a0497c
commit
936b30d22a
3
.vscode/settings.json
vendored
3
.vscode/settings.json
vendored
@ -4,6 +4,9 @@
|
|||||||
"data/scenarios/**/*.yaml",
|
"data/scenarios/**/*.yaml",
|
||||||
"scenarios/**/*.yaml"
|
"scenarios/**/*.yaml"
|
||||||
],
|
],
|
||||||
|
"data/schema/terrains.json": [
|
||||||
|
"data/terrains.yaml"
|
||||||
|
],
|
||||||
"data/schema/entities.json": [
|
"data/schema/entities.json": [
|
||||||
"data/entities.yaml"
|
"data/entities.yaml"
|
||||||
],
|
],
|
||||||
|
@ -47,6 +47,7 @@ cliParser =
|
|||||||
Data.Foldable.asum
|
Data.Foldable.asum
|
||||||
[ pure Nothing
|
[ pure Nothing
|
||||||
, Just Entities <$ switch (long "entities" <> help "Generate entities page (uses data from entities.yaml)")
|
, 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 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 Capabilities <$ switch (long "capabilities" <> help "Generate capabilities page (uses entity map)")
|
||||||
, Just Commands <$ switch (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)")
|
, Just Commands <$ switch (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)")
|
||||||
|
@ -35,6 +35,7 @@ import Swarm.Doc.Util
|
|||||||
import Swarm.Doc.Wiki.Cheatsheet
|
import Swarm.Doc.Wiki.Cheatsheet
|
||||||
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName)
|
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName)
|
||||||
import Swarm.Game.Entity qualified as E
|
import Swarm.Game.Entity qualified as E
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs)
|
import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs)
|
||||||
import Swarm.Game.Robot (Robot, equippedDevices, robotInventory)
|
import Swarm.Game.Robot (Robot, equippedDevices, robotInventory)
|
||||||
import Swarm.Game.Scenario (GameStateInputs (..), loadStandaloneScenario, scenarioLandscape)
|
import Swarm.Game.Scenario (GameStateInputs (..), loadStandaloneScenario, scenarioLandscape)
|
||||||
@ -135,7 +136,7 @@ generateSpecialKeyNames =
|
|||||||
|
|
||||||
generateRecipe :: IO String
|
generateRecipe :: IO String
|
||||||
generateRecipe = simpleErrorHandle $ do
|
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
|
baseRobot <- instantiateBaseRobot $ classic ^. scenarioLandscape
|
||||||
return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes
|
return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes
|
||||||
|
|
||||||
|
@ -31,6 +31,7 @@ import Swarm.Game.Display (displayChar)
|
|||||||
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
|
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
|
||||||
import Swarm.Game.Entity qualified as E
|
import Swarm.Game.Entity qualified as E
|
||||||
import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight)
|
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 (Capability)
|
||||||
import Swarm.Language.Capability qualified as Capability
|
import Swarm.Language.Capability qualified as Capability
|
||||||
import Swarm.Language.Pretty (prettyText, prettyTextLine)
|
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.Syntax qualified as Syntax
|
||||||
import Swarm.Language.Text.Markdown as Markdown (docToMark)
|
import Swarm.Language.Text.Markdown as Markdown (docToMark)
|
||||||
import Swarm.Language.Typecheck (inferConst)
|
import Swarm.Language.Typecheck (inferConst)
|
||||||
import Swarm.Util (listEnums)
|
import Swarm.Util (listEnums, showT)
|
||||||
import Swarm.Util.Effect (simpleErrorHandle)
|
import Swarm.Util.Effect (simpleErrorHandle)
|
||||||
|
|
||||||
-- * Types
|
-- * Types
|
||||||
@ -54,7 +55,7 @@ data PageAddress = PageAddress
|
|||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | An enumeration of the kinds of cheat sheets we can produce.
|
-- | 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)
|
deriving (Eq, Show, Enum, Bounded)
|
||||||
|
|
||||||
-- * Functions
|
-- * Functions
|
||||||
@ -73,6 +74,9 @@ makeWikiPage address s = case s of
|
|||||||
Entities -> simpleErrorHandle $ do
|
Entities -> simpleErrorHandle $ do
|
||||||
entities <- loadEntities
|
entities <- loadEntities
|
||||||
sendIO $ T.putStrLn $ entitiesPage address (Map.elems $ entitiesByName entities)
|
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
|
Recipes -> simpleErrorHandle $ do
|
||||||
entities <- loadEntities
|
entities <- loadEntities
|
||||||
recipes <- loadRecipes entities
|
recipes <- loadRecipes entities
|
||||||
|
@ -55,3 +55,4 @@ Achievements
|
|||||||
1634-message-colors.yaml
|
1634-message-colors.yaml
|
||||||
1681-pushable-entity.yaml
|
1681-pushable-entity.yaml
|
||||||
1747-volume-command.yaml
|
1747-volume-command.yaml
|
||||||
|
1775-custom-terrain.yaml
|
||||||
|
58
data/scenarios/Testing/1775-custom-terrain.yaml
Normal file
58
data/scenarios/Testing/1775-custom-terrain.yaml
Normal file
@ -0,0 +1,58 @@
|
|||||||
|
version: 1
|
||||||
|
name: Demo custom terrain
|
||||||
|
description: |
|
||||||
|
Colorful new terrain
|
||||||
|
creative: false
|
||||||
|
attrs:
|
||||||
|
- name: beachsand
|
||||||
|
bg: "#c2b280"
|
||||||
|
- name: lava
|
||||||
|
bg: "#dd7733"
|
||||||
|
- name: lilac
|
||||||
|
bg: "#a4a4bb"
|
||||||
|
terrains:
|
||||||
|
- name: beach
|
||||||
|
attr: beachsand
|
||||||
|
description: |
|
||||||
|
Shoreline covering, laborious to cross
|
||||||
|
- name: lava
|
||||||
|
attr: lava
|
||||||
|
description: |
|
||||||
|
Scorching, liquid rock
|
||||||
|
- name: heather
|
||||||
|
attr: lilac
|
||||||
|
description: |
|
||||||
|
Flowery ground cover
|
||||||
|
objectives:
|
||||||
|
- goal:
|
||||||
|
- |
|
||||||
|
No entities should be here
|
||||||
|
condition: |
|
||||||
|
as base {
|
||||||
|
isEmpty
|
||||||
|
}
|
||||||
|
solution: |
|
||||||
|
noop
|
||||||
|
robots:
|
||||||
|
- name: base
|
||||||
|
dir: east
|
||||||
|
known: []
|
||||||
|
world:
|
||||||
|
dsl: |
|
||||||
|
{grass}
|
||||||
|
palette:
|
||||||
|
'B': [heather, null, base]
|
||||||
|
'.': [heather]
|
||||||
|
'i': [ice]
|
||||||
|
'b': [beach]
|
||||||
|
'v': [lava]
|
||||||
|
upperleft: [0, 0]
|
||||||
|
map: |
|
||||||
|
vvvvvvvv
|
||||||
|
vvvvvvvv
|
||||||
|
B.......
|
||||||
|
........
|
||||||
|
iiiiiiii
|
||||||
|
iiiiiiii
|
||||||
|
bbbbbbbb
|
||||||
|
bbbbbbbb
|
@ -0,0 +1,27 @@
|
|||||||
|
version: 1
|
||||||
|
name: Custom terrain - invalid attribute
|
||||||
|
description: |
|
||||||
|
Colorful new terrain
|
||||||
|
creative: false
|
||||||
|
attrs:
|
||||||
|
- name: lava
|
||||||
|
bg: "#dd7733"
|
||||||
|
terrains:
|
||||||
|
- name: lava
|
||||||
|
attr: baklava
|
||||||
|
description: |
|
||||||
|
Scorching, liquid rock
|
||||||
|
robots:
|
||||||
|
- name: base
|
||||||
|
dir: east
|
||||||
|
known: []
|
||||||
|
world:
|
||||||
|
dsl: |
|
||||||
|
{grass}
|
||||||
|
palette:
|
||||||
|
'B': [grass, null, base]
|
||||||
|
'.': [lava]
|
||||||
|
upperleft: [0, 0]
|
||||||
|
map: |
|
||||||
|
B.
|
||||||
|
..
|
@ -0,0 +1,27 @@
|
|||||||
|
version: 1
|
||||||
|
name: Custom terrain - invalid terrain reference
|
||||||
|
description: |
|
||||||
|
Colorful new terrain
|
||||||
|
creative: false
|
||||||
|
attrs:
|
||||||
|
- name: lava
|
||||||
|
bg: "#dd7733"
|
||||||
|
terrains:
|
||||||
|
- name: lava
|
||||||
|
attr: lava
|
||||||
|
description: |
|
||||||
|
Scorching, liquid rock
|
||||||
|
robots:
|
||||||
|
- name: base
|
||||||
|
dir: east
|
||||||
|
known: []
|
||||||
|
world:
|
||||||
|
dsl: |
|
||||||
|
{grass}
|
||||||
|
palette:
|
||||||
|
'B': [grass, null, base]
|
||||||
|
'.': [liver]
|
||||||
|
upperleft: [0, 0]
|
||||||
|
map: |
|
||||||
|
B.
|
||||||
|
..
|
@ -32,6 +32,13 @@
|
|||||||
"default": null,
|
"default": null,
|
||||||
"type": "number"
|
"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": {
|
"entities": {
|
||||||
"description": "An optional list of custom entities, to be used in addition to the built-in entities.",
|
"description": "An optional list of custom entities, to be used in addition to the built-in entities.",
|
||||||
"default": [],
|
"default": [],
|
||||||
|
27
data/schema/terrain.json
Normal file
27
data/schema/terrain.json
Normal file
@ -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)."
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
10
data/schema/terrains.json
Normal file
10
data/schema/terrains.json
Normal file
@ -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"
|
||||||
|
}
|
||||||
|
}
|
16
data/terrains.yaml
Normal file
16
data/terrains.yaml
Normal file
@ -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.
|
@ -4,7 +4,7 @@ SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )
|
|||||||
cd $SCRIPT_DIR/..
|
cd $SCRIPT_DIR/..
|
||||||
|
|
||||||
|
|
||||||
if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\b' src 2>&1 | grep -vP '#\d+'; then
|
if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\b' src app 2>&1 | grep -vP '#\d+'; then
|
||||||
echo "Please add a link to Issue, for example: TODO: #123"
|
echo "Please add a link to Issue, for example: TODO: #123"
|
||||||
exit 1
|
exit 1
|
||||||
else
|
else
|
||||||
|
@ -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
|
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/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
|
check-jsonschema --base-uri $(git rev-parse --show-toplevel)/data/schema/recipes.json --schemafile data/schema/recipes.json data/recipes.yaml
|
@ -31,8 +31,8 @@ import Data.Set qualified as S
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Swarm.Constant
|
import Swarm.Constant
|
||||||
import Swarm.Game.Entity (loadEntities)
|
|
||||||
import Swarm.Game.Failure (SystemFailure)
|
import Swarm.Game.Failure (SystemFailure)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Scenario (
|
import Swarm.Game.Scenario (
|
||||||
Scenario,
|
Scenario,
|
||||||
scenarioDescription,
|
scenarioDescription,
|
||||||
@ -174,13 +174,14 @@ generateIntroductionsSequence =
|
|||||||
-- For unit tests, can instead access the scenarios via the GameState.
|
-- For unit tests, can instead access the scenarios via the GameState.
|
||||||
loadScenarioCollection :: IO ScenarioCollection
|
loadScenarioCollection :: IO ScenarioCollection
|
||||||
loadScenarioCollection = simpleErrorHandle $ do
|
loadScenarioCollection = simpleErrorHandle $ do
|
||||||
entities <- loadEntities
|
tem <- loadEntitiesAndTerrain
|
||||||
|
|
||||||
-- Note we ignore any warnings generated by 'loadWorlds' and
|
-- Note we ignore any warnings generated by 'loadWorlds' and
|
||||||
-- 'loadScenarios' below. Any warnings will be caught when loading
|
-- 'loadScenarios' below. Any warnings will be caught when loading
|
||||||
-- all the scenarios via the usual code path; we do not need to do
|
-- all the scenarios via the usual code path; we do not need to do
|
||||||
-- anything with them here while simply rendering pedagogy info.
|
-- anything with them here while simply rendering pedagogy info.
|
||||||
worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities
|
worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem
|
||||||
ignoreWarnings @(Seq SystemFailure) $ loadScenarios entities worlds
|
ignoreWarnings @(Seq SystemFailure) $ loadScenarios tem worlds
|
||||||
|
|
||||||
renderUsagesMarkdown :: CoverageInfo -> Text
|
renderUsagesMarkdown :: CoverageInfo -> Text
|
||||||
renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) =
|
renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) =
|
||||||
|
@ -75,6 +75,7 @@ import Swarm.Game.Achievement.Definitions
|
|||||||
import Swarm.Game.Achievement.Persistence
|
import Swarm.Game.Achievement.Persistence
|
||||||
import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine)
|
import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine)
|
||||||
import Swarm.Game.Entity hiding (empty)
|
import Swarm.Game.Entity hiding (empty)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.ResourceLoading (getSwarmHistoryPath)
|
import Swarm.Game.ResourceLoading (getSwarmHistoryPath)
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
@ -1191,7 +1192,7 @@ handleREPLEventTyping = \case
|
|||||||
CharKey '\t' -> do
|
CharKey '\t' -> do
|
||||||
s <- get
|
s <- get
|
||||||
let names = s ^.. gameState . baseRobot . robotContext . defTypes . to assocs . traverse . _1
|
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
|
modify validateREPLForm
|
||||||
EscapeKey -> do
|
EscapeKey -> do
|
||||||
formSt <- use $ uiState . uiGameplay . uiREPL . replPromptType
|
formSt <- use $ uiState . uiGameplay . uiREPL . replPromptType
|
||||||
|
@ -16,6 +16,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
|||||||
import Data.Map qualified as M
|
import Data.Map qualified as M
|
||||||
import Data.Yaml qualified as Y
|
import Data.Yaml qualified as Y
|
||||||
import Graphics.Vty qualified as V
|
import Graphics.Vty qualified as V
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||||
import Swarm.Game.State
|
import Swarm.Game.State
|
||||||
import Swarm.Game.State.Landscape
|
import Swarm.Game.State.Landscape
|
||||||
@ -83,9 +84,11 @@ handleMiddleClick mouseLoc = do
|
|||||||
worldEditor <- use $ uiState . uiGameplay . uiWorldEditor
|
worldEditor <- use $ uiState . uiGameplay . uiWorldEditor
|
||||||
when (worldEditor ^. worldOverdraw . isWorldEditorEnabled) $ do
|
when (worldEditor ^. worldOverdraw . isWorldEditorEnabled) $ do
|
||||||
w <- use $ gameState . landscape . multiWorld
|
w <- use $ gameState . landscape . multiWorld
|
||||||
|
tm <- use $ gameState . landscape . terrainAndEntities . terrainMap
|
||||||
let setTerrainPaint coords = do
|
let setTerrainPaint coords = do
|
||||||
let (terrain, maybeElementPaint) =
|
let (terrain, maybeElementPaint) =
|
||||||
EU.getEditorContentAt
|
EU.getEditorContentAt
|
||||||
|
tm
|
||||||
(worldEditor ^. worldOverdraw)
|
(worldEditor ^. worldOverdraw)
|
||||||
w
|
w
|
||||||
coords
|
coords
|
||||||
@ -142,7 +145,8 @@ saveMapFile = do
|
|||||||
worldEditor <- use $ uiState . uiGameplay . uiWorldEditor
|
worldEditor <- use $ uiState . uiGameplay . uiWorldEditor
|
||||||
maybeBounds <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsRect
|
maybeBounds <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsRect
|
||||||
w <- use $ gameState . landscape . multiWorld
|
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
|
let fp = worldEditor ^. outputFilePath
|
||||||
maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef
|
maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef
|
||||||
|
@ -79,7 +79,7 @@ initialWorldEditor :: TimeSpec -> WorldEditor Name
|
|||||||
initialWorldEditor ts =
|
initialWorldEditor ts =
|
||||||
WorldEditor
|
WorldEditor
|
||||||
(WorldOverdraw False mempty)
|
(WorldOverdraw False mempty)
|
||||||
(BL.list TerrainList (V.fromList listEnums) 1)
|
(BL.list TerrainList (V.fromList []) 1)
|
||||||
(BL.list EntityPaintList (V.fromList []) 1)
|
(BL.list EntityPaintList (V.fromList []) 1)
|
||||||
bounds
|
bounds
|
||||||
(focusRing $ map WorldEditorPanelControl listEnums)
|
(focusRing $ map WorldEditorPanelControl listEnums)
|
||||||
|
@ -20,6 +20,7 @@ import Data.Text qualified as T
|
|||||||
import Data.Tuple (swap)
|
import Data.Tuple (swap)
|
||||||
import Swarm.Game.Display (Display, defaultChar)
|
import Swarm.Game.Display (Display, defaultChar)
|
||||||
import Swarm.Game.Entity (Entity, EntityName, entitiesByName)
|
import Swarm.Game.Entity (Entity, EntityName, entitiesByName)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Scenario
|
import Swarm.Game.Scenario
|
||||||
import Swarm.Game.Scenario.Topography.Area
|
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.EntityFacade
|
||||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
||||||
import Swarm.Game.Scenario.Topography.WorldPalette
|
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.Game.Universe
|
||||||
import Swarm.Language.Text.Markdown (fromText)
|
import Swarm.Language.Text.Markdown (fromText)
|
||||||
import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario))
|
import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario))
|
||||||
import Swarm.Util (binTuples, histogram)
|
import Swarm.Util (binTuples, histogram)
|
||||||
import Swarm.Util qualified as U
|
|
||||||
import Swarm.Util.Erasable
|
import Swarm.Util.Erasable
|
||||||
|
|
||||||
makeSuggestedPalette ::
|
makeSuggestedPalette ::
|
||||||
|
TerrainMap ->
|
||||||
KM.KeyMap (AugmentedCell Entity) ->
|
KM.KeyMap (AugmentedCell Entity) ->
|
||||||
[[CellPaintDisplay]] ->
|
[[CellPaintDisplay]] ->
|
||||||
KM.KeyMap (AugmentedCell EntityFacade)
|
KM.KeyMap (AugmentedCell EntityFacade)
|
||||||
makeSuggestedPalette originalScenarioPalette cellGrid =
|
makeSuggestedPalette tm originalScenarioPalette cellGrid =
|
||||||
KM.fromMapText
|
KM.fromMapText
|
||||||
. M.map (AugmentedCell Nothing)
|
. M.map (AugmentedCell Nothing)
|
||||||
. M.fromList
|
. M.fromList
|
||||||
@ -109,7 +110,7 @@ makeSuggestedPalette originalScenarioPalette cellGrid =
|
|||||||
-- TODO (#1153): Filter out terrain-only palette entries that aren't actually
|
-- TODO (#1153): Filter out terrain-only palette entries that aren't actually
|
||||||
-- used in the map.
|
-- used in the map.
|
||||||
terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
|
terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
|
||||||
terrainOnlyPalette = M.fromList $ map f U.listEnums
|
terrainOnlyPalette = M.fromList . map f . M.keys $ terrainByName tm
|
||||||
where
|
where
|
||||||
f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing []))
|
f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing []))
|
||||||
|
|
||||||
@ -126,7 +127,8 @@ constructScenario maybeOriginalScenario (Grid cellGrid) =
|
|||||||
wd
|
wd
|
||||||
[] -- robots
|
[] -- robots
|
||||||
where
|
where
|
||||||
customEntities = maybe mempty (^. scenarioLandscape . scenarioEntities) maybeOriginalScenario
|
tem = maybe mempty (^. scenarioLandscape . scenarioTerrainAndEntities) maybeOriginalScenario
|
||||||
|
customEntities = tem ^. entityMap
|
||||||
wd =
|
wd =
|
||||||
WorldDescription
|
WorldDescription
|
||||||
{ offsetOrigin = False
|
{ offsetOrigin = False
|
||||||
@ -142,7 +144,7 @@ constructScenario maybeOriginalScenario (Grid cellGrid) =
|
|||||||
|
|
||||||
extractPalette = unPalette . palette . NE.head . (^. scenarioLandscape . scenarioWorlds)
|
extractPalette = unPalette . palette . NE.head . (^. scenarioLandscape . scenarioWorlds)
|
||||||
originalPalette = maybe mempty extractPalette maybeOriginalScenario
|
originalPalette = maybe mempty extractPalette maybeOriginalScenario
|
||||||
suggestedPalette = makeSuggestedPalette originalPalette cellGrid
|
suggestedPalette = makeSuggestedPalette (tem ^. terrainMap) originalPalette cellGrid
|
||||||
|
|
||||||
upperLeftCoord =
|
upperLeftCoord =
|
||||||
Location
|
Location
|
||||||
|
@ -14,7 +14,7 @@ import Swarm.Game.Scenario.Topography.Area qualified as EA
|
|||||||
import Swarm.Game.Scenario.Topography.Cell
|
import Swarm.Game.Scenario.Topography.Cell
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||||
import Swarm.Game.Scenario.Topography.WorldDescription
|
import Swarm.Game.Scenario.Topography.WorldDescription
|
||||||
import Swarm.Game.Terrain (TerrainType)
|
import Swarm.Game.Terrain (TerrainMap, TerrainType)
|
||||||
import Swarm.Game.Universe
|
import Swarm.Game.Universe
|
||||||
import Swarm.Game.World qualified as W
|
import Swarm.Game.World qualified as W
|
||||||
import Swarm.TUI.Editor.Model
|
import Swarm.TUI.Editor.Model
|
||||||
@ -37,11 +37,12 @@ getEditingBounds myWorld =
|
|||||||
lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc
|
lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc
|
||||||
|
|
||||||
getEditorContentAt ::
|
getEditorContentAt ::
|
||||||
|
TerrainMap ->
|
||||||
WorldOverdraw ->
|
WorldOverdraw ->
|
||||||
W.MultiWorld Int Entity ->
|
W.MultiWorld Int Entity ->
|
||||||
Cosmic W.Coords ->
|
Cosmic W.Coords ->
|
||||||
(TerrainType, Maybe EntityPaint)
|
(TerrainType, Maybe EntityPaint)
|
||||||
getEditorContentAt editorOverdraw w coords =
|
getEditorContentAt tm editorOverdraw w coords =
|
||||||
(terrainWithOverride, entityWithOverride)
|
(terrainWithOverride, entityWithOverride)
|
||||||
where
|
where
|
||||||
terrainWithOverride = Maybe.fromMaybe underlyingCellTerrain $ do
|
terrainWithOverride = Maybe.fromMaybe underlyingCellTerrain $ do
|
||||||
@ -60,15 +61,16 @@ getEditorContentAt editorOverdraw w coords =
|
|||||||
pm = editorOverdraw ^. paintedTerrain
|
pm = editorOverdraw ^. paintedTerrain
|
||||||
|
|
||||||
entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride
|
entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride
|
||||||
(underlyingCellTerrain, underlyingCellEntity) = getContentAt w coords
|
(underlyingCellTerrain, underlyingCellEntity) = getContentAt tm w coords
|
||||||
|
|
||||||
getEditorTerrainAt ::
|
getEditorTerrainAt ::
|
||||||
|
TerrainMap ->
|
||||||
WorldOverdraw ->
|
WorldOverdraw ->
|
||||||
W.MultiWorld Int Entity ->
|
W.MultiWorld Int Entity ->
|
||||||
Cosmic W.Coords ->
|
Cosmic W.Coords ->
|
||||||
TerrainType
|
TerrainType
|
||||||
getEditorTerrainAt editor w coords =
|
getEditorTerrainAt tm editor w coords =
|
||||||
fst $ getEditorContentAt editor w coords
|
fst $ getEditorContentAt tm editor w coords
|
||||||
|
|
||||||
isOutsideTopLeftCorner ::
|
isOutsideTopLeftCorner ::
|
||||||
-- | top left corner coords
|
-- | top left corner coords
|
||||||
@ -98,12 +100,13 @@ isOutsideRegion (tl, br) coord =
|
|||||||
isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord
|
isOutsideTopLeftCorner tl coord || isOutsideBottomRightCorner br coord
|
||||||
|
|
||||||
getEditedMapRectangle ::
|
getEditedMapRectangle ::
|
||||||
|
TerrainMap ->
|
||||||
WorldOverdraw ->
|
WorldOverdraw ->
|
||||||
Maybe (Cosmic W.BoundsRectangle) ->
|
Maybe (Cosmic W.BoundsRectangle) ->
|
||||||
W.MultiWorld Int Entity ->
|
W.MultiWorld Int Entity ->
|
||||||
EA.Grid CellPaintDisplay
|
EA.Grid CellPaintDisplay
|
||||||
getEditedMapRectangle _ Nothing _ = EA.Grid []
|
getEditedMapRectangle _ _ Nothing _ = EA.Grid []
|
||||||
getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w =
|
getEditedMapRectangle tm worldEditor (Just (Cosmic subworldName coords)) w =
|
||||||
getMapRectangle toFacade getContent coords
|
getMapRectangle toFacade getContent coords
|
||||||
where
|
where
|
||||||
getContent = getEditorContentAt worldEditor w . Cosmic subworldName
|
getContent = getEditorContentAt tm worldEditor w . Cosmic subworldName
|
||||||
|
@ -8,9 +8,11 @@ import Brick.Widgets.Center (hCenter)
|
|||||||
import Brick.Widgets.List qualified as BL
|
import Brick.Widgets.List qualified as BL
|
||||||
import Control.Lens hiding (Const, from)
|
import Control.Lens hiding (Const, from)
|
||||||
import Data.List qualified as L
|
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.Area qualified as EA
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||||
import Swarm.Game.Terrain (TerrainType)
|
import Swarm.Game.Terrain (TerrainMap, TerrainType)
|
||||||
import Swarm.Game.Universe
|
import Swarm.Game.Universe
|
||||||
import Swarm.Game.World qualified as W
|
import Swarm.Game.World qualified as W
|
||||||
import Swarm.TUI.Border
|
import Swarm.TUI.Border
|
||||||
@ -22,7 +24,11 @@ import Swarm.TUI.Panel
|
|||||||
import Swarm.TUI.View.Attribute.Attr
|
import Swarm.TUI.View.Attribute.Attr
|
||||||
import Swarm.TUI.View.CellDisplay (renderDisplay)
|
import Swarm.TUI.View.CellDisplay (renderDisplay)
|
||||||
import Swarm.TUI.View.Util qualified as VU
|
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 :: FocusRing Name -> UIState -> Widget Name
|
||||||
drawWorldEditor toplevelFocusRing uis =
|
drawWorldEditor toplevelFocusRing uis =
|
||||||
@ -73,10 +79,12 @@ drawWorldEditor toplevelFocusRing uis =
|
|||||||
where
|
where
|
||||||
selectedThing = snd <$> BL.listSelectedElement list
|
selectedThing = snd <$> BL.listSelectedElement list
|
||||||
|
|
||||||
|
tm = extractTerrainMap uis
|
||||||
|
|
||||||
brushWidget =
|
brushWidget =
|
||||||
mkFormControl (WorldEditorPanelControl BrushSelector) $
|
mkFormControl (WorldEditorPanelControl BrushSelector) $
|
||||||
padRight (Pad 1) (str "Brush:")
|
padRight (Pad 1) (str "Brush:")
|
||||||
<+> swatchContent (worldEditor ^. terrainList) VU.drawLabeledTerrainSwatch
|
<+> swatchContent (worldEditor ^. terrainList) (VU.drawLabeledTerrainSwatch tm)
|
||||||
|
|
||||||
entityWidget =
|
entityWidget =
|
||||||
mkFormControl (WorldEditorPanelControl EntitySelector) $
|
mkFormControl (WorldEditorPanelControl EntitySelector) $
|
||||||
@ -141,13 +149,13 @@ drawTerrainSelector :: AppState -> Widget Name
|
|||||||
drawTerrainSelector s =
|
drawTerrainSelector s =
|
||||||
padAll 1
|
padAll 1
|
||||||
. hCenter
|
. hCenter
|
||||||
. vLimit (length (listEnums :: [TerrainType]))
|
. vLimit 8
|
||||||
. BL.renderListWithIndex listDrawTerrainElement True
|
. BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap $ s ^. uiState) True
|
||||||
$ s ^. uiState . uiGameplay . uiWorldEditor . terrainList
|
$ s ^. uiState . uiGameplay . uiWorldEditor . terrainList
|
||||||
|
|
||||||
listDrawTerrainElement :: Int -> Bool -> TerrainType -> Widget Name
|
listDrawTerrainElement :: TerrainMap -> Int -> Bool -> TerrainType -> Widget Name
|
||||||
listDrawTerrainElement pos _isSelected a =
|
listDrawTerrainElement tm pos _isSelected a =
|
||||||
clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch a
|
clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch tm a
|
||||||
|
|
||||||
drawEntityPaintSelector :: AppState -> Widget Name
|
drawEntityPaintSelector :: AppState -> Widget Name
|
||||||
drawEntityPaintSelector s =
|
drawEntityPaintSelector s =
|
||||||
|
@ -45,6 +45,7 @@ import Swarm.Game.Achievement.Attainment
|
|||||||
import Swarm.Game.Achievement.Definitions
|
import Swarm.Game.Achievement.Definitions
|
||||||
import Swarm.Game.Achievement.Persistence
|
import Swarm.Game.Achievement.Persistence
|
||||||
import Swarm.Game.Failure (SystemFailure)
|
import Swarm.Game.Failure (SystemFailure)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Scenario (
|
import Swarm.Game.Scenario (
|
||||||
loadScenario,
|
loadScenario,
|
||||||
scenarioAttrs,
|
scenarioAttrs,
|
||||||
@ -141,7 +142,12 @@ constructAppState rs ui opts@(AppOpts {..}) = do
|
|||||||
case skipMenu opts of
|
case skipMenu opts of
|
||||||
False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs
|
False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs
|
||||||
True -> do
|
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
|
maybeRunScript <- traverse parseCodeFile scriptToRun
|
||||||
|
|
||||||
let maybeAutoplay = do
|
let maybeAutoplay = do
|
||||||
@ -260,8 +266,14 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do
|
|||||||
return $
|
return $
|
||||||
u
|
u
|
||||||
& uiPlaying .~ True
|
& uiPlaying .~ True
|
||||||
& uiGameplay . uiGoal .~ emptyGoalDisplay
|
|
||||||
& uiCheatMode ||~ isAutoplaying
|
& uiCheatMode ||~ isAutoplaying
|
||||||
|
& uiAttrMap
|
||||||
|
.~ applyAttrMappings
|
||||||
|
( map (first getWorldAttrName . toAttrPair) $
|
||||||
|
fst siPair ^. scenarioLandscape . scenarioAttrs
|
||||||
|
)
|
||||||
|
swarmAttrMap
|
||||||
|
& uiGameplay . uiGoal .~ emptyGoalDisplay
|
||||||
& uiGameplay . uiHideGoals .~ (isAutoplaying && not (u ^. uiCheatMode))
|
& uiGameplay . uiHideGoals .~ (isAutoplaying && not (u ^. uiCheatMode))
|
||||||
& uiGameplay . uiFocusRing .~ initFocusRing
|
& uiGameplay . uiFocusRing .~ initFocusRing
|
||||||
& uiGameplay . uiInventory . uiInventoryList .~ Nothing
|
& uiGameplay . uiInventory . uiInventoryList .~ Nothing
|
||||||
@ -270,12 +282,6 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do
|
|||||||
& uiGameplay . uiTiming . uiShowFPS .~ False
|
& uiGameplay . uiTiming . uiShowFPS .~ False
|
||||||
& uiGameplay . uiREPL .~ initREPLState (u ^. uiGameplay . uiREPL . replHistory)
|
& uiGameplay . uiREPL .~ initREPLState (u ^. uiGameplay . uiREPL . replHistory)
|
||||||
& uiGameplay . uiREPL . replHistory %~ restartREPLHistory
|
& uiGameplay . uiREPL . replHistory %~ restartREPLHistory
|
||||||
& uiAttrMap
|
|
||||||
.~ applyAttrMappings
|
|
||||||
( map (first getWorldAttrName . toAttrPair) $
|
|
||||||
fst siPair ^. scenarioLandscape . scenarioAttrs
|
|
||||||
)
|
|
||||||
swarmAttrMap
|
|
||||||
& uiGameplay . scenarioRef ?~ siPair
|
& uiGameplay . scenarioRef ?~ siPair
|
||||||
& uiGameplay . uiTiming . lastFrameTime .~ curTime
|
& uiGameplay . uiTiming . lastFrameTime .~ curTime
|
||||||
& uiGameplay . uiWorldEditor . EM.entityPaintList %~ BL.listReplace entityList Nothing
|
& 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)
|
(SR.makeListWidget . M.elems $ gs ^. discovery . structureRecognition . automatons . originalStructureDefinitions)
|
||||||
(focusSetCurrent (StructureWidgets StructuresList) $ focusRing $ map StructureWidgets listEnums)
|
(focusSetCurrent (StructureWidgets StructuresList) $ focusRing $ map StructureWidgets listEnums)
|
||||||
where
|
where
|
||||||
entityList = EU.getEntitiesForList $ gs ^. landscape . entityMap
|
entityList = EU.getEntitiesForList $ gs ^. landscape . terrainAndEntities . entityMap
|
||||||
|
|
||||||
(isEmptyArea, newBounds) =
|
(isEmptyArea, newBounds) =
|
||||||
EU.getEditingBounds $
|
EU.getEditingBounds $
|
||||||
|
@ -75,6 +75,7 @@ import Swarm.Constant
|
|||||||
import Swarm.Game.CESK (CESK (..))
|
import Swarm.Game.CESK (CESK (..))
|
||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
import Swarm.Game.Entity as E
|
import Swarm.Game.Entity as E
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Recipe
|
import Swarm.Game.Recipe
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
@ -91,6 +92,7 @@ import Swarm.Game.Scenario (
|
|||||||
scenarioObjectives,
|
scenarioObjectives,
|
||||||
scenarioOperation,
|
scenarioOperation,
|
||||||
scenarioSeed,
|
scenarioSeed,
|
||||||
|
scenarioTerrainAndEntities,
|
||||||
)
|
)
|
||||||
import Swarm.Game.Scenario.Scoring.Best
|
import Swarm.Game.Scenario.Scoring.Best
|
||||||
import Swarm.Game.Scenario.Scoring.CodeSize
|
import Swarm.Game.Scenario.Scoring.CodeSize
|
||||||
@ -263,14 +265,17 @@ drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of
|
|||||||
fromMaybe 0 $
|
fromMaybe 0 $
|
||||||
s ^. scenarioLandscape . scenarioSeed
|
s ^. scenarioLandscape . scenarioSeed
|
||||||
|
|
||||||
ri =
|
entIsKnown =
|
||||||
RenderingInput theWorlds $
|
|
||||||
getEntityIsKnown $
|
getEntityIsKnown $
|
||||||
EntityKnowledgeDependencies
|
EntityKnowledgeDependencies
|
||||||
{ isCreativeMode = s ^. scenarioOperation . scenarioCreative
|
{ isCreativeMode = s ^. scenarioOperation . scenarioCreative
|
||||||
, globallyKnownEntities = s ^. scenarioLandscape . scenarioKnown
|
, globallyKnownEntities = s ^. scenarioLandscape . scenarioKnown
|
||||||
, theFocusedRobot = Nothing
|
, theFocusedRobot = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
|
tm = s ^. scenarioLandscape . scenarioTerrainAndEntities . terrainMap
|
||||||
|
ri = RenderingInput theWorlds entIsKnown tm
|
||||||
|
|
||||||
renderCoord = renderDisplay . displayLocRaw (WorldOverdraw False mempty) ri []
|
renderCoord = renderDisplay . displayLocRaw (WorldOverdraw False mempty) ri []
|
||||||
worldPeek = worldWidget renderCoord vc
|
worldPeek = worldWidget renderCoord vc
|
||||||
|
|
||||||
@ -520,7 +525,12 @@ drawWorldCursorInfo worldEditor g cCoords =
|
|||||||
where
|
where
|
||||||
f cell preposition = [renderDisplay cell, txt preposition]
|
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
|
terrain = displayTerrainCell worldEditor ri cCoords
|
||||||
entity = displayEntityCell worldEditor ri cCoords
|
entity = displayEntityCell worldEditor ri cCoords
|
||||||
robot = displayRobotCell g cCoords
|
robot = displayRobotCell g cCoords
|
||||||
|
@ -19,7 +19,6 @@ module Swarm.TUI.View.Attribute.Attr (
|
|||||||
messageAttributeNames,
|
messageAttributeNames,
|
||||||
toAttrName,
|
toAttrName,
|
||||||
getWorldAttrName,
|
getWorldAttrName,
|
||||||
getTerrainAttrName,
|
|
||||||
mkBrickColor,
|
mkBrickColor,
|
||||||
|
|
||||||
-- ** Common attributes
|
-- ** Common attributes
|
||||||
@ -69,7 +68,6 @@ toAttrName = \case
|
|||||||
ARobot -> robotAttr
|
ARobot -> robotAttr
|
||||||
AEntity -> entityAttr
|
AEntity -> entityAttr
|
||||||
AWorld n -> worldPrefix <> attrName (unpack n)
|
AWorld n -> worldPrefix <> attrName (unpack n)
|
||||||
ATerrain n -> terrainPrefix <> attrName (unpack n)
|
|
||||||
ADefault -> defAttr
|
ADefault -> defAttr
|
||||||
|
|
||||||
toVtyAttr :: PreservableColor -> V.Attr
|
toVtyAttr :: PreservableColor -> V.Attr
|
||||||
@ -98,7 +96,6 @@ swarmAttrMap =
|
|||||||
$ NE.toList activityMeterAttributes
|
$ NE.toList activityMeterAttributes
|
||||||
<> NE.toList robotMessageAttributes
|
<> NE.toList robotMessageAttributes
|
||||||
<> map (getWorldAttrName *** toVtyAttr) (M.toList worldAttributes)
|
<> map (getWorldAttrName *** toVtyAttr) (M.toList worldAttributes)
|
||||||
<> map (getTerrainAttrName *** toVtyAttr) (M.toList terrainAttributes)
|
|
||||||
<> [ -- Robot attribute
|
<> [ -- Robot attribute
|
||||||
(robotAttr, fg V.white `V.withStyle` V.bold)
|
(robotAttr, fg V.white `V.withStyle` V.bold)
|
||||||
, -- UI rendering attributes
|
, -- UI rendering attributes
|
||||||
@ -126,12 +123,6 @@ swarmAttrMap =
|
|||||||
(defAttr, V.defAttr)
|
(defAttr, V.defAttr)
|
||||||
]
|
]
|
||||||
|
|
||||||
terrainPrefix :: AttrName
|
|
||||||
terrainPrefix = attrName "terrain"
|
|
||||||
|
|
||||||
getTerrainAttrName :: TerrainAttr -> AttrName
|
|
||||||
getTerrainAttrName (TerrainAttr n) = terrainPrefix <> attrName n
|
|
||||||
|
|
||||||
worldPrefix :: AttrName
|
worldPrefix :: AttrName
|
||||||
worldPrefix = attrName "world"
|
worldPrefix = attrName "world"
|
||||||
|
|
||||||
|
@ -30,6 +30,7 @@ import Swarm.Game.Display (
|
|||||||
hidden,
|
hidden,
|
||||||
)
|
)
|
||||||
import Swarm.Game.Entity
|
import Swarm.Game.Entity
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||||
import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures)
|
import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures)
|
||||||
@ -76,6 +77,7 @@ drawLoc ui g cCoords@(Cosmic _ coords) =
|
|||||||
data RenderingInput = RenderingInput
|
data RenderingInput = RenderingInput
|
||||||
{ multiworldInfo :: W.MultiWorld Int Entity
|
{ multiworldInfo :: W.MultiWorld Int Entity
|
||||||
, isKnownFunc :: EntityPaint -> Bool
|
, isKnownFunc :: EntityPaint -> Bool
|
||||||
|
, terrMap :: TerrainMap
|
||||||
}
|
}
|
||||||
|
|
||||||
displayTerrainCell ::
|
displayTerrainCell ::
|
||||||
@ -84,7 +86,10 @@ displayTerrainCell ::
|
|||||||
Cosmic W.Coords ->
|
Cosmic W.Coords ->
|
||||||
Display
|
Display
|
||||||
displayTerrainCell worldEditor ri coords =
|
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 ::
|
displayRobotCell ::
|
||||||
GameState ->
|
GameState ->
|
||||||
@ -136,7 +141,7 @@ displayEntityCell ::
|
|||||||
displayEntityCell worldEditor ri coords =
|
displayEntityCell worldEditor ri coords =
|
||||||
maybeToList $ displayForEntity <$> maybeEntity
|
maybeToList $ displayForEntity <$> maybeEntity
|
||||||
where
|
where
|
||||||
(_, maybeEntity) = EU.getEditorContentAt worldEditor (multiworldInfo ri) coords
|
(_, maybeEntity) = EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri) coords
|
||||||
|
|
||||||
displayForEntity :: EntityPaint -> Display
|
displayForEntity :: EntityPaint -> Display
|
||||||
displayForEntity e = (if isKnownFunc ri e then id else hidden) $ getDisplay e
|
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
|
staticDisplay g coords
|
||||||
<> displayLocRaw we ri robots cCoords
|
<> displayLocRaw we ri robots cCoords
|
||||||
where
|
where
|
||||||
ri = RenderingInput (g ^. landscape . multiWorld) (getEntityIsKnown $ mkEntityKnowledge g)
|
ri =
|
||||||
|
RenderingInput
|
||||||
|
(g ^. landscape . multiWorld)
|
||||||
|
(getEntityIsKnown $ mkEntityKnowledge g)
|
||||||
|
(g ^. landscape . terrainAndEntities . terrainMap)
|
||||||
|
|
||||||
robots =
|
robots =
|
||||||
if showRobots
|
if showRobots
|
||||||
then displayRobotCell g cCoords
|
then displayRobotCell g cCoords
|
||||||
|
@ -39,4 +39,4 @@ drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws)
|
|||||||
plantAttr = getWorldAttrName $ fst plant
|
plantAttr = getWorldAttrName $ fst plant
|
||||||
|
|
||||||
dirtAttr :: AttrName
|
dirtAttr :: AttrName
|
||||||
dirtAttr = getTerrainAttrName $ fst dirt
|
dirtAttr = getWorldAttrName $ fst dirt
|
||||||
|
@ -16,10 +16,12 @@ import Data.Text (Text)
|
|||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Graphics.Vty qualified as V
|
import Graphics.Vty qualified as V
|
||||||
import Swarm.Game.Entity as E
|
import Swarm.Game.Entity as E
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Scenario (scenarioMetadata, scenarioName)
|
import Swarm.Game.Scenario (scenarioMetadata, scenarioName)
|
||||||
import Swarm.Game.ScenarioInfo (scenarioItemName)
|
import Swarm.Game.ScenarioInfo (scenarioItemName)
|
||||||
import Swarm.Game.State
|
import Swarm.Game.State
|
||||||
|
import Swarm.Game.State.Landscape
|
||||||
import Swarm.Game.State.Substate
|
import Swarm.Game.State.Substate
|
||||||
import Swarm.Game.Terrain
|
import Swarm.Game.Terrain
|
||||||
import Swarm.Language.Pretty (prettyTextLine)
|
import Swarm.Language.Pretty (prettyTextLine)
|
||||||
@ -30,7 +32,6 @@ import Swarm.TUI.Model
|
|||||||
import Swarm.TUI.Model.UI
|
import Swarm.TUI.Model.UI
|
||||||
import Swarm.TUI.View.Attribute.Attr
|
import Swarm.TUI.View.Attribute.Attr
|
||||||
import Swarm.TUI.View.CellDisplay
|
import Swarm.TUI.View.CellDisplay
|
||||||
import Swarm.Util (listEnums)
|
|
||||||
import Witch (from, into)
|
import Witch (from, into)
|
||||||
|
|
||||||
-- | Generate a fresh modal window of the requested type.
|
-- | 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)
|
KeepPlayingModal -> ("", Just (Button CancelButton, [("OK", Button CancelButton, Cancel)]), 80)
|
||||||
TerrainPaletteModal -> ("Terrain", Nothing, w)
|
TerrainPaletteModal -> ("Terrain", Nothing, w)
|
||||||
where
|
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
|
w = wordLength + 6
|
||||||
EntityPaletteModal -> ("Entity", Nothing, 30)
|
EntityPaletteModal -> ("Entity", Nothing, 30)
|
||||||
|
|
||||||
@ -150,11 +152,16 @@ drawMarkdown d = do
|
|||||||
"type" -> magentaAttr
|
"type" -> magentaAttr
|
||||||
_snippet -> highlightAttr -- same as plain code
|
_snippet -> highlightAttr -- same as plain code
|
||||||
|
|
||||||
drawLabeledTerrainSwatch :: TerrainType -> Widget Name
|
drawLabeledTerrainSwatch :: TerrainMap -> TerrainType -> Widget Name
|
||||||
drawLabeledTerrainSwatch a =
|
drawLabeledTerrainSwatch tm a =
|
||||||
tile <+> str materialName
|
tile <+> str materialName
|
||||||
where
|
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
|
materialName = init $ show a
|
||||||
|
|
||||||
descriptionTitle :: Entity -> String
|
descriptionTitle :: Entity -> String
|
||||||
|
@ -55,8 +55,8 @@ import Data.Sequence (Seq)
|
|||||||
import Data.Sequence qualified as Seq
|
import Data.Sequence qualified as Seq
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Yaml as Y
|
import Data.Yaml as Y
|
||||||
import Swarm.Game.Entity
|
|
||||||
import Swarm.Game.Failure
|
import Swarm.Game.Failure
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath)
|
import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath)
|
||||||
import Swarm.Game.Scenario
|
import Swarm.Game.Scenario
|
||||||
import Swarm.Game.Scenario.Scoring.CodeSize
|
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.
|
-- | Load all the scenarios from the scenarios data directory.
|
||||||
loadScenarios ::
|
loadScenarios ::
|
||||||
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
WorldMap ->
|
WorldMap ->
|
||||||
m ScenarioCollection
|
m ScenarioCollection
|
||||||
loadScenarios em worldMap = do
|
loadScenarios tem worldMap = do
|
||||||
res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios"
|
res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios"
|
||||||
case res of
|
case res of
|
||||||
Left err -> do
|
Left err -> do
|
||||||
warn err
|
warn err
|
||||||
return $ SC mempty mempty
|
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
|
-- | The name of the special file which indicates the order of
|
||||||
-- scenarios in a folder.
|
-- scenarios in a folder.
|
||||||
@ -161,11 +161,11 @@ readOrderFile orderFile =
|
|||||||
-- the 00-ORDER file (if any) giving the order for the scenarios.
|
-- the 00-ORDER file (if any) giving the order for the scenarios.
|
||||||
loadScenarioDir ::
|
loadScenarioDir ::
|
||||||
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
WorldMap ->
|
WorldMap ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
m ScenarioCollection
|
m ScenarioCollection
|
||||||
loadScenarioDir em worldMap dir = do
|
loadScenarioDir tem worldMap dir = do
|
||||||
let orderFile = dir </> orderFileName
|
let orderFile = dir </> orderFileName
|
||||||
dirName = takeBaseName dir
|
dirName = takeBaseName dir
|
||||||
orderExists <- sendIO $ doesFileExist orderFile
|
orderExists <- sendIO $ doesFileExist orderFile
|
||||||
@ -196,7 +196,7 @@ loadScenarioDir em worldMap dir = do
|
|||||||
-- Only keep the files from 00-ORDER.txt that actually exist.
|
-- Only keep the files from 00-ORDER.txt that actually exist.
|
||||||
let morder' = filter (`elem` itemPaths) <$> morder
|
let morder' = filter (`elem` itemPaths) <$> morder
|
||||||
loadItem filepath = do
|
loadItem filepath = do
|
||||||
item <- loadScenarioItem em worldMap (dir </> filepath)
|
item <- loadScenarioItem tem worldMap (dir </> filepath)
|
||||||
return (filepath, item)
|
return (filepath, item)
|
||||||
scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths
|
scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths
|
||||||
let (failures, successes) = partitionEithers scenarios
|
let (failures, successes) = partitionEithers scenarios
|
||||||
@ -257,17 +257,17 @@ loadScenarioItem ::
|
|||||||
, Has (Accum (Seq SystemFailure)) sig m
|
, Has (Accum (Seq SystemFailure)) sig m
|
||||||
, Has (Lift IO) sig m
|
, Has (Lift IO) sig m
|
||||||
) =>
|
) =>
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
WorldMap ->
|
WorldMap ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
m ScenarioItem
|
m ScenarioItem
|
||||||
loadScenarioItem em worldMap path = do
|
loadScenarioItem tem worldMap path = do
|
||||||
isDir <- sendIO $ doesDirectoryExist path
|
isDir <- sendIO $ doesDirectoryExist path
|
||||||
let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path
|
let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path
|
||||||
case isDir of
|
case isDir of
|
||||||
True -> SICollection collectionName <$> loadScenarioDir em worldMap path
|
True -> SICollection collectionName <$> loadScenarioDir tem worldMap path
|
||||||
False -> do
|
False -> do
|
||||||
s <- loadScenarioFile em worldMap path
|
s <- loadScenarioFile tem worldMap path
|
||||||
eitherSi <- runThrow @SystemFailure (loadScenarioInfo path)
|
eitherSi <- runThrow @SystemFailure (loadScenarioInfo path)
|
||||||
case eitherSi of
|
case eitherSi of
|
||||||
Right si -> return $ SISingle (s, si)
|
Right si -> return $ SISingle (s, si)
|
||||||
|
@ -101,6 +101,7 @@ import Linear (V2 (..))
|
|||||||
import Swarm.Game.CESK (emptyStore, finalValue, initMachine)
|
import Swarm.Game.CESK (emptyStore, finalValue, initMachine)
|
||||||
import Swarm.Game.Entity
|
import Swarm.Game.Entity
|
||||||
import Swarm.Game.Failure (SystemFailure (..))
|
import Swarm.Game.Failure (SystemFailure (..))
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Recipe (
|
import Swarm.Game.Recipe (
|
||||||
catRecipeMap,
|
catRecipeMap,
|
||||||
@ -577,7 +578,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc =
|
|||||||
& randomness . seed .~ theSeed
|
& randomness . seed .~ theSeed
|
||||||
& randomness . randGen .~ mkStdGen theSeed
|
& randomness . randGen .~ mkStdGen theSeed
|
||||||
& recipesInfo %~ modifyRecipesInfo
|
& recipesInfo %~ modifyRecipesInfo
|
||||||
& landscape .~ mkLandscape sLandscape em worldTuples theSeed
|
& landscape .~ mkLandscape sLandscape worldTuples theSeed
|
||||||
& gameControls . initiallyRunCode .~ initialCodeToRun
|
& gameControls . initiallyRunCode .~ initialCodeToRun
|
||||||
& gameControls . replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working,
|
& 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)
|
-- 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
|
& recipesIn %~ addRecipesWith inRecipeMap
|
||||||
& recipesCat %~ addRecipesWith catRecipeMap
|
& recipesCat %~ addRecipesWith catRecipeMap
|
||||||
|
|
||||||
em = integrateScenarioEntities (initState gsc) sLandscape
|
TerrainEntityMaps _ em = sLandscape ^. scenarioTerrainAndEntities
|
||||||
baseID = 0
|
baseID = 0
|
||||||
(things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))
|
(things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))
|
||||||
|
|
||||||
|
@ -13,7 +13,7 @@ module Swarm.Game.State.Runtime (
|
|||||||
eventLog,
|
eventLog,
|
||||||
worlds,
|
worlds,
|
||||||
scenarios,
|
scenarios,
|
||||||
stdEntityMap,
|
stdEntityTerrainMap,
|
||||||
stdRecipes,
|
stdRecipes,
|
||||||
appData,
|
appData,
|
||||||
nameParts,
|
nameParts,
|
||||||
@ -32,8 +32,9 @@ import Data.Map (Map)
|
|||||||
import Data.Sequence (Seq)
|
import Data.Sequence (Seq)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Network.Wai.Handler.Warp (Port)
|
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.Failure (SystemFailure)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Recipe (Recipe, loadRecipes)
|
import Swarm.Game.Recipe (Recipe, loadRecipes)
|
||||||
import Swarm.Game.ResourceLoading (NameGenerator, initNameGenerator, readAppData)
|
import Swarm.Game.ResourceLoading (NameGenerator, initNameGenerator, readAppData)
|
||||||
import Swarm.Game.Scenario (GameStateInputs (..))
|
import Swarm.Game.Scenario (GameStateInputs (..))
|
||||||
@ -51,7 +52,7 @@ data RuntimeState = RuntimeState
|
|||||||
, _eventLog :: Notifications LogEntry
|
, _eventLog :: Notifications LogEntry
|
||||||
, _worlds :: WorldMap
|
, _worlds :: WorldMap
|
||||||
, _scenarios :: ScenarioCollection
|
, _scenarios :: ScenarioCollection
|
||||||
, _stdEntityMap :: EntityMap
|
, _stdEntityTerrainMap :: TerrainEntityMaps
|
||||||
, _stdRecipes :: [Recipe Entity]
|
, _stdRecipes :: [Recipe Entity]
|
||||||
, _appData :: Map Text Text
|
, _appData :: Map Text Text
|
||||||
, _nameParts :: NameGenerator
|
, _nameParts :: NameGenerator
|
||||||
@ -64,10 +65,10 @@ initRuntimeState ::
|
|||||||
) =>
|
) =>
|
||||||
m RuntimeState
|
m RuntimeState
|
||||||
initRuntimeState = do
|
initRuntimeState = do
|
||||||
entities <- loadEntities
|
tem <- loadEntitiesAndTerrain
|
||||||
recipes <- loadRecipes entities
|
recipes <- loadRecipes $ tem ^. entityMap
|
||||||
worlds <- loadWorlds entities
|
worlds <- loadWorlds tem
|
||||||
scenarios <- loadScenarios entities worlds
|
scenarios <- loadScenarios tem worlds
|
||||||
appDataMap <- readAppData
|
appDataMap <- readAppData
|
||||||
nameGen <- initNameGenerator appDataMap
|
nameGen <- initNameGenerator appDataMap
|
||||||
return $
|
return $
|
||||||
@ -77,7 +78,7 @@ initRuntimeState = do
|
|||||||
, _eventLog = mempty
|
, _eventLog = mempty
|
||||||
, _worlds = worlds
|
, _worlds = worlds
|
||||||
, _scenarios = scenarios
|
, _scenarios = scenarios
|
||||||
, _stdEntityMap = entities
|
, _stdEntityTerrainMap = tem
|
||||||
, _stdRecipes = recipes
|
, _stdRecipes = recipes
|
||||||
, _appData = appDataMap
|
, _appData = appDataMap
|
||||||
, _nameParts = nameGen
|
, _nameParts = nameGen
|
||||||
@ -105,10 +106,10 @@ worlds :: Lens' RuntimeState WorldMap
|
|||||||
-- | The collection of scenarios that comes with the game.
|
-- | The collection of scenarios that comes with the game.
|
||||||
scenarios :: Lens' RuntimeState ScenarioCollection
|
scenarios :: Lens' RuntimeState ScenarioCollection
|
||||||
|
|
||||||
-- | The standard entity map loaded from disk. Individual scenarios
|
-- | The standard terrain/entity maps loaded from disk. Individual scenarios
|
||||||
-- may define additional entities which will get added to this map
|
-- may define additional terrain/entities which will get added to this map
|
||||||
-- when loading the scenario.
|
-- when loading the scenario.
|
||||||
stdEntityMap :: Lens' RuntimeState EntityMap
|
stdEntityTerrainMap :: Lens' RuntimeState TerrainEntityMaps
|
||||||
|
|
||||||
-- | The standard list of recipes loaded from disk. Individual scenarios
|
-- | The standard list of recipes loaded from disk. Individual scenarios
|
||||||
-- may define additional recipes which will get added to this list
|
-- may define additional recipes which will get added to this list
|
||||||
@ -129,7 +130,7 @@ mkGameStateConfig rs =
|
|||||||
{ initNameParts = rs ^. nameParts
|
{ initNameParts = rs ^. nameParts
|
||||||
, initState =
|
, initState =
|
||||||
GameStateInputs
|
GameStateInputs
|
||||||
{ initEntities = rs ^. stdEntityMap
|
{ initEntityTerrain = rs ^. stdEntityTerrainMap
|
||||||
, initRecipes = rs ^. stdRecipes
|
, initRecipes = rs ^. stdRecipes
|
||||||
, initWorldMap = rs ^. worlds
|
, initWorldMap = rs ^. worlds
|
||||||
}
|
}
|
||||||
|
@ -48,6 +48,7 @@ import Swarm.Game.CESK
|
|||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
||||||
import Swarm.Game.Exception
|
import Swarm.Game.Exception
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.Robot.Activity
|
import Swarm.Game.Robot.Activity
|
||||||
import Swarm.Game.Robot.Concrete
|
import Swarm.Game.Robot.Concrete
|
||||||
@ -123,7 +124,7 @@ gameTick = do
|
|||||||
case wc of
|
case wc of
|
||||||
WinConditions winState oc -> do
|
WinConditions winState oc -> do
|
||||||
g <- get @GameState
|
g <- get @GameState
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
hypotheticalWinCheck em g winState oc
|
hypotheticalWinCheck em g winState oc
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
return ticked
|
return ticked
|
||||||
@ -620,7 +621,7 @@ stepCESK cesk = case cesk of
|
|||||||
-- listing the requirements of the given expression.
|
-- listing the requirements of the given expression.
|
||||||
Out (VRequirements src t _) s (FExec : k) -> do
|
Out (VRequirements src t _) s (FExec : k) -> do
|
||||||
currentContext <- use $ robotContext . defReqs
|
currentContext <- use $ robotContext . defReqs
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
let (R.Requirements caps devs inv, _) = R.requirements currentContext t
|
let (R.Requirements caps devs inv, _) = R.requirements currentContext t
|
||||||
|
|
||||||
devicesForCaps, requiredDevices :: Set (Set Text)
|
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.
|
-- cells which were in the middle of being evaluated will be reset.
|
||||||
let s' = resetBlackholes s
|
let s' = resetBlackholes s
|
||||||
h <- hasCapability CLog
|
h <- hasCapability CLog
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
if h
|
if h
|
||||||
then do
|
then do
|
||||||
void $ traceLog RobotError Error (formatExn em exn)
|
void $ traceLog RobotError Error (formatExn em exn)
|
||||||
|
@ -28,6 +28,7 @@ import Swarm.Game.CESK (emptyStore, initMachine)
|
|||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
||||||
import Swarm.Game.Entity qualified as E
|
import Swarm.Game.Entity qualified as E
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.State
|
import Swarm.Game.State
|
||||||
@ -91,7 +92,7 @@ addCombustionBot inputEntity combustibility ts loc = do
|
|||||||
botInventory <- case maybeCombustionProduct of
|
botInventory <- case maybeCombustionProduct of
|
||||||
Nothing -> return []
|
Nothing -> return []
|
||||||
Just n -> do
|
Just n -> do
|
||||||
maybeE <- uses (landscape . entityMap) (lookupEntityName n)
|
maybeE <- uses (landscape . terrainAndEntities . entityMap) (lookupEntityName n)
|
||||||
return $ maybe [] (pure . (1,)) maybeE
|
return $ maybe [] (pure . (1,)) maybeE
|
||||||
combustionDurationRand <- uniform durationRange
|
combustionDurationRand <- uniform durationRange
|
||||||
let combustionProg = combustionProgram combustionDurationRand combustibility
|
let combustionProg = combustionProgram combustionDurationRand combustibility
|
||||||
|
@ -52,6 +52,7 @@ import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
|||||||
import Swarm.Game.Entity qualified as E
|
import Swarm.Game.Entity qualified as E
|
||||||
import Swarm.Game.Exception
|
import Swarm.Game.Exception
|
||||||
import Swarm.Game.Failure
|
import Swarm.Game.Failure
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Recipe
|
import Swarm.Game.Recipe
|
||||||
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||||
@ -292,7 +293,7 @@ execConst runChildProg c vs s k = do
|
|||||||
let area = map (<$ nextLoc) $ getLocsInArea (nextLoc ^. planar) 5
|
let area = map (<$ nextLoc) $ getLocsInArea (nextLoc ^. planar) 5
|
||||||
emptyLocs <- filterM (fmap isNothing . entityAt) area
|
emptyLocs <- filterM (fmap isNothing . entityAt) area
|
||||||
randomLoc <- weightedChoice (const 1) emptyLocs
|
randomLoc <- weightedChoice (const 1) emptyLocs
|
||||||
es <- uses (landscape . entityMap) allEntities
|
es <- uses (landscape . terrainAndEntities . entityMap) allEntities
|
||||||
randomEntity <- weightedChoice (const 1) es
|
randomEntity <- weightedChoice (const 1) es
|
||||||
case (randomLoc, randomEntity) of
|
case (randomLoc, randomEntity) of
|
||||||
(Just loc, Just e) -> updateEntityAt loc (const (Just e))
|
(Just loc, Just e) -> updateEntityAt loc (const (Just e))
|
||||||
@ -427,7 +428,7 @@ execConst runChildProg c vs s k = do
|
|||||||
[VText name] -> do
|
[VText name] -> do
|
||||||
inv <- use robotInventory
|
inv <- use robotInventory
|
||||||
ins <- use equippedDevices
|
ins <- use equippedDevices
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
e <-
|
e <-
|
||||||
lookupEntityName name em
|
lookupEntityName name em
|
||||||
`isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]
|
`isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]
|
||||||
@ -570,7 +571,7 @@ execConst runChildProg c vs s k = do
|
|||||||
_ -> badConst
|
_ -> badConst
|
||||||
HasTag -> case vs of
|
HasTag -> case vs of
|
||||||
[VText eName, VText tName] -> do
|
[VText eName, VText tName] -> do
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
e <-
|
e <-
|
||||||
lookupEntityName eName em
|
lookupEntityName eName em
|
||||||
`isJustOrFail` ["I've never heard of", indefiniteQ eName <> "."]
|
`isJustOrFail` ["I've never heard of", indefiniteQ eName <> "."]
|
||||||
@ -845,7 +846,7 @@ execConst runChildProg c vs s k = do
|
|||||||
_ -> badConst
|
_ -> badConst
|
||||||
Create -> case vs of
|
Create -> case vs of
|
||||||
[VText name] -> do
|
[VText name] -> do
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
e <-
|
e <-
|
||||||
lookupEntityName name em
|
lookupEntityName name em
|
||||||
`isJustOrFail` ["I've never heard of", indefiniteQ name <> "."]
|
`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
|
-- Copy over the salvaged robot's log, if we have one
|
||||||
inst <- use equippedDevices
|
inst <- use equippedDevices
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
isPrivileged <- isPrivilegedBot
|
isPrivileged <- isPrivilegedBot
|
||||||
logger <-
|
logger <-
|
||||||
lookupEntityName "logger" em
|
lookupEntityName "logger" em
|
||||||
@ -1467,7 +1468,7 @@ execConst runChildProg c vs s k = do
|
|||||||
m (Set Entity, Inventory)
|
m (Set Entity, Inventory)
|
||||||
checkRequirements parentInventory childInventory childDevices cmd subject fixI = do
|
checkRequirements parentInventory childInventory childDevices cmd subject fixI = do
|
||||||
currentContext <- use $ robotContext . defReqs
|
currentContext <- use $ robotContext . defReqs
|
||||||
em <- use $ landscape . entityMap
|
em <- use $ landscape . terrainAndEntities . entityMap
|
||||||
creative <- use creativeMode
|
creative <- use creativeMode
|
||||||
let -- Note that _capCtx must be empty: at least at the
|
let -- Note that _capCtx must be empty: at least at the
|
||||||
-- moment, definitions are only allowed at the top level,
|
-- moment, definitions are only allowed at the top level,
|
||||||
@ -1734,7 +1735,7 @@ execConst runChildProg c vs s k = do
|
|||||||
let yieldName = e ^. entityYields
|
let yieldName = e ^. entityYields
|
||||||
e' <- case yieldName of
|
e' <- case yieldName of
|
||||||
Nothing -> return e
|
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'
|
robotInventory %= insert e'
|
||||||
updateDiscoveredEntities e'
|
updateDiscoveredEntities e'
|
||||||
|
@ -54,12 +54,9 @@ import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)
|
|||||||
type Priority = Int
|
type Priority = Int
|
||||||
|
|
||||||
-- | An internal attribute name.
|
-- | 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)
|
deriving (Eq, Ord, Show, Generic, Hashable)
|
||||||
|
|
||||||
terrainPrefix :: Text
|
|
||||||
terrainPrefix = "terrain_"
|
|
||||||
|
|
||||||
instance FromJSON Attribute where
|
instance FromJSON Attribute where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withText "attribute" $
|
withText "attribute" $
|
||||||
@ -67,7 +64,6 @@ instance FromJSON Attribute where
|
|||||||
"robot" -> ARobot
|
"robot" -> ARobot
|
||||||
"entity" -> AEntity
|
"entity" -> AEntity
|
||||||
"default" -> ADefault
|
"default" -> ADefault
|
||||||
t | terrainPrefix `T.isPrefixOf` t -> ATerrain $ T.drop (T.length terrainPrefix) t
|
|
||||||
w -> AWorld w
|
w -> AWorld w
|
||||||
|
|
||||||
instance ToJSON Attribute where
|
instance ToJSON Attribute where
|
||||||
@ -76,7 +72,6 @@ instance ToJSON Attribute where
|
|||||||
ARobot -> String "robot"
|
ARobot -> String "robot"
|
||||||
AEntity -> String "entity"
|
AEntity -> String "entity"
|
||||||
AWorld w -> String w
|
AWorld w -> String w
|
||||||
ATerrain t -> String $ terrainPrefix <> t
|
|
||||||
|
|
||||||
-- | A record explaining how to display an entity in the TUI.
|
-- | A record explaining how to display an entity in the TUI.
|
||||||
data Display = Display
|
data Display = Display
|
||||||
|
@ -47,7 +47,7 @@ module Swarm.Game.Entity (
|
|||||||
-- ** Entity map
|
-- ** Entity map
|
||||||
EntityMap (..),
|
EntityMap (..),
|
||||||
buildEntityMap,
|
buildEntityMap,
|
||||||
validateAttrRefs,
|
validateEntityAttrRefs,
|
||||||
loadEntities,
|
loadEntities,
|
||||||
allEntities,
|
allEntities,
|
||||||
lookupEntityName,
|
lookupEntityName,
|
||||||
@ -403,8 +403,8 @@ deviceForCap :: Capability -> EntityMap -> [Entity]
|
|||||||
deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap
|
deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap
|
||||||
|
|
||||||
-- | Validates references to 'Display' attributes
|
-- | Validates references to 'Display' attributes
|
||||||
validateAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m ()
|
validateEntityAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m ()
|
||||||
validateAttrRefs validAttrs es =
|
validateEntityAttrRefs validAttrs es =
|
||||||
forM_ namedEntities $ \(eName, ent) ->
|
forM_ namedEntities $ \(eName, ent) ->
|
||||||
case ent ^. entityDisplay . displayAttr of
|
case ent ^. entityDisplay . displayAttr of
|
||||||
AWorld n ->
|
AWorld n ->
|
||||||
@ -496,7 +496,7 @@ loadEntities = do
|
|||||||
withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $
|
withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $
|
||||||
decodeFileEither fileName
|
decodeFileEither fileName
|
||||||
|
|
||||||
withThrow entityFailure $ validateAttrRefs (M.keysSet worldAttributes) decoded
|
withThrow entityFailure $ validateEntityAttrRefs (M.keysSet worldAttributes) decoded
|
||||||
withThrow entityFailure $ buildEntityMap decoded
|
withThrow entityFailure $ buildEntityMap decoded
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
|
@ -69,6 +69,3 @@ flattenBg = \case
|
|||||||
|
|
||||||
newtype WorldAttr = WorldAttr String
|
newtype WorldAttr = WorldAttr String
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
newtype TerrainAttr = TerrainAttr String
|
|
||||||
deriving (Eq, Ord, Show)
|
|
||||||
|
@ -15,7 +15,7 @@ import Data.Map (Map)
|
|||||||
import Data.Map qualified as M
|
import Data.Map qualified as M
|
||||||
import Swarm.Game.Entity.Cosmetic
|
import Swarm.Game.Entity.Cosmetic
|
||||||
|
|
||||||
-- * Entities
|
-- * Entities and Terrain
|
||||||
|
|
||||||
entity :: (WorldAttr, PreservableColor)
|
entity :: (WorldAttr, PreservableColor)
|
||||||
entity = (WorldAttr "entity", FgOnly $ AnsiColor White)
|
entity = (WorldAttr "entity", FgOnly $ AnsiColor White)
|
||||||
@ -29,13 +29,33 @@ rock = (WorldAttr "rock", FgOnly $ Triple $ RGB 80 80 80)
|
|||||||
plant :: (WorldAttr, PreservableColor)
|
plant :: (WorldAttr, PreservableColor)
|
||||||
plant = (WorldAttr "plant", FgOnly $ AnsiColor Green)
|
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.
|
-- | Colors of entities in the world.
|
||||||
worldAttributes :: Map WorldAttr PreservableColor
|
worldAttributes :: Map WorldAttr PreservableColor
|
||||||
worldAttributes =
|
worldAttributes =
|
||||||
M.fromList $
|
M.fromList $
|
||||||
-- these four are referenced elsewhere,
|
-- these few are referenced elsewhere,
|
||||||
-- so they have their own toplevel definition
|
-- so they have their own toplevel definition
|
||||||
[entity, water, rock, plant]
|
[ entity
|
||||||
|
, water
|
||||||
|
, rock
|
||||||
|
, plant
|
||||||
|
, dirt
|
||||||
|
, grass
|
||||||
|
, stone
|
||||||
|
, ice
|
||||||
|
]
|
||||||
<> map
|
<> map
|
||||||
(bimap WorldAttr FgOnly)
|
(bimap WorldAttr FgOnly)
|
||||||
[ ("device", AnsiColor BrightYellow)
|
[ ("device", AnsiColor BrightYellow)
|
||||||
@ -56,26 +76,3 @@ worldAttributes =
|
|||||||
, ("green", AnsiColor Green)
|
, ("green", AnsiColor Green)
|
||||||
, ("blue", AnsiColor Blue)
|
, ("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
|
|
||||||
]
|
|
||||||
|
@ -33,7 +33,7 @@ import Witch (into)
|
|||||||
-- Failure descriptions
|
-- Failure descriptions
|
||||||
|
|
||||||
-- | Enumeration of various assets we can attempt to load.
|
-- | 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)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Overarching enumeration of various assets we can attempt to load.
|
-- | Overarching enumeration of various assets we can attempt to load.
|
||||||
|
42
src/swarm-scenario/Swarm/Game/Land.hs
Normal file
42
src/swarm-scenario/Swarm/Game/Land.hs
Normal file
@ -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
|
@ -80,6 +80,7 @@ import GHC.Generics (Generic)
|
|||||||
import Linear
|
import Linear
|
||||||
import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible)
|
import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible)
|
||||||
import Swarm.Game.Entity hiding (empty)
|
import Swarm.Game.Entity hiding (empty)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location (Heading, Location, toDirection, toHeading)
|
import Swarm.Game.Location (Heading, Location, toDirection, toHeading)
|
||||||
import Swarm.Game.Universe
|
import Swarm.Game.Universe
|
||||||
import Swarm.Language.Capability (Capability)
|
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
|
-- | 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.
|
-- '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
|
parseJSONE = withObjectE "robot" $ \v -> do
|
||||||
-- Note we can't generate a unique ID here since we don't have
|
-- 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
|
-- 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)
|
<*> liftE (fmap getHeading $ v .:? "dir" .!= HeadingSpec zero)
|
||||||
<*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay)
|
<*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay)
|
||||||
<*> liftE (v .:? "program")
|
<*> liftE (v .:? "program")
|
||||||
<*> v ..:? "devices" ..!= []
|
<*> localE (view entityMap) (v ..:? "devices" ..!= [])
|
||||||
<*> v ..:? "inventory" ..!= []
|
<*> localE (view entityMap) (v ..:? "inventory" ..!= [])
|
||||||
<*> pure sys
|
<*> pure sys
|
||||||
<*> liftE (v .:? "heavy" .!= False)
|
<*> liftE (v .:? "heavy" .!= False)
|
||||||
<*> liftE (v .:? "unwalkable" ..!= mempty)
|
<*> liftE (v .:? "unwalkable" ..!= mempty)
|
||||||
|
@ -38,7 +38,7 @@ module Swarm.Game.Scenario (
|
|||||||
scenarioCreative,
|
scenarioCreative,
|
||||||
scenarioSeed,
|
scenarioSeed,
|
||||||
scenarioAttrs,
|
scenarioAttrs,
|
||||||
scenarioEntities,
|
scenarioTerrainAndEntities,
|
||||||
scenarioCosmetics,
|
scenarioCosmetics,
|
||||||
scenarioRecipes,
|
scenarioRecipes,
|
||||||
scenarioKnown,
|
scenarioKnown,
|
||||||
@ -58,7 +58,6 @@ module Swarm.Game.Scenario (
|
|||||||
GameStateInputs (..),
|
GameStateInputs (..),
|
||||||
|
|
||||||
-- * Utilities
|
-- * Utilities
|
||||||
integrateScenarioEntities,
|
|
||||||
arbitrateSeed,
|
arbitrateSeed,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -83,6 +82,7 @@ import Swarm.Game.Entity
|
|||||||
import Swarm.Game.Entity.Cosmetic
|
import Swarm.Game.Entity.Cosmetic
|
||||||
import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes)
|
import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes)
|
||||||
import Swarm.Game.Failure
|
import Swarm.Game.Failure
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Recipe
|
import Swarm.Game.Recipe
|
||||||
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
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.Symmetry
|
||||||
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..))
|
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..))
|
||||||
import Swarm.Game.Scenario.Topography.WorldDescription
|
import Swarm.Game.Scenario.Topography.WorldDescription
|
||||||
|
import Swarm.Game.Terrain
|
||||||
import Swarm.Game.Universe
|
import Swarm.Game.Universe
|
||||||
import Swarm.Game.World.Gen (Seed)
|
import Swarm.Game.World.Gen (Seed)
|
||||||
import Swarm.Game.World.Load (loadWorlds)
|
import Swarm.Game.World.Load (loadWorlds)
|
||||||
@ -197,7 +198,7 @@ scenarioStepsPerTick :: Lens' ScenarioOperation (Maybe Int)
|
|||||||
data ScenarioLandscape = ScenarioLandscape
|
data ScenarioLandscape = ScenarioLandscape
|
||||||
{ _scenarioSeed :: Maybe Int
|
{ _scenarioSeed :: Maybe Int
|
||||||
, _scenarioAttrs :: [CustomAttr]
|
, _scenarioAttrs :: [CustomAttr]
|
||||||
, _scenarioEntities :: EntityMap
|
, _scenarioTerrainAndEntities :: TerrainEntityMaps
|
||||||
, _scenarioCosmetics :: M.Map WorldAttr PreservableColor
|
, _scenarioCosmetics :: M.Map WorldAttr PreservableColor
|
||||||
, _scenarioKnown :: Set EntityName
|
, _scenarioKnown :: Set EntityName
|
||||||
, _scenarioWorlds :: NonEmpty WorldDescription
|
, _scenarioWorlds :: NonEmpty WorldDescription
|
||||||
@ -216,8 +217,9 @@ scenarioSeed :: Lens' ScenarioLandscape (Maybe Int)
|
|||||||
-- | Custom attributes defined in the scenario.
|
-- | Custom attributes defined in the scenario.
|
||||||
scenarioAttrs :: Lens' ScenarioLandscape [CustomAttr]
|
scenarioAttrs :: Lens' ScenarioLandscape [CustomAttr]
|
||||||
|
|
||||||
-- | Any custom entities used for this scenario.
|
-- | Any custom terrain and entities used for this scenario,
|
||||||
scenarioEntities :: Lens' ScenarioLandscape EntityMap
|
-- combined with the default system terrain and entities.
|
||||||
|
scenarioTerrainAndEntities :: Lens' ScenarioLandscape TerrainEntityMaps
|
||||||
|
|
||||||
-- | High-fidelity color map for entities
|
-- | High-fidelity color map for entities
|
||||||
scenarioCosmetics :: Lens' ScenarioLandscape (M.Map WorldAttr PreservableColor)
|
scenarioCosmetics :: Lens' ScenarioLandscape (M.Map WorldAttr PreservableColor)
|
||||||
@ -263,8 +265,11 @@ scenarioLandscape :: Lens' Scenario ScenarioLandscape
|
|||||||
|
|
||||||
-- * Parsing
|
-- * Parsing
|
||||||
|
|
||||||
instance FromJSONE (EntityMap, WorldMap) Scenario where
|
instance FromJSONE (TerrainEntityMaps, WorldMap) Scenario where
|
||||||
parseJSONE = withObjectE "scenario" $ \v -> do
|
parseJSONE = withObjectE "scenario" $ \v -> do
|
||||||
|
-- parse custom terrain
|
||||||
|
tmRaw <- liftE (v .:? "terrains" .!= [])
|
||||||
|
|
||||||
-- parse custom entities
|
-- parse custom entities
|
||||||
emRaw <- liftE (v .:? "entities" .!= [])
|
emRaw <- liftE (v .:? "entities" .!= [])
|
||||||
|
|
||||||
@ -272,20 +277,29 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
|
|||||||
let mergedCosmetics = worldAttributes <> M.fromList (mapMaybe toHifiPair parsedAttrs)
|
let mergedCosmetics = worldAttributes <> M.fromList (mapMaybe toHifiPair parsedAttrs)
|
||||||
attrsUnion = M.keysSet mergedCosmetics
|
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
|
em <- runValidation $ buildEntityMap emRaw
|
||||||
|
|
||||||
|
let scenarioSpecificTerrainEntities = TerrainEntityMaps tm em
|
||||||
|
|
||||||
-- Save the passed in WorldMap for later
|
-- Save the passed in WorldMap for later
|
||||||
worldMap <- snd <$> getE
|
worldMap <- snd <$> getE
|
||||||
|
|
||||||
-- Get rid of WorldMap from context locally, and combine EntityMap
|
-- Get rid of WorldMap from context locally, and combine
|
||||||
-- with any custom entities parsed above
|
-- the default system TerrainMap and EntityMap
|
||||||
localE fst $ withE em $ do
|
-- with any custom terrain/entities parsed above
|
||||||
|
localE fst $ withE scenarioSpecificTerrainEntities $ do
|
||||||
-- parse 'known' entity names and make sure they exist
|
-- parse 'known' entity names and make sure they exist
|
||||||
known <- liftE (v .:? "known" .!= mempty)
|
known <- liftE (v .:? "known" .!= mempty)
|
||||||
em' <- getE
|
combinedTEM <- getE
|
||||||
case filter (isNothing . (`lookupEntityName` em')) known of
|
|
||||||
|
let TerrainEntityMaps _tm emCombined = combinedTEM
|
||||||
|
case filter (isNothing . (`lookupEntityName` emCombined)) known of
|
||||||
[] -> return ()
|
[] -> return ()
|
||||||
unk -> failT ["Unknown entities in 'known' list:", T.intercalate ", " unk]
|
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
|
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"
|
rootWorld <- v ..: "world"
|
||||||
subworlds <- v ..:? "subworlds" ..!= []
|
subworlds <- v ..:? "subworlds" ..!= []
|
||||||
return $ rootWorld :| subworlds
|
return $ rootWorld :| subworlds
|
||||||
@ -355,7 +369,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
|
|||||||
ScenarioLandscape
|
ScenarioLandscape
|
||||||
seed
|
seed
|
||||||
parsedAttrs
|
parsedAttrs
|
||||||
em
|
combinedTEM
|
||||||
mergedCosmetics
|
mergedCosmetics
|
||||||
(Set.fromList known)
|
(Set.fromList known)
|
||||||
allWorlds
|
allWorlds
|
||||||
@ -375,7 +389,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
|
|||||||
<*> liftE (v .:? "description" .!= "")
|
<*> liftE (v .:? "description" .!= "")
|
||||||
<*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
|
<*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
|
||||||
<*> liftE (v .:? "solution")
|
<*> liftE (v .:? "solution")
|
||||||
<*> v ..:? "recipes" ..!= []
|
<*> localE (view entityMap) (v ..:? "recipes" ..!= [])
|
||||||
<*> liftE (v .:? "stepsPerTick")
|
<*> liftE (v .:? "stepsPerTick")
|
||||||
|
|
||||||
return $ Scenario metadata playInfo landscape
|
return $ Scenario metadata playInfo landscape
|
||||||
@ -402,24 +416,24 @@ getScenarioPath scenario = do
|
|||||||
loadScenario ::
|
loadScenario ::
|
||||||
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
|
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
|
||||||
FilePath ->
|
FilePath ->
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
WorldMap ->
|
WorldMap ->
|
||||||
m (Scenario, FilePath)
|
m (Scenario, FilePath)
|
||||||
loadScenario scenario em worldMap = do
|
loadScenario scenario tem worldMap = do
|
||||||
mfileName <- getScenarioPath scenario
|
mfileName <- getScenarioPath scenario
|
||||||
fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName
|
fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName
|
||||||
(,fileName) <$> loadScenarioFile em worldMap fileName
|
(,fileName) <$> loadScenarioFile tem worldMap fileName
|
||||||
|
|
||||||
-- | Load a scenario from a file.
|
-- | Load a scenario from a file.
|
||||||
loadScenarioFile ::
|
loadScenarioFile ::
|
||||||
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
|
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
WorldMap ->
|
WorldMap ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
m Scenario
|
m Scenario
|
||||||
loadScenarioFile em worldMap fileName =
|
loadScenarioFile tem worldMap fileName =
|
||||||
(withThrow adaptError . (liftEither <=< sendIO)) $
|
(withThrow adaptError . (liftEither <=< sendIO)) $
|
||||||
decodeFileEitherE (em, worldMap) fileName
|
decodeFileEitherE (tem, worldMap) fileName
|
||||||
where
|
where
|
||||||
adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml
|
adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml
|
||||||
|
|
||||||
@ -428,22 +442,18 @@ loadStandaloneScenario ::
|
|||||||
FilePath ->
|
FilePath ->
|
||||||
m (Scenario, GameStateInputs)
|
m (Scenario, GameStateInputs)
|
||||||
loadStandaloneScenario fp = do
|
loadStandaloneScenario fp = do
|
||||||
entities <- loadEntities
|
tem <- loadEntitiesAndTerrain
|
||||||
recipes <- loadRecipes entities
|
recipes <- loadRecipes $ tem ^. entityMap
|
||||||
worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities
|
worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem
|
||||||
scene <- fst <$> loadScenario fp entities worlds
|
scene <- fst <$> loadScenario fp tem worlds
|
||||||
return (scene, GameStateInputs worlds entities recipes)
|
return (scene, GameStateInputs worlds tem recipes)
|
||||||
|
|
||||||
data GameStateInputs = GameStateInputs
|
data GameStateInputs = GameStateInputs
|
||||||
{ initWorldMap :: WorldMap
|
{ initWorldMap :: WorldMap
|
||||||
, initEntities :: EntityMap
|
, initEntityTerrain :: TerrainEntityMaps
|
||||||
, initRecipes :: [Recipe Entity]
|
, 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:
|
-- Decide on a seed. In order of preference, we will use:
|
||||||
-- 1. seed value provided by the user
|
-- 1. seed value provided by the user
|
||||||
|
@ -11,17 +11,21 @@ module Swarm.Game.Scenario.Topography.Cell (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Lens hiding (from, (.=), (<.>))
|
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.List.NonEmpty qualified as NE
|
||||||
|
import Data.Map.Strict qualified as M
|
||||||
import Data.Maybe (catMaybes, listToMaybe)
|
import Data.Maybe (catMaybes, listToMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Text qualified as T
|
||||||
import Data.Vector qualified as V
|
import Data.Vector qualified as V
|
||||||
import Data.Yaml as Y
|
import Data.Yaml as Y
|
||||||
import Swarm.Game.Entity hiding (empty)
|
import Swarm.Game.Entity hiding (empty)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Scenario.RobotLookup
|
import Swarm.Game.Scenario.RobotLookup
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||||
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
|
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
|
||||||
import Swarm.Game.Terrain
|
import Swarm.Game.Terrain
|
||||||
|
import Swarm.Util (quote, showT)
|
||||||
import Swarm.Util.Erasable (Erasable (..))
|
import Swarm.Util.Erasable (Erasable (..))
|
||||||
import Swarm.Util.Yaml
|
import Swarm.Util.Yaml
|
||||||
|
|
||||||
@ -67,14 +71,24 @@ instance ToJSON Cell where
|
|||||||
ENothing -> Nothing
|
ENothing -> Nothing
|
||||||
EJust e -> Just (e ^. entityName)
|
EJust e -> Just (e ^. entityName)
|
||||||
|
|
||||||
instance FromJSONE (EntityMap, RobotMap) Cell where
|
instance FromJSONE (TerrainEntityMaps, RobotMap) Cell where
|
||||||
parseJSONE = withArrayE "tuple" $ \v -> do
|
parseJSONE = withArrayE "tuple" $ \v -> do
|
||||||
let tupRaw = V.toList v
|
let tupRaw = V.toList v
|
||||||
tup <- case NE.nonEmpty tupRaw of
|
tup <- case NE.nonEmpty tupRaw of
|
||||||
Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)"
|
Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)"
|
||||||
Just x -> return x
|
Just x -> return x
|
||||||
|
|
||||||
|
(TerrainEntityMaps tm _, _) <- getE
|
||||||
terr <- liftE $ parseJSON (NE.head tup)
|
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
|
ent <- case tup ^? ix 1 of
|
||||||
Nothing -> return ENothing
|
Nothing -> return ENothing
|
||||||
@ -83,7 +97,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
|
|||||||
case meName of
|
case meName of
|
||||||
Nothing -> return ENothing
|
Nothing -> return ENothing
|
||||||
Just "erase" -> return EErase
|
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
|
let name2rob r = do
|
||||||
mrName <- liftE $ parseJSON @(Maybe RobotName) r
|
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
|
-- entity and robot, if present, are immediately looked up and
|
||||||
-- converted into 'Entity' and 'TRobot' values. If they are not
|
-- converted into 'Entity' and 'TRobot' values. If they are not
|
||||||
-- found, a parse error results.
|
-- found, a parse error results.
|
||||||
instance FromJSONE (EntityMap, RobotMap) (AugmentedCell Entity) where
|
instance FromJSONE (TerrainEntityMaps, RobotMap) (AugmentedCell Entity) where
|
||||||
parseJSONE x = case x of
|
parseJSONE x = case x of
|
||||||
Object v -> objParse v
|
Object v -> objParse v
|
||||||
z -> AugmentedCell Nothing <$> parseJSONE z
|
z -> AugmentedCell Nothing <$> parseJSONE z
|
||||||
|
@ -22,7 +22,7 @@ import Data.Set qualified as Set
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Data.Yaml as Y
|
import Data.Yaml as Y
|
||||||
import Swarm.Game.Entity
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Scenario.RobotLookup
|
import Swarm.Game.Scenario.RobotLookup
|
||||||
import Swarm.Game.Scenario.Topography.Area
|
import Swarm.Game.Scenario.Topography.Area
|
||||||
@ -58,7 +58,7 @@ type NamedStructure c = NamedArea (PStructure c)
|
|||||||
|
|
||||||
type InheritedStructureDefs = [NamedStructure (Maybe Cell)]
|
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
|
parseJSONE = withObjectE "named structure" $ \v -> do
|
||||||
NamedArea
|
NamedArea
|
||||||
<$> liftE (v .: "name")
|
<$> liftE (v .: "name")
|
||||||
@ -211,14 +211,16 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
|
|||||||
where
|
where
|
||||||
renderDir = quote . T.pack . directionJsonModifier . show
|
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
|
parseJSONE = withObjectE "structure definition" $ \v -> do
|
||||||
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
||||||
localStructureDefs <- v ..:? "structures" ..!= []
|
localStructureDefs <- v ..:? "structures" ..!= []
|
||||||
placementDefs <- liftE $ v .:? "placements" .!= []
|
|
||||||
waypointDefs <- liftE $ v .:? "waypoints" .!= []
|
liftE $ do
|
||||||
maybeMaskChar <- liftE $ v .:? "mask"
|
placementDefs <- v .:? "placements" .!= []
|
||||||
(maskedArea, mapWaypoints) <- liftE $ (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal
|
waypointDefs <- v .:? "waypoints" .!= []
|
||||||
|
maybeMaskChar <- v .:? "mask"
|
||||||
|
(maskedArea, mapWaypoints) <- (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal
|
||||||
return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints
|
return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints
|
||||||
|
|
||||||
-- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw
|
-- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw
|
||||||
|
@ -15,6 +15,7 @@ import Data.Maybe (catMaybes)
|
|||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Data.Yaml as Y
|
import Data.Yaml as Y
|
||||||
import Swarm.Game.Entity
|
import Swarm.Game.Entity
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Scenario.RobotLookup
|
import Swarm.Game.Scenario.RobotLookup
|
||||||
import Swarm.Game.Scenario.Topography.Cell
|
import Swarm.Game.Scenario.Topography.Cell
|
||||||
@ -61,10 +62,18 @@ data PWorldDescription e = WorldDescription
|
|||||||
|
|
||||||
type WorldDescription = PWorldDescription Entity
|
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
|
parseJSONE = withObjectE "world description" $ \v -> do
|
||||||
(worldMap, scenarioLevelStructureDefs, em, rm) <- getE
|
WorldParseDependencies worldMap scenarioLevelStructureDefs rm tem <- getE
|
||||||
(pal, rootWorldStructureDefs) <- localE (const (em, rm)) $ do
|
(pal, rootWorldStructureDefs) <- localE (const (tem, rm)) $ do
|
||||||
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
||||||
rootWorldStructs <- v ..:? "structures" ..!= []
|
rootWorldStructs <- v ..:? "structures" ..!= []
|
||||||
return (pal, rootWorldStructs)
|
return (pal, rootWorldStructs)
|
||||||
@ -97,7 +106,7 @@ instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) World
|
|||||||
mwexp <- liftE (v .:? "dsl")
|
mwexp <- liftE (v .:? "dsl")
|
||||||
dslTerm <- forM mwexp $ \wexp -> do
|
dslTerm <- forM mwexp $ \wexp -> do
|
||||||
let checkResult =
|
let checkResult =
|
||||||
run . runThrow @CheckErr . runReader worldMap . runReader em $
|
run . runThrow @CheckErr . runReader worldMap . runReader tem $
|
||||||
check CNil (TTyWorld TTyCell) wexp
|
check CNil (TTyWorld TTyCell) wexp
|
||||||
either (fail . prettyString) return checkResult
|
either (fail . prettyString) return checkResult
|
||||||
WorldDescription
|
WorldDescription
|
||||||
|
@ -14,6 +14,7 @@ import Data.Text (Text)
|
|||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Data.Tuple (swap)
|
import Data.Tuple (swap)
|
||||||
import Swarm.Game.Entity
|
import Swarm.Game.Entity
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Scenario.RobotLookup
|
import Swarm.Game.Scenario.RobotLookup
|
||||||
import Swarm.Game.Scenario.Topography.Cell
|
import Swarm.Game.Scenario.Topography.Cell
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||||
@ -26,7 +27,7 @@ newtype WorldPalette e = WorldPalette
|
|||||||
{unPalette :: KeyMap (AugmentedCell e)}
|
{unPalette :: KeyMap (AugmentedCell e)}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
|
instance FromJSONE (TerrainEntityMaps, RobotMap) (WorldPalette Entity) where
|
||||||
parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
|
parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
|
||||||
|
|
||||||
type TerrainWith a = (TerrainType, Erasable a)
|
type TerrainWith a = (TerrainType, Erasable a)
|
||||||
|
@ -12,7 +12,7 @@ module Swarm.Game.State.Landscape (
|
|||||||
worldNavigation,
|
worldNavigation,
|
||||||
multiWorld,
|
multiWorld,
|
||||||
worldScrollable,
|
worldScrollable,
|
||||||
entityMap,
|
terrainAndEntities,
|
||||||
|
|
||||||
-- ** Utilities
|
-- ** Utilities
|
||||||
initLandscape,
|
initLandscape,
|
||||||
@ -34,12 +34,13 @@ import Data.List.NonEmpty qualified as NE
|
|||||||
import Data.Map qualified as M
|
import Data.Map qualified as M
|
||||||
import Data.Maybe (isJust, listToMaybe)
|
import Data.Maybe (isJust, listToMaybe)
|
||||||
import Swarm.Game.Entity
|
import Swarm.Game.Entity
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Robot (TRobot, trobotLocation)
|
import Swarm.Game.Robot (TRobot, trobotLocation)
|
||||||
import Swarm.Game.Scenario
|
import Swarm.Game.Scenario
|
||||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
||||||
import Swarm.Game.State.Config
|
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.Universe as U
|
||||||
import Swarm.Game.World
|
import Swarm.Game.World
|
||||||
import Swarm.Game.World.Eval (runWorld)
|
import Swarm.Game.World.Eval (runWorld)
|
||||||
@ -53,7 +54,7 @@ type SubworldDescription = (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int
|
|||||||
data Landscape = Landscape
|
data Landscape = Landscape
|
||||||
{ _worldNavigation :: Navigation (M.Map SubworldName) Location
|
{ _worldNavigation :: Navigation (M.Map SubworldName) Location
|
||||||
, _multiWorld :: MultiWorld Int Entity
|
, _multiWorld :: MultiWorld Int Entity
|
||||||
, _entityMap :: EntityMap
|
, _terrainAndEntities :: TerrainEntityMaps
|
||||||
, _worldScrollable :: Bool
|
, _worldScrollable :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -69,8 +70,8 @@ worldNavigation :: Lens' Landscape (Navigation (M.Map SubworldName) Location)
|
|||||||
-- unboxed tile arrays.
|
-- unboxed tile arrays.
|
||||||
multiWorld :: Lens' Landscape (MultiWorld Int Entity)
|
multiWorld :: Lens' Landscape (MultiWorld Int Entity)
|
||||||
|
|
||||||
-- | The catalog of all entities that the game knows about.
|
-- | The catalogs of all terrain and entities that the game knows about.
|
||||||
entityMap :: Lens' Landscape EntityMap
|
terrainAndEntities :: Lens' Landscape TerrainEntityMaps
|
||||||
|
|
||||||
-- | Whether the world map is supposed to be scrollable or not.
|
-- | Whether the world map is supposed to be scrollable or not.
|
||||||
worldScrollable :: Lens' Landscape Bool
|
worldScrollable :: Lens' Landscape Bool
|
||||||
@ -82,16 +83,16 @@ initLandscape gsc =
|
|||||||
Landscape
|
Landscape
|
||||||
{ _worldNavigation = Navigation mempty mempty
|
{ _worldNavigation = Navigation mempty mempty
|
||||||
, _multiWorld = mempty
|
, _multiWorld = mempty
|
||||||
, _entityMap = initEntities $ initState gsc
|
, _terrainAndEntities = initEntityTerrain $ initState gsc
|
||||||
, _worldScrollable = True
|
, _worldScrollable = True
|
||||||
}
|
}
|
||||||
|
|
||||||
mkLandscape :: ScenarioLandscape -> EntityMap -> NonEmpty SubworldDescription -> Seed -> Landscape
|
mkLandscape :: ScenarioLandscape -> NonEmpty SubworldDescription -> Seed -> Landscape
|
||||||
mkLandscape sLandscape em worldTuples theSeed =
|
mkLandscape sLandscape worldTuples theSeed =
|
||||||
Landscape
|
Landscape
|
||||||
{ _entityMap = em
|
{ _worldNavigation = sLandscape ^. scenarioNavigation
|
||||||
, _worldNavigation = sLandscape ^. scenarioNavigation
|
|
||||||
, _multiWorld = genMultiWorld worldTuples theSeed
|
, _multiWorld = genMultiWorld worldTuples theSeed
|
||||||
|
, _terrainAndEntities = sLandscape ^. scenarioTerrainAndEntities
|
||||||
, -- TODO (#1370): Should we allow subworlds to have their own scrollability?
|
, -- TODO (#1370): Should we allow subworlds to have their own scrollability?
|
||||||
-- Leaning toward no, but for now just adopt the root world scrollability
|
-- Leaning toward no, but for now just adopt the root world scrollability
|
||||||
-- as being universal.
|
-- as being universal.
|
||||||
@ -100,7 +101,7 @@ mkLandscape sLandscape em worldTuples theSeed =
|
|||||||
|
|
||||||
buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription
|
buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription
|
||||||
buildWorldTuples sLandscape =
|
buildWorldTuples sLandscape =
|
||||||
NE.map (worldName &&& buildWorld) $
|
NE.map (worldName &&& buildWorld (sLandscape ^. scenarioTerrainAndEntities)) $
|
||||||
sLandscape ^. scenarioWorlds
|
sLandscape ^. scenarioWorlds
|
||||||
|
|
||||||
genMultiWorld :: NonEmpty SubworldDescription -> Seed -> MultiWorld Int Entity
|
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
|
-- | Take a world description, parsed from a scenario file, and turn
|
||||||
-- it into a list of located robots and a world function.
|
-- it into a list of located robots and a world function.
|
||||||
buildWorld :: WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)
|
buildWorld :: TerrainEntityMaps -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)
|
||||||
buildWorld WorldDescription {..} = (robots worldName, first fromEnum . wf)
|
buildWorld tem WorldDescription {..} =
|
||||||
|
(robots worldName, first getTerrainIndex . wf)
|
||||||
where
|
where
|
||||||
|
getTerrainIndex t = M.findWithDefault 0 t $ terrainIndexByName $ tem ^. terrainMap
|
||||||
rs = fromIntegral $ length area
|
rs = fromIntegral $ length area
|
||||||
cs = fromIntegral $ maybe 0 length $ listToMaybe area
|
cs = fromIntegral $ maybe 0 length $ listToMaybe area
|
||||||
Coords (ulr, ulc) = locToCoords ul
|
Coords (ulr, ulc) = locToCoords ul
|
||||||
|
@ -5,36 +5,60 @@
|
|||||||
--
|
--
|
||||||
-- Terrain types and properties.
|
-- Terrain types and properties.
|
||||||
module Swarm.Game.Terrain (
|
module Swarm.Game.Terrain (
|
||||||
-- * Terrain
|
|
||||||
TerrainType (..),
|
TerrainType (..),
|
||||||
readTerrain,
|
TerrainObj (..),
|
||||||
terrainMap,
|
TerrainMap (..),
|
||||||
|
blankTerrainIndex,
|
||||||
getTerrainDefaultPaletteChar,
|
getTerrainDefaultPaletteChar,
|
||||||
getTerrainWord,
|
getTerrainWord,
|
||||||
|
terrainFromText,
|
||||||
|
loadTerrain,
|
||||||
|
mkTerrainMap,
|
||||||
|
validateTerrainAttrRefs,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson (FromJSON (..), withText)
|
import Control.Algebra (Has)
|
||||||
import Data.List.NonEmpty qualified as NE
|
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 (Map)
|
||||||
import Data.Map qualified as M
|
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.Text qualified as T
|
||||||
|
import Data.Tuple (swap)
|
||||||
|
import Data.Yaml
|
||||||
|
import GHC.Generics (Generic)
|
||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
import Swarm.Util (failT, showEnum)
|
import Swarm.Game.Entity.Cosmetic (WorldAttr (..))
|
||||||
import Text.Read (readMaybe)
|
import Swarm.Game.Failure
|
||||||
import Witch (into)
|
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||||
|
import Swarm.Util (enumeratedMap, quote)
|
||||||
|
import Swarm.Util.Effect (withThrow)
|
||||||
|
|
||||||
-- | The different possible types of terrain. Unlike entities and
|
data TerrainType = BlankT | TerrainType Text
|
||||||
-- robots, these are hard-coded into the game.
|
deriving (Eq, Ord, Show, Generic, ToJSON)
|
||||||
data TerrainType
|
|
||||||
= StoneT
|
|
||||||
| DirtT
|
|
||||||
| GrassT
|
|
||||||
| IceT
|
|
||||||
| BlankT
|
|
||||||
deriving (Eq, Ord, Show, Read, Bounded, Enum)
|
|
||||||
|
|
||||||
readTerrain :: T.Text -> Maybe TerrainType
|
blankTerrainIndex :: Int
|
||||||
readTerrain t = readMaybe (into @String (T.toTitle t) ++ "T")
|
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
|
instance Semigroup TerrainType where
|
||||||
t <> BlankT = t
|
t <> BlankT = t
|
||||||
@ -43,25 +67,98 @@ instance Semigroup TerrainType where
|
|||||||
instance Monoid TerrainType where
|
instance Monoid TerrainType where
|
||||||
mempty = BlankT
|
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 :: TerrainType -> Char
|
||||||
getTerrainDefaultPaletteChar = NE.head . showEnum
|
getTerrainDefaultPaletteChar = toUpper . T.head . getTerrainWord
|
||||||
|
|
||||||
getTerrainWord :: TerrainType -> T.Text
|
-- | Representation for parsing only. Not exported.
|
||||||
getTerrainWord = T.toLower . T.pack . init . show
|
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'.
|
data TerrainObj = TerrainObj
|
||||||
terrainMap :: Map TerrainType Display
|
{ terrainName :: TerrainType
|
||||||
terrainMap =
|
, terrainDesc :: Text
|
||||||
M.fromList
|
, terrainDisplay :: Display
|
||||||
[ (StoneT, defaultTerrainDisplay (ATerrain "stone"))
|
}
|
||||||
, (DirtT, defaultTerrainDisplay (ATerrain "dirt"))
|
deriving (Show)
|
||||||
, (GrassT, defaultTerrainDisplay (ATerrain "grass"))
|
|
||||||
, (IceT, defaultTerrainDisplay (ATerrain "ice"))
|
promoteTerrainObjects :: [TerrainItem] -> [TerrainObj]
|
||||||
, (BlankT, defaultTerrainDisplay ADefault)
|
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
|
||||||
|
@ -61,14 +61,16 @@ import Data.Bifunctor (second)
|
|||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Data.Foldable (foldl')
|
import Data.Foldable (foldl')
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
|
import Data.IntMap qualified as IM
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import Data.Map.Strict qualified as M
|
import Data.Map.Strict qualified as M
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Semigroup (Last (..))
|
import Data.Semigroup (Last (..))
|
||||||
import Data.Yaml (FromJSON, ToJSON)
|
import Data.Yaml (FromJSON, ToJSON)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Swarm.Game.Entity (Entity)
|
import Swarm.Game.Entity (Entity)
|
||||||
import Swarm.Game.Location
|
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.Universe
|
||||||
import Swarm.Game.World.Coords
|
import Swarm.Game.World.Coords
|
||||||
import Swarm.Game.World.Modify
|
import Swarm.Game.World.Modify
|
||||||
@ -199,12 +201,15 @@ newWorld :: WorldFun t e -> World t e
|
|||||||
newWorld f = World f M.empty M.empty
|
newWorld f = World f M.empty M.empty
|
||||||
|
|
||||||
lookupCosmicTerrain ::
|
lookupCosmicTerrain ::
|
||||||
IArray U.UArray Int =>
|
TerrainMap ->
|
||||||
Cosmic Coords ->
|
Cosmic Coords ->
|
||||||
MultiWorld Int e ->
|
MultiWorld Int e ->
|
||||||
TerrainType
|
TerrainType
|
||||||
lookupCosmicTerrain (Cosmic subworldName i) multiWorld =
|
lookupCosmicTerrain tm (Cosmic subworldName i) multiWorld =
|
||||||
maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName 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
|
-- | Look up the terrain value at certain coordinates: try looking it
|
||||||
-- up in the tile cache first, and fall back to running the 'WorldFun'
|
-- up in the tile cache first, and fall back to running the 'WorldFun'
|
||||||
|
@ -16,8 +16,8 @@ import Data.Map qualified as M
|
|||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Data.Sequence (Seq)
|
import Data.Sequence (Seq)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Swarm.Game.Entity (EntityMap)
|
|
||||||
import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..))
|
import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..))
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.ResourceLoading (getDataDirSafe)
|
import Swarm.Game.ResourceLoading (getDataDirSafe)
|
||||||
import Swarm.Game.World.Parse (parseWExp, runParser)
|
import Swarm.Game.World.Parse (parseWExp, runParser)
|
||||||
import Swarm.Game.World.Typecheck
|
import Swarm.Game.World.Typecheck
|
||||||
@ -31,15 +31,15 @@ import Witch (into)
|
|||||||
-- Emit a warning for each one which fails to parse or typecheck.
|
-- Emit a warning for each one which fails to parse or typecheck.
|
||||||
loadWorlds ::
|
loadWorlds ::
|
||||||
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
m WorldMap
|
m WorldMap
|
||||||
loadWorlds em = do
|
loadWorlds tem = do
|
||||||
res <- throwToWarning @SystemFailure $ getDataDirSafe Worlds "worlds"
|
res <- throwToWarning @SystemFailure $ getDataDirSafe Worlds "worlds"
|
||||||
case res of
|
case res of
|
||||||
Nothing -> return M.empty
|
Nothing -> return M.empty
|
||||||
Just dir -> do
|
Just dir -> do
|
||||||
worldFiles <- sendIO $ acquireAllWithExt dir "world"
|
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
|
return . M.fromList . catMaybes $ ws
|
||||||
|
|
||||||
-- | Load a file containing a world DSL term, throwing an exception if
|
-- | Load a file containing a world DSL term, throwing an exception if
|
||||||
@ -47,16 +47,16 @@ loadWorlds em = do
|
|||||||
loadWorld ::
|
loadWorld ::
|
||||||
(Has (Throw SystemFailure) sig m) =>
|
(Has (Throw SystemFailure) sig m) =>
|
||||||
FilePath ->
|
FilePath ->
|
||||||
EntityMap ->
|
TerrainEntityMaps ->
|
||||||
(FilePath, String) ->
|
(FilePath, String) ->
|
||||||
m (Text, Some (TTerm '[]))
|
m (Text, Some (TTerm '[]))
|
||||||
loadWorld dir em (fp, src) = do
|
loadWorld dir tem (fp, src) = do
|
||||||
wexp <-
|
wexp <-
|
||||||
liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $
|
liftEither . left (AssetNotLoaded (Data Worlds) fp . CanNotParseMegaparsec) $
|
||||||
runParser parseWExp (into @Text src)
|
runParser parseWExp (into @Text src)
|
||||||
t <-
|
t <-
|
||||||
withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $
|
withThrow (AssetNotLoaded (Data Worlds) fp . DoesNotTypecheck . prettyText @CheckErr) $
|
||||||
runReader em . runReader @WorldMap M.empty $
|
runReader tem . runReader @WorldMap M.empty $
|
||||||
infer CNil wexp
|
infer CNil wexp
|
||||||
return (into @Text (dropExtension (stripDir dir fp)), t)
|
return (into @Text (dropExtension (stripDir dir fp)), t)
|
||||||
|
|
||||||
|
@ -20,6 +20,7 @@ import Linear (V2 (..))
|
|||||||
import Swarm.Game.Display (defaultChar)
|
import Swarm.Game.Display (defaultChar)
|
||||||
import Swarm.Game.Entity.Cosmetic
|
import Swarm.Game.Entity.Cosmetic
|
||||||
import Swarm.Game.Failure (SystemFailure)
|
import Swarm.Game.Failure (SystemFailure)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.Scenario
|
import Swarm.Game.Scenario
|
||||||
import Swarm.Game.Scenario.Topography.Area
|
import Swarm.Game.Scenario.Topography.Area
|
||||||
@ -128,7 +129,7 @@ getDisplayGrid ::
|
|||||||
getDisplayGrid vc sLandscape ls maybeSize =
|
getDisplayGrid vc sLandscape ls maybeSize =
|
||||||
getMapRectangle
|
getMapRectangle
|
||||||
mkFacade
|
mkFacade
|
||||||
(getContentAt worlds . mkCosmic)
|
(getContentAt (sLandscape ^. scenarioTerrainAndEntities . terrainMap) worlds . mkCosmic)
|
||||||
(getBoundingBox vc firstScenarioWorld maybeSize)
|
(getBoundingBox vc firstScenarioWorld maybeSize)
|
||||||
where
|
where
|
||||||
mkCosmic = Cosmic $ worldName firstScenarioWorld
|
mkCosmic = Cosmic $ worldName firstScenarioWorld
|
||||||
@ -142,13 +143,12 @@ getRenderableGrid ::
|
|||||||
FilePath ->
|
FilePath ->
|
||||||
m (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor)
|
m (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor)
|
||||||
getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize _) fp = do
|
getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize _) fp = do
|
||||||
(myScenario, gsi) <- loadStandaloneScenario fp
|
(myScenario, _gsi) <- loadStandaloneScenario fp
|
||||||
let sLandscape = myScenario ^. scenarioLandscape
|
let sLandscape = myScenario ^. scenarioLandscape
|
||||||
theSeed <- sendIO $ arbitrateSeed maybeSeed sLandscape
|
theSeed <- sendIO $ arbitrateSeed maybeSeed sLandscape
|
||||||
|
|
||||||
let em = integrateScenarioEntities gsi sLandscape
|
let worldTuples = buildWorldTuples sLandscape
|
||||||
worldTuples = buildWorldTuples sLandscape
|
myLandscape = mkLandscape sLandscape worldTuples theSeed
|
||||||
myLandscape = mkLandscape sLandscape em worldTuples theSeed
|
|
||||||
|
|
||||||
vc =
|
vc =
|
||||||
view planar $
|
view planar $
|
||||||
|
@ -34,8 +34,9 @@ import Data.Semigroup (Last (..))
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Type.Equality (TestEquality (..), type (:~:) (Refl))
|
import Data.Type.Equality (TestEquality (..), type (:~:) (Refl))
|
||||||
import Prettyprinter
|
import Prettyprinter
|
||||||
import Swarm.Game.Entity (EntityMap, lookupEntityName)
|
import Swarm.Game.Entity (lookupEntityName)
|
||||||
import Swarm.Game.Terrain (readTerrain)
|
import Swarm.Game.Land
|
||||||
|
import Swarm.Game.Terrain
|
||||||
import Swarm.Game.World.Syntax
|
import Swarm.Game.World.Syntax
|
||||||
import Swarm.Language.Pretty
|
import Swarm.Language.Pretty
|
||||||
import Swarm.Util (showT)
|
import Swarm.Util (showT)
|
||||||
@ -448,7 +449,7 @@ lookup x (CCons y ty ctx)
|
|||||||
-- value (/i.e./ @const 3@).
|
-- value (/i.e./ @const 3@).
|
||||||
check ::
|
check ::
|
||||||
( Has (Throw CheckErr) sig m
|
( Has (Throw CheckErr) sig m
|
||||||
, Has (Reader EntityMap) sig m
|
, Has (Reader TerrainEntityMaps) sig m
|
||||||
, Has (Reader WorldMap) sig m
|
, Has (Reader WorldMap) sig m
|
||||||
) =>
|
) =>
|
||||||
Ctx g ->
|
Ctx g ->
|
||||||
@ -562,7 +563,7 @@ typeArgsFor _ _ = []
|
|||||||
-- a typed, elaborated version of the application.
|
-- a typed, elaborated version of the application.
|
||||||
applyOp ::
|
applyOp ::
|
||||||
( Has (Throw CheckErr) sig m
|
( Has (Throw CheckErr) sig m
|
||||||
, Has (Reader EntityMap) sig m
|
, Has (Reader TerrainEntityMaps) sig m
|
||||||
, Has (Reader WorldMap) sig m
|
, Has (Reader WorldMap) sig m
|
||||||
) =>
|
) =>
|
||||||
Ctx g ->
|
Ctx g ->
|
||||||
@ -577,7 +578,7 @@ applyOp ctx op ts = do
|
|||||||
infer ::
|
infer ::
|
||||||
forall sig m g.
|
forall sig m g.
|
||||||
( Has (Throw CheckErr) sig m
|
( Has (Throw CheckErr) sig m
|
||||||
, Has (Reader EntityMap) sig m
|
, Has (Reader TerrainEntityMaps) sig m
|
||||||
, Has (Reader WorldMap) sig m
|
, Has (Reader WorldMap) sig m
|
||||||
) =>
|
) =>
|
||||||
Ctx g ->
|
Ctx g ->
|
||||||
@ -606,7 +607,9 @@ infer _ctx (WImport key) = do
|
|||||||
-- terrain, entities, and robots---into a real 'CellVal' with
|
-- terrain, entities, and robots---into a real 'CellVal' with
|
||||||
-- references to actual terrain, entities, and robots.
|
-- references to actual terrain, entities, and robots.
|
||||||
resolveCell ::
|
resolveCell ::
|
||||||
(Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m) =>
|
( Has (Throw CheckErr) sig m
|
||||||
|
, Has (Reader TerrainEntityMaps) sig m
|
||||||
|
) =>
|
||||||
RawCellVal ->
|
RawCellVal ->
|
||||||
m CellVal
|
m CellVal
|
||||||
resolveCell items = do
|
resolveCell items = do
|
||||||
@ -617,7 +620,9 @@ resolveCell items = do
|
|||||||
-- entity, robot, etc.).
|
-- entity, robot, etc.).
|
||||||
resolveCellItem ::
|
resolveCellItem ::
|
||||||
forall sig m.
|
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) ->
|
(Maybe CellTag, Text) ->
|
||||||
m CellVal
|
m CellVal
|
||||||
resolveCellItem (mCellTag, item) = case mCellTag of
|
resolveCellItem (mCellTag, item) = case mCellTag of
|
||||||
@ -635,14 +640,17 @@ resolveCellItem (mCellTag, item) = case mCellTag of
|
|||||||
where
|
where
|
||||||
mkTerrain t = CellVal t mempty mempty
|
mkTerrain t = CellVal t mempty mempty
|
||||||
mkEntity e = CellVal mempty (EJust (Last e)) mempty
|
mkEntity e = CellVal mempty (EJust (Last e)) mempty
|
||||||
|
|
||||||
resolverByTag :: CellTag -> Text -> m (Maybe CellVal)
|
resolverByTag :: CellTag -> Text -> m (Maybe CellVal)
|
||||||
resolverByTag = \case
|
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 ->
|
CellEntity -> \eName ->
|
||||||
case eName of
|
case eName of
|
||||||
"erase" -> return $ Just (CellVal mempty EErase mempty)
|
"erase" -> return $ Just (CellVal mempty EErase mempty)
|
||||||
_ -> do
|
_ -> do
|
||||||
em <- ask @EntityMap
|
TerrainEntityMaps _tm em <- ask @TerrainEntityMaps
|
||||||
return . fmap mkEntity $ lookupEntityName eName em
|
return . fmap mkEntity $ lookupEntityName eName em
|
||||||
CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots
|
CellRobot -> \_ -> return Nothing -- TODO (#1396): support robots
|
||||||
|
|
||||||
@ -650,7 +658,7 @@ resolveCellItem (mCellTag, item) = case mCellTag of
|
|||||||
-- of lambda applications.
|
-- of lambda applications.
|
||||||
inferLet ::
|
inferLet ::
|
||||||
( Has (Throw CheckErr) sig m
|
( Has (Throw CheckErr) sig m
|
||||||
, Has (Reader EntityMap) sig m
|
, Has (Reader TerrainEntityMaps) sig m
|
||||||
, Has (Reader WorldMap) sig m
|
, Has (Reader WorldMap) sig m
|
||||||
) =>
|
) =>
|
||||||
Ctx g ->
|
Ctx g ->
|
||||||
@ -667,7 +675,7 @@ inferLet ctx ((x, e) : xs) body = do
|
|||||||
-- chain of @<>@ (over) operations.
|
-- chain of @<>@ (over) operations.
|
||||||
inferOverlay ::
|
inferOverlay ::
|
||||||
( Has (Throw CheckErr) sig m
|
( Has (Throw CheckErr) sig m
|
||||||
, Has (Reader EntityMap) sig m
|
, Has (Reader TerrainEntityMaps) sig m
|
||||||
, Has (Reader WorldMap) sig m
|
, Has (Reader WorldMap) sig m
|
||||||
) =>
|
) =>
|
||||||
Ctx g ->
|
Ctx g ->
|
||||||
|
@ -11,21 +11,20 @@ import Data.Map qualified as M
|
|||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
import Swarm.Game.Entity.Cosmetic
|
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.Area qualified as EA
|
||||||
import Swarm.Game.Scenario.Topography.Cell (PCell (..))
|
import Swarm.Game.Scenario.Topography.Cell (PCell (..))
|
||||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
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.Universe
|
||||||
import Swarm.Game.World
|
import Swarm.Game.World
|
||||||
import Swarm.Util.Erasable (erasableToMaybe, maybeToErasable)
|
import Swarm.Util.Erasable (erasableToMaybe, maybeToErasable)
|
||||||
|
|
||||||
-- | Get the terrain and entity at a single cell
|
-- | Get the terrain and entity at a single cell
|
||||||
getContentAt :: MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e)
|
getContentAt :: TerrainMap -> MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e)
|
||||||
getContentAt w coords = (underlyingCellTerrain, underlyingCellEntity)
|
getContentAt tm w coords = (underlyingCellTerrain, underlyingCellEntity)
|
||||||
where
|
where
|
||||||
underlyingCellEntity = lookupCosmicEntity coords w
|
underlyingCellEntity = lookupCosmicEntity coords w
|
||||||
underlyingCellTerrain = lookupCosmicTerrain coords w
|
underlyingCellTerrain = lookupCosmicTerrain tm coords w
|
||||||
|
|
||||||
-- * Rendering
|
-- * Rendering
|
||||||
|
|
||||||
@ -60,7 +59,7 @@ getTerrainEntityColor ::
|
|||||||
getTerrainEntityColor aMap (Cell terr cellEnt _) =
|
getTerrainEntityColor aMap (Cell terr cellEnt _) =
|
||||||
(entityColor =<< erasableToMaybe cellEnt) <|> terrainFallback
|
(entityColor =<< erasableToMaybe cellEnt) <|> terrainFallback
|
||||||
where
|
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
|
entityColor (EntityFacade _ d) = case d ^. displayAttr of
|
||||||
AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap
|
AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
@ -13,6 +13,7 @@ module Swarm.Util (
|
|||||||
sortPair,
|
sortPair,
|
||||||
maxOn,
|
maxOn,
|
||||||
maximum0,
|
maximum0,
|
||||||
|
enumeratedMap,
|
||||||
cycleEnum,
|
cycleEnum,
|
||||||
listEnums,
|
listEnums,
|
||||||
listEnumsNonempty,
|
listEnumsNonempty,
|
||||||
@ -90,6 +91,8 @@ import Data.Bifunctor (Bifunctor (bimap), first)
|
|||||||
import Data.Char (isAlphaNum, toLower)
|
import Data.Char (isAlphaNum, toLower)
|
||||||
import Data.Either.Validation
|
import Data.Either.Validation
|
||||||
import Data.Foldable qualified as Foldable
|
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 (foldl', maximumBy, partition)
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||||
@ -142,6 +145,9 @@ maximum0 :: (Num a, Ord a) => [a] -> a
|
|||||||
maximum0 [] = 0
|
maximum0 [] = 0
|
||||||
maximum0 xs = maximum xs
|
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
|
-- | Take the successor of an 'Enum' type, wrapping around when it
|
||||||
-- reaches the end.
|
-- reaches the end.
|
||||||
cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e
|
cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e
|
||||||
|
@ -188,6 +188,7 @@ library swarm-scenario
|
|||||||
Swarm.Game.Entity.Cosmetic
|
Swarm.Game.Entity.Cosmetic
|
||||||
Swarm.Game.Entity.Cosmetic.Assignment
|
Swarm.Game.Entity.Cosmetic.Assignment
|
||||||
Swarm.Game.Failure
|
Swarm.Game.Failure
|
||||||
|
Swarm.Game.Land
|
||||||
Swarm.Game.Location
|
Swarm.Game.Location
|
||||||
Swarm.Game.Recipe
|
Swarm.Game.Recipe
|
||||||
Swarm.Game.ResourceLoading
|
Swarm.Game.ResourceLoading
|
||||||
@ -536,6 +537,7 @@ library
|
|||||||
Swarm.Game.Entity.Cosmetic.Assignment,
|
Swarm.Game.Entity.Cosmetic.Assignment,
|
||||||
Swarm.Game.Exception,
|
Swarm.Game.Exception,
|
||||||
Swarm.Game.Failure,
|
Swarm.Game.Failure,
|
||||||
|
Swarm.Game.Land,
|
||||||
Swarm.Game.Location,
|
Swarm.Game.Location,
|
||||||
Swarm.Game.Recipe,
|
Swarm.Game.Recipe,
|
||||||
Swarm.Game.ResourceLoading,
|
Swarm.Game.ResourceLoading,
|
||||||
|
@ -25,7 +25,7 @@ import Swarm.Game.State.Landscape (multiWorld)
|
|||||||
import Swarm.Game.State.Robot (addTRobot)
|
import Swarm.Game.State.Robot (addTRobot)
|
||||||
import Swarm.Game.State.Runtime (initRuntimeState, mkGameStateConfig)
|
import Swarm.Game.State.Runtime (initRuntimeState, mkGameStateConfig)
|
||||||
import Swarm.Game.Step (gameTick)
|
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.Universe (Cosmic (..), SubworldName (DefaultRootSubworld))
|
||||||
import Swarm.Game.World (WorldFun (..), newWorld)
|
import Swarm.Game.World (WorldFun (..), newWorld)
|
||||||
import Swarm.Language.Context qualified as Context
|
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)
|
(zoomRobots $ mapM_ (addTRobot $ initMachine prog Context.empty emptyStore) robots)
|
||||||
( gs
|
( gs
|
||||||
& creativeMode .~ True
|
& 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.
|
-- | Runs numGameTicks ticks of the game.
|
||||||
|
@ -31,8 +31,9 @@ import Swarm.Doc.Keyword qualified as Keyword
|
|||||||
import Swarm.Effect (runTimeIO)
|
import Swarm.Effect (runTimeIO)
|
||||||
import Swarm.Game.Achievement.Definitions (GameplayAchievement (..))
|
import Swarm.Game.Achievement.Definitions (GameplayAchievement (..))
|
||||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
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.Failure (SystemFailure)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Robot (equippedDevices, systemRobot)
|
import Swarm.Game.Robot (equippedDevices, systemRobot)
|
||||||
import Swarm.Game.Robot.Activity (commandsHistogram, lifetimeStepCount, tangibleCommandCount)
|
import Swarm.Game.Robot.Activity (commandsHistogram, lifetimeStepCount, tangibleCommandCount)
|
||||||
import Swarm.Game.Robot.Concrete (activityCounts, machine, robotContext, robotLog, waitingUntil)
|
import Swarm.Game.Robot.Concrete (activityCounts, machine, robotContext, robotLog, waitingUntil)
|
||||||
@ -57,7 +58,7 @@ import Swarm.Game.State.Robot (
|
|||||||
import Swarm.Game.State.Runtime (
|
import Swarm.Game.State.Runtime (
|
||||||
RuntimeState,
|
RuntimeState,
|
||||||
eventLog,
|
eventLog,
|
||||||
stdEntityMap,
|
stdEntityTerrainMap,
|
||||||
worlds,
|
worlds,
|
||||||
)
|
)
|
||||||
import Swarm.Game.State.Substate (
|
import Swarm.Game.State.Substate (
|
||||||
@ -106,16 +107,16 @@ main = do
|
|||||||
(rs, ui) <- do
|
(rs, ui) <- do
|
||||||
out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts
|
out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts
|
||||||
either (assertFailure . prettyString) return out
|
either (assertFailure . prettyString) return out
|
||||||
let em = rs ^. stdEntityMap
|
let tem = rs ^. stdEntityTerrainMap
|
||||||
let rs' = rs & eventLog .~ mempty
|
rs' = rs & eventLog .~ mempty
|
||||||
defaultMain $
|
defaultMain $
|
||||||
testGroup
|
testGroup
|
||||||
"Tests"
|
"Tests"
|
||||||
[ testNoLoadingErrors rs
|
[ testNoLoadingErrors rs
|
||||||
, exampleTests examplePaths
|
, exampleTests examplePaths
|
||||||
, exampleTests scenarioPrograms
|
, exampleTests scenarioPrograms
|
||||||
, scenarioParseTests em (rs ^. worlds) parseableScenarios
|
, scenarioParseTests tem (rs ^. worlds) parseableScenarios
|
||||||
, scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios
|
, scenarioParseInvalidTests tem (rs ^. worlds) unparseableScenarios
|
||||||
, testScenarioSolutions rs' ui
|
, testScenarioSolutions rs' ui
|
||||||
, testEditorFiles
|
, testEditorFiles
|
||||||
]
|
]
|
||||||
@ -144,27 +145,27 @@ exampleTest (path, fileContent) =
|
|||||||
where
|
where
|
||||||
value = processTerm $ into @Text fileContent
|
value = processTerm $ into @Text fileContent
|
||||||
|
|
||||||
scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree
|
scenarioParseTests :: TerrainEntityMaps -> WorldMap -> [(FilePath, String)] -> TestTree
|
||||||
scenarioParseTests em worldMap inputs =
|
scenarioParseTests tem worldMap inputs =
|
||||||
testGroup
|
testGroup
|
||||||
"Test scenarios parse"
|
"Test scenarios parse"
|
||||||
(map (scenarioTest Parsed em worldMap) inputs)
|
(map (scenarioTest Parsed tem worldMap) inputs)
|
||||||
|
|
||||||
scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree
|
scenarioParseInvalidTests :: TerrainEntityMaps -> WorldMap -> [(FilePath, String)] -> TestTree
|
||||||
scenarioParseInvalidTests em worldMap inputs =
|
scenarioParseInvalidTests tem worldMap inputs =
|
||||||
testGroup
|
testGroup
|
||||||
"Test invalid scenarios fail to parse"
|
"Test invalid scenarios fail to parse"
|
||||||
(map (scenarioTest Failed em worldMap) inputs)
|
(map (scenarioTest Failed tem worldMap) inputs)
|
||||||
|
|
||||||
data ParseResult = Parsed | Failed
|
data ParseResult = Parsed | Failed
|
||||||
|
|
||||||
scenarioTest :: ParseResult -> EntityMap -> WorldMap -> (FilePath, String) -> TestTree
|
scenarioTest :: ParseResult -> TerrainEntityMaps -> WorldMap -> (FilePath, String) -> TestTree
|
||||||
scenarioTest expRes em worldMap (path, _) =
|
scenarioTest expRes tem worldMap (path, _) =
|
||||||
testCase ("parse scenario " ++ show path) (getScenario expRes em worldMap path)
|
testCase ("parse scenario " ++ show path) (getScenario expRes tem worldMap path)
|
||||||
|
|
||||||
getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO ()
|
getScenario :: ParseResult -> TerrainEntityMaps -> WorldMap -> FilePath -> IO ()
|
||||||
getScenario expRes em worldMap p = do
|
getScenario expRes tem worldMap p = do
|
||||||
res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario)
|
res <- decodeFileEitherE (tem, worldMap) p :: IO (Either ParseException Scenario)
|
||||||
case expRes of
|
case expRes of
|
||||||
Parsed -> case res of
|
Parsed -> case res of
|
||||||
Left err -> assertFailure (prettyPrintParseException err)
|
Left err -> assertFailure (prettyPrintParseException err)
|
||||||
@ -366,6 +367,7 @@ testScenarioSolutions rs ui =
|
|||||||
, testSolution Default "Testing/1536-custom-unwalkable-entities"
|
, testSolution Default "Testing/1536-custom-unwalkable-entities"
|
||||||
, testSolution Default "Testing/1631-tags"
|
, testSolution Default "Testing/1631-tags"
|
||||||
, testSolution Default "Testing/1747-volume-command"
|
, testSolution Default "Testing/1747-volume-command"
|
||||||
|
, testSolution Default "Testing/1775-custom-terrain"
|
||||||
, testGroup
|
, testGroup
|
||||||
-- Note that the description of the classic world in
|
-- Note that the description of the classic world in
|
||||||
-- data/worlds/classic.yaml (automatically tested to some
|
-- data/worlds/classic.yaml (automatically tested to some
|
||||||
|
@ -12,8 +12,9 @@ import Data.Map qualified as M
|
|||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName)
|
import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName)
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Recipe (recipeOutputs)
|
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 Swarm.Util (commaList, quote)
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.ExpectedFailure (expectFailBecause)
|
import Test.Tasty.ExpectedFailure (expectFailBecause)
|
||||||
@ -41,7 +42,9 @@ testDeviceRecipeCoverage rs =
|
|||||||
]
|
]
|
||||||
|
|
||||||
-- Only include entities that grant a capability:
|
-- 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
|
getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs
|
||||||
recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes
|
recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes
|
||||||
|
@ -16,6 +16,7 @@ import Data.Text qualified as T
|
|||||||
import Swarm.Effect
|
import Swarm.Effect
|
||||||
import Swarm.Game.CESK
|
import Swarm.Game.CESK
|
||||||
import Swarm.Game.Exception
|
import Swarm.Game.Exception
|
||||||
|
import Swarm.Game.Land
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.Robot.Concrete (isActive)
|
import Swarm.Game.Robot.Concrete (isActive)
|
||||||
import Swarm.Game.State
|
import Swarm.Game.State
|
||||||
@ -48,7 +49,7 @@ evalCESK g cesk =
|
|||||||
orderResult ((res, rr), rg) = (rg, rr, res)
|
orderResult ((res, rr), rg) = (rg, rr, res)
|
||||||
|
|
||||||
runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value, Int))
|
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
|
runCESK !steps cesk = case finalValue cesk of
|
||||||
Just (v, _) -> return (Right (v, steps))
|
Just (v, _) -> return (Right (v, steps))
|
||||||
Nothing -> runTimeIO (stepCESK cesk) >>= runCESK (steps + 1)
|
Nothing -> runTimeIO (stepCESK cesk) >>= runCESK (steps + 1)
|
||||||
|
Loading…
Reference in New Issue
Block a user