{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module      : Graphics.Color.Space.Internal
-- Copyright   : (c) Alexey Kuleshevich 2018-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.Internal
  ( ColorModel(..)
  -- * Alpha
  , Alpha
  , Opaque
  , addAlpha
  , getAlpha
  , setAlpha
  , dropAlpha
  , modifyAlpha
  , modifyOpaque
  , Color(Alpha, Luminance, XYZ, CIExyY)
  , ColorSpace(..)
  , Chromaticity(..)
  , Primary(.., Primary)
  , xPrimary
  , yPrimary
  , zPrimary
  , primaryXZ
  , primaryTristimulus
  , Illuminant(..)
  , WhitePoint(.., WhitePoint)
  , xWhitePoint
  , yWhitePoint
  , zWhitePoint
  , whitePointXZ
  , whitePointTristimulus
  , CCT(..)
  , Y
  , unY
  , pattern Y
  , pattern YA
  , XYZ
  , pattern ColorXYZ
  , pattern ColorXYZA
  , CIExyY
  , pattern ColorCIExy
  , pattern ColorCIExyY
  , showsColorModel
  , module Graphics.Color.Algebra.Binary
  , module Graphics.Color.Algebra.Elevator
  , module Graphics.Color.Model.X
  ) where

import Data.Coerce
import Data.Kind
import Data.List.NonEmpty
import Data.Typeable
import Foreign.Storable
import GHC.TypeNats
import Graphics.Color.Algebra.Binary
import Graphics.Color.Algebra.Elevator
import Graphics.Color.Model.Internal
import Graphics.Color.Model.X

class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) =>
  ColorSpace cs (i :: k) e | cs -> i where
  {-# MINIMAL toBaseSpace, fromBaseSpace, luminance, grayscale, (replaceGrayscale|applyGrayscale) #-}

  type BaseModel cs :: Type

  type BaseSpace cs :: Type
  type BaseSpace cs = cs

  -- | Drop color space down to the base color model
  toBaseModel :: Color cs e -> Color (BaseModel cs) e
  default toBaseModel ::
    Coercible (Color cs e) (Color (BaseModel cs) e) => Color cs e -> Color (BaseModel cs) e
  toBaseModel = Color cs e -> Color (BaseModel cs) e
forall a b. Coercible a b => a -> b
coerce

  -- | Promote color model to a color space
  fromBaseModel :: Color (BaseModel cs) e -> Color cs e
  default fromBaseModel ::
    Coercible (Color (BaseModel cs) e) (Color cs e) => Color (BaseModel cs) e -> Color cs e
  fromBaseModel = Color (BaseModel cs) e -> Color cs e
forall a b. Coercible a b => a -> b
coerce

  toBaseSpace :: ColorSpace (BaseSpace cs) i e => Color cs e -> Color (BaseSpace cs) e
  fromBaseSpace :: ColorSpace (BaseSpace cs) i e => Color (BaseSpace cs) e -> Color cs e

  -- | Get the relative luminance of a color. This is different from `grayscale` in that
  -- it will produce achromatic color that is no longer dependent on the source color
  --
  -- @since 0.1.0
  luminance :: (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a

  -- | Drop chromatic information and get only the grayscale information from
  -- the color. Without knowledge of the source color the produced value is
  -- inconsequential, becaus each class of color spaces has its own notion of
  -- grayscale (luma, luminocity, in linear or non-linear form, etc.)
  --
  -- /Warning/ - This method is still experimental. Use at your own risk.
  --
  -- @since 0.4.0
  grayscale :: Color cs e -> Color X e

  -- | Replace the grayscale information, leaving the chromatic portion of the coloer
  -- intact.
  --
  -- Property that this function must obide:
  --
  -- > replaceGrayscale c y = applyGrayscale c (const y)
  --
  -- /Warning/ - This method is still experimental. Use at your own risk.
  --
  -- @since 0.4.0
  replaceGrayscale :: Color cs e -> Color X e -> Color cs e
  replaceGrayscale Color cs e
c Color X e
y = Color cs e -> (Color X e -> Color X e) -> Color cs e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> (Color X e -> Color X e) -> Color cs e
applyGrayscale Color cs e
c (Color X e -> Color X e -> Color X e
forall a b. a -> b -> a
const Color X e
y)
  {-# INLINE replaceGrayscale #-}

  -- | Apply a function to the grayscale portion of the color leaving chromaticity
  -- intact. The meaning of "grayscale" is very much specific to the color space it is being
  -- applied to.
  --
  -- Property that this function must obide:
  --
  -- > applyGrayscale c f = replaceGrayscale c (f (grayscale c))
  --
  -- @since 0.4.0
  applyGrayscale :: Color cs e -> (Color X e -> Color X e) -> Color cs e
  applyGrayscale Color cs e
c Color X e -> Color X e
f = Color cs e -> Color X e -> Color cs e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color X e -> Color cs e
replaceGrayscale Color cs e
c (Color X e -> Color X e
f (Color cs e -> Color X e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color X e
grayscale Color cs e
c))
  {-# INLINE applyGrayscale #-}


  toColorXYZ :: (Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a
  default toColorXYZ ::
    (ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a
  toColorXYZ = Color (BaseSpace cs) e -> Color (XYZ i) a
forall a.
(Elevator a, RealFloat a) =>
Color (BaseSpace cs) e -> Color (XYZ i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ (Color (BaseSpace cs) e -> Color (XYZ i) a)
-> (Color cs e -> Color (BaseSpace cs) e)
-> Color cs e
-> Color (XYZ i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color cs e -> Color (BaseSpace cs) e
forall k cs (i :: k) e.
(ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) =>
Color cs e -> Color (BaseSpace cs) e
toBaseSpace
  {-# INLINE toColorXYZ #-}

  fromColorXYZ :: (Elevator a, RealFloat a) => Color (XYZ i) a -> Color cs e
  default fromColorXYZ ::
    (ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color (XYZ i) a -> Color cs e
  fromColorXYZ = Color (BaseSpace cs) e -> Color cs e
forall k cs (i :: k) e.
(ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) =>
Color (BaseSpace cs) e -> Color cs e
fromBaseSpace (Color (BaseSpace cs) e -> Color cs e)
-> (Color (XYZ i) a -> Color (BaseSpace cs) e)
-> Color (XYZ i) a
-> Color cs e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (XYZ i) a -> Color (BaseSpace cs) e
forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (BaseSpace cs) e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ
  {-# INLINE fromColorXYZ #-}


instance ( ColorSpace cs i e
         , ColorSpace (BaseSpace cs) i e
         , cs ~ Opaque (Alpha cs)
         , BaseModel cs ~ Opaque (Alpha (BaseModel cs))
         ) =>
         ColorSpace (Alpha cs) i e where
  type BaseModel (Alpha cs) = Alpha (BaseModel cs)
  type BaseSpace (Alpha cs) = Alpha (BaseSpace cs)
  toBaseModel :: Color (Alpha cs) e -> Color (BaseModel (Alpha cs)) e
toBaseModel = (Color cs e -> Color (BaseModel cs) e)
-> Color (Alpha cs) e -> Color (Alpha (BaseModel cs)) e
forall cs e cs'.
(Color cs e -> Color cs' e)
-> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque Color cs e -> Color (BaseModel cs) e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color (BaseModel cs) e
toBaseModel
  {-# INLINE toBaseModel #-}
  fromBaseModel :: Color (BaseModel (Alpha cs)) e -> Color (Alpha cs) e
fromBaseModel = (Color (BaseModel cs) e -> Color cs e)
-> Color (Alpha (BaseModel cs)) e -> Color (Alpha cs) e
forall cs e cs'.
(Color cs e -> Color cs' e)
-> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque Color (BaseModel cs) e -> Color cs e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color (BaseModel cs) e -> Color cs e
fromBaseModel
  {-# INLINE fromBaseModel #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (Alpha cs) e -> Color (XYZ i) a
toColorXYZ = Color cs e -> Color (XYZ i) a
forall a.
(Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ (Color cs e -> Color (XYZ i) a)
-> (Color (Alpha cs) e -> Color cs e)
-> Color (Alpha cs) e
-> Color (XYZ i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (Alpha cs) e -> Color cs e
forall cs e. Color (Alpha cs) e -> Color cs e
dropAlpha
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (Alpha cs) e
fromColorXYZ = (Color cs e -> e -> Color (Alpha cs) e
forall cs e. Color cs e -> e -> Color (Alpha cs) e
`addAlpha` e
forall e. Elevator e => e
maxValue) (Color cs e -> Color (Alpha cs) e)
-> (Color (XYZ i) a -> Color cs e)
-> Color (XYZ i) a
-> Color (Alpha cs) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (XYZ i) a -> Color cs e
forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ
  {-# INLINE fromColorXYZ #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (Alpha cs) e -> Color (Y i) a
luminance = Color cs e -> Color (Y i) a
forall a. (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (Y i) a
luminance (Color cs e -> Color (Y i) a)
-> (Color (Alpha cs) e -> Color cs e)
-> Color (Alpha cs) e
-> Color (Y i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (Alpha cs) e -> Color cs e
forall cs e. Color (Alpha cs) e -> Color cs e
dropAlpha
  {-# INLINE luminance #-}
  grayscale :: Color (Alpha cs) e -> Color X e
grayscale = Color cs e -> Color X e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color X e
grayscale (Color cs e -> Color X e)
-> (Color (Alpha cs) e -> Color cs e)
-> Color (Alpha cs) e
-> Color X e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (Alpha cs) e -> Color cs e
forall cs e. Color (Alpha cs) e -> Color cs e
dropAlpha
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color (Alpha cs) e -> Color X e -> Color (Alpha cs) e
replaceGrayscale Color (Alpha cs) e
c Color X e
x = (Color cs e -> Color cs e)
-> Color (Alpha cs) e -> Color (Alpha cs) e
forall cs e cs'.
(Color cs e -> Color cs' e)
-> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque (Color cs e -> Color X e -> Color cs e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color X e -> Color cs e
`replaceGrayscale` Color X e
x) Color (Alpha cs) e
c
  {-# INLINE replaceGrayscale #-}
  toBaseSpace :: ColorSpace (BaseSpace (Alpha cs)) i e =>
Color (Alpha cs) e -> Color (BaseSpace (Alpha cs)) e
toBaseSpace = (Color cs e -> Color (BaseSpace cs) e)
-> Color (Alpha cs) e -> Color (Alpha (BaseSpace cs)) e
forall cs e cs'.
(Color cs e -> Color cs' e)
-> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque Color cs e -> Color (BaseSpace cs) e
forall k cs (i :: k) e.
(ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) =>
Color cs e -> Color (BaseSpace cs) e
toBaseSpace
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (Alpha cs)) i e =>
Color (BaseSpace (Alpha cs)) e -> Color (Alpha cs) e
fromBaseSpace = (Color (BaseSpace cs) e -> Color cs e)
-> Color (Alpha (BaseSpace cs)) e -> Color (Alpha cs) e
forall cs e cs'.
(Color cs e -> Color cs' e)
-> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque Color (BaseSpace cs) e -> Color cs e
forall k cs (i :: k) e.
(ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) =>
Color (BaseSpace cs) e -> Color cs e
fromBaseSpace
  {-# INLINE fromBaseSpace #-}

-- | This is a data type that encodes a data point on the chromaticity diagram
newtype Chromaticity i e =
  Chromaticity { forall {k} (i :: k) e. Chromaticity i e -> Color (CIExyY i) e
chromaticityCIExyY :: Color (CIExyY i) e }
  deriving (Chromaticity i e -> Chromaticity i e -> Bool
(Chromaticity i e -> Chromaticity i e -> Bool)
-> (Chromaticity i e -> Chromaticity i e -> Bool)
-> Eq (Chromaticity i e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (i :: k) e.
Eq e =>
Chromaticity i e -> Chromaticity i e -> Bool
$c== :: forall k (i :: k) e.
Eq e =>
Chromaticity i e -> Chromaticity i e -> Bool
== :: Chromaticity i e -> Chromaticity i e -> Bool
$c/= :: forall k (i :: k) e.
Eq e =>
Chromaticity i e -> Chromaticity i e -> Bool
/= :: Chromaticity i e -> Chromaticity i e -> Bool
Eq, Int -> Chromaticity i e -> ShowS
[Chromaticity i e] -> ShowS
Chromaticity i e -> String
(Int -> Chromaticity i e -> ShowS)
-> (Chromaticity i e -> String)
-> ([Chromaticity i e] -> ShowS)
-> Show (Chromaticity i e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Int -> Chromaticity i e -> ShowS
forall k (i :: k) e.
(Illuminant i, Elevator e) =>
[Chromaticity i e] -> ShowS
forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Chromaticity i e -> String
$cshowsPrec :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Int -> Chromaticity i e -> ShowS
showsPrec :: Int -> Chromaticity i e -> ShowS
$cshow :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Chromaticity i e -> String
show :: Chromaticity i e -> String
$cshowList :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
[Chromaticity i e] -> ShowS
showList :: [Chromaticity i e] -> ShowS
Show)


----------------
-- WhitePoint --
----------------

-- | Correlated color temperature (CCT) of a white point in Kelvin
newtype CCT (i :: k) = CCT
  { forall k (i :: k). CCT i -> Double
unCCT :: Double
  } deriving (CCT i -> CCT i -> Bool
(CCT i -> CCT i -> Bool) -> (CCT i -> CCT i -> Bool) -> Eq (CCT i)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (i :: k). CCT i -> CCT i -> Bool
$c== :: forall k (i :: k). CCT i -> CCT i -> Bool
== :: CCT i -> CCT i -> Bool
$c/= :: forall k (i :: k). CCT i -> CCT i -> Bool
/= :: CCT i -> CCT i -> Bool
Eq, Int -> CCT i -> ShowS
[CCT i] -> ShowS
CCT i -> String
(Int -> CCT i -> ShowS)
-> (CCT i -> String) -> ([CCT i] -> ShowS) -> Show (CCT i)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (i :: k). Int -> CCT i -> ShowS
forall k (i :: k). [CCT i] -> ShowS
forall k (i :: k). CCT i -> String
$cshowsPrec :: forall k (i :: k). Int -> CCT i -> ShowS
showsPrec :: Int -> CCT i -> ShowS
$cshow :: forall k (i :: k). CCT i -> String
show :: CCT i -> String
$cshowList :: forall k (i :: k). [CCT i] -> ShowS
showList :: [CCT i] -> ShowS
Show)

class (Typeable i, Typeable k, KnownNat (Temperature i)) => Illuminant (i :: k) where
  type Temperature i :: n
  whitePoint :: RealFloat e => WhitePoint i e

  colorTemperature :: CCT i
  colorTemperature = Double -> CCT i
forall k (i :: k). Double -> CCT i
CCT (Nat -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy (Temperature i) -> Nat
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal (Proxy (Temperature i)
forall {k}. Proxy (Temperature i)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Temperature i))))


newtype WhitePoint (i :: k) e =
  WhitePointChromaticity { forall k (i :: k) e. WhitePoint i e -> Chromaticity i e
whitePointChromaticity :: Chromaticity i e }
  deriving (WhitePoint i e -> WhitePoint i e -> Bool
(WhitePoint i e -> WhitePoint i e -> Bool)
-> (WhitePoint i e -> WhitePoint i e -> Bool)
-> Eq (WhitePoint i e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (i :: k) e.
Eq e =>
WhitePoint i e -> WhitePoint i e -> Bool
$c== :: forall k (i :: k) e.
Eq e =>
WhitePoint i e -> WhitePoint i e -> Bool
== :: WhitePoint i e -> WhitePoint i e -> Bool
$c/= :: forall k (i :: k) e.
Eq e =>
WhitePoint i e -> WhitePoint i e -> Bool
/= :: WhitePoint i e -> WhitePoint i e -> Bool
Eq)

instance (Illuminant i, Elevator e) => Show (WhitePoint (i :: k) e) where
  showsPrec :: Int -> WhitePoint i e -> ShowS
showsPrec Int
n (WhitePointChromaticity Chromaticity i e
wp)
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ShowS
inner
    | Bool
otherwise = (Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
inner ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')' Char -> ShowS
forall a. a -> [a] -> [a]
:)
    where
      inner :: ShowS
inner = (String
"WhitePoint (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chromaticity i e -> ShowS
forall a. Show a => a -> ShowS
shows Chromaticity i e
wp ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')' Char -> ShowS
forall a. a -> [a] -> [a]
:)

-- | Constructor for the most common @XYZ@ color space
pattern WhitePoint :: e -> e -> WhitePoint i e
pattern $mWhitePoint :: forall {r} {k} {e} {i :: k}.
WhitePoint i e -> (e -> e -> r) -> ((# #) -> r) -> r
$bWhitePoint :: forall {k} e (i :: k). e -> e -> WhitePoint i e
WhitePoint x y <- (coerce -> (V2 x y)) where
  WhitePoint e
x e
y = V2 e -> WhitePoint i e
forall a b. Coercible a b => a -> b
coerce (e -> e -> V2 e
forall a. a -> a -> V2 a
V2 e
x e
y)
{-# COMPLETE WhitePoint #-}

-- | @x@ value of a `WhitePoint`
--
-- @since 0.1.0
xWhitePoint :: WhitePoint i e -> e
xWhitePoint :: forall {k} (i :: k) e. WhitePoint i e -> e
xWhitePoint (WhitePoint i e -> V2 e
forall a b. Coercible a b => a -> b
coerce -> V2 e
x e
_) = e
x
{-# INLINE xWhitePoint #-}

-- | @y@ value of a `WhitePoint`
--
-- @since 0.1.0
yWhitePoint :: WhitePoint i e -> e
yWhitePoint :: forall {k} (i :: k) e. WhitePoint i e -> e
yWhitePoint (WhitePoint i e -> V2 e
forall a b. Coercible a b => a -> b
coerce -> V2 e
_ e
y) = e
y
{-# INLINE yWhitePoint #-}

-- | Compute @z@ value of a `WhitePoint`: @z = 1 - x - y@
--
-- @since 0.1.0
zWhitePoint :: Num e => WhitePoint i e -> e
zWhitePoint :: forall {k} e (i :: k). Num e => WhitePoint i e -> e
zWhitePoint WhitePoint i e
wp = e
1 e -> e -> e
forall a. Num a => a -> a -> a
- WhitePoint i e -> e
forall {k} (i :: k) e. WhitePoint i e -> e
xWhitePoint WhitePoint i e
wp e -> e -> e
forall a. Num a => a -> a -> a
- WhitePoint i e -> e
forall {k} (i :: k) e. WhitePoint i e -> e
yWhitePoint WhitePoint i e
wp
{-# INLINE zWhitePoint #-}

-- | Compute a normalized @XYZ@ tristimulus of a white point, where @Y = 1@
--
-- @since 0.1.0
whitePointTristimulus ::
     forall i e. (Illuminant i, RealFloat e, Elevator e)
  => Color (XYZ i) e
whitePointTristimulus :: forall {k} (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Color (XYZ i) e
whitePointTristimulus = Color (CIExyY i) e -> Color (XYZ i) e
forall a.
(Elevator a, RealFloat a) =>
Color (CIExyY i) e -> Color (XYZ i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ (WhitePoint i e -> Color (CIExyY i) e
forall a b. Coercible a b => a -> b
coerce (WhitePoint i e
forall e. RealFloat e => WhitePoint i e
forall k (i :: k) e. (Illuminant i, RealFloat e) => WhitePoint i e
whitePoint :: WhitePoint i e) :: Color (CIExyY i) e)
{-# INLINE whitePointTristimulus #-}


-- | Compute @XYZ@ tristimulus of a white point.
--
-- @since 0.1.0
whitePointXZ ::
     Fractional e
  => e
     -- ^ @Y@ value, which is usually set to @1@
  -> WhitePoint i e
     -- ^ White point that specifies @x@ and @y@
  -> Color (XYZ i) e
whitePointXZ :: forall {k} e (i :: k).
Fractional e =>
e -> WhitePoint i e -> Color (XYZ i) e
whitePointXZ e
vY (WhitePoint i e -> V2 e
forall a b. Coercible a b => a -> b
coerce -> V2 e
x e
y) = e -> e -> e -> Color (XYZ i) e
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ (e
vYy e -> e -> e
forall a. Num a => a -> a -> a
* e
x) e
vY (e
vYy e -> e -> e
forall a. Num a => a -> a -> a
* (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e
x e -> e -> e
forall a. Num a => a -> a -> a
- e
y))
  where !vYy :: e
vYy = e
vY e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
y
{-# INLINE whitePointXZ #-}

-------------
-- Primary --
-------------

newtype Primary (i :: k) e =
  PrimaryChromaticity
    { forall k (i :: k) e. Primary i e -> Chromaticity i e
primaryChromaticity :: Chromaticity i e
    }
  deriving (Primary i e -> Primary i e -> Bool
(Primary i e -> Primary i e -> Bool)
-> (Primary i e -> Primary i e -> Bool) -> Eq (Primary i e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (i :: k) e. Eq e => Primary i e -> Primary i e -> Bool
$c== :: forall k (i :: k) e. Eq e => Primary i e -> Primary i e -> Bool
== :: Primary i e -> Primary i e -> Bool
$c/= :: forall k (i :: k) e. Eq e => Primary i e -> Primary i e -> Bool
/= :: Primary i e -> Primary i e -> Bool
Eq, Int -> Primary i e -> ShowS
[Primary i e] -> ShowS
Primary i e -> String
(Int -> Primary i e -> ShowS)
-> (Primary i e -> String)
-> ([Primary i e] -> ShowS)
-> Show (Primary i e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Int -> Primary i e -> ShowS
forall k (i :: k) e.
(Illuminant i, Elevator e) =>
[Primary i e] -> ShowS
forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Primary i e -> String
$cshowsPrec :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Int -> Primary i e -> ShowS
showsPrec :: Int -> Primary i e -> ShowS
$cshow :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Primary i e -> String
show :: Primary i e -> String
$cshowList :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
[Primary i e] -> ShowS
showList :: [Primary i e] -> ShowS
Show)


-- | Constructor for the most common @XYZ@ color space
pattern Primary :: e -> e -> Primary i e
pattern $mPrimary :: forall {r} {k} {e} {i :: k}.
Primary i e -> (e -> e -> r) -> ((# #) -> r) -> r
$bPrimary :: forall {k} e (i :: k). e -> e -> Primary i e
Primary x y <- (coerce -> V2 x y) where
  Primary e
x e
y = V2 e -> Primary i e
forall a b. Coercible a b => a -> b
coerce (e -> e -> V2 e
forall a. a -> a -> V2 a
V2 e
x e
y)
{-# COMPLETE Primary #-}



xPrimary :: Primary i e -> e
xPrimary :: forall {k} (i :: k) e. Primary i e -> e
xPrimary (Primary i e -> V2 e
forall a b. Coercible a b => a -> b
coerce -> V2 e
x e
_) = e
x
{-# INLINE xPrimary #-}

yPrimary :: Primary i e -> e
yPrimary :: forall {k} (i :: k) e. Primary i e -> e
yPrimary (Primary i e -> V2 e
forall a b. Coercible a b => a -> b
coerce -> V2 e
_ e
y) = e
y
{-# INLINE yPrimary #-}

-- | Compute @z = 1 - x - y@ of a `Primary`.
zPrimary :: Num e => Primary i e -> e
zPrimary :: forall {k} e (i :: k). Num e => Primary i e -> e
zPrimary Primary i e
p = e
1 e -> e -> e
forall a. Num a => a -> a -> a
- Primary i e -> e
forall {k} (i :: k) e. Primary i e -> e
xPrimary Primary i e
p e -> e -> e
forall a. Num a => a -> a -> a
- Primary i e -> e
forall {k} (i :: k) e. Primary i e -> e
yPrimary Primary i e
p
{-# INLINE zPrimary #-}




-- | Compute normalized `XYZ` tristimulus of a `Primary`, where @Y = 1@
--
-- @since 0.1.0
primaryTristimulus ::
     forall i e. (Illuminant i, RealFloat e, Elevator e)
  => Primary i e
     -- ^ Primary that specifies @x@ and @y@
  -> Color (XYZ i) e
primaryTristimulus :: forall {k} (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Primary i e -> Color (XYZ i) e
primaryTristimulus Primary i e
xy = Color (CIExyY i) e -> Color (XYZ i) e
forall a.
(Elevator a, RealFloat a) =>
Color (CIExyY i) e -> Color (XYZ i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ (Primary i e -> Color (CIExyY i) e
forall a b. Coercible a b => a -> b
coerce Primary i e
xy :: Color (CIExyY i) e)
{-# INLINE primaryTristimulus #-}

-- | Compute `XYZ` tristimulus of a `Primary`.
--
-- @since 0.1.0
primaryXZ ::
     Fractional e =>
     e
     -- ^ @Y@ value, which is usually set to @1@
  -> Primary i e
     -- ^ Primary that specifies @x@ and @y@
  -> Color (XYZ i) e
primaryXZ :: forall {k} e (i :: k).
Fractional e =>
e -> Primary i e -> Color (XYZ i) e
primaryXZ e
vY (Primary e
x e
y) = e -> e -> e -> Color (XYZ i) e
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ (e
vYy e -> e -> e
forall a. Num a => a -> a -> a
* e
x) e
vY (e
vYy e -> e -> e
forall a. Num a => a -> a -> a
* (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e
x e -> e -> e
forall a. Num a => a -> a -> a
- e
y))
  where !vYy :: e
vYy = e
vY e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
y
{-# INLINE primaryXZ #-}


-----------
--- XYZ ---
-----------

-- | The original color space CIE 1931 XYZ color space
data XYZ i

-- | CIE1931 `XYZ` color space
newtype instance Color (XYZ i) e = XYZ (V3 e)

-- | Constructor for the most common @XYZ@ color space
pattern ColorXYZ :: e -> e -> e -> Color (XYZ i) e
pattern $mColorXYZ :: forall {r} {k} {e} {i :: k}.
Color (XYZ i) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorXYZ :: forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ x y z = XYZ (V3 x y z)
{-# COMPLETE ColorXYZ #-}

-- | Constructor for @XYZ@ with alpha channel.
pattern ColorXYZA :: e -> e -> e -> e -> Color (Alpha (XYZ i)) e
pattern $mColorXYZA :: forall {r} {k} {e} {i :: k}.
Color (Alpha (XYZ i)) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorXYZA :: forall {k} e (i :: k). e -> e -> e -> e -> Color (Alpha (XYZ i)) e
ColorXYZA x y z a = Alpha (XYZ (V3 x y z)) a
{-# COMPLETE ColorXYZA #-}


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

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

-- | CIE1931 `XYZ` color space
instance (Illuminant i, Elevator e) => ColorModel (XYZ (i :: k)) e where
  type Components (XYZ i) e = (e, e, e)
  type ChannelCount (XYZ i) = 3
  channelCount :: Proxy (Color (XYZ i) e) -> Word8
channelCount Proxy (Color (XYZ i) e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (XYZ i) e) -> NonEmpty String
channelNames Proxy (Color (XYZ i) e)
_ = String
"X" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"Y", String
"Z"]
  channelColors :: Proxy (Color (XYZ i) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (XYZ i) e)
_ = Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0xff Word8
0xff Word8
0xff V3 Word8 -> [V3 Word8] -> NonEmpty (V3 Word8)
forall a. a -> [a] -> NonEmpty a
:| [Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x80 Word8
0x80 Word8
0x80, Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x2f Word8
0x4f Word8
0x4f]
  toComponents :: Color (XYZ i) e -> Components (XYZ i) e
toComponents (ColorXYZ e
x e
y e
z) = (e
x, e
y, e
z)
  {-# INLINE toComponents #-}
  fromComponents :: Components (XYZ i) e -> Color (XYZ i) e
fromComponents (e
x, e
y, e
z) = e -> e -> e -> Color (XYZ i) e
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ e
x e
y e
z
  {-# INLINE fromComponents #-}

-- | CIE1931 `XYZ` color space
instance (Illuminant i, Elevator e) => ColorSpace (XYZ i) i e where
  type BaseModel (XYZ i) = XYZ i
  toBaseModel :: Color (XYZ i) e -> Color (BaseModel (XYZ i)) e
toBaseModel = Color (XYZ i) e -> Color (XYZ i) e
Color (XYZ i) e -> Color (BaseModel (XYZ i)) e
forall a. a -> a
id
  fromBaseModel :: Color (BaseModel (XYZ i)) e -> Color (XYZ i) e
fromBaseModel = Color (XYZ i) e -> Color (XYZ i) e
Color (BaseModel (XYZ i)) e -> Color (XYZ i) e
forall a. a -> a
id
  toBaseSpace :: ColorSpace (BaseSpace (XYZ i)) i e =>
Color (XYZ i) e -> Color (BaseSpace (XYZ i)) e
toBaseSpace = Color (XYZ i) e -> Color (XYZ i) e
Color (XYZ i) e -> Color (BaseSpace (XYZ i)) e
forall a. a -> a
id
  fromBaseSpace :: ColorSpace (BaseSpace (XYZ i)) i e =>
Color (BaseSpace (XYZ i)) e -> Color (XYZ i) e
fromBaseSpace = Color (XYZ i) e -> Color (XYZ i) e
Color (BaseSpace (XYZ i)) e -> Color (XYZ i) e
forall a. a -> a
id
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) e -> Color (Y i) a
luminance (ColorXYZ e
_ e
y e
_) = a -> Color (Y i) a
forall {k} e (i :: k). e -> Color (Y i) e
Y (e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y)
  {-# INLINE luminance #-}
  grayscale :: Color (XYZ i) e -> Color X e
grayscale (ColorXYZ e
_ e
y e
_) = e -> Color X e
forall e. e -> Color X e
X e
y
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color (XYZ i) e -> Color X e -> Color (XYZ i) e
replaceGrayscale (ColorXYZ e
x e
_ e
z) (X e
y) = e -> e -> e -> Color (XYZ i) e
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ e
x e
y e
z
  {-# INLINE replaceGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) e -> Color (XYZ i) a
toColorXYZ (ColorXYZ e
x e
y e
z) = a -> a -> a -> Color (XYZ i) a
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ (e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
x) (e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y) (e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
z)
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (XYZ i) e
fromColorXYZ (ColorXYZ a
x a
y a
z) = e -> e -> e -> Color (XYZ i) e
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ (a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
x) (a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
y) (a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
z)
  {-# INLINE fromColorXYZ #-}

{-# RULES
"toColorXYZ   :: Color (XYZ i) a -> Color (XYZ i) a"   toColorXYZ = id
"fromColorXYZ :: Color (XYZ i) a -> Color (XYZ i) a" fromColorXYZ = id
 #-}


---------------
--- CIE xyY ---
---------------

-- | Alternative representation of the CIE 1931 XYZ color space
data CIExyY (i :: k)

-- | CIE1931 `CIExyY` color space
newtype instance Color (CIExyY i) e = CIExyY (V2 e)

-- | Constructor @CIE xyY@ color space. It only requires @x@ and @y@, then @Y@ part will
-- always be equal to 1.
pattern ColorCIExy :: e -> e -> Color (CIExyY i) e
pattern $mColorCIExy :: forall {r} {k} {e} {i :: k}.
Color (CIExyY i) e -> (e -> e -> r) -> ((# #) -> r) -> r
$bColorCIExy :: forall {k} e (i :: k). e -> e -> Color (CIExyY i) e
ColorCIExy x y = CIExyY (V2 x y)
{-# COMPLETE ColorCIExy #-}

-- | Patttern match on the @CIE xyY@, 3rd argument @Y@ is always set to @1@
pattern ColorCIExyY :: Num e => e -> e -> e -> Color (CIExyY i) e
pattern $mColorCIExyY :: forall {r} {k} {e} {i :: k}.
Num e =>
Color (CIExyY i) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
ColorCIExyY x y y' <- (addY -> V3 x y y')
{-# COMPLETE ColorCIExyY #-}

addY :: Num e => Color (CIExyY i) e -> V3 e
addY :: forall {k} e (i :: k). Num e => Color (CIExyY i) e -> V3 e
addY (CIExyY (V2 e
x e
y)) = e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
x e
y e
1
{-# INLINE addY #-}

-- | CIE xyY color space
deriving instance Eq e => Eq (Color (CIExyY i) e)
-- | CIE xyY color space
deriving instance Ord e => Ord (Color (CIExyY i) e)
-- | CIE xyY color space
deriving instance Functor (Color (CIExyY i))
-- | CIE xyY color space
deriving instance Applicative (Color (CIExyY i))
-- | CIE xyY color space
deriving instance Foldable (Color (CIExyY i))
-- | CIE xyY color space
deriving instance Traversable (Color (CIExyY i))
-- | CIE xyY color space
deriving instance Storable e => Storable (Color (CIExyY i) e)

-- | CIE xyY color space
instance (Illuminant i, Elevator e) => Show (Color (CIExyY (i :: k)) e) where
  showsPrec :: Int -> Color (CIExyY i) e -> ShowS
showsPrec Int
_ = Color (CIExyY i) e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModel

-- | CIE xyY color space
instance (Illuminant i, Elevator e) => ColorModel (CIExyY (i :: k)) e where
  type Components (CIExyY i) e = (e, e)
  type ChannelCount (CIExyY i) = 2
  channelCount :: Proxy (Color (CIExyY i) e) -> Word8
channelCount Proxy (Color (CIExyY i) e)
_ = Word8
2
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (CIExyY i) e) -> NonEmpty String
channelNames Proxy (Color (CIExyY i) e)
_ = String
"x" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"y"]
  channelColors :: Proxy (Color (CIExyY i) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (CIExyY i) e)
_ = Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0xbd Word8
0xb7 Word8
0x6b V3 Word8 -> [V3 Word8] -> NonEmpty (V3 Word8)
forall a. a -> [a] -> NonEmpty a
:| [Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0xf0 Word8
0xe6 Word8
0x8c]
  toComponents :: Color (CIExyY i) e -> Components (CIExyY i) e
toComponents (CIExyY (V2 e
x e
y)) = (e
x, e
y)
  {-# INLINE toComponents #-}
  fromComponents :: Components (CIExyY i) e -> Color (CIExyY i) e
fromComponents (e
x, e
y) = V2 e -> Color (CIExyY i) e
forall k (i :: k) e. V2 e -> Color (CIExyY i) e
CIExyY (e -> e -> V2 e
forall a. a -> a -> V2 a
V2 e
x e
y)
  {-# INLINE fromComponents #-}
  showsColorModelName :: Proxy (Color (CIExyY i) e) -> ShowS
showsColorModelName Proxy (Color (CIExyY i) e)
_ = Proxy (CIExyY i) -> ShowS
forall {k} (t :: k) (proxy :: k -> *).
Typeable t =>
proxy t -> ShowS
showsType (Proxy (CIExyY i)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (CIExyY i))

-- | CIE xyY color space
instance (Illuminant i, RealFloat e, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where
  type BaseModel (CIExyY i) = CIExyY i
  toBaseModel :: Color (CIExyY i) e -> Color (BaseModel (CIExyY i)) e
toBaseModel = Color (CIExyY i) e -> Color (CIExyY i) e
Color (CIExyY i) e -> Color (BaseModel (CIExyY i)) e
forall a. a -> a
id
  fromBaseModel :: Color (BaseModel (CIExyY i)) e -> Color (CIExyY i) e
fromBaseModel = Color (CIExyY i) e -> Color (CIExyY i) e
Color (BaseModel (CIExyY i)) e -> Color (CIExyY i) e
forall a. a -> a
id
  toBaseSpace :: ColorSpace (BaseSpace (CIExyY i)) i e =>
Color (CIExyY i) e -> Color (BaseSpace (CIExyY i)) e
toBaseSpace = Color (CIExyY i) e -> Color (CIExyY i) e
Color (CIExyY i) e -> Color (BaseSpace (CIExyY i)) e
forall a. a -> a
id
  fromBaseSpace :: ColorSpace (BaseSpace (CIExyY i)) i e =>
Color (BaseSpace (CIExyY i)) e -> Color (CIExyY i) e
fromBaseSpace = Color (CIExyY i) e -> Color (CIExyY i) e
Color (BaseSpace (CIExyY i)) e -> Color (CIExyY i) e
forall a. a -> a
id
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (CIExyY i) e -> Color (Y i) a
luminance Color (CIExyY i) e
_ = a -> Color (Y i) a
forall {k} e (i :: k). e -> Color (Y i) e
Y a
1
  {-# INLINE luminance #-}
  grayscale :: Color (CIExyY i) e -> Color X e
grayscale Color (CIExyY i) e
_ = e -> Color X e
forall e. e -> Color X e
X e
1
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color (CIExyY i) e -> Color X e -> Color (CIExyY i) e
replaceGrayscale Color (CIExyY i) e
xy Color X e
y =
    Color (XYZ i) e -> Color (CIExyY i) e
forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (CIExyY i) e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ (Color (XYZ i) e -> Color X e -> Color (XYZ i) e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color X e -> Color cs e
replaceGrayscale (Color (CIExyY i) e -> Color (XYZ i) e
forall a.
(Elevator a, RealFloat a) =>
Color (CIExyY i) e -> Color (XYZ i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ Color (CIExyY i) e
xy) Color X e
y :: Color (XYZ i) e)
  {-# INLINE replaceGrayscale #-}
  applyGrayscale :: Color (CIExyY i) e
-> (Color X e -> Color X e) -> Color (CIExyY i) e
applyGrayscale Color (CIExyY i) e
xy Color X e -> Color X e
f =
    Color (XYZ i) e -> Color (CIExyY i) e
forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (CIExyY i) e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ (Color (XYZ i) e -> (Color X e -> Color X e) -> Color (XYZ i) e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> (Color X e -> Color X e) -> Color cs e
applyGrayscale (Color (CIExyY i) e -> Color (XYZ i) e
forall a.
(Elevator a, RealFloat a) =>
Color (CIExyY i) e -> Color (XYZ i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ Color (CIExyY i) e
xy) Color X e -> Color X e
f :: Color (XYZ i) e)
  {-# INLINE applyGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (CIExyY i) e -> Color (XYZ i) a
toColorXYZ Color (CIExyY i) e
xy = a -> a -> a -> Color (XYZ i) a
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ (a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
y) a
1 ((a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
y)
    where ColorCIExy a
x a
y = e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat (e -> a) -> Color (CIExyY i) e -> Color (CIExyY i) a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Color (CIExyY i) e
xy
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (CIExyY i) e
fromColorXYZ Color (XYZ i) a
xyz = a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat (a -> e) -> Color (CIExyY i) a -> Color (CIExyY i) e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> Color (CIExyY i) a
forall {k} e (i :: k). e -> e -> Color (CIExyY i) e
ColorCIExy (a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
s) (a
y a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
s)
    where
      ColorXYZ a
x a
y a
z = Color (XYZ i) a
xyz
      !s :: a
s = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
z
  {-# INLINE fromColorXYZ #-}


-------------
--- Y ---
-------------

-- | [Relative Luminance](https://en.wikipedia.org/wiki/Relative_luminance) of a color
data Y (i :: k)

-- | Luminance `Y`
newtype instance Color (Y i) e = Luminance (Color X e)

-- | Get the luminance value
unY :: Color (Y i) e -> e
unY :: forall {k} (i :: k) e. Color (Y i) e -> e
unY = Color (Y i) e -> e
forall a b. Coercible a b => a -> b
coerce
{-# INLINE unY #-}

-- | Constructor for @Y@ with alpha channel.
pattern Y :: e -> Color (Y i) e
pattern $mY :: forall {r} {k} {e} {i :: k}.
Color (Y i) e -> (e -> r) -> ((# #) -> r) -> r
$bY :: forall {k} e (i :: k). e -> Color (Y i) e
Y y = Luminance (X y)
{-# COMPLETE Y #-}

-- | Constructor for @Y@ with alpha channel.
pattern YA :: e -> e -> Color (Alpha (Y i)) e
pattern $mYA :: forall {r} {k} {e} {i :: k}.
Color (Alpha (Y i)) e -> (e -> e -> r) -> ((# #) -> r) -> r
$bYA :: forall {k} e (i :: k). e -> e -> Color (Alpha (Y i)) e
YA y a = Alpha (Luminance (X y)) a
{-# COMPLETE YA #-}

-- | `Y` - relative luminance of a color space
deriving instance Eq e => Eq (Color (Y i) e)
-- | `Y` - relative luminance of a color space
deriving instance Ord e => Ord (Color (Y i) e)
-- | `Y` - relative luminance of a color space
deriving instance Functor (Color (Y i))
-- | `Y` - relative luminance of a color space
deriving instance Applicative (Color (Y i))
-- | `Y` - relative luminance of a color space
deriving instance Foldable (Color (Y i))
-- | `Y` - relative luminance of a color space
deriving instance Traversable (Color (Y i))
-- | `Y` - relative luminance of a color space
deriving instance Storable e => Storable (Color (Y i) e)


-- | `Y` - relative luminance of a color space
instance (Illuminant i, Elevator e) => Show (Color (Y i) e) where
  showsPrec :: Int -> Color (Y i) e -> ShowS
showsPrec Int
_ = Color (Y i) e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModel

-- | `Y` - relative luminance of a color space
instance (Illuminant i, Elevator e) => ColorModel (Y i) e where
  type Components (Y i) e = e
  type ChannelCount (Y i) = 1
  channelCount :: Proxy (Color (Y i) e) -> Word8
channelCount Proxy (Color (Y i) e)
_ = Word8
1
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (Y i) e) -> NonEmpty String
channelNames Proxy (Color (Y i) e)
_ = String
"Luminance" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
  channelColors :: Proxy (Color (Y i) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (Y i) e)
_ = Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x80 Word8
0x80 Word8
0x80 V3 Word8 -> [V3 Word8] -> NonEmpty (V3 Word8)
forall a. a -> [a] -> NonEmpty a
:| []
  toComponents :: Color (Y i) e -> Components (Y i) e
toComponents = Color (Y i) e -> e
Color (Y i) e -> Components (Y i) e
forall a b. Coercible a b => a -> b
coerce
  {-# INLINE toComponents #-}
  fromComponents :: Components (Y i) e -> Color (Y i) e
fromComponents = e -> Color (Y i) e
Components (Y i) e -> Color (Y i) e
forall a b. Coercible a b => a -> b
coerce
  {-# INLINE fromComponents #-}


-- | CIE1931 `XYZ` color space
instance (Illuminant i, Elevator e) => ColorSpace (Y i) i e where
  type BaseModel (Y i) = X
  toBaseSpace :: ColorSpace (BaseSpace (Y i)) i e =>
Color (Y i) e -> Color (BaseSpace (Y i)) e
toBaseSpace = Color (Y i) e -> Color (Y i) e
Color (Y i) e -> Color (BaseSpace (Y i)) e
forall a. a -> a
id
  fromBaseSpace :: ColorSpace (BaseSpace (Y i)) i e =>
Color (BaseSpace (Y i)) e -> Color (Y i) e
fromBaseSpace = Color (Y i) e -> Color (Y i) e
Color (BaseSpace (Y i)) e -> Color (Y i) e
forall a. a -> a
id
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (Y i) e -> Color (Y i) a
luminance = (e -> a) -> Color (Y i) e -> Color (Y i) a
forall a b. (a -> b) -> Color (Y i) a -> Color (Y i) 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 (Y i) e -> Color X e
grayscale = Color (Y i) e -> Color X e
forall a b. Coercible a b => a -> b
coerce
  {-# INLINE grayscale #-}
  applyGrayscale :: Color (Y i) e -> (Color X e -> Color X e) -> Color (Y i) e
applyGrayscale Color (Y i) e
c Color X e -> Color X e
f = Color X e -> Color (Y i) e
forall a b. Coercible a b => a -> b
coerce (Color X e -> Color X e
f (Color (Y i) e -> Color X e
forall a b. Coercible a b => a -> b
coerce Color (Y i) e
c))
  {-# INLINE applyGrayscale #-}
  replaceGrayscale :: Color (Y i) e -> Color X e -> Color (Y i) e
replaceGrayscale Color (Y i) e
_ = Color X e -> Color (Y i) e
forall a b. Coercible a b => a -> b
coerce
  {-# INLINE replaceGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (Y i) e -> Color (XYZ i) a
toColorXYZ (Y e
y) = a -> a -> a -> Color (XYZ i) a
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ a
0 (e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y) a
0
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (Y i) e
fromColorXYZ (ColorXYZ a
_ a
y a
_) = e -> Color (Y i) e
forall {k} e (i :: k). e -> Color (Y i) e
Y (a -> e
forall a. (Elevator a, RealFloat a) => a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
y)
  {-# INLINE fromColorXYZ #-}

{-# RULES
"luminance :: RealFloat a => Color (Y i) a -> Color (Y i) a" luminance = id
 #-}