Alternate approach to background passthrough

data/scenarios/Testing/1034-custom-attributes.yaml

@@ -8,6 +8,7 @@ creative: false
 attrs:
   - name: robotWithBackground
     bg: "#880088"
+
   - name: rainbow1
     fg: "#ffadad"
   - name: rainbow2
@@ -22,6 +23,7 @@ attrs:
     fg: "#a0c4ff"
   - name: rainbow7
     fg: "#bdb2ff"
+
   - name: rainbow1bg
     bg: "#ffadad"
   - name: rainbow2bg
@@ -36,6 +38,7 @@ attrs:
     bg: "#a0c4ff"
   - name: rainbow7bg
     bg: "#bdb2ff"
+
   - name: redOnYellow
     fg: "#ff0000"
     bg: "#ffff00"
@@ -112,6 +115,7 @@ entities:
     description:
       - c7
     properties: [known]
+
   - name: color1bg
     display:
       char: ' '
@@ -161,6 +165,7 @@ entities:
     description:
       - c7bg
     properties: [known]
+
   - name: color1f
     display:
       char: '█'
@@ -281,6 +286,7 @@ world:
     'Ω': [blank, null, base]
     'α': [blank, null, companion]
     'β': [blank, null, companion2]
+
     '.': [blank]
     '1': [blank, color1]
     '2': [blank, color2]
@@ -289,20 +295,23 @@ world:
     '5': [blank, color5]
     '6': [blank, color6]
     '7': [blank, color7]
+
     'T': [blank, color1bg]
     'U': [blank, color2bg]
     'V': [blank, color3bg]
     'W': [blank, color4bg]
     'X': [blank, color5bg]
     'Y': [blank, color6bg]
     'Z': [blank, color7bg]
+
     'a': [blank, color1f]
     'b': [blank, color2f]
     'c': [blank, color3f]
     'd': [blank, color4f]
     'e': [blank, color5f]
     'f': [blank, color6f]
     'g': [blank, color7f]
+
     'y': [blank, blueBackround]
     'z': [blank, greenForeground]
     'R': [blank, redYellow]

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

@@ -27,6 +27,8 @@ module Swarm.Game.Display (
   displayPriority,
   invisible,
   childInheritance,
+  backgroundColor,
+  _backgroundColor,
 
   -- ** Rendering
   displayChar,
@@ -54,6 +56,9 @@ import Data.Text qualified as T
 import Data.Yaml
 import GHC.Generics (Generic)
 import Graphics.Text.Width
+import Graphics.Vty qualified as V
+import Swarm.Game.Entity.Cosmetic
+import Swarm.Game.Terra
 import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..))
 import Swarm.Util (applyWhen, maxOn, quote)
 import Swarm.Util.Lens (makeLensesNoSigs)
@@ -100,14 +105,18 @@ data Display = Display
   , _displayPriority :: Priority
   , _invisible :: Bool
   , _childInheritance :: ChildInheritance
+  , _backgroundColor :: Maybe TerrainType
   }
-  deriving (Eq, Ord, Show, Generic, Hashable)
+  deriving (Eq, Show, Generic, Hashable)
 
 instance Semigroup Display where
   d1 <> d2
     | _invisible d1 = d2
     | _invisible d2 = d1
-    | otherwise = maxOn _displayPriority d1 d2
+    | otherwise =
+        (maxOn _displayPriority d1 d2)
+          { _backgroundColor = _backgroundColor d1 <|> _backgroundColor d2
+          }
 
 makeLensesNoSigs ''Display
 
@@ -140,6 +149,9 @@ invisible :: Lens' Display Bool
 -- | For robots, whether children of this inherit the parent's display
 childInheritance :: Lens' Display ChildInheritance
 
+-- | Background color
+backgroundColor :: Lens' Display (Maybe TerrainType)
+
 instance FromJSON Display where
   parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ')
 
@@ -157,6 +169,7 @@ instance FromJSONE Display Display where
     liftE $ do
       let _defaultChar = c
           _boundaryOverride = Nothing
+          _backgroundColor = Nothing
       _orientationMap <- v .:? "orientationMap" .!= dOM
       _curOrientation <- v .:? "curOrientation" .!= (defD ^. curOrientation)
       _displayAttr <- (v .:? "attr") .!= (defD ^. displayAttr)
@@ -222,6 +235,7 @@ defaultEntityDisplay c =
     , _displayPriority = 1
     , _invisible = False
     , _childInheritance = Inherit
+    , _backgroundColor = Nothing
     }
 
 -- | Construct a default robot display for a given orientation, with
@@ -247,6 +261,7 @@ defaultRobotDisplay =
     , _displayPriority = 10
     , _invisible = False
     , _childInheritance = Inherit
+    , _backgroundColor = Nothing
     }
 
 instance Monoid Display where

src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 --
@@ -6,7 +8,9 @@ module Swarm.Game.Entity.Cosmetic where
 
 import Codec.Picture (PixelRGBA8 (..))
 import Data.Colour.SRGB (RGB (..))
+import Data.Hashable
 import Data.Word (Word8)
+import GHC.Generics (Generic)
 import Swarm.Game.Scenario.Topography.Rasterize
 
 data NamedColor
@@ -17,7 +21,7 @@ data NamedColor
   | Blue
   | BrightYellow
   | Yellow
-  deriving (Show)
+  deriving (Show, Eq, Generic, Hashable)
 
 -- | 8-bit color
 type RGBColor = RGB Word8
@@ -43,12 +47,15 @@ namedToTriple = \case
   BrightYellow -> RGB 233 173 12
   Yellow -> RGB 162 115 76
 
+instance Hashable RGBColor where
+  hashWithSalt a (RGB r g b) = hashWithSalt a (r, g, b)
+
 -- | High-fidelity color representation for rendering
 -- outside of the TUI.
 data TrueColor
   = AnsiColor NamedColor
   | Triple RGBColor
-  deriving (Show)
+  deriving (Show, Eq, Generic, Hashable)
 
 -- |
 -- A value of type @ColorLayers a@ represents the assignment of
@@ -74,7 +81,9 @@ data ColorLayers a
       a
       -- | background
       a
-  deriving (Show, Functor)
+  deriving (Show, Eq, Functor, Generic)
+
+instance Hashable (ColorLayers TrueColor)
 
 type PreservableColor = ColorLayers TrueColor
 

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

@@ -0,0 +1,15 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Terrain type
+module Swarm.Game.Terra (
+  TerrainType (..),
+) where
+
+import Data.Hashable (Hashable)
+import Data.Text (Text)
+import Data.Yaml
+import GHC.Generics (Generic)
+
+data TerrainType = BlankT | TerrainType Text
+  deriving (Eq, Ord, Show, Generic, ToJSON, Hashable)

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

@@ -37,14 +37,12 @@ import Data.Yaml
 import GHC.Generics (Generic)
 import Swarm.Failure
 import Swarm.Game.Display
-import Swarm.Game.Entity.Cosmetic (WorldAttr (..))
+import Swarm.Game.Entity.Cosmetic
+import Swarm.Game.Terra
 import Swarm.ResourceLoading (getDataFileNameSafe)
 import Swarm.Util (enumeratedMap, quote)
 import Swarm.Util.Effect (withThrow)
 
-data TerrainType = BlankT | TerrainType Text
-  deriving (Eq, Ord, Show, Generic, ToJSON, Hashable)
-
 blankTerrainIndex :: Int
 blankTerrainIndex = 0
 
@@ -88,7 +86,16 @@ data TerrainObj = TerrainObj
 
 promoteTerrainObjects :: [TerrainItem] -> [TerrainObj]
 promoteTerrainObjects =
-  map (\(TerrainItem n a d) -> TerrainObj n d $ defaultTerrainDisplay (AWorld a))
+  map
+    ( \(TerrainItem n a d) ->
+        TerrainObj
+          n
+          d
+          ( (defaultTerrainDisplay (AWorld a))
+              { _backgroundColor = Just n
+              }
+          )
+    )
 
 invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int
 invertedIndexMap = M.fromList . map (first terrainName . swap) . IM.toList

src/swarm-scenario/Swarm/Util/Content.hs

@@ -11,7 +11,7 @@ import Data.Map qualified as M
 import Data.Text qualified as T
 import Swarm.Game.Display
 import Swarm.Game.Entity.Cosmetic
-import Swarm.Game.Scenario.Topography.Cell (PCell (..))
+import Swarm.Game.Scenario.Topography.Cell (CellPaintDisplay, PCell (..))
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainWord)
@@ -60,7 +60,14 @@ getTerrainEntityColor ::
 getTerrainEntityColor aMap (Cell terr cellEnt _) =
   (entityColor =<< erasableToMaybe cellEnt) <|> terrainFallback
  where
-  terrainFallback = M.lookup (WorldAttr $ T.unpack $ getTerrainWord terr) aMap
+  terrainFallback = getTerrainColor aMap terr
   entityColor (EntityFacade _ d) = case d ^. displayAttr of
     AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap
     _ -> Nothing
+
+getTerrainColor ::
+  M.Map WorldAttr PreservableColor ->
+  TerrainType ->
+  Maybe PreservableColor
+getTerrainColor aMap terr =
+  M.lookup (WorldAttr $ T.unpack $ getTerrainWord terr) aMap

