background passthrough

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

@@ -17,6 +17,7 @@ module Swarm.Game.Display (
   readAttribute,
   Display,
   ChildInheritance (..),
+  BackgroundSource (..),
 
   -- ** Fields
   defaultChar,
@@ -27,6 +28,8 @@ module Swarm.Game.Display (
   displayPriority,
   invisible,
   childInheritance,
+  backgroundSources,
+  _backgroundSources,
 
   -- ** Rendering
   displayChar,
@@ -54,6 +57,7 @@ import Data.Text qualified as T
 import Data.Yaml
 import GHC.Generics (Generic)
 import Graphics.Text.Width
+import Swarm.Game.Entity.Cosmetic
 import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..))
 import Swarm.Util (applyWhen, maxOn, quote)
 import Swarm.Util.Lens (makeLensesNoSigs)
@@ -90,6 +94,19 @@ data ChildInheritance
   | DefaultDisplay
   deriving (Eq, Ord, Show, Generic, Hashable)
 
+data BackgroundSource a = BackgroundSource
+  { terrainBgAttr :: Maybe a
+  , entityBgAttr :: Maybe a
+  }
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic, Hashable)
+
+instance Semigroup (BackgroundSource a) where
+  BackgroundSource x1 y1 <> BackgroundSource x2 y2 =
+    BackgroundSource (x1 <|> x2) (y1 <|> y2)
+
+instance Monoid (BackgroundSource a) where
+  mempty = BackgroundSource Nothing Nothing
+
 -- | A record explaining how to display an entity in the TUI.
 data Display = Display
   { _defaultChar :: Char
@@ -100,14 +117,18 @@ data Display = Display
   , _displayPriority :: Priority
   , _invisible :: Bool
   , _childInheritance :: ChildInheritance
+  , _backgroundSources :: BackgroundSource WorldAttr
   }
-  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)
+          { _backgroundSources = _backgroundSources d1 <> _backgroundSources d2
+          }
 
 makeLensesNoSigs ''Display
 
@@ -140,6 +161,9 @@ invisible :: Lens' Display Bool
 -- | For robots, whether children of this inherit the parent's display
 childInheritance :: Lens' Display ChildInheritance
 
+-- | Background color
+backgroundSources :: Lens' Display (BackgroundSource WorldAttr)
+
 instance FromJSON Display where
   parseJSON v = runE (parseJSONE v) (defaultEntityDisplay ' ')
 
@@ -157,6 +181,7 @@ instance FromJSONE Display Display where
     liftE $ do
       let _defaultChar = c
           _boundaryOverride = Nothing
+          _backgroundSources = mempty
       _orientationMap <- v .:? "orientationMap" .!= dOM
       _curOrientation <- v .:? "curOrientation" .!= (defD ^. curOrientation)
       _displayAttr <- (v .:? "attr") .!= (defD ^. displayAttr)
@@ -222,6 +247,7 @@ defaultEntityDisplay c =
     , _displayPriority = 1
     , _invisible = False
     , _childInheritance = Inherit
+    , _backgroundSources = mempty
     }
 
 -- | Construct a default robot display for a given orientation, with
@@ -247,6 +273,7 @@ defaultRobotDisplay =
     , _displayPriority = 10
     , _invisible = False
     , _childInheritance = Inherit
+    , _backgroundSources = mempty
     }
 
 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
 
@@ -96,4 +105,4 @@ flattenBg = \case
   FgAndBg _ x -> x
 
 newtype WorldAttr = WorldAttr String
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic, Hashable)

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -37,7 +38,7 @@ 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.ResourceLoading (getDataFileNameSafe)
 import Swarm.Util (enumeratedMap, quote)
 import Swarm.Util.Effect (withThrow)
@@ -88,7 +89,17 @@ data TerrainObj = TerrainObj
 
 promoteTerrainObjects :: [TerrainItem] -> [TerrainObj]
 promoteTerrainObjects =
-  map (\(TerrainItem n a d) -> TerrainObj n d $ defaultTerrainDisplay (AWorld a))
+  map f
+ where
+  f (TerrainItem n a d) =
+    TerrainObj n d $
+      (defaultTerrainDisplay (AWorld a))
+        { _backgroundSources =
+            BackgroundSource
+              { terrainBgAttr = Just . WorldAttr . T.unpack $ getTerrainWord n
+              , entityBgAttr = Nothing
+              }
+        }
 
 invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int
 invertedIndexMap = M.fromList . map (first terrainName . swap) . IM.toList

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

@@ -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/Model.hs

@@ -10,9 +10,11 @@ import Brick.Widgets.List qualified as BL
 import Control.Lens hiding (from, (.=), (<.>))
 import Data.List.Extra (enumerate)
 import Data.Map qualified as M
+import Data.Text qualified as T
 import Data.Vector qualified as V
-import Swarm.Game.Display (Display)
+import Swarm.Game.Display
 import Swarm.Game.Entity qualified as E
+import Swarm.Game.Entity.Cosmetic
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Terrain (TerrainType)
@@ -33,8 +35,19 @@ data EntityPaint
   deriving (Eq)
 
 getDisplay :: EntityPaint -> Display
-getDisplay (Facade (EntityFacade _ d)) = d
-getDisplay (Ref e) = e ^. E.entityDisplay
+getDisplay ep = mkEntBgSource $ case ep of
+  Facade (EntityFacade _ d) -> d
+  Ref e -> e ^. E.entityDisplay
+ where
+  mkEntBgSource d = d {_backgroundSources = src}
+   where
+    src = case d ^. displayAttr of
+      AWorld n ->
+        BackgroundSource
+          { terrainBgAttr = Just . WorldAttr $ T.unpack n
+          , entityBgAttr = Nothing
+          }
+      _ -> mempty
 
 toFacade :: EntityPaint -> EntityFacade
 toFacade = \case

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
@@ -80,16 +82,17 @@ drawWorldEditor toplevelFocusRing uig =
     selectedThing = snd <$> BL.listSelectedElement list
 
   tm = extractTerrainMap uig
+  aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ uig ^. 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
@@ -139,32 +142,54 @@ drawWorldEditor toplevelFocusRing uig =
 
   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 :: UIGameplay -> Widget Name
 drawTerrainSelector uig =
   padAll 1
     . hCenter
     . vLimit 8
-    . BL.renderListWithIndex (listDrawTerrainElement $ extractTerrainMap uig) True
+    . BL.renderListWithIndex (listDrawTerrainElement aMap $ extractTerrainMap uig) True
     $ uig ^. 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) $
+      uig ^. 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 :: UIGameplay -> Widget Name
 drawEntityPaintSelector uig =
   padAll 1
     . hCenter
     . vLimit 10
-    . BL.renderListWithIndex listDrawEntityPaintElement True
+    . BL.renderListWithIndex (listDrawEntityPaintElement aMap) True
     $ uig ^. 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) $
+      uig ^. scenarioRef
+
+listDrawEntityPaintElement ::
+  M.Map WorldAttr PreservableColor ->
+  Int ->
+  Bool ->
+  EntityFacade ->
+  Widget Name
+listDrawEntityPaintElement aMap pos _isSelected =
+  clickable (EntityPaintListItem pos) . drawLabeledEntitySwatch aMap