{-# LANGUAGE ViewPatterns #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Types for styling custom entity attributes
module Swarm.Game.Scenario.Style where

import Codec.Picture (PixelRGBA8 (..))
import Data.Aeson
import Data.Colour.Palette.Types (Kolor)
import Data.Colour.SRGB (RGB (..), sRGB24reads, sRGB24show, toSRGB24)
import Data.Colour.SRGB.Linear (toRGB)
import Data.Set (Set)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Swarm.Game.Entity.Cosmetic
import Swarm.Game.Scenario.Topography.Rasterize

data StyleFlag
  = Standout
  | Italic
  | Strikethrough
  | Underline
  | ReverseVideo
  | Blink
  | Dim
  | Bold
  deriving (StyleFlag -> StyleFlag -> Bool
(StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool) -> Eq StyleFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StyleFlag -> StyleFlag -> Bool
== :: StyleFlag -> StyleFlag -> Bool
$c/= :: StyleFlag -> StyleFlag -> Bool
/= :: StyleFlag -> StyleFlag -> Bool
Eq, Eq StyleFlag
Eq StyleFlag =>
(StyleFlag -> StyleFlag -> Ordering)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> Bool)
-> (StyleFlag -> StyleFlag -> StyleFlag)
-> (StyleFlag -> StyleFlag -> StyleFlag)
-> Ord StyleFlag
StyleFlag -> StyleFlag -> Bool
StyleFlag -> StyleFlag -> Ordering
StyleFlag -> StyleFlag -> StyleFlag
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 :: StyleFlag -> StyleFlag -> Ordering
compare :: StyleFlag -> StyleFlag -> Ordering
$c< :: StyleFlag -> StyleFlag -> Bool
< :: StyleFlag -> StyleFlag -> Bool
$c<= :: StyleFlag -> StyleFlag -> Bool
<= :: StyleFlag -> StyleFlag -> Bool
$c> :: StyleFlag -> StyleFlag -> Bool
> :: StyleFlag -> StyleFlag -> Bool
$c>= :: StyleFlag -> StyleFlag -> Bool
>= :: StyleFlag -> StyleFlag -> Bool
$cmax :: StyleFlag -> StyleFlag -> StyleFlag
max :: StyleFlag -> StyleFlag -> StyleFlag
$cmin :: StyleFlag -> StyleFlag -> StyleFlag
min :: StyleFlag -> StyleFlag -> StyleFlag
Ord, Int -> StyleFlag -> ShowS
[StyleFlag] -> ShowS
StyleFlag -> String
(Int -> StyleFlag -> ShowS)
-> (StyleFlag -> String)
-> ([StyleFlag] -> ShowS)
-> Show StyleFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StyleFlag -> ShowS
showsPrec :: Int -> StyleFlag -> ShowS
$cshow :: StyleFlag -> String
show :: StyleFlag -> String
$cshowList :: [StyleFlag] -> ShowS
showList :: [StyleFlag] -> ShowS
Show, (forall x. StyleFlag -> Rep StyleFlag x)
-> (forall x. Rep StyleFlag x -> StyleFlag) -> Generic StyleFlag
forall x. Rep StyleFlag x -> StyleFlag
forall x. StyleFlag -> Rep StyleFlag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StyleFlag -> Rep StyleFlag x
from :: forall x. StyleFlag -> Rep StyleFlag x
$cto :: forall x. Rep StyleFlag x -> StyleFlag
to :: forall x. Rep StyleFlag x -> StyleFlag
Generic)

styleFlagJsonOptions :: Options
styleFlagJsonOptions :: Options
styleFlagJsonOptions =
  Options
defaultOptions
    { sumEncoding = UntaggedValue
    }

instance FromJSON StyleFlag where
  parseJSON :: Value -> Parser StyleFlag
parseJSON = Options -> Value -> Parser StyleFlag
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
styleFlagJsonOptions

instance ToJSON StyleFlag where
  toJSON :: StyleFlag -> Value
toJSON = Options -> StyleFlag -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
styleFlagJsonOptions

