From 71c837cac6ae3964754ea4f81d99e2b05198c375 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Thu, 22 Feb 2024 16:30:55 -0800 Subject: [PATCH] flatten Terrain and World attribute namespaces --- data/scenarios/Testing/00-ORDER.txt | 1 + src/Swarm/TUI/View/Attribute/Attr.hs | 9 ---- src/Swarm/TUI/View/Logo.hs | 2 +- src/swarm-scenario/Swarm/Game/Display.hs | 7 +-- src/swarm-scenario/Swarm/Game/Entity.hs | 8 +-- .../Swarm/Game/Entity/Cosmetic.hs | 3 -- .../Swarm/Game/Entity/Cosmetic/Assignment.hs | 49 +++++++++---------- src/swarm-scenario/Swarm/Game/Scenario.hs | 6 ++- src/swarm-scenario/Swarm/Game/Terrain.hs | 28 +++++++++-- src/swarm-scenario/Swarm/Util/Content.hs | 3 +- test/unit/TestRecipeCoverage.hs | 5 +- 11 files changed, 62 insertions(+), 59 deletions(-) diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index d7d06b4b6f..26bf083141 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -55,3 +55,4 @@ Achievements 1634-message-colors.yaml 1681-pushable-entity.yaml 1747-volume-command.yaml +1775-custom-terrain.yaml diff --git a/src/Swarm/TUI/View/Attribute/Attr.hs b/src/Swarm/TUI/View/Attribute/Attr.hs index 5f89381bd5..23e24528c1 100644 --- a/src/Swarm/TUI/View/Attribute/Attr.hs +++ b/src/Swarm/TUI/View/Attribute/Attr.hs @@ -19,7 +19,6 @@ module Swarm.TUI.View.Attribute.Attr ( messageAttributeNames, toAttrName, getWorldAttrName, - getTerrainAttrName, mkBrickColor, -- ** Common attributes @@ -69,7 +68,6 @@ toAttrName = \case ARobot -> robotAttr AEntity -> entityAttr AWorld n -> worldPrefix <> attrName (unpack n) - ATerrain n -> terrainPrefix <> attrName (unpack n) ADefault -> defAttr toVtyAttr :: PreservableColor -> V.Attr @@ -98,7 +96,6 @@ swarmAttrMap = $ NE.toList activityMeterAttributes <> NE.toList robotMessageAttributes <> map (getWorldAttrName *** toVtyAttr) (M.toList worldAttributes) - <> map (getTerrainAttrName *** toVtyAttr) (M.toList terrainAttributes) <> [ -- Robot attribute (robotAttr, fg V.white `V.withStyle` V.bold) , -- UI rendering attributes @@ -126,12 +123,6 @@ swarmAttrMap = (defAttr, V.defAttr) ] -terrainPrefix :: AttrName -terrainPrefix = attrName "terrain" - -getTerrainAttrName :: TerrainAttr -> AttrName -getTerrainAttrName (TerrainAttr n) = terrainPrefix <> attrName n - worldPrefix :: AttrName worldPrefix = attrName "world" diff --git a/src/Swarm/TUI/View/Logo.hs b/src/Swarm/TUI/View/Logo.hs index d7dc02a4bd..5ea290ec91 100644 --- a/src/Swarm/TUI/View/Logo.hs +++ b/src/Swarm/TUI/View/Logo.hs @@ -39,4 +39,4 @@ drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws) plantAttr = getWorldAttrName $ fst plant dirtAttr :: AttrName - dirtAttr = getTerrainAttrName $ fst dirt + dirtAttr = getWorldAttrName $ fst dirt diff --git a/src/swarm-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs index 3665ab6081..aac8d57fae 100644 --- a/src/swarm-scenario/Swarm/Game/Display.hs +++ b/src/swarm-scenario/Swarm/Game/Display.hs @@ -54,12 +54,9 @@ import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) type Priority = Int -- | An internal attribute name. -data Attribute = ADefault | ARobot | AEntity | AWorld Text | ATerrain Text +data Attribute = ADefault | ARobot | AEntity | AWorld Text deriving (Eq, Ord, Show, Generic, Hashable) -terrainPrefix :: Text -terrainPrefix = "terrain_" - instance FromJSON Attribute where parseJSON = withText "attribute" $ @@ -67,7 +64,6 @@ instance FromJSON Attribute where "robot" -> ARobot "entity" -> AEntity "default" -> ADefault - t | terrainPrefix `T.isPrefixOf` t -> ATerrain $ T.drop (T.length terrainPrefix) t w -> AWorld w instance ToJSON Attribute where @@ -76,7 +72,6 @@ instance ToJSON Attribute where ARobot -> String "robot" AEntity -> String "entity" AWorld w -> String w - ATerrain t -> String $ terrainPrefix <> t -- | A record explaining how to display an entity in the TUI. data Display = Display diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 00775837b3..6513891d23 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -47,7 +47,7 @@ module Swarm.Game.Entity ( -- ** Entity map EntityMap (..), buildEntityMap, - validateAttrRefs, + validateEntityAttrRefs, loadEntities, allEntities, lookupEntityName, @@ -403,8 +403,8 @@ deviceForCap :: Capability -> EntityMap -> [Entity] deviceForCap cap = fromMaybe [] . M.lookup cap . entitiesByCap -- | Validates references to 'Display' attributes -validateAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m () -validateAttrRefs validAttrs es = +validateEntityAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m () +validateEntityAttrRefs validAttrs es = forM_ namedEntities $ \(eName, ent) -> case ent ^. entityDisplay . displayAttr of AWorld n -> @@ -496,7 +496,7 @@ loadEntities = do withThrow (entityFailure . CanNotParseYaml) . (liftEither <=< sendIO) $ decodeFileEither fileName - withThrow entityFailure $ validateAttrRefs (M.keysSet worldAttributes) decoded + withThrow entityFailure $ validateEntityAttrRefs (M.keysSet worldAttributes) decoded withThrow entityFailure $ buildEntityMap decoded ------------------------------------------------------------ diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs index 8d8455de6c..2f6c3758c0 100644 --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs @@ -69,6 +69,3 @@ flattenBg = \case newtype WorldAttr = WorldAttr String deriving (Eq, Ord, Show) - -newtype TerrainAttr = TerrainAttr String - deriving (Eq, Ord, Show) diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs index 70a5668232..3df7d90d5d 100644 --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs +++ b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic/Assignment.hs @@ -15,7 +15,7 @@ import Data.Map (Map) import Data.Map qualified as M import Swarm.Game.Entity.Cosmetic --- * Entities +-- * Entities and Terrain entity :: (WorldAttr, PreservableColor) entity = (WorldAttr "entity", FgOnly $ AnsiColor White) @@ -29,13 +29,33 @@ rock = (WorldAttr "rock", FgOnly $ Triple $ RGB 80 80 80) plant :: (WorldAttr, PreservableColor) plant = (WorldAttr "plant", FgOnly $ AnsiColor Green) +dirt :: (WorldAttr, PreservableColor) +dirt = (WorldAttr "dirt", BgOnly $ Triple $ RGB 87 47 47) + +grass :: (WorldAttr, PreservableColor) +grass = (WorldAttr "grass", BgOnly $ Triple $ RGB 0 47 0) -- dark green + +stone :: (WorldAttr, PreservableColor) +stone = (WorldAttr "stone", BgOnly $ Triple $ RGB 47 47 47) + +ice :: (WorldAttr, PreservableColor) +ice = (WorldAttr "ice", BgOnly $ AnsiColor White) + -- | Colors of entities in the world. worldAttributes :: Map WorldAttr PreservableColor worldAttributes = M.fromList $ - -- these four are referenced elsewhere, + -- these few are referenced elsewhere, -- so they have their own toplevel definition - [entity, water, rock, plant] + [ entity + , water + , rock + , plant + , dirt + , grass + , stone + , ice + ] <> map (bimap WorldAttr FgOnly) [ ("device", AnsiColor BrightYellow) @@ -56,26 +76,3 @@ worldAttributes = , ("green", AnsiColor Green) , ("blue", AnsiColor Blue) ] - --- * Terrain - -dirt :: (TerrainAttr, PreservableColor) -dirt = (TerrainAttr "dirt", BgOnly $ Triple $ RGB 87 47 47) - -grass :: (TerrainAttr, PreservableColor) -grass = (TerrainAttr "grass", BgOnly $ Triple $ RGB 0 47 0) -- dark green - -stone :: (TerrainAttr, PreservableColor) -stone = (TerrainAttr "stone", BgOnly $ Triple $ RGB 47 47 47) - -ice :: (TerrainAttr, PreservableColor) -ice = (TerrainAttr "ice", BgOnly $ AnsiColor White) - -terrainAttributes :: M.Map TerrainAttr PreservableColor -terrainAttributes = - M.fromList - [ dirt - , grass - , stone - , ice - ] diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index 1690d4c569..5f62ad339f 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -277,9 +277,11 @@ instance FromJSONE (TerrainEntityMaps, WorldMap) Scenario where let mergedCosmetics = worldAttributes <> M.fromList (mapMaybe toHifiPair parsedAttrs) attrsUnion = M.keysSet mergedCosmetics - let tm = mkTerrainMap $ promoteTerrainObjects tmRaw + validatedTerrainObjects <- runValidation $ validateTerrainAttrRefs attrsUnion tmRaw - runValidation $ validateAttrRefs attrsUnion emRaw + let tm = mkTerrainMap validatedTerrainObjects + + runValidation $ validateEntityAttrRefs attrsUnion emRaw em <- runValidation $ buildEntityMap emRaw diff --git a/src/swarm-scenario/Swarm/Game/Terrain.hs b/src/swarm-scenario/Swarm/Game/Terrain.hs index 12feeb3aa5..7eafb131ae 100644 --- a/src/swarm-scenario/Swarm/Game/Terrain.hs +++ b/src/swarm-scenario/Swarm/Game/Terrain.hs @@ -13,28 +13,32 @@ module Swarm.Game.Terrain ( getTerrainWord, terrainFromText, loadTerrain, - promoteTerrainObjects, mkTerrainMap, + validateTerrainAttrRefs, ) where import Control.Algebra (Has) import Control.Arrow (first, (&&&)) import Control.Effect.Lift (Lift, sendIO) -import Control.Effect.Throw (Throw, liftEither) -import Control.Monad ((<=<)) +import Control.Effect.Throw (Throw, liftEither, throwError) +import Control.Monad (forM, unless, (<=<)) import Data.Char (toUpper) import Data.IntMap (IntMap) import Data.IntMap qualified as IM import Data.Map (Map) import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Tuple (swap) import Data.Yaml import GHC.Generics (Generic) import Swarm.Game.Display +import Swarm.Game.Entity.Cosmetic (WorldAttr (..)) import Swarm.Game.Failure import Swarm.Game.ResourceLoading (getDataFileNameSafe) +import Swarm.Util (quote) import Swarm.Util.Effect (withThrow) data TerrainType = BlankT | TerrainType Text @@ -83,7 +87,7 @@ data TerrainObj = TerrainObj promoteTerrainObjects :: [TerrainItem] -> [TerrainObj] promoteTerrainObjects = - map (\(TerrainItem n a d) -> TerrainObj n d $ defaultTerrainDisplay (ATerrain a)) + map (\(TerrainItem n a d) -> TerrainObj n d $ defaultTerrainDisplay (AWorld a)) enumeratedMap :: Int -> [a] -> IntMap a enumeratedMap startIdx = IM.fromList . zip [startIdx ..] @@ -126,7 +130,21 @@ mkTerrainMap items = where byIndex = enumeratedMap blankTerrainIndex items --- TODO make a combo function that loads both entities and terrain? +-- | 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. diff --git a/src/swarm-scenario/Swarm/Util/Content.hs b/src/swarm-scenario/Swarm/Util/Content.hs index a54a88ae9f..03ad1a4915 100644 --- a/src/swarm-scenario/Swarm/Util/Content.hs +++ b/src/swarm-scenario/Swarm/Util/Content.hs @@ -11,7 +11,6 @@ import Data.Map qualified as M import Data.Text qualified as T import Swarm.Game.Display import Swarm.Game.Entity.Cosmetic -import Swarm.Game.Entity.Cosmetic.Assignment (terrainAttributes) import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.Cell (PCell (..)) import Swarm.Game.Scenario.Topography.EntityFacade @@ -60,7 +59,7 @@ getTerrainEntityColor :: getTerrainEntityColor aMap (Cell terr cellEnt _) = (entityColor =<< erasableToMaybe cellEnt) <|> terrainFallback where - terrainFallback = M.lookup (TerrainAttr $ T.unpack $ getTerrainWord terr) terrainAttributes + terrainFallback = M.lookup (WorldAttr $ T.unpack $ getTerrainWord terr) aMap entityColor (EntityFacade _ d) = case d ^. displayAttr of AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap _ -> Nothing diff --git a/test/unit/TestRecipeCoverage.hs b/test/unit/TestRecipeCoverage.hs index fbd8cd90ad..dc73a17ee4 100644 --- a/test/unit/TestRecipeCoverage.hs +++ b/test/unit/TestRecipeCoverage.hs @@ -12,6 +12,7 @@ import Data.Map qualified as M import Data.Set qualified as Set import Data.Text qualified as T import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName) +import Swarm.Game.Land import Swarm.Game.Recipe (recipeOutputs) import Swarm.Game.State.Runtime (RuntimeState, stdEntityTerrainMap, stdRecipes) import Swarm.Util (commaList, quote) @@ -41,7 +42,9 @@ testDeviceRecipeCoverage rs = ] -- Only include entities that grant a capability: - entityNames = Set.fromList . map (^. entityName) . concat . M.elems . entitiesByCap $ rs ^. stdEntityTerrainMap . entityMap + entityNames = + Set.fromList . map (^. entityName) . concat . M.elems . entitiesByCap $ + rs ^. stdEntityTerrainMap . entityMap getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes