{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# 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-2025
-- 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
    -- * Helpers
    -- ** XYZ to L*a*b*
  , xyz2lab
  , ft
    -- ** L*a*b* to XYZ
  , lab2xyz
  , ift
  ) where

import Data.List.NonEmpty
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
--
-- It is customary to have CIELAB color channels to be in range of [0, 100], however in
-- this library all values for consistency are kept in a [0, 1] range for floating point
-- precision.
--
-- Conversion from `XYZ` (`xyz2lab`):
--
-- \[
-- \begin{align}
--   L^\star &= 1.16 \  f\!\left(\frac{Y}{Y_{\mathrm{n}}}\right) - 0.16\\
--   a^\star &= 5.0 \left(f\!\left(\frac{X}{X_{\mathrm{n}}}\right) - f\!\left(\frac{Y}{Y_{\mathrm{n}}}\right)\right)\\
--   b^\star &= 2.0 \left(f\!\left(\frac{Y}{Y_{\mathrm{n}}}\right) - f\!\left(\frac{Z}{Z_{\mathrm{n}}}\right)\right)
-- \end{align}
-- \]
--
-- Where `ft` is defined as:
--
-- \[
-- \begin{align}
--   f(t) &= \begin{cases}
--     \sqrt[3]{t} & \text{if } t > \delta^3 \\
--     \dfrac{t}{3 \delta^2} + \frac{4}{29} & \text{otherwise}
--   \end{cases} \\
--   \delta &= \tfrac{6}{29}
-- \end{align}
-- \]
--
-- Conversion to `XYZ` (`lab2xyz`):
--
-- \[
-- \begin{align}
--   X &= X_{\mathrm{n}} f^{-1}\left(\frac{L^\star+0.16}{1.16} + \frac{a^\star}{5.0}\right)\\
--   Y &= Y_{\mathrm{n}} f^{-1}\left(\frac{L^\star+0.16}{1.16}\right)\\
--   Z &= Z_{\mathrm{n}} f^{-1}\left(\frac{L^\star+0.16}{1.16} - \frac{b^\star}{2.0}\right)\\
-- \end{align}
-- \]
--
-- Where `ift` is defined as:
--
-- \[
-- f^{-1}(t) = \begin{cases}
--   t^3 & \text{if } t > \delta \\
--   3\delta^2\left(t - \tfrac{4}{29}\right) & \text{otherwise}
-- \end{cases}
-- \]
--
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 $mColorLAB :: forall {r} {k} {e} {i :: k}.
Color (LAB i) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLAB :: forall {k} e (i :: k). e -> e -> e -> Color (LAB i) e
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 $mColorLABA :: forall {r} {k} {e} {i :: k}.
Color (Alpha (LAB i)) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLABA :: forall {k} e (i :: k). e -> e -> e -> e -> Color (Alpha (LAB i)) e
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)
  type ChannelCount (LAB i) = 3
  channelCount :: Proxy (Color (LAB i) e) -> Word8
channelCount Proxy (Color (LAB i) e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (LAB i) e) -> NonEmpty String
channelNames Proxy (Color (LAB i) e)
_ = String
"L*" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"a*", String
"b*"]
  channelColors :: Proxy (Color (LAB i) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (LAB 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
:| -- gray
                  [ Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x00 Word8
0x64 Word8
0x00    -- dark green
                  , Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x00 Word8
0x00 Word8
0x8b    -- dark blue
                  ]
  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 (e
l', e
a', e
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 :: ColorSpace (BaseSpace (LAB i)) i e =>
Color (LAB i) e -> Color (BaseSpace (LAB i)) e
toBaseSpace = Color (LAB i) e -> Color (BaseSpace (LAB i)) e
Color (LAB i) e -> Color (LAB i) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (LAB i)) i e =>
Color (BaseSpace (LAB i)) e -> Color (LAB i) e
fromBaseSpace = Color (BaseSpace (LAB i)) e -> Color (LAB i) e
Color (LAB i) e -> Color (LAB i) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
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 #-}
  grayscale :: Color (LAB i) e -> Color X e
grayscale (ColorLAB e
l' e
_ e
_) = e -> Color X e
forall e. e -> Color X e
X e
l'
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color (LAB i) e -> Color X e -> Color (LAB i) e
replaceGrayscale (ColorLAB e
_ e
a' e
b') (X e
l') = 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 replaceGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
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 :: forall a.
(Elevator a, RealFloat a) =>
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 :: forall {k} (i :: k) a e.
(Illuminant i, Elevator e, Elevator a, RealFloat a) =>
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 a. (Elevator a, RealFloat 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
5)
    !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 a. (Elevator a, RealFloat 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
2)
{-# INLINE lab2xyz #-}

scaleLightness :: (Elevator e, Elevator a, RealFloat a) => e -> a
scaleLightness :: forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
scaleLightness e
l' = (e -> a
forall a. (Elevator a, RealFloat a) => 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
0.16) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
1.16
{-# INLINE scaleLightness #-}

ift :: (Fractional a, Ord a) => a -> a
ift :: forall a. (Fractional a, Ord a) => 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)
{-# INLINE ift #-}


xyz2lab ::
     forall i a e. (Illuminant i, Elevator a, Elevator e, RealFloat e)
  => Color (XYZ i) a
  -> Color (LAB i) e
xyz2lab :: forall {k} (i :: k) a e.
(Illuminant i, Elevator a, Elevator e, RealFloat e) =>
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 a. (Elevator a, RealFloat a) => a -> a
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 a. (Elevator a, RealFloat a) => a -> a
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 a. (Elevator a, RealFloat a) => a -> a
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
1.16 e -> e -> e
forall a. Num a => a -> a -> a
* e
fy e -> e -> e
forall a. Num a => a -> a -> a
- e
0.16
    !a' :: e
a' = e
5 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
2 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 :: forall a. RealFloat a => 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 :: forall a. RealFloat a => a
m = a
841 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
108

t0 :: RealFloat a => a
t0 :: forall a. RealFloat a => 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