-- | A color, parsed from hexadecimal notation.  May include a leading
--   hash symbol (see 'Data.Colour.SRGB.sRGB24read').
newtype HexColor = HexColor {HexColor -> Kolor
getHexColor :: Kolor}
  deriving (HexColor -> HexColor -> Bool
(HexColor -> HexColor -> Bool)
-> (HexColor -> HexColor -> Bool) -> Eq HexColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HexColor -> HexColor -> Bool
== :: HexColor -> HexColor -> Bool
$c/= :: HexColor -> HexColor -> Bool
/= :: HexColor -> HexColor -> Bool
Eq, Int -> HexColor -> ShowS
[HexColor] -> ShowS
HexColor -> String
(Int -> HexColor -> ShowS)
-> (HexColor -> String) -> ([HexColor] -> ShowS) -> Show HexColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HexColor -> ShowS
showsPrec :: Int -> HexColor -> ShowS
$cshow :: HexColor -> String
show :: HexColor -> String
$cshowList :: [HexColor] -> ShowS
showList :: [HexColor] -> ShowS
Show, (forall x. HexColor -> Rep HexColor x)
-> (forall x. Rep HexColor x -> HexColor) -> Generic HexColor
forall x. Rep HexColor x -> HexColor
forall x. HexColor -> Rep HexColor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HexColor -> Rep HexColor x
from :: forall x. HexColor -> Rep HexColor x
$cto :: forall x. Rep HexColor x -> HexColor
to :: forall x. Rep HexColor x -> HexColor
Generic)

instance Ord HexColor where
  -- There is no Ord instance for Colour a, but we need one to use
  -- with OccurrenceEncoder, so we make our own.
  --
  -- We use toRGB here since it does no conversions whatsoever, it
  -- simply unpacks the raw color data into an RGB triple.  For the
  -- purposes of an Ord instance, it doesn't matter: we just want a
  -- consistent way to put a total ordering on colors as fast as
  -- possible.
  compare :: HexColor -> HexColor -> Ordering
compare (HexColor (Kolor -> RGB Double
forall a. Fractional a => Colour a -> RGB a
toRGB -> RGB Double
r1 Double
g1 Double
b1)) (HexColor (Kolor -> RGB Double
forall a. Fractional a => Colour a -> RGB a
toRGB -> RGB Double
r2 Double
g2 Double
b2)) =
    (Double, Double, Double) -> (Double, Double, Double) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double
r1, Double
g1, Double
b1) (Double
r2, Double
g2, Double
b2)

instance FromJSON HexColor where
  parseJSON :: Value -> Parser HexColor
parseJSON = String -> (Text -> Parser HexColor) -> Value -> Parser HexColor
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"hex color" ((Text -> Parser HexColor) -> Value -> Parser HexColor)
-> (Text -> Parser HexColor) -> Value -> Parser HexColor
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case ReadS Kolor
forall b. (Ord b, Floating b) => ReadS (Colour b)
sRGB24reads (Text -> String
T.unpack Text
t) of
      ((Kolor
c, String
_) : [(Kolor, String)]
_) -> HexColor -> Parser HexColor
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HexColor -> Parser HexColor) -> HexColor -> Parser HexColor
forall a b. (a -> b) -> a -> b
$ Kolor -> HexColor
HexColor Kolor
c
      [(Kolor, String)]
_ -> String -> Parser HexColor
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser HexColor) -> String -> Parser HexColor
forall a b. (a -> b) -> a -> b
$ String
"Could not parse hex color '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"

instance ToJSON HexColor where
  toJSON :: HexColor -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (HexColor -> Text) -> HexColor -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (HexColor -> String) -> HexColor -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kolor -> String
forall b. (RealFrac b, Floating b) => Colour b -> String
sRGB24show (Kolor -> String) -> (HexColor -> Kolor) -> HexColor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexColor -> Kolor
getHexColor

instance ToPixel HexColor where
  toPixel :: HexColor -> PixelRGBA8
toPixel (HexColor Kolor
kolor) = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
255
   where
    RGB Pixel8
r Pixel8
g Pixel8
b = Kolor -> RGB Pixel8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Pixel8
toSRGB24 Kolor
kolor

