{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module      : Graphics.Color.Space.CIE1976.LAB
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.CIE1976.LAB
  ( -- * Constructors for an CIE L*a*b* color space.
    pattern LAB
  , pattern ColorLAB
  , pattern ColorLABA
  , LAB
  ) where

import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Space.Internal

--------------
--- CIELAB ---
--------------

-- | [CIE L*a*b*](https://en.wikipedia.org/wiki/CIELAB_color_space) color space
data LAB (i :: k)

-- | Color in CIE L*a*b* color space
newtype instance Color (LAB i) e = LAB (V3 e)


pattern ColorLAB :: e -> e -> e -> Color (LAB i) e
pattern $bColorLAB :: e -> e -> e -> Color (LAB i) e
$mColorLAB :: forall r k e (i :: k).
Color (LAB i) e -> (e -> e -> e -> r) -> (Void# -> r) -> r
ColorLAB l' a' b' = LAB (V3 l' a' b')
{-# COMPLETE ColorLAB #-}

-- | Constructor for @LAB@ with alpha channel.
pattern ColorLABA :: e -> e -> e -> e -> Color (Alpha (LAB i)) e
pattern $bColorLABA :: e -> e -> e -> e -> Color (Alpha (LAB i)) e
$mColorLABA :: forall r k e (i :: k).
Color (Alpha (LAB i)) e
-> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
ColorLABA l' a' b' a = Alpha (LAB (V3 l' a' b')) a
{-# COMPLETE ColorLABA #-}

-- | CIE1976 `LAB` color space
deriving instance Eq e => Eq (Color (LAB i) e)

-- | CIE1976 `LAB` color space
deriving instance Ord e => Ord (Color (LAB i) e)

-- | CIE1976 `LAB` color space
deriving instance Functor (Color (LAB i))

-- | CIE1976 `LAB` color space
deriving instance Applicative (Color (LAB i))

-- | CIE1976 `LAB` color space
deriving instance Foldable (Color (LAB i))

-- | CIE1976 `LAB` color space
deriving instance Traversable (Color (LAB i))

-- | CIE1976 `LAB` color space
deriving instance Storable e => Storable (Color (LAB i) e)

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

-- | CIE1976 `LAB` color space
instance (Illuminant i, Elevator e) => ColorModel (LAB i) e where
  type Components (LAB i) e = (e, e, e)
  toComponents :: Color (LAB i) e -> Components (LAB i) e
toComponents (ColorLAB e
l' e
a' e
b') = (e
l', e
a', e
b')
  {-# INLINE toComponents #-}
  fromComponents :: Components (LAB i) e -> Color (LAB i) e
fromComponents (l', a', b') = e -> e -> e -> Color (LAB i) e
forall k e (i :: k). e -> e -> e -> Color (LAB i) e
ColorLAB e
l' e
a' e
b'
  {-# INLINE fromComponents #-}

instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (LAB (i :: k)) i e where
  type BaseModel (LAB i) = LAB i
  type BaseSpace (LAB i) = LAB i
  toBaseSpace :: Color (LAB i) e -> Color (BaseSpace (LAB i)) e
toBaseSpace = Color (LAB i) e -> Color (BaseSpace (LAB i)) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: Color (BaseSpace (LAB i)) e -> Color (LAB i) e
fromBaseSpace = Color (BaseSpace (LAB i)) e -> Color (LAB i) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: Color (LAB i) e -> Color (Y i) a
luminance (ColorLAB e
l' e
_ e
_) = a -> Color (Y i) a
forall k e (i :: k). e -> Color (Y i) e
Y (a -> a
forall a. (Fractional a, Ord a) => a -> a
ift (e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
scaleLightness e
l'))
  {-# INLINE luminance #-}
  toColorXYZ :: Color (LAB i) e -> Color (XYZ i) a
toColorXYZ = Color (LAB i) e -> Color (XYZ i) a
forall k (i :: k) a e.
(Illuminant i, Elevator e, Elevator a, RealFloat a) =>
Color (LAB i) e -> Color (XYZ i) a
lab2xyz
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: Color (XYZ i) a -> Color (LAB i) e
fromColorXYZ = Color (XYZ i) a -> Color (LAB i) e
forall k (i :: k) a e.
(Illuminant i, Elevator a, Elevator e, RealFloat e) =>
Color (XYZ i) a -> Color (LAB i) e
xyz2lab
  {-# INLINE fromColorXYZ #-}

lab2xyz ::
     forall i a e. (Illuminant i, Elevator e, Elevator a, RealFloat a)
  => Color (LAB i) e
  -> Color (XYZ i) a
lab2xyz :: Color (LAB i) e -> Color (XYZ i) a
lab2xyz (ColorLAB e
l' e
a' e
b') = a -> a -> a -> Color (XYZ i) a
forall k e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ a
x a
y a
z
  where
    !(ColorXYZ a
wx a
_ a
wz) = Color (XYZ i) a
forall k (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Color (XYZ i) e
whitePointTristimulus :: Color (XYZ i) a
    !l :: a
l = e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
scaleLightness e
l'
    !x :: a
x = a
wx a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. (Fractional a, Ord a) => a -> a
ift (a
l a -> a -> a
forall a. Num a => a -> a -> a
+ e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
a' a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
500)
    !y :: a
y = a -> a
forall a. (Fractional a, Ord a) => a -> a
ift a
l
    !z :: a
z = a
wz a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. (Fractional a, Ord a) => a -> a
ift (a
l a -> a -> a
forall a. Num a => a -> a -> a
- e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
b' a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
200)
{-# INLINE lab2xyz #-}

scaleLightness :: (Elevator e, Elevator a, RealFloat a) => e -> a
scaleLightness :: e -> a
scaleLightness e
l' = (e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
l' a -> a -> a
forall a. Num a => a -> a -> a
+ a
16) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
116
{-# INLINE scaleLightness #-}

ift :: (Fractional a, Ord a) => a -> a
ift :: a -> a
ift a
t
  | a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
6 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
29 = a
t a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
  | Bool
otherwise = (a
108 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
841) a -> a -> a
forall a. Num a => a -> a -> a
* (a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
4 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
29)



xyz2lab ::
     forall i a e. (Illuminant i, Elevator a, Elevator e, RealFloat e)
  => Color (XYZ i) a
  -> Color (LAB i) e
xyz2lab :: Color (XYZ i) a -> Color (LAB i) e
xyz2lab (ColorXYZ a
x a
y a
z) = e -> e -> e -> Color (LAB i) e
forall k e (i :: k). e -> e -> e -> Color (LAB i) e
ColorLAB e
l' e
a' e
b'
  where
    !(ColorXYZ e
wx e
_ e
wz) = Color (XYZ i) e
forall k (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Color (XYZ i) e
whitePointTristimulus :: Color (XYZ i) e
    !fx :: e
fx = e -> e
forall a. RealFloat a => a -> a
ft (a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
x e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
wx)
    !fy :: e
fy = e -> e
forall a. RealFloat a => a -> a
ft (a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
y)
    !fz :: e
fz = e -> e
forall a. RealFloat a => a -> a
ft (a -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
z e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
wz)
    !l' :: e
l' = e
116 e -> e -> e
forall a. Num a => a -> a -> a
* e
fy e -> e -> e
forall a. Num a => a -> a -> a
- e
16
    !a' :: e
a' = e
500 e -> e -> e
forall a. Num a => a -> a -> a
* (e
fx e -> e -> e
forall a. Num a => a -> a -> a
- e
fy)
    !b' :: e
b' = e
200 e -> e -> e
forall a. Num a => a -> a -> a
* (e
fy e -> e -> e
forall a. Num a => a -> a -> a
- e
fz)
{-# INLINE xyz2lab #-}

ft :: RealFloat a => a -> a
ft :: a -> a
ft a
t
  | a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
forall a. RealFloat a => a
t0 = a
t a -> a -> a
forall a. Floating a => a -> a -> a
** (a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3)
  | Bool
otherwise = a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. RealFloat a => a
m a -> a -> a
forall a. Num a => a -> a -> a
+ a
4 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
29
{-# INLINE ft #-}

m :: RealFloat a => a
m :: a
m = a
841 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
108

t0 :: RealFloat a => a
t0 :: a
t0 = a
216 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
24389
  -- where
  --   m = 1/3 * δ^-2 = 841/108 =~ 7.787[037]
  --   t0 = δ^3 =~ 0.008856
  --   δ = 6/29 =~ 0.2069