{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module      : Graphics.Color.Space.RGB.SRGB
-- Copyright   : (c) Alexey Kuleshevich 2019-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.RGB.SRGB
  ( -- * Constructors for a sRGB color space.
    pattern SRGB
  , pattern ColorSRGB
  , pattern ColorSRGBA
  , SRGB
  , D50
  , D65
  ) where

import Data.Coerce
import Data.Typeable
import Foreign.Storable
import Graphics.Color.Illuminant.ICC.PCS (D50)
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.ITU.Rec709 (BT709, D65)
import Graphics.Color.Space.RGB.Luma

-- | The most common [sRGB](https://en.wikipedia.org/wiki/SRGB) color space, which is
-- defined with:
--
-- * `D65` illuminant
--
-- * Transfer function:
--
-- \[
-- \gamma(u) = \begin{cases}
--     12.92 u & u \leq 0.0031308 \\
--     1.055 u^{1/2.4} - 0.055 & \text{otherwise}
--   \end{cases}
-- \]
--
-- * Inverse transfer function
--
-- \[
-- \gamma^{-1}(u) = \begin{cases}
--     u / 12.92 & u \leq 0.04045 \\
--     \left(\tfrac{u + 0.055}{1.055}\right)^{2.4} & \text{otherwise}
--   \end{cases}
-- \]
--
-- * Normalized primary matrix:
--
-- >>> :set -XDataKinds
-- >>> import Graphics.Color.Space.RGB
-- >>> npm :: NPM SRGB Float
-- [ [ 0.41240000, 0.35760000, 0.18050000 ]
-- , [ 0.21260000, 0.71520000, 0.07220000 ]
-- , [ 0.01930000, 0.11920000, 0.95050000 ] ]
--
-- * Inverse normalized primary matrix:
--
-- >>> :set -XDataKinds
-- >>> import Graphics.Color.Space.RGB
-- >>> inpm :: INPM SRGB Float
-- [ [ 3.24060000,-1.53720000,-0.49860000 ]
-- , [-0.96890000, 1.87580000, 0.04150000 ]
-- , [ 0.05570000,-0.20400000, 1.05700000 ] ]
--
data SRGB (l :: Linearity)


newtype instance Color (SRGB l) e = SRGB (Color CM.RGB e)

-- | Constructor for a color in @sRGB@ color space
--
-- @since 0.1.0
pattern ColorSRGB :: e -> e -> e -> Color (SRGB l) e
pattern $bColorSRGB :: e -> e -> e -> Color (SRGB l) e
$mColorSRGB :: forall r e (l :: Linearity).
Color (SRGB l) e -> (e -> e -> e -> r) -> (Void# -> r) -> r
ColorSRGB r g b = SRGB (CM.ColorRGB r g b)
{-# COMPLETE ColorSRGB #-}

-- | Constructor for a color in @sRGB@ color space with alphs channel
--
-- @since 0.1.0
pattern ColorSRGBA :: e -> e -> e -> e -> Color (Alpha (SRGB l)) e
pattern $bColorSRGBA :: e -> e -> e -> e -> Color (Alpha (SRGB l)) e
$mColorSRGBA :: forall r e (l :: Linearity).
Color (Alpha (SRGB l)) e
-> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
ColorSRGBA r g b a = Alpha (SRGB (CM.ColorRGB r g b)) a
{-# COMPLETE ColorSRGBA #-}


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

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

-- | `SRGB` color space
instance (Typeable l, Elevator e) => ColorModel (SRGB l) e where
  type Components (SRGB l) e = (e, e, e)
  toComponents :: Color (SRGB l) e -> Components (SRGB 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 (SRGB l) e -> Color RGB e)
-> Color (SRGB l) e
-> (e, e, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (SRGB 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 (SRGB l) e -> Color (SRGB l) e
fromComponents = Color RGB e -> Color (SRGB 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 l) e)
-> ((e, e, e) -> Color RGB e) -> (e, e, e) -> Color (SRGB 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 #-}

-- | `SRGB` linear color space
instance Elevator e => ColorSpace (SRGB 'Linear) D65 e where
  type BaseModel (SRGB 'Linear) = CM.RGB
  toBaseSpace :: Color (SRGB 'Linear) e -> Color (BaseSpace (SRGB 'Linear)) e
toBaseSpace = Color (SRGB 'Linear) e -> Color (BaseSpace (SRGB 'Linear)) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: Color (BaseSpace (SRGB 'Linear)) e -> Color (SRGB 'Linear) e
fromBaseSpace = Color (BaseSpace (SRGB 'Linear)) e -> Color (SRGB 'Linear) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: Color (SRGB 'Linear) e -> Color (Y D65) a
luminance = Color (SRGB 'Linear) a -> Color (Y D65) 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 'Linear) a -> Color (Y D65) a)
-> (Color (SRGB 'Linear) e -> Color (SRGB 'Linear) a)
-> Color (SRGB 'Linear) e
-> Color (Y D65) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (SRGB 'Linear) e -> Color (SRGB '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
  {-# INLINE luminance #-}
  toColorXYZ :: Color (SRGB 'Linear) e -> Color (XYZ D65) a
toColorXYZ = Color (SRGB 'Linear) a -> Color (XYZ D65) 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 'Linear) a -> Color (XYZ D65) a)
-> (Color (SRGB 'Linear) e -> Color (SRGB 'Linear) a)
-> Color (SRGB 'Linear) e
-> Color (XYZ D65) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (SRGB 'Linear) e -> Color (SRGB '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
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: Color (XYZ D65) a -> Color (SRGB 'Linear) e
fromColorXYZ = (a -> e) -> Color (SRGB 'Linear) a -> Color (SRGB 'Linear) e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat (Color (SRGB 'Linear) a -> Color (SRGB 'Linear) e)
-> (Color (XYZ D65) a -> Color (SRGB 'Linear) a)
-> Color (XYZ D65) a
-> Color (SRGB 'Linear) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (XYZ D65) a -> Color (SRGB '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` linear color space
instance Elevator e => ColorSpace (SRGB 'NonLinear) D65 e where
  type BaseModel (SRGB 'NonLinear) = CM.RGB
  toBaseSpace :: Color (SRGB 'NonLinear) e -> Color (BaseSpace (SRGB 'NonLinear)) e
toBaseSpace = Color (SRGB 'NonLinear) e -> Color (BaseSpace (SRGB 'NonLinear)) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: Color (BaseSpace (SRGB 'NonLinear)) e -> Color (SRGB 'NonLinear) e
fromBaseSpace = Color (BaseSpace (SRGB 'NonLinear)) e -> Color (SRGB 'NonLinear) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: Color (SRGB 'NonLinear) e -> Color (Y D65) a
luminance = Color (SRGB 'NonLinear) a -> Color (Y D65) 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 'NonLinear) a -> Color (Y D65) a)
-> (Color (SRGB 'NonLinear) e -> Color (SRGB 'NonLinear) a)
-> Color (SRGB 'NonLinear) e
-> Color (Y D65) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (SRGB 'NonLinear) e -> Color (SRGB 'NonLinear) 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 (SRGB 'NonLinear) e -> Color (XYZ D65) a
toColorXYZ = Color (SRGB 'NonLinear) a -> Color (XYZ D65) 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 'NonLinear) a -> Color (XYZ D65) a)
-> (Color (SRGB 'NonLinear) e -> Color (SRGB 'NonLinear) a)
-> Color (SRGB 'NonLinear) e
-> Color (XYZ D65) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> a) -> Color (SRGB 'NonLinear) e -> Color (SRGB 'NonLinear) 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 toColorXYZ #-}
  fromColorXYZ :: Color (XYZ D65) a -> Color (SRGB 'NonLinear) e
fromColorXYZ = (a -> e) -> Color (SRGB 'NonLinear) a -> Color (SRGB 'NonLinear) e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => a -> e
fromRealFloat (Color (SRGB 'NonLinear) a -> Color (SRGB 'NonLinear) e)
-> (Color (XYZ D65) a -> Color (SRGB 'NonLinear) a)
-> Color (XYZ D65) a
-> Color (SRGB 'NonLinear) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (XYZ D65) a -> Color (SRGB '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
instance RedGreenBlue SRGB D65 where
  gamut :: Gamut SRGB D65 e
gamut = Gamut BT709 D65 e -> Gamut SRGB D65 e
coerce (forall i e. (RedGreenBlue BT709 i, RealFloat e) => Gamut BT709 i e
forall k (cs :: Linearity -> *) (i :: k) e.
(RedGreenBlue cs i, RealFloat e) =>
Gamut cs i e
gamut @_ @BT709)
  npm :: NPM SRGB e
npm = M3x3 e -> NPM SRGB e
forall k (cs :: k) e. M3x3 e -> NPM cs e
NPM (M3x3 e -> NPM SRGB e) -> M3x3 e -> NPM SRGB e
forall a b. (a -> b) -> a -> b
$ V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
0.4124 e
0.3576 e
0.1805)
                   (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
0.2126 e
0.7152 e
0.0722)
                   (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
0.0193 e
0.1192 e
0.9505)
  inpm :: INPM SRGB e
inpm = M3x3 e -> INPM SRGB e
forall k (cs :: k) e. M3x3 e -> INPM cs e
INPM (M3x3 e -> INPM SRGB e) -> M3x3 e -> INPM SRGB e
forall a b. (a -> b) -> a -> b
$ V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
3.2406 e
-1.5372 e
-0.4986)
                     (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
-0.9689  e
1.8758  e
0.0415)
                     (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.0557 e
-0.2040  e
1.0570)
  transfer :: e -> e
transfer e
u
    | e
u e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
0.0031308 = e
12.92 e -> e -> e
forall a. Num a => a -> a -> a
* e
u
    | Bool
otherwise = e
1.055 e -> e -> e
forall a. Num a => a -> a -> a
* (e
u e -> e -> e
forall a. Floating a => a -> a -> a
** (e
1 e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
2.4)) e -> e -> e
forall a. Num a => a -> a -> a
- e
0.055
  {-# INLINE transfer #-}
  itransfer :: e -> e
itransfer e
u
    | e
u e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
0.04045 = e
u e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
12.92
    | Bool
otherwise = ((e
u e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.055) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
1.055) e -> e -> e
forall a. Floating a => a -> a -> a
** e
2.4
  {-# INLINE itransfer #-}

instance Luma SRGB where
  rWeight :: Weight SRGB e
rWeight = Weight SRGB e
0.299
  gWeight :: Weight SRGB e
gWeight = Weight SRGB e
0.587
  bWeight :: Weight SRGB e
bWeight = Weight SRGB e
0.114