-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Preserve color fidelity for non-TUI rendering
module Swarm.Game.Entity.Cosmetic where

import Codec.Picture (PixelRGBA8 (..))
import Data.Colour.SRGB (RGB (..))
import Data.Word (Word8)
import Swarm.Game.Scenario.Topography.Rasterize

data NamedColor
  = White
  | BrightRed
  | Red
  | Green
  | Blue
  | BrightYellow
  | Yellow
  deriving (Int -> NamedColor -> ShowS
[NamedColor] -> ShowS
NamedColor -> String
(Int -> NamedColor -> ShowS)
-> (NamedColor -> String)
-> ([NamedColor] -> ShowS)
-> Show NamedColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamedColor -> ShowS
showsPrec :: Int -> NamedColor -> ShowS
$cshow :: NamedColor -> String
show :: NamedColor -> String
$cshowList :: [NamedColor] -> ShowS
showList :: [NamedColor] -> ShowS
Show)

-- | 8-bit color
type RGBColor = RGB Word8

fromHiFi :: PreservableColor -> ColorLayers RGBColor
fromHiFi :: PreservableColor -> ColorLayers RGBColor
fromHiFi = (TrueColor -> RGBColor) -> PreservableColor -> ColorLayers RGBColor
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TrueColor -> RGBColor)
 -> PreservableColor -> ColorLayers RGBColor)
-> (TrueColor -> RGBColor)
-> PreservableColor
-> ColorLayers RGBColor
forall a b. (a -> b) -> a -> b
$ \case
  Triple RGBColor
x -> RGBColor
x
  -- The triples we've manually assigned for named
  -- ANSI colors do not need to be round-tripped, since
  -- those triples are not inputs to the VTY attribute creation.
  AnsiColor NamedColor
x -> NamedColor -> RGBColor
namedToTriple NamedColor
x

-- | Since terminals can customize these named
-- colors using themes or explicit user overrides,
-- these color assignments are somewhat arbitrary.
namedToTriple :: NamedColor -> RGBColor
namedToTriple :: NamedColor -> RGBColor
namedToTriple = \case
  NamedColor
White -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
208 Word8
207 Word8
204
  NamedColor
BrightRed -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
246 Word8
97 Word8
81
  NamedColor
Red -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
192 Word8
28 Word8
40
  NamedColor
Green -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
38 Word8
162 Word8
105
  NamedColor
Blue -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
18 Word8
72 Word8
139
  NamedColor
BrightYellow -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
233 Word8
173 Word8
12
  NamedColor
Yellow -> Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
162 Word8
115 Word8
76

-- | High-fidelity color representation for rendering
-- outside of the TUI.
data TrueColor
  = AnsiColor NamedColor
  | Triple RGBColor
  deriving (Int -> TrueColor -> ShowS
[TrueColor] -> ShowS
TrueColor -> String
(Int -> TrueColor -> ShowS)
-> (TrueColor -> String)
-> ([TrueColor] -> ShowS)
-> Show TrueColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TrueColor -> ShowS
showsPrec :: Int -> TrueColor -> ShowS
$cshow :: TrueColor -> String
show :: TrueColor -> String
$cshowList :: [TrueColor] -> ShowS
showList :: [TrueColor] -> ShowS
Show)

-- |
-- A value of type @ColorLayers a@ represents the assignment of
-- foreground and\/or background color to an 'Entity' or terrain,
-- where @a@ may be a medium-independent (i.e. "authoritative") color
-- representation, or medium-specific (e.g. a @vty@ color).
-- The 'Functor' instance facilitates easy conversion from the
-- authoritative color to the specialized representation.
--
-- Ignores @vty@ "styles", such as bold\/italic\/underline.
--
-- This is intended to facilitate multiple rendering mediums:
--
-- * 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 ColorLayers a
  = FgOnly a
  | BgOnly a
  | FgAndBg
      -- | foreground
      a
      -- | background
      a
  deriving (Int -> ColorLayers a -> ShowS
[ColorLayers a] -> ShowS
ColorLayers a -> String
(Int -> ColorLayers a -> ShowS)
-> (ColorLayers a -> String)
-> ([ColorLayers a] -> ShowS)
-> Show (ColorLayers a)
forall a. Show a => Int -> ColorLayers a -> ShowS
forall a. Show a => [ColorLayers a] -> ShowS
forall a. Show a => ColorLayers a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ColorLayers a -> ShowS
showsPrec :: Int -> ColorLayers a -> ShowS
$cshow :: forall a. Show a => ColorLayers a -> String
show :: ColorLayers a -> String
$cshowList :: forall a. Show a => [ColorLayers a] -> ShowS
showList :: [ColorLayers a] -> ShowS
Show, (forall a b. (a -> b) -> ColorLayers a -> ColorLayers b)
-> (forall a b. a -> ColorLayers b -> ColorLayers a)
-> Functor ColorLayers
forall a b. a -> ColorLayers b -> ColorLayers a
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
fmap :: forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
$c<$ :: forall a b. a -> ColorLayers b -> ColorLayers a
<$ :: forall a b. a -> ColorLayers b -> ColorLayers a
Functor)

