{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module      : Graphics.Color.Space.RGB.Derived.SRGB
-- Copyright   : (c) Alexey Kuleshevich 2019-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.RGB.Derived.SRGB
  ( SRGB
  ) where

import Data.Coerce
import Data.Typeable
import Foreign.Storable
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space.Internal
import Graphics.Color.Space.RGB.Internal
import Graphics.Color.Space.RGB.Luma
import qualified Graphics.Color.Space.RGB.SRGB as SRGB
import Graphics.Color.Space.RGB.ITU.Rec601 (applyGrayscaleRec601)

-- | The most common @sRGB@ color space with an arbitrary illuminant
data SRGB (i :: k) (l :: Linearity)

-- | `SRGB` color space (derived)
newtype instance Color (SRGB i l) e = SRGB (Color CM.RGB e)

-- | `SRGB` color space (derived)
deriving instance Eq e => Eq (Color (SRGB i l) e)
-- | `SRGB` color space (derived)
deriving instance Ord e => Ord (Color (SRGB i l) e)
-- | `SRGB` color space (derived)
deriving instance Functor (Color (SRGB i l))
-- | `SRGB` color space (derived)
deriving instance Applicative (Color (SRGB i l))
-- | `SRGB` color space (derived)
deriving instance Foldable (Color (SRGB i l))
-- | `SRGB` color space (derived)
deriving instance Traversable (Color (SRGB i l))
-- | `SRGB` color space (derived)
deriving instance Storable e => Storable (Color (SRGB i l) e)

-- | `SRGB` color space (derived)
instance (Typeable l, Illuminant i, Elevator e) => Show (Color (SRGB (i :: k) l) e) where
  showsPrec :: Int -> Color (SRGB i l) e -> ShowS
showsPrec Int
_ = Color (SRGB i l) e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModel

-- | `SRGB` color space (derived)
instance (Typeable l, Illuminant i, Elevator e) => ColorModel (SRGB (i :: k) l) e where
  type Components (SRGB i l) e = (e, e, e)
  type ChannelCount (SRGB i l) = 3
  channelCount :: Proxy (Color (SRGB i l) e) -> Word8
channelCount Proxy (Color (SRGB i l) e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (SRGB i l) e) -> NonEmpty String
channelNames Proxy (Color (SRGB i l) e)
_ = Proxy (Color RGB e) -> NonEmpty String
forall cs e.
ColorModel cs e =>
Proxy (Color cs e) -> NonEmpty String
channelNames (Proxy (Color RGB e)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Color CM.RGB e))
  channelColors :: Proxy (Color (SRGB i l) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (SRGB i l) e)
_ = Proxy (Color RGB e) -> NonEmpty (V3 Word8)
forall cs e.
ColorModel cs e =>
Proxy (Color cs e) -> NonEmpty (V3 Word8)
channelColors (Proxy (Color RGB e)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Color CM.RGB e))
  toComponents :: Color (SRGB i l) e -> Components (SRGB i l) e
