{-# 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 UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module      : Graphics.Color.Space.Internal
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- 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
  , 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
  ) where

import Foreign.Storable
import Graphics.Color.Algebra.Binary
import Graphics.Color.Algebra.Elevator
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.X as CM
import Data.Typeable
import Data.Coerce
import GHC.TypeNats
import Data.Kind

class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) =>
  ColorSpace cs (i :: k) e | cs -> i where

  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
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
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
  --
  -- @since 0.1.0
  luminance :: (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a

  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 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 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 (Opaque (Alpha (BaseModel cs))) e)
-> Color (Alpha cs) e
-> Color (Alpha (Opaque (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 (Opaque (Alpha (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 (Opaque (Alpha (BaseModel cs))) e -> Color cs e)
-> Color (Alpha (Opaque (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 (Opaque (Alpha (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 :: Color (Alpha cs) e -> Color (XYZ i) a
toColorXYZ = 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 :: 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 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 :: Color (Alpha cs) e -> Color (Y i) a
luminance = 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 #-}
  toBaseSpace :: 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 :: 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 { 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
/= :: 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
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
showList :: [Chromaticity i e] -> ShowS
$cshowList :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
[Chromaticity i e] -> ShowS
show :: Chromaticity i e -> String
$cshow :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Chromaticity i e -> String
showsPrec :: Int -> Chromaticity i e -> ShowS
$cshowsPrec :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Int -> Chromaticity i e -> ShowS
Show)


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

-- | Correlated color temperature (CCT) of a white point in Kelvin
newtype CCT (i :: k) = CCT
  { 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
/= :: 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
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
showList :: [CCT i] -> ShowS
$cshowList :: forall k (i :: k). [CCT i] -> ShowS
show :: CCT i -> String
$cshow :: forall k (i :: k). CCT i -> String
showsPrec :: Int -> CCT i -> ShowS
$cshowsPrec :: forall k (i :: k). Int -> 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 (Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy (Temperature i) -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall k. Proxy (Temperature i)
forall k (t :: k). Proxy t
Proxy :: Proxy (Temperature i))))


newtype WhitePoint (i :: k) e =
  WhitePointChromaticity { 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
/= :: 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
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 $bWhitePoint :: e -> e -> WhitePoint i e
$mWhitePoint :: forall r k e (i :: k).
WhitePoint i e -> (e -> e -> r) -> (Void# -> r) -> r
WhitePoint x y <- (coerce -> (V2 x y)) where
  WhitePoint e
x e
y = V2 e -> WhitePoint i e
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 :: WhitePoint i e -> e
xWhitePoint (WhitePoint i e -> V2 e
coerce -> V2 e
x e
_) = e
x
{-# INLINE xWhitePoint #-}

-- | @y@ value of a `WhitePoint`
--
-- @since 0.1.0
yWhitePoint :: WhitePoint i e -> e
yWhitePoint :: WhitePoint i e -> e
yWhitePoint (WhitePoint i e -> V2 e
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 :: 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 :: Color (XYZ i) e
whitePointTristimulus = Color (CIExyY i) e -> Color (XYZ i) e
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
coerce (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 :: e -> WhitePoint i e -> Color (XYZ i) e
whitePointXZ e
vY (WhitePoint i e -> V2 e
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
    { 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
/= :: 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
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
showList :: [Primary i e] -> ShowS
$cshowList :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
[Primary i e] -> ShowS
show :: Primary i e -> String
$cshow :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Primary i e -> String
showsPrec :: Int -> Primary i e -> ShowS
$cshowsPrec :: forall k (i :: k) e.
(Illuminant i, Elevator e) =>
Int -> Primary i e -> ShowS
Show)


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



xPrimary :: Primary i e -> e
xPrimary :: Primary i e -> e
xPrimary (Primary i e -> V2 e
coerce -> V2 e
x e
_) = e
x
{-# INLINE xPrimary #-}

yPrimary :: Primary i e -> e
yPrimary :: Primary i e -> e
yPrimary (Primary i e -> V2 e
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 :: 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 :: Primary i e -> Color (XYZ i) e
primaryTristimulus Primary i e
xy = Color (CIExyY i) e -> Color (XYZ i) e
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
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 :: 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 $bColorXYZ :: e -> e -> e -> Color (XYZ i) e
$mColorXYZ :: forall r k e (i :: k).
Color (XYZ i) e -> (e -> e -> e -> r) -> (Void# -> r) -> r
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 $bColorXYZA :: e -> e -> e -> e -> Color (Alpha (XYZ i)) e
$mColorXYZA :: forall r k e (i :: k).
Color (Alpha (XYZ i)) e
-> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
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)
  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 (x, y, 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 (BaseModel (XYZ i)) e
forall a. a -> a
id
  fromBaseModel :: Color (BaseModel (XYZ i)) e -> Color (XYZ i) e
fromBaseModel = Color (BaseModel (XYZ i)) e -> Color (XYZ i) e
forall a. a -> a
id
  toBaseSpace :: Color (XYZ i) e -> Color (BaseSpace (XYZ i)) e
toBaseSpace = Color (XYZ i) e -> Color (BaseSpace (XYZ i)) e
forall a. a -> a
id
  fromBaseSpace :: Color (BaseSpace (XYZ i)) e -> Color (XYZ i) e
fromBaseSpace = Color (BaseSpace (XYZ i)) e -> Color (XYZ i) e
forall a. a -> a
id
  luminance :: 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 e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y)
  {-# INLINE luminance #-}
  toColorXYZ :: 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 e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
x) (e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y) (e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
z)
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: 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 e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
x) (a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
y) (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 $bColorCIExy :: e -> e -> Color (CIExyY i) e
$mColorCIExy :: forall r k e (i :: k).
Color (CIExyY i) e -> (e -> e -> r) -> (Void# -> r) -> r
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) -> (Void# -> r) -> r
ColorCIExyY x y y' <- (addY -> V3 x y y')
{-# COMPLETE ColorCIExyY #-}

addY :: Num e => Color (CIExyY i) e -> V3 e
addY :: Color (CIExyY i) e -> V3 e
addY (CIExyY (V2 x 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)
  toComponents :: Color (CIExyY i) e -> Components (CIExyY i) e
toComponents (CIExyY (V2 x y)) = (e
x, e
y)
  {-# INLINE toComponents #-}
  fromComponents :: Components (CIExyY i) e -> Color (CIExyY i) e
fromComponents (x, 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, 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 (BaseModel (CIExyY i)) e
forall a. a -> a
id
  fromBaseModel :: Color (BaseModel (CIExyY i)) e -> Color (CIExyY i) e
fromBaseModel = Color (BaseModel (CIExyY i)) e -> Color (CIExyY i) e
forall a. a -> a
id
  toBaseSpace :: Color (CIExyY i) e -> Color (BaseSpace (CIExyY i)) e
toBaseSpace = Color (CIExyY i) e -> Color (BaseSpace (CIExyY i)) e
forall a. a -> a
id
  fromBaseSpace :: Color (BaseSpace (CIExyY i)) e -> Color (CIExyY i) e
fromBaseSpace = Color (BaseSpace (CIExyY i)) e -> Color (CIExyY i) e
forall a. a -> a
id
  luminance :: 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 #-}
  toColorXYZ :: 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 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 :: Color (XYZ i) a -> Color (CIExyY i) e
fromColorXYZ Color (XYZ i) a
xyz = 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 (CM.Color CM.X e)

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

-- | Constructor for @Y@ with alpha channel.
pattern YA :: e -> e -> Color (Alpha (Y i)) e
pattern $bYA :: e -> e -> Color (Alpha (Y i)) e
$mYA :: forall r k e (i :: k).
Color (Alpha (Y i)) e -> (e -> e -> r) -> (Void# -> r) -> r
YA y a = Alpha (Luminance (CM.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
  toComponents :: Color (Y i) e -> Components (Y i) e
toComponents = Color (Y i) e -> Components (Y i) e
coerce
  {-# INLINE toComponents #-}
  fromComponents :: Components (Y i) e -> Color (Y i) e
fromComponents = Components (Y i) e -> Color (Y i) e
coerce
  {-# INLINE fromComponents #-}


-- | CIE1931 `XYZ` color space
instance (Illuminant i, Elevator e) => ColorSpace (Y i) i e where
  type BaseModel (Y i) = CM.X
  toBaseSpace :: Color (Y i) e -> Color (BaseSpace (Y i)) e
toBaseSpace = Color (Y i) e -> Color (BaseSpace (Y i)) e
forall a. a -> a
id
  fromBaseSpace :: Color (BaseSpace (Y i)) e -> Color (Y i) e
fromBaseSpace = Color (BaseSpace (Y i)) e -> Color (Y i) e
forall a. a -> a
id
  luminance :: Color (Y i) e -> Color (Y i) a
luminance = (e -> a) -> Color (Y i) e -> Color (Y i) a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat
  {-# INLINE luminance #-}
  toColorXYZ :: 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 e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y) a
0
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: 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 e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat a
y)
  {-# INLINE fromColorXYZ #-}

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