flatten Terrain and World attribute namespaces

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

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"
 

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

src/swarm-scenario/Swarm/Game/Display.hs

@@ -54,20 +54,16 @@ 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" $
       pure . \case
         "robot" -> ARobot
         "entity" -> AEntity
         "default" -> ADefault
-        t | terrainPrefix `T.isPrefixOf` t -> ATerrain $ T.drop (T.length terrainPrefix) t
         w -> AWorld w
 
 instance ToJSON Attribute where
@@ -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

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
 
 ------------------------------------------------------------

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)

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
-    ]

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
 

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.

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

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