src/swarm-tui/Swarm/TUI/Editor/View.hs

@@ -8,6 +8,8 @@ import Brick.Widgets.Center (hCenter)
 import Brick.Widgets.List qualified as BL
 import Control.Lens hiding (Const, from)
 import Data.List qualified as L
+import Data.Map qualified as M
+import Swarm.Game.Entity.Cosmetic
 import Swarm.Game.Land
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Topography.Area qualified as EA
@@ -81,16 +83,17 @@ drawWorldEditor toplevelFocusRing uis =
     selectedThing = snd <$> BL.listSelectedElement list
 
   tm = extractTerrainMap uis
+  aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ uis ^. uiGameplay . scenarioRef
 
   brushWidget =
     mkFormControl (WorldEditorPanelControl BrushSelector) $
       padRight (Pad 1) (str "Brush:")
-        <+> swatchContent (worldEditor ^. terrainList) (VU.drawLabeledTerrainSwatch tm)
+        <+> swatchContent (worldEditor ^. terrainList) (VU.drawLabeledTerrainSwatch aMap tm)
 
   entityWidget =
     mkFormControl (WorldEditorPanelControl EntitySelector) $
       padRight (Pad 1) (str "Entity:")
-        <+> swatchContent (worldEditor ^. entityPaintList) drawLabeledEntitySwatch
+        <+> swatchContent (worldEditor ^. entityPaintList) (drawLabeledEntitySwatch aMap)
 
   clearEntityButtonWidget =
     if null $ worldEditor ^. entityPaintList . BL.listSelectedL
@@ -140,32 +143,54 @@ drawWorldEditor toplevelFocusRing uis =
 
   statusBox = maybe emptyWidget str $ worldEditor ^. lastWorldEditorMessage
 
-drawLabeledEntitySwatch :: EntityFacade -> Widget Name
-drawLabeledEntitySwatch (EntityFacade eName eDisplay) =
+drawLabeledEntitySwatch ::
+  M.Map WorldAttr PreservableColor ->
+  EntityFacade ->
+  Widget Name
+drawLabeledEntitySwatch aMap (EntityFacade eName eDisplay) =
   tile <+> txt eName
  where
-  tile = padRight (Pad 1) $ renderDisplay eDisplay
+  tile = padRight (Pad 1) $ renderDisplay aMap eDisplay
 
 drawTerrainSelector :: AppState -> Widget Name
 drawTerrainSelector s =
   padAll 1
     . hCenter
     . vLimit 8
-    . BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap $ s ^. uiState) True
+    . BL.renderListWithIndex (listDrawTerrainElement aMap $ extractTerrainMap $ s ^. uiState) True
     $ s ^. uiState . uiGameplay . uiWorldEditor . terrainList
-
-listDrawTerrainElement :: TerrainMap -> Int -> Bool -> TerrainType -> Widget Name
-listDrawTerrainElement tm pos _isSelected a =
-  clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch tm a
+ where
+  aMap =
+    maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $
+      s ^. uiState . uiGameplay . scenarioRef
+
+listDrawTerrainElement ::
+  M.Map WorldAttr PreservableColor ->
+  TerrainMap ->
+  Int ->
+  Bool ->
+  TerrainType ->
+  Widget Name
+listDrawTerrainElement aMap tm pos _isSelected a =
+  clickable (TerrainListItem pos) $ VU.drawLabeledTerrainSwatch aMap tm a
 
 drawEntityPaintSelector :: AppState -> Widget Name
 drawEntityPaintSelector s =
   padAll 1
     . hCenter
     . vLimit 10
-    . BL.renderListWithIndex listDrawEntityPaintElement True
+    . BL.renderListWithIndex (listDrawEntityPaintElement aMap) True
     $ s ^. uiState . uiGameplay . uiWorldEditor . entityPaintList
-
-listDrawEntityPaintElement :: Int -> Bool -> EntityFacade -> Widget Name
-listDrawEntityPaintElement pos _isSelected a =
-  clickable (EntityPaintListItem pos) $ drawLabeledEntitySwatch a
+ where
+  aMap =
+    maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $
+      s ^. uiState . uiGameplay . scenarioRef
+
+listDrawEntityPaintElement ::
+  M.Map WorldAttr PreservableColor ->
+  Int ->
+  Bool ->
+  EntityFacade ->
+  Widget Name
+listDrawEntityPaintElement aMap pos _isSelected a =
+  clickable (EntityPaintListItem pos) $ drawLabeledEntitySwatch aMap a