{-# 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.CIE1931.RGB
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.CIE1931.RGB
  ( CIERGB
  , castLinearity
  ) where

import Data.Coerce
import Data.Typeable
import Foreign.Storable
import Graphics.Color.Illuminant.CIE1931
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space.Internal
import Graphics.Color.Space.RGB.Internal


-- | The original @CIE1931 RGB@ color space with an arbitrary illuminant
data CIERGB (l :: Linearity)

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

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

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

-- | `CIERGB` color space
instance (Typeable l, Elevator e) => ColorModel (CIERGB l) e where
  type Components (CIERGB l) e = (e, e, e)
  toComponents :: Color (CIERGB l) e -> Components (CIERGB l) e
toComponents = Color RGB e -> (e, e, e)
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color RGB e -> (e, e, e))
-> (Color (CIERGB l) e -> Color RGB e)
-> Color (CIERGB l) e
-> (e, e, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (CIERGB l) e -> Color RGB e
forall k (cs :: Linearity -> *) (i :: k) (l :: Linearity) e.
RedGreenBlue cs i =>
Color (cs l) e -> Color RGB e
unColorRGB
  {-# INLINE toComponents #-}
  fromComponents :: Components (CIERGB l) e -> Color (CIERGB l) e
fromComponents = Color RGB e -> Color (CIERGB 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 (CIERGB l) e)
-> ((e, e, e) -> Color RGB e) -> (e, e, e) -> Color (CIERGB l) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e, e, e) -> Color RGB e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents
  {-# INLINE fromComponents #-}

-- | `CIERGB` linear color space
instance (Typeable l, Elevator e) => ColorSpace (CIERGB l) 'E e where
  type BaseModel (CIERGB l) = CM.RGB
  toBaseSpace :: Color (CIERGB l) e -> Color (BaseSpace (CIERGB l)) e
toBaseSpace = Color (CIERGB l) e -> Color (BaseSpace (CIERGB l)) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: Color (BaseSpace (CIERGB l)) e -> Color (CIERGB l) e
fromBaseSpace = Color (BaseSpace (CIERGB l)) e -> Color (CIERGB l) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: Color (CIERGB l) e -> Color (Y 'E) a
luminance = Color (CIERGB 'Linear) a -> Color (Y 'E) 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 (CIERGB 'Linear) a -> Color (Y 'E) a)
-> (Color (CIERGB l) e -> Color (CIERGB 'Linear) a)
-> Color (CIERGB l) e
-> Color (Y 'E) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (CIERGB l) a -> Color (CIERGB 'Linear) a
forall (l' :: Linearity) e (l :: Linearity).
Color (CIERGB l') e -> Color (CIERGB l) e
castLinearity (Color (CIERGB l) a -> Color (CIERGB 'Linear) a)
-> (Color (CIERGB l) e -> Color (CIERGB l) a)
-> Color (CIERGB l) e
-> Color (CIERGB 'Linear) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (CIERGB l) e -> Color (CIERGB l) 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 (CIERGB l) e -> Color (XYZ 'E) a
toColorXYZ = Color (CIERGB 'Linear) a -> Color (XYZ 'E) 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 (CIERGB 'Linear) a -> Color (XYZ 'E) a)
-> (Color (CIERGB l) e -> Color (CIERGB 'Linear) a)
-> Color (CIERGB l) e
-> Color (XYZ 'E) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (CIERGB 'Linear) e -> Color (CIERGB 'Linear) 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 (Color (CIERGB 'Linear) e -> Color (CIERGB 'Linear) a)
-> (Color (CIERGB l) e -> Color (CIERGB 'Linear) e)
-> Color (CIERGB l) e
-> Color (CIERGB 'Linear) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (CIERGB l) e -> Color (CIERGB 'Linear) e
forall (l' :: Linearity) e (l :: Linearity).
Color (CIERGB l') e -> Color (CIERGB l) e
castLinearity
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: Color (XYZ 'E) a -> Color (CIERGB l) e
fromColorXYZ Color (XYZ 'E) a
xyz = Color (CIERGB 'Linear) e -> Color (CIERGB l) e
forall (l' :: Linearity) e (l :: Linearity).
Color (CIERGB l') e -> Color (CIERGB l) e
castLinearity (a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat (a -> e) -> Color (CIERGB 'Linear) a -> Color (CIERGB 'Linear) e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Color (XYZ 'E) a -> Color (CIERGB '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 @CIERGB Color (XYZ 'E) a
xyz)
  {-# INLINE fromColorXYZ #-}

-- | `CIERGB` color space
instance RedGreenBlue CIERGB 'E where
  -- | [Source](https://github.com/colour-science/colour/blob/60679360c3990bc549b5f947bfeb621383e18b5e/colour/models/rgb/datasets/cie_rgb.py#L44-L48)
  gamut :: Gamut CIERGB 'E e
gamut = Primary 'E e -> Primary 'E e -> Primary 'E e -> Gamut CIERGB 'E e
forall k (cs :: Linearity -> *) (i :: k) e.
Primary i e -> Primary i e -> Primary i e -> Gamut cs i e
Gamut (e -> e -> Primary 'E e
forall k e (i :: k). e -> e -> Primary i e
Primary e
0.734742840005998 e
0.265257159994002)
                (e -> e -> Primary 'E e
forall k e (i :: k). e -> e -> Primary i e
Primary e
0.273779033824958 e
0.717477700256116)
                (e -> e -> Primary 'E e
forall k e (i :: k). e -> e -> Primary i e
Primary e
0.166555629580280 e
0.008910726182545)
  transfer :: e -> e
transfer = e -> e
forall a. a -> a
id
  itransfer :: e -> e
itransfer = e -> e
forall a. a -> a
id

-- | CIE RGB does not utilize any gamma function, therefore it is safe to cast the
-- `Linearity` kind.
--
-- @since 0.2.0
castLinearity :: Color (CIERGB l') e -> Color (CIERGB l) e
castLinearity :: Color (CIERGB l') e -> Color (CIERGB l) e
castLinearity = Color (CIERGB l') e -> Color (CIERGB l) e
coerce