preserve ANSI named colors

src/Swarm/Game/Entity.hs

@@ -397,7 +397,6 @@ buildEntityMap es = do
   case findDup (map fst namedEntities) of
     Nothing -> return ()
     Just duped -> throwError $ Duplicate Entities duped
-
   return $
     EntityMap
       { entitiesByName = M.fromList namedEntities

src/Swarm/Game/Entity/Cosmetic.hs

@@ -7,8 +7,23 @@ module Swarm.Game.Entity.Cosmetic where
 import Data.Colour.SRGB (RGB)
 import Data.Word (Word8)
 
+data NamedColor
+  = White
+  | BrightRed
+  | Red
+  | Green
+  | Blue
+  | BrightYellow
+  | Yellow
+  deriving (Show)
+
 type RGBColor = RGB Word8
 
+data TrueColor
+  = AnsiColor NamedColor
+  | Triple RGBColor
+  deriving (Show)
+
 -- | High-fidelity color representation, for rendering
 -- outside of the TUI.
 -- Ignores vty "styles", such as bold/italic/underline.
@@ -18,15 +33,17 @@ type RGBColor = RGB Word8
 -- * Single pixel per world cell (one color must be chosen between foreground and background, if both are specified)
 -- * Pixel block per world cell (can show two colors in some stylized manner)
 -- * Glyph per world cell (can render a colored display character on a colored background)
-data HiFiColor
-  = FgOnly RGBColor
-  | BgOnly RGBColor
+data HiFiColor a
+  = FgOnly a
+  | BgOnly a
   | FgAndBg
       -- | foreground
-      RGBColor
+      a
       -- | background
-      RGBColor
-  deriving (Show)
+      a
+  deriving (Show, Functor)
+
+type PreservableColor = HiFiColor TrueColor
 
 newtype WorldAttr = WorldAttr String
   deriving (Eq, Ord, Show)

src/Swarm/Game/Entity/Cosmetic/Specimen.hs

@@ -10,86 +10,63 @@ import Data.Map (Map)
 import Data.Map qualified as M
 import Swarm.Game.Entity.Cosmetic
 
--- * Named colors
-
-whiteRGB :: RGBColor
-whiteRGB = RGB 208 207 204
-
-brightRedRGB :: RGBColor
-brightRedRGB = RGB 246 97 81
-
-redRGB :: RGBColor
-redRGB = RGB 192 28 40
-
-greenRGB :: RGBColor
-greenRGB = RGB 38 162 105
-
-blueRGB :: RGBColor
-blueRGB = RGB 18 72 139
-
-brightYellowRGB :: RGBColor
-brightYellowRGB = RGB 233 173 12
-
-yellowRGB :: RGBColor
-yellowRGB = RGB 162 115 76
-
 -- * Entities
 
-entity :: (WorldAttr, HiFiColor)
-entity = (WorldAttr "entity", FgOnly whiteRGB)
+entity :: (WorldAttr, PreservableColor)
+entity = (WorldAttr "entity", FgOnly $ AnsiColor White)
 
-water :: (WorldAttr, HiFiColor)
-water = (WorldAttr "water", FgAndBg whiteRGB blueRGB)
+water :: (WorldAttr, PreservableColor)
+water = (WorldAttr "water", FgAndBg (AnsiColor White) (AnsiColor Blue))
 
-rock :: (WorldAttr, HiFiColor)
-rock = (WorldAttr "rock", FgOnly $ RGB 80 80 80)
+rock :: (WorldAttr, PreservableColor)
+rock = (WorldAttr "rock", FgOnly $ Triple $ RGB 80 80 80)
 
-plant :: (WorldAttr, HiFiColor)
-plant = (WorldAttr "plant", FgOnly greenRGB)
+plant :: (WorldAttr, PreservableColor)
+plant = (WorldAttr "plant", FgOnly $ AnsiColor Green)
 
 -- | Colors of entities in the world.
-worldAttributes :: Map WorldAttr HiFiColor
+worldAttributes :: Map WorldAttr PreservableColor
 worldAttributes =
   M.fromList $
     -- these four are referenced elsewhere,
     -- so they have their own toplevel definition
     [entity, water, rock, plant]
       <> map
         (bimap WorldAttr FgOnly)
-        [ ("device", brightYellowRGB)
-        , ("wood", RGB 139 69 19)
-        , ("flower", RGB 200 0 200)
-        , ("rubber", RGB 245 224 179)
-        , ("copper", yellowRGB)
-        , ("copper'", RGB 78 117 102)
-        , ("iron", RGB 97 102 106)
-        , ("iron'", RGB 183 65 14)
-        , ("quartz", whiteRGB)
-        , ("silver", RGB 192 192 192)
-        , ("gold", RGB 255 215 0)
-        , ("snow", whiteRGB)
-        , ("sand", RGB 194 178 128)
-        , ("fire", brightRedRGB)
-        , ("red", redRGB)
-        , ("green", greenRGB)
-        , ("blue", blueRGB)
+        [ ("device", AnsiColor BrightYellow)
+        , ("wood", Triple $ RGB 139 69 19)
+        , ("flower", Triple $ RGB 200 0 200)
+        , ("rubber", Triple $ RGB 245 224 179)
+        , ("copper", AnsiColor Yellow)
+        , ("copper'", Triple $ RGB 78 117 102)
+        , ("iron", Triple $ RGB 97 102 106)
+        , ("iron'", Triple $ RGB 183 65 14)
+        , ("quartz", AnsiColor White)
+        , ("silver", Triple $ RGB 192 192 192)
+        , ("gold", Triple $ RGB 255 215 0)
+        , ("snow", AnsiColor White)
+        , ("sand", Triple $ RGB 194 178 128)
+        , ("fire", AnsiColor BrightRed)
+        , ("red", AnsiColor Red)
+        , ("green", AnsiColor Green)
+        , ("blue", AnsiColor Blue)
         ]
 
 -- * Terrain
 
-dirt :: (TerrainAttr, HiFiColor)
-dirt = (TerrainAttr "dirt", FgOnly $ RGB 165 42 42)
+dirt :: (TerrainAttr, PreservableColor)
+dirt = (TerrainAttr "dirt", FgOnly $ Triple $ RGB 165 42 42)
 
-grass :: (TerrainAttr, HiFiColor)
-grass = (TerrainAttr "grass", FgOnly $ RGB 0 32 0) -- dark green
+grass :: (TerrainAttr, PreservableColor)
+grass = (TerrainAttr "grass", FgOnly $ Triple $ RGB 0 32 0) -- dark green
 
-stone :: (TerrainAttr, HiFiColor)
-stone = (TerrainAttr "stone", FgOnly $ RGB 32 32 32)
+stone :: (TerrainAttr, PreservableColor)
+stone = (TerrainAttr "stone", FgOnly $ Triple $ RGB 32 32 32)
 
-ice :: (TerrainAttr, HiFiColor)
-ice = (TerrainAttr "ice", BgOnly whiteRGB)
+ice :: (TerrainAttr, PreservableColor)
+ice = (TerrainAttr "ice", BgOnly $ AnsiColor White)
 
-terrainAttributes :: M.Map TerrainAttr HiFiColor
+terrainAttributes :: M.Map TerrainAttr PreservableColor
 terrainAttributes =
   M.fromList
     [ dirt

src/Swarm/Game/Scenario.hs

@@ -128,7 +128,7 @@ data Scenario = Scenario
   , _scenarioSeed :: Maybe Int
   , _scenarioAttrs :: [CustomAttr]
   , _scenarioEntities :: EntityMap
-  , _scenarioCosmetics :: M.Map WorldAttr HiFiColor
+  , _scenarioCosmetics :: M.Map WorldAttr PreservableColor
   , _scenarioRecipes :: [Recipe Entity]
   , _scenarioKnown :: [Text]
   , _scenarioWorlds :: NonEmpty WorldDescription
@@ -283,7 +283,7 @@ scenarioAttrs :: Lens' Scenario [CustomAttr]
 scenarioEntities :: Lens' Scenario EntityMap
 
 -- | High-fidelity color map for entities
-scenarioCosmetics :: Lens' Scenario (M.Map WorldAttr HiFiColor)
+scenarioCosmetics :: Lens' Scenario (M.Map WorldAttr PreservableColor)
 
 -- | Any custom recipes used in this scenario.
 scenarioRecipes :: Lens' Scenario [Recipe Entity]

src/Swarm/Game/Scenario/Style.hs

@@ -58,7 +58,7 @@ instance ToJSON CustomAttr where
 
 -- | Must specify either a foreground or background color;
 -- just a style is not sufficient.
-toHifiPair :: CustomAttr -> Maybe (WorldAttr, HiFiColor)
+toHifiPair :: CustomAttr -> Maybe (WorldAttr, PreservableColor)
 toHifiPair (CustomAttr n maybeFg maybeBg _) =
   sequenceA (WorldAttr n, c)
  where
@@ -68,7 +68,7 @@ toHifiPair (CustomAttr n maybeFg maybeBg _) =
     (Nothing, Just b) -> Just $ BgOnly (conv b)
     (Nothing, Nothing) -> Nothing
 
-  conv (HexColor x) = toSRGB24 kolor
+  conv (HexColor x) = Triple $ toSRGB24 kolor
    where
     kolor :: Kolor
     kolor = sRGB24read $ T.unpack x

src/Swarm/Game/World/Render.hs

@@ -15,6 +15,7 @@ import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
 import Data.Tuple.Extra (both)
 import Data.Vector qualified as V
+import Graphics.Vty.Attributes.Color240
 import Linear (V2 (..))
 import Swarm.Doc.Gen (loadStandaloneScenario)
 import Swarm.Game.Display (Attribute (AWorld), defaultChar, displayAttr)
@@ -55,7 +56,7 @@ getDisplayChar = maybe ' ' facadeChar . erasableToMaybe . cellEntity
  where
   facadeChar (EntityFacade _ d) = view defaultChar d
 
-getDisplayColor :: M.Map WorldAttr HiFiColor -> PCell EntityFacade -> PixelRGBA8
+getDisplayColor :: M.Map WorldAttr PreservableColor -> PCell EntityFacade -> PixelRGBA8
 getDisplayColor aMap (Cell terr cellEnt _) =
   maybe terrainFallback facadeColor $ erasableToMaybe cellEnt
  where
@@ -68,14 +69,43 @@ getDisplayColor aMap (Cell terr cellEnt _) =
     AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap
     _ -> Nothing
 
-mkPixelColor :: HiFiColor -> PixelRGBA8
+-- | Round-trip conversion to fit into the terminal color space
+roundTripVty :: RGBColor -> RGBColor
+roundTripVty c@(RGB r g b) =
+  maybe
+    c
+    (\(r', g', b') -> fromIntegral <$> RGB r' g' b')
+    converted
+ where
+  converted = color240CodeToRGB $ rgbColorToColor240 r g b
+
+mkPixelColor :: PreservableColor -> PixelRGBA8
 mkPixelColor h = PixelRGBA8 r g b 255
  where
-  RGB r g b = case h of
+  RGB r g b = roundTripVty singleColor
+  singleColor = case fromHiFi h of
     FgOnly c -> c
     BgOnly c -> c
     FgAndBg _ c -> c
 
+-- | Since terminals can customize these named
+-- colors using themes or explicit user overrides,
+-- these color assignments are somewhat arbitrary.
+namedToTriple :: NamedColor -> RGBColor
+namedToTriple = \case
+  White -> RGB 208 207 204
+  BrightRed -> RGB 246 97 81
+  Red -> RGB 192 28 40
+  Green -> RGB 38 162 105
+  Blue -> RGB 18 72 139
+  BrightYellow -> RGB 233 173 12
+  Yellow -> RGB 162 115 76
+
+fromHiFi :: PreservableColor -> HiFiColor RGBColor
+fromHiFi = fmap $ \case
+  Triple x -> x
+  AnsiColor x -> namedToTriple x
+
 -- | When output size is not explicitly provided on command line,
 -- uses natural map bounds (if a map exists).
 getDisplayGrid ::
@@ -117,7 +147,7 @@ getDisplayGrid myScenario gs maybeSize =
 getRenderableGrid ::
   RenderOpts ->
   FilePath ->
-  IO ([[PCell EntityFacade]], M.Map WorldAttr HiFiColor)
+  IO ([[PCell EntityFacade]], M.Map WorldAttr PreservableColor)
 getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize) fp = simpleErrorHandle $ do
   (myScenario, (worldDefs, entities, recipes)) <- loadStandaloneScenario fp
   appDataMap <- readAppData

src/Swarm/TUI/View/Attribute/Attr.hs

@@ -51,6 +51,7 @@ import Brick.Widgets.Edit qualified as E
 import Brick.Widgets.List (listSelectedFocusedAttr)
 import Control.Arrow ((***))
 import Data.Colour.Palette.BrewerSet
+import Data.Colour.SRGB (RGB (..))
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
@@ -60,7 +61,6 @@ import Graphics.Vty qualified as V
 import Swarm.Game.Display (Attribute (..))
 import Swarm.Game.Entity.Cosmetic
 import Swarm.Game.Entity.Cosmetic.Specimen
-import Swarm.TUI.View.Attribute.Color
 import Swarm.TUI.View.Attribute.Util
 
 toAttrName :: Attribute -> AttrName
@@ -71,15 +71,32 @@ toAttrName = \case
   ATerrain n -> terrainPrefix <> attrName (unpack n)
   ADefault -> defAttr
 
+toVtyAttr :: PreservableColor -> V.Attr
+toVtyAttr hifi = case fmap mkBrickColor hifi of
+  FgOnly c -> fg c
+  BgOnly c -> bg c
+  FgAndBg foreground background -> foreground `on` background
+ where
+  mkBrickColor = \case
+    Triple (RGB r g b) -> V.rgbColor r g b
+    AnsiColor x -> case x of
+      White -> V.white
+      BrightRed -> V.brightRed
+      Red -> V.red
+      Green -> V.green
+      Blue -> V.blue
+      BrightYellow -> V.brightYellow
+      Yellow -> V.yellow
+
 -- | A mapping from the defined attribute names to TUI attributes.
 swarmAttrMap :: AttrMap
 swarmAttrMap =
   attrMap
     V.defAttr
     $ NE.toList activityMeterAttributes
       <> NE.toList robotMessageAttributes
-      <> map (getWorldAttrName *** vtyColor . fromHiFi) (M.toList worldAttributes)
-      <> map (getTerrainAttrName *** vtyColor . fromHiFi) (M.toList terrainAttributes)
+      <> 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

swarm.cabal

@@ -215,7 +215,6 @@ library
                       Swarm.TUI.View.Achievement
                       Swarm.TUI.View.Attribute.Attr
                       Swarm.TUI.View.Attribute.CustomStyling
-                      Swarm.TUI.View.Attribute.Color
                       Swarm.TUI.View.Attribute.Util
                       Swarm.TUI.View.CellDisplay
                       Swarm.TUI.View.Logo