From 2035ea18e14c8bbec3646f83c4ae1f08bd6efd74 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 4 Jan 2025 23:38:28 -0800 Subject: [PATCH] background passthrough --- src/swarm-scenario/Swarm/Game/Display.hs | 31 ++++++++++- .../Swarm/Game/Entity/Cosmetic.hs | 17 ++++-- src/swarm-scenario/Swarm/Game/Terrain.hs | 15 ++++- src/swarm-scenario/Swarm/Util/Content.hs | 9 ++- src/swarm-tui/Swarm/TUI/Editor/Model.hs | 19 ++++++- src/swarm-tui/Swarm/TUI/Editor/View.hs | 55 ++++++++++++++----- src/swarm-tui/Swarm/TUI/View.hs | 55 +++++++++++++------ src/swarm-tui/Swarm/TUI/View/CellDisplay.hs | 40 +++++++++----- src/swarm-tui/Swarm/TUI/View/Robot.hs | 4 +- src/swarm-tui/Swarm/TUI/View/Structure.hs | 24 +++++--- src/swarm-tui/Swarm/TUI/View/Util.hs | 20 +++++-- 11 files changed, 218 insertions(+), 71 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs index 59ebb20f1..e04c2eaea 100644 --- a/src/swarm-scenario/Swarm/Game/Display.hs +++ b/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 diff --git a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs b/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs index 91d571cc1..4e1318d0c 100644 --- a/src/swarm-scenario/Swarm/Game/Entity/Cosmetic.hs +++ b/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) diff --git a/src/swarm-scenario/Swarm/Game/Terrain.hs b/src/swarm-scenario/Swarm/Game/Terrain.hs index 7cbc7de55..b1dacb226 100644 --- a/src/swarm-scenario/Swarm/Game/Terrain.hs +++ b/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 diff --git a/src/swarm-scenario/Swarm/Util/Content.hs b/src/swarm-scenario/Swarm/Util/Content.hs index f61089661..55a90ede3 100644 --- a/src/swarm-scenario/Swarm/Util/Content.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/Editor/Model.hs b/src/swarm-tui/Swarm/TUI/Editor/Model.hs index 3cf10a9a5..6c4daaac8 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Model.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/Editor/View.hs b/src/swarm-tui/Swarm/TUI/Editor/View.hs index 69acd0249..c03d9c5cc 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/View.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index ba942f76b..0ba815aea 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -70,6 +70,7 @@ import Swarm.Constant import Swarm.Game.Device (commandCost, commandsForDeviceCaps, enabledCommands, getCapabilitySet, getMap, ingredients) import Swarm.Game.Display import Swarm.Game.Entity as E +import Swarm.Game.Entity.Cosmetic import Swarm.Game.Ingredients import Swarm.Game.Land import Swarm.Game.Location @@ -78,6 +79,7 @@ import Swarm.Game.Robot import Swarm.Game.Robot.Concrete import Swarm.Game.Scenario ( scenarioAuthor, + scenarioCosmetics, scenarioCreative, scenarioDescription, scenarioKnown, @@ -277,7 +279,9 @@ drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of tm = s ^. scenarioLandscape . scenarioTerrainAndEntities . terrainMap ri = RenderingInput theWorlds entIsKnown tm - renderCoord = renderDisplay . displayLocRaw (WorldOverdraw False mempty) ri [] + aMap = s ^. scenarioLandscape . scenarioCosmetics + + renderCoord = renderDisplay aMap . displayLocRaw (WorldOverdraw False mempty) ri [] worldPeek = worldWidget renderCoord vc firstRow = @@ -459,7 +463,18 @@ drawGameUI s = where widg = case uig ^. uiWorldCursor of Nothing -> str $ renderCoordsString $ s ^. gameState . robotInfo . viewCenter - Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (uig ^. uiWorldEditor . worldOverdraw) (s ^. gameState) coord + Just coord -> + clickable WorldPositionIndicator $ + drawWorldCursorInfo + aMap + (uig ^. uiWorldEditor . worldOverdraw) + (s ^. gameState) + coord + where + aMap = + maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ + s ^. uiState . uiGameplay . scenarioRef + -- Add clock display in top right of the world view if focused robot -- has a clock equipped addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (uig ^. uiTiming . lgTicksPerSecond) $ s ^. gameState) @@ -499,10 +514,15 @@ drawGameUI s = ) ] -drawWorldCursorInfo :: WorldOverdraw -> GameState -> Cosmic Coords -> Widget Name -drawWorldCursorInfo worldEditor g cCoords = +drawWorldCursorInfo :: + M.Map WorldAttr PreservableColor -> + WorldOverdraw -> + GameState -> + Cosmic Coords -> + Widget Name +drawWorldCursorInfo aMap worldEditor g cCoords = case getStatic g coords of - Just s -> renderDisplay $ displayStatic s + Just s -> renderDisplay aMap $ displayStatic s Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget] where Cosmic _ coords = cCoords @@ -516,7 +536,7 @@ drawWorldCursorInfo worldEditor g cCoords = . zipWith f tileMembers $ ["at", "on", "with"] where - f cell preposition = [renderDisplay cell, txt preposition] + f cell preposition = [renderDisplay aMap cell, txt preposition] ri = RenderingInput @@ -622,9 +642,9 @@ drawModal s = \case (s ^. keyEventHandling) RobotsModal -> drawRobotsModal $ uig ^. uiDialogs . uiRobot RecipesModal -> availableListWidget gs RecipeList - CommandsModal -> commandsListWidget gs + CommandsModal -> commandsListWidget (s ^. uiState . uiGameplay) gs MessagesModal -> availableListWidget gs MessageList - StructuresModal -> SR.renderStructuresDisplay gs (uig ^. uiDialogs . uiStructure) + StructuresModal -> SR.renderStructuresDisplay gs uig ScenarioEndModal outcome -> padBottom (Pad 1) $ vBox $ @@ -737,8 +757,8 @@ mkAvailableList gs notifLens notifRender = map padRender news <> notifSep <> map ] | otherwise = [] -commandsListWidget :: GameState -> Widget Name -commandsListWidget gs = +commandsListWidget :: UIGameplay -> GameState -> Widget Name +commandsListWidget uig gs = hCenter $ vBox [ table @@ -780,7 +800,8 @@ commandsListWidget gs = (r ^. equippedDevices) `union` (r ^. robotInventory) Nothing -> mempty - listDevices cmd = vBox $ map drawLabelledEntityName providerDevices + aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ uig ^. scenarioRef + listDevices cmd = vBox $ map (drawLabelledEntityName aMap) providerDevices where providerDevices = concatMap (flip (M.findWithDefault []) entsByCap) $ @@ -1047,11 +1068,12 @@ drawRobotPanel s -- away and a robot that does not exist. | Just r <- s ^. gameState . to focusedRobot , Just (_, lst) <- s ^. uiState . uiGameplay . uiInventory . uiInventoryList = - let drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb + let aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ s ^. uiState . uiGameplay . scenarioRef + drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem aMap (lst ^. BL.listSelectedL) pos selb details = [ txt (r ^. robotName) , padLeft (Pad 2) . str . renderCoordsString $ r ^. robotLocation - , padLeft (Pad 2) $ renderDisplay (r ^. robotDisplay) + , padLeft (Pad 2) $ renderDisplay aMap (r ^. robotDisplay) ] in padBottom Max $ vBox @@ -1066,6 +1088,7 @@ blank = padRight Max . padBottom Max $ str " " -- | Draw an inventory entry. drawItem :: + M.Map WorldAttr PreservableColor -> -- | The index of the currently selected inventory entry Maybe Int -> -- | The index of the entry we are drawing @@ -1077,17 +1100,17 @@ drawItem :: -- | The entry to draw. InventoryListEntry -> Widget Name -drawItem sel i _ (Separator l) = +drawItem _ sel i _ (Separator l) = -- Make sure a separator right before the focused element is -- visible. Otherwise, when a separator occurs as the very first -- element of the list, once it scrolls off the top of the viewport -- it will never become visible again. -- See https://github.com/jtdaugherty/brick/issues/336#issuecomment-921220025 applyWhen (sel == Just (i + 1)) visible $ hBorderWithLabel (txt l) -drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n +drawItem aMap _ _ _ (InventoryEntry n e) = drawLabelledEntityName aMap e <+> showCount n where showCount = padLeft Max . str . show -drawItem _ _ _ (EquippedEntry e) = drawLabelledEntityName e <+> padLeft Max (str " ") +drawItem aMap _ _ _ (EquippedEntry e) = drawLabelledEntityName aMap e <+> padLeft Max (str " ") ------------------------------------------------------------ -- Info panel diff --git a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs index d768c1bb3..280c7fee7 100644 --- a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs +++ b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs @@ -7,6 +7,7 @@ module Swarm.TUI.View.CellDisplay where import Brick +import Control.Applicative ((<|>)) import Control.Lens (to, view, (&), (.~), (^.)) import Data.ByteString (ByteString) import Data.Hash.Murmur @@ -20,21 +21,13 @@ import Data.Tagged (unTagged) import Data.Word (Word32) import Graphics.Vty qualified as V import Linear.Affine ((.-.)) -import Swarm.Game.Display ( - Attribute (AEntity), - Display, - boundaryOverride, - defaultEntityDisplay, - displayAttr, - displayChar, - displayPriority, - getBoundaryDisplay, - hidden, - ) +import Swarm.Game.Display import Swarm.Game.Entity +import Swarm.Game.Entity.Cosmetic import Swarm.Game.Land import Swarm.Game.Location (Point (..), toHeading) import Swarm.Game.Robot +import Swarm.Game.Scenario import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByLocation) @@ -60,8 +53,23 @@ import Witch (from) import Witch.Encoding qualified as Encoding -- | Render a display as a UI widget. -renderDisplay :: Display -> Widget n -renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] +renderDisplay :: + M.Map WorldAttr PreservableColor -> + Display -> + Widget n +renderDisplay aMap disp = + applyBackground $ withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp] + where + applyBackground = + maybe id (\c -> modifyDefAttr (`V.withBackColor` c)) $ + lookupBg e <|> lookupBg t + where + BackgroundSource t e = disp ^. backgroundSources + + lookupBg mayAttr = do + a <- mayAttr + b <- M.lookup a aMap + getBackground $ mkBrickColor <$> b -- | Render the 'Display' for a specific location. drawLoc :: UIGameplay -> GameState -> Cosmic Coords -> Widget Name @@ -72,7 +80,11 @@ drawLoc ui g cCoords@(Cosmic _ coords) = where showRobots = ui ^. uiShowRobots we = ui ^. uiWorldEditor . worldOverdraw - drawCell = renderDisplay $ displayLoc showRobots we g cCoords + + -- TODO (#2265): "UIGameplay" should be an optional member of UIState, + -- and "scenarioRef" should be a mandatory member of UIGameplay. + aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ ui ^. scenarioRef + drawCell = renderDisplay aMap $ displayLoc showRobots we g cCoords boldStructure = applyWhen isStructure $ modifyDefAttr (`V.withStyle` V.bold) where diff --git a/src/swarm-tui/Swarm/TUI/View/Robot.hs b/src/swarm-tui/Swarm/TUI/View/Robot.hs index 1d90778d9..f6c44e10b 100644 --- a/src/swarm-tui/Swarm/TUI/View/Robot.hs +++ b/src/swarm-tui/Swarm/TUI/View/Robot.hs @@ -44,6 +44,7 @@ import Swarm.Game.Location import Swarm.Game.Robot import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete +import Swarm.Game.Scenario import Swarm.Game.State import Swarm.Game.State.Robot import Swarm.Game.State.Substate @@ -319,11 +320,12 @@ mkLibraryEntries c = , rowLog = strWidget $ pure rLog } where + aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ c ^. gameplay . scenarioRef nameWidget = WithWidth (2 + T.length nameTxt) w where w = hBox - [ renderDisplay (r ^. robotDisplay) + [ renderDisplay aMap (r ^. robotDisplay) , highlightSystem . txt $ " " <> nameTxt ] nameTxt = r ^. robotName diff --git a/src/swarm-tui/Swarm/TUI/View/Structure.hs b/src/swarm-tui/Swarm/TUI/View/Structure.hs index 26484a09c..b1b138aba 100644 --- a/src/swarm-tui/Swarm/TUI/View/Structure.hs +++ b/src/swarm-tui/Swarm/TUI/View/Structure.hs @@ -20,6 +20,8 @@ import Data.Set qualified as Set import Data.Text qualified as T import Data.Vector qualified as V import Swarm.Game.Entity (Entity, entityDisplay) +import Swarm.Game.Entity.Cosmetic +import Swarm.Game.Scenario import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Structure.Named qualified as Structure @@ -32,6 +34,7 @@ import Swarm.Game.State.Substate (structureRecognition) import Swarm.Language.Syntax.Direction (directionJsonModifier) import Swarm.TUI.Model.Dialog.Structure import Swarm.TUI.Model.Name +import Swarm.TUI.Model.UI.Gameplay import Swarm.TUI.View.Attribute.Attr import Swarm.TUI.View.CellDisplay import Swarm.TUI.View.Shared (tabControlFooter) @@ -40,8 +43,12 @@ import Swarm.Util (commaList) -- | Render a two-pane widget with structure selection on the left -- and single-structure details on the right. -structureWidget :: GameState -> StructureInfo b Entity -> Widget n -structureWidget gs s = +structureWidget :: + M.Map WorldAttr PreservableColor -> + GameState -> + StructureInfo b Entity -> + Widget n +structureWidget aMap gs s = vBox [ hBox [ headerItem "Name" $ Structure.getStructureName theName @@ -107,7 +114,7 @@ structureWidget gs s = showCount (e, c) = hBox - [ drawLabelledEntityName e + [ drawLabelledEntityName aMap e , txt $ T.unwords [ ":" @@ -118,7 +125,7 @@ structureWidget gs s = theName = Structure.name theNamedGrid cells = getRows $ Grid $ entityProcessedGrid s - renderOneCell = maybe (txt " ") (renderDisplay . view entityDisplay) + renderOneCell = maybe (txt " ") (renderDisplay aMap . view entityDisplay) makeListWidget :: [StructureInfo b a] -> BL.List Name (StructureInfo b a) makeListWidget structureDefinitions = @@ -126,9 +133,9 @@ makeListWidget structureDefinitions = renderStructuresDisplay :: GameState -> - StructureDisplay -> + UIGameplay -> Widget Name -renderStructuresDisplay gs structureDisplay = +renderStructuresDisplay gs uig = vBox [ hBox [ leftSide @@ -137,6 +144,9 @@ renderStructuresDisplay gs structureDisplay = , tabControlFooter ] where + aMap = maybe mempty (view (scenarioLandscape . scenarioCosmetics) . fst) $ uig ^. scenarioRef + + structureDisplay = uig ^. uiDialogs . uiStructure lw = _structurePanelListWidget structureDisplay fr = _structurePanelFocus structureDisplay leftSide = @@ -159,7 +169,7 @@ renderStructuresDisplay gs structureDisplay = structureElaboration = clickable (StructureWidgets StructureSummary) . maybeScroll ModalViewport - . maybe emptyWidget (padAll 1 . padRight (Pad 1) . highlightIfFocused . structureWidget gs . snd) + . maybe emptyWidget (padAll 1 . padRight (Pad 1) . highlightIfFocused . structureWidget aMap gs . snd) $ BL.listSelectedElement lw drawSidebarListItem :: diff --git a/src/swarm-tui/Swarm/TUI/View/Util.hs b/src/swarm-tui/Swarm/TUI/View/Util.hs index dae391adb..368f17c4f 100644 --- a/src/swarm-tui/Swarm/TUI/View/Util.hs +++ b/src/swarm-tui/Swarm/TUI/View/Util.hs @@ -17,6 +17,7 @@ import Data.Text (Text) import Data.Text qualified as T import Graphics.Vty qualified as V import Swarm.Game.Entity as E +import Swarm.Game.Entity.Cosmetic import Swarm.Game.Land import Swarm.Game.Scenario (scenarioMetadata, scenarioName) import Swarm.Game.ScenarioInfo (scenarioItemName) @@ -164,13 +165,17 @@ drawMarkdown d = do "type" -> magentaAttr _snippet -> highlightAttr -- same as plain code -drawLabeledTerrainSwatch :: TerrainMap -> TerrainType -> Widget Name -drawLabeledTerrainSwatch tm a = +drawLabeledTerrainSwatch :: + M.Map WorldAttr PreservableColor -> + TerrainMap -> + TerrainType -> + Widget Name +drawLabeledTerrainSwatch aMap tm a = tile <+> str materialName where tile = padRight (Pad 1) - . renderDisplay + . renderDisplay aMap . maybe mempty terrainDisplay $ M.lookup a (terrainByName tm) @@ -243,10 +248,13 @@ maybeScroll vpName contents = -- | Draw the name of an entity, labelled with its visual -- representation as a cell in the world. -drawLabelledEntityName :: Entity -> Widget n -drawLabelledEntityName e = +drawLabelledEntityName :: + M.Map WorldAttr PreservableColor -> + Entity -> + Widget n +drawLabelledEntityName aMap e = hBox - [ padRight (Pad 2) (renderDisplay (e ^. entityDisplay)) + [ padRight (Pad 2) (renderDisplay aMap (e ^. entityDisplay)) , txt (e ^. entityName) ]