type PreservableColor = ColorLayers TrueColor

instance ToPixel PreservableColor where
  toPixel :: PreservableColor -> PixelRGBA8
toPixel PreservableColor
h = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
255
   where
    RGB Word8
r Word8
g Word8
b = ColorLayers RGBColor -> RGBColor
forall a. ColorLayers a -> a
flattenBg (ColorLayers RGBColor -> RGBColor)
-> ColorLayers RGBColor -> RGBColor
forall a b. (a -> b) -> a -> b
$ PreservableColor -> ColorLayers RGBColor
fromHiFi PreservableColor
h

getBackground :: ColorLayers a -> Maybe a
getBackground :: forall a. ColorLayers a -> Maybe a
getBackground = \case
  FgOnly a
_ -> Maybe a
forall a. Maybe a
Nothing
  BgOnly a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
  FgAndBg a
_ a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x

flattenBg :: ColorLayers a -> a
flattenBg :: forall a. ColorLayers a -> a
flattenBg = \case
  FgOnly a
x -> a
x
  BgOnly a
x -> a
x
  FgAndBg a
_ a
x -> a
x

newtype WorldAttr = WorldAttr String
  deriving (WorldAttr -> WorldAttr -> Bool
(WorldAttr -> WorldAttr -> Bool)
-> (WorldAttr -> WorldAttr -> Bool) -> Eq WorldAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorldAttr -> WorldAttr -> Bool
== :: WorldAttr -> WorldAttr -> Bool
$c/= :: WorldAttr -> WorldAttr -> Bool
/= :: WorldAttr -> WorldAttr -> Bool
Eq, Eq WorldAttr
Eq WorldAttr =>
(WorldAttr -> WorldAttr -> Ordering)
-> (WorldAttr -> WorldAttr -> Bool)
-> (WorldAttr -> WorldAttr -> Bool)
-> (WorldAttr -> WorldAttr -> Bool)
-> (WorldAttr -> WorldAttr -> Bool)
-> (WorldAttr -> WorldAttr -> WorldAttr)
-> (WorldAttr -> WorldAttr -> WorldAttr)
-> Ord WorldAttr
WorldAttr -> WorldAttr -> Bool
WorldAttr -> WorldAttr -> Ordering
WorldAttr -> WorldAttr -> WorldAttr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WorldAttr -> WorldAttr -> Ordering
compare :: WorldAttr -> WorldAttr -> Ordering
$c< :: WorldAttr -> WorldAttr -> Bool
< :: WorldAttr -> WorldAttr -> Bool
$c<= :: WorldAttr -> WorldAttr -> Bool
<= :: WorldAttr -> WorldAttr -> Bool
$c> :: WorldAttr -> WorldAttr -> Bool
> :: WorldAttr -> WorldAttr -> Bool
$c>= :: WorldAttr -> WorldAttr -> Bool
>= :: WorldAttr -> WorldAttr -> Bool
$cmax :: WorldAttr -> WorldAttr -> WorldAttr
max :: WorldAttr -> WorldAttr -> WorldAttr
$cmin :: WorldAttr -> WorldAttr -> WorldAttr
min :: WorldAttr -> WorldAttr -> WorldAttr
Ord, Int -> WorldAttr -> ShowS
[WorldAttr] -> ShowS
WorldAttr -> String
(Int -> WorldAttr -> ShowS)
-> (WorldAttr -> String)
-> ([WorldAttr] -> ShowS)
-> Show WorldAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorldAttr -> ShowS
showsPrec :: Int -> WorldAttr -> ShowS
$cshow :: WorldAttr -> String
show :: WorldAttr -> String
$cshowList :: [WorldAttr] -> ShowS
showList :: [WorldAttr] -> ShowS
Show)