data CustomAttr = CustomAttr
  { CustomAttr -> String
name :: String
  , CustomAttr -> Maybe HexColor
fg :: Maybe HexColor
  , CustomAttr -> Maybe HexColor
bg :: Maybe HexColor
  , CustomAttr -> Maybe (Set StyleFlag)
style :: Maybe (Set StyleFlag)
  }
  deriving (CustomAttr -> CustomAttr -> Bool
(CustomAttr -> CustomAttr -> Bool)
-> (CustomAttr -> CustomAttr -> Bool) -> Eq CustomAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CustomAttr -> CustomAttr -> Bool
== :: CustomAttr -> CustomAttr -> Bool
$c/= :: CustomAttr -> CustomAttr -> Bool
/= :: CustomAttr -> CustomAttr -> Bool
Eq, Int -> CustomAttr -> ShowS
[CustomAttr] -> ShowS
CustomAttr -> String
(Int -> CustomAttr -> ShowS)
-> (CustomAttr -> String)
-> ([CustomAttr] -> ShowS)
-> Show CustomAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CustomAttr -> ShowS
showsPrec :: Int -> CustomAttr -> ShowS
$cshow :: CustomAttr -> String
show :: CustomAttr -> String
$cshowList :: [CustomAttr] -> ShowS
showList :: [CustomAttr] -> ShowS
Show, (forall x. CustomAttr -> Rep CustomAttr x)
-> (forall x. Rep CustomAttr x -> CustomAttr) -> Generic CustomAttr
forall x. Rep CustomAttr x -> CustomAttr
forall x. CustomAttr -> Rep CustomAttr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CustomAttr -> Rep CustomAttr x
from :: forall x. CustomAttr -> Rep CustomAttr x
$cto :: forall x. Rep CustomAttr x -> CustomAttr
to :: forall x. Rep CustomAttr x -> CustomAttr
Generic, Maybe CustomAttr
Value -> Parser [CustomAttr]
Value -> Parser CustomAttr
(Value -> Parser CustomAttr)
-> (Value -> Parser [CustomAttr])
-> Maybe CustomAttr
-> FromJSON CustomAttr
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser CustomAttr
parseJSON :: Value -> Parser CustomAttr
$cparseJSONList :: Value -> Parser [CustomAttr]
parseJSONList :: Value -> Parser [CustomAttr]
$comittedField :: Maybe CustomAttr
omittedField :: Maybe CustomAttr
FromJSON)

instance ToJSON CustomAttr where
  toJSON :: CustomAttr -> Value
toJSON =
    Options -> CustomAttr -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON
      Options
defaultOptions
        { omitNothingFields = True
        }

-- | Must specify either a foreground or background color;
-- just a style is not sufficient.
toHifiPair :: CustomAttr -> Maybe (WorldAttr, PreservableColor)
toHifiPair :: CustomAttr -> Maybe (WorldAttr, PreservableColor)
toHifiPair (CustomAttr String
n Maybe HexColor
maybeFg Maybe HexColor
maybeBg Maybe (Set StyleFlag)
_) =
  (WorldAttr, Maybe PreservableColor)
-> Maybe (WorldAttr, PreservableColor)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(WorldAttr, f a) -> f (WorldAttr, a)
sequenceA (String -> WorldAttr
WorldAttr String
n, (HexColor -> TrueColor) -> ColorLayers HexColor -> PreservableColor
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HexColor -> TrueColor
conv (ColorLayers HexColor -> PreservableColor)
-> Maybe (ColorLayers HexColor) -> Maybe PreservableColor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ColorLayers HexColor)
c)
 where
  c :: Maybe (ColorLayers HexColor)
c = case (Maybe HexColor
maybeFg, Maybe HexColor
maybeBg) of
    (Just HexColor
f, Just HexColor
b) -> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a. a -> Maybe a
Just (ColorLayers HexColor -> Maybe (ColorLayers HexColor))
-> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a b. (a -> b) -> a -> b
$ HexColor -> HexColor -> ColorLayers HexColor
forall a. a -> a -> ColorLayers a
FgAndBg HexColor
f HexColor
b
    (Just HexColor
f, Maybe HexColor
Nothing) -> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a. a -> Maybe a
Just (ColorLayers HexColor -> Maybe (ColorLayers HexColor))
-> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a b. (a -> b) -> a -> b
$ HexColor -> ColorLayers HexColor
forall a. a -> ColorLayers a
FgOnly HexColor
f
    (Maybe HexColor
Nothing, Just HexColor
b) -> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a. a -> Maybe a
Just (ColorLayers HexColor -> Maybe (ColorLayers HexColor))
-> ColorLayers HexColor -> Maybe (ColorLayers HexColor)
forall a b. (a -> b) -> a -> b
$ HexColor -> ColorLayers HexColor
forall a. a -> ColorLayers a
BgOnly HexColor
b
    (Maybe HexColor
Nothing, Maybe HexColor
Nothing) -> Maybe (ColorLayers HexColor)
forall a. Maybe a
Nothing

  conv :: HexColor -> TrueColor
conv (HexColor Kolor
kolor) = RGB Pixel8 -> TrueColor
Triple (RGB Pixel8 -> TrueColor) -> RGB Pixel8 -> TrueColor
forall a b. (a -> b) -> a -> b
$ Kolor -> RGB Pixel8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Pixel8
toSRGB24 Kolor
kolor