toComponents = Color RGB e -> (e, e, e)
Color RGB e -> Components RGB e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color RGB e -> (e, e, e))
-> (Color (SRGB i l) e -> Color RGB e)
-> Color (SRGB i l) e
-> (e, e, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (SRGB i l) e -> Color RGB e
forall k (cs :: Linearity -> *) (i :: k) (l :: Linearity) e.
RedGreenBlue cs i =>
Color (cs l) e -> Color RGB e
forall (l :: Linearity) e. Color (SRGB i l) e -> Color RGB e
unColorRGB
  {-# INLINE toComponents #-}
  fromComponents :: Components (SRGB i l) e -> Color (SRGB i l) e
fromComponents = Color RGB e -> Color (SRGB i l) e
forall e (l :: Linearity). Color RGB e -> Color (SRGB i l) e
forall k (cs :: Linearity -> *) (i :: k) e (l :: Linearity).
RedGreenBlue cs i =>
Color RGB e -> Color (cs l) e
mkColorRGB (Color RGB e -> Color (SRGB i l) e)
-> ((e, e, e) -> Color RGB e) -> (e, e, e) -> Color (SRGB i l) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e, e, e) -> Color RGB e
Components RGB e -> Color RGB e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents
  {-# INLINE fromComponents #-}

-- | `SRGB` linear color space (derived)
instance (Illuminant i, Elevator e) => ColorSpace (SRGB i 'Linear) i e where
  type BaseModel (SRGB i 'Linear) = CM.RGB
  toBaseSpace :: ColorSpace (BaseSpace (SRGB i 'Linear)) i e =>
Color (SRGB i 'Linear) e -> Color (BaseSpace (SRGB i 'Linear)) e
toBaseSpace = Color (SRGB i 'Linear) e -> Color (BaseSpace (SRGB i 'Linear)) e
Color (SRGB i 'Linear) e -> Color (SRGB i 'Linear) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (SRGB i 'Linear)) i e =>
Color (BaseSpace (SRGB i 'Linear)) e -> Color (SRGB i 'Linear) e
fromBaseSpace = Color (BaseSpace (SRGB i 'Linear)) e -> Color (SRGB i 'Linear) e
Color (SRGB i 'Linear) e -> Color (SRGB i 'Linear) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (SRGB i 'Linear) e -> Color (Y i) a
luminance = Color (SRGB i 'Linear) a -> Color (Y i) a
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (cs 'Linear) e -> Color (Y i) e
rgbLinearLuminance (Color (SRGB i 'Linear) a -> Color (Y i) a)
-> (Color (SRGB i 'Linear) e -> Color (SRGB i 'Linear) a)
-> Color (SRGB i 'Linear) e
-> Color (Y i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (SRGB i 'Linear) e -> Color (SRGB i 'Linear) a
forall a b.
(a -> b) -> Color (SRGB i 'Linear) a -> Color (SRGB i 'Linear) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat
  {-# INLINE luminance #-}
  grayscale :: Color (SRGB i 'Linear) e -> Color X e
grayscale = Color (SRGB i 'Linear) e -> Color X e
forall {k} (cs :: Linearity -> *) (i :: k) e.
ColorSpace (cs 'Linear) i e =>
Color (cs 'Linear) e -> Color X e
rgbLinearGrayscale
  {-# INLINE grayscale #-}
  applyGrayscale :: Color (SRGB i 'Linear) e
-> (Color X e -> Color X e) -> Color (SRGB i 'Linear) e
applyGrayscale = Color (SRGB i 'Linear) e
-> (Color X e -> Color X e) -> Color (SRGB i 'Linear) e
forall {k} (cs :: Linearity -> *) (i :: k) e.
ColorSpace (cs 'Linear) i e =>
Color (cs 'Linear) e
-> (Color X e -> Color X e) -> Color (cs 'Linear) e
rgbLinearApplyGrayscale
  {-# INLINE applyGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (SRGB i 'Linear) e -> Color (XYZ i) a
toColorXYZ = Color (SRGB i 'Linear) a -> Color (XYZ i) a
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e,
 ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (cs 'Linear) e -> Color (XYZ i) e
rgbLinear2xyz (Color (SRGB i 'Linear) a -> Color (XYZ i) a)
-> (Color (SRGB i 'Linear) e -> Color (SRGB i 'Linear) a)
-> Color (SRGB i 'Linear) e
-> Color (XYZ i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (SRGB i 'Linear) e -> Color (SRGB i 'Linear) a
forall a b.
(a -> b) -> Color (SRGB i 'Linear) a -> Color (SRGB i 'Linear) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (SRGB i 'Linear) e
fromColorXYZ = (a -> e) -> Color (SRGB i 'Linear) a -> Color (SRGB i 'Linear) e
forall a b.
(a -> b) -> Color (SRGB i 'Linear) a -> Color (SRGB i 'Linear) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat (Color (SRGB i 'Linear) a -> Color (SRGB i 'Linear) e)
-> (Color (XYZ i) a -> Color (SRGB i 'Linear) a)
-> Color (XYZ i) a
-> Color (SRGB i 'Linear) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (XYZ i) a -> Color (SRGB i 'Linear) a
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e,
 ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (XYZ i) e -> Color (cs 'Linear) e
xyz2rgbLinear
  {-# INLINE fromColorXYZ #-}


-- | `SRGB` color space (derived)
instance (Illuminant i, Elevator e) => ColorSpace (SRGB i 'NonLinear) i e where
  type BaseModel (SRGB i 'NonLinear) = CM.RGB
  toBaseSpace :: ColorSpace (BaseSpace (SRGB i 'NonLinear)) i e =>
Color (SRGB i 'NonLinear) e
-> Color (BaseSpace (SRGB i 'NonLinear)) e
toBaseSpace = Color (SRGB i 'NonLinear) e
-> Color (BaseSpace (SRGB i 'NonLinear)) e
Color (SRGB i 'NonLinear) e -> Color (SRGB i 'NonLinear) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (SRGB i 'NonLinear)) i e =>
Color (BaseSpace (SRGB i 'NonLinear)) e
-> Color (SRGB i 'NonLinear) e
fromBaseSpace = Color (BaseSpace (SRGB i 'NonLinear)) e
-> Color (SRGB i 'NonLinear) e
Color (SRGB i 'NonLinear) e -> Color (SRGB i 'NonLinear) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (SRGB i 'NonLinear) e -> Color (Y i) a
luminance = Color (SRGB i 'NonLinear) a -> Color (Y i) a
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (cs 'NonLinear) e -> Color (Y i) e
rgbLuminance (Color (SRGB i 'NonLinear) a -> Color (Y i) a)
-> (Color (SRGB i 'NonLinear) e -> Color (SRGB i 'NonLinear) a)
-> Color (SRGB i 'NonLinear) e
-> Color (Y i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a)
-> Color (SRGB i 'NonLinear) e -> Color (SRGB i 'NonLinear) a
forall a b.
(a -> b)
-> Color (SRGB i 'NonLinear) a -> Color (SRGB i 'NonLinear) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat
  {-# INLINE luminance #-}
  grayscale :: Color (SRGB i 'NonLinear) e -> Color X e
grayscale = (Double -> e) -> Color X Double -> Color X e
forall a b. (a -> b) -> Color X a -> Color X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> e
forall e. Elevator e => Double -> e
fromDouble (Color X Double -> Color X e)
-> (Color (SRGB i 'NonLinear) e -> Color X Double)
-> Color (SRGB i 'NonLinear) e
-> Color X e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (Y' (SRGB i)) Double -> Color X Double
forall a b. Coercible a b => a -> b
coerce (Color (Y' (SRGB i)) Double -> Color X Double)
-> (Color (SRGB i 'NonLinear) e -> Color (Y' (SRGB i)) Double)
-> Color (SRGB i 'NonLinear) e
-> Color X Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (cs :: Linearity -> *) (i :: k) e' e.
(Luma cs, RedGreenBlue cs i, Elevator e', Elevator e,
 RealFloat e) =>
Color (cs 'NonLinear) e' -> Color (Y' cs) e
forall (cs :: Linearity -> *) (i :: k) e' e.
(Luma cs, RedGreenBlue cs i, Elevator e', Elevator e,
 RealFloat e) =>
Color (cs 'NonLinear) e' -> Color (Y' cs) e
rgbLuma @_ @_ @_ @Double
  {-# INLINE grayscale #-}
  applyGrayscale :: Color (SRGB i 'NonLinear) e
-> (Color X e -> Color X e) -> Color (SRGB i 'NonLinear) e
applyGrayscale = Color (SRGB i 'NonLinear) e
-> (Color X e -> Color X e) -> Color (SRGB i 'NonLinear) e
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e) =>
Color (cs 'NonLinear) e
-> (Color X e -> Color X e) -> Color (cs 'NonLinear) e
applyGrayscaleRec601
  {-# INLINE applyGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (SRGB i 'NonLinear) e -> Color (XYZ i) a
toColorXYZ = Color (SRGB i 'NonLinear) a -> Color (XYZ i) a
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e,
 ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (cs 'NonLinear) e -> Color (XYZ i) e
rgb2xyz (Color (SRGB i 'NonLinear) a -> Color (XYZ i) a)
-> (Color (SRGB i 'NonLinear) e -> Color (SRGB i 'NonLinear) a)
-> Color (SRGB i 'NonLinear) e
-> Color (XYZ i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a)
-> Color (SRGB i 'NonLinear) e -> Color (SRGB i 'NonLinear) a
forall a b.
(a -> b)
-> Color (SRGB i 'NonLinear) a -> Color (SRGB i 'NonLinear) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (SRGB i 'NonLinear) e
fromColorXYZ = (a -> e)
-> Color (SRGB i 'NonLinear) a -> Color (SRGB i 'NonLinear) e
forall a b.
(a -> b)
-> Color (SRGB i 'NonLinear) a -> Color (SRGB i 'NonLinear) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat (Color (SRGB i 'NonLinear) a -> Color (SRGB i 'NonLinear) e)
-> (Color (XYZ i) a -> Color (SRGB i 'NonLinear) a)
-> Color (XYZ i) a
-> Color (SRGB i 'NonLinear) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (XYZ i) a -> Color (SRGB i 'NonLinear) a
forall {k} (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e,
 ColorSpace (cs 'Linear) i e, RealFloat e) =>
Color (XYZ i) e -> Color (cs 'NonLinear) e
xyz2rgb
  {-# INLINE fromColorXYZ #-}

-- | `SRGB` color space (derived)
instance Illuminant i => RedGreenBlue (SRGB i) i where
  gamut :: forall e. RealFloat e => Gamut (SRGB i) i e
gamut = Gamut SRGB D65 e -> Gamut (SRGB i) i e
forall {k1} {k2} (cs' :: Linearity -> *) (i' :: k1) e
       (cs :: Linearity -> *) (i :: k2).
Gamut cs' i' e -> Gamut cs i e
coerceGamut (forall k (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, RealFloat e) =>
Gamut cs i e
gamut @_ @SRGB.SRGB)
  transfer :: forall e. RealFloat e => e -> e
transfer = forall k (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, RealFloat e) =>
e -> e
transfer @_ @SRGB.SRGB
  {-# INLINE transfer #-}
  itransfer :: forall e. RealFloat e => e -> e
itransfer = forall k (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, RealFloat e) =>
e -> e
itransfer @_ @SRGB.SRGB
  {-# INLINE itransfer #-}


instance Luma (SRGB i) where
  rWeight :: forall e. RealFloat e => Weight (SRGB i) e
rWeight = Weight (SRGB i) e
0.299
  gWeight :: forall e. RealFloat e => Weight (SRGB i) e
gWeight = Weight (SRGB i) e
0.587
  bWeight :: forall e. RealFloat e => Weight (SRGB i) e
bWeight = Weight (SRGB i) e
0.114