{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module      : Graphics.Color.Space.CIE1976.LUV
--
module Graphics.Color.Space.CIE1976.LUV
  ( -- * Constructors for an CIE L*u*v* color space.
    pattern LUV
  , pattern ColorLUV
  , pattern ColorLUVA
  , LUV
  ) where

import Data.Coerce
import Data.List.NonEmpty
import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Space.Internal

--------------
--- CIELUV ---
--------------

-- | [CIE L*u*v*](https://en.wikipedia.org/wiki/CIELUV_color_space) color space
data LUV (i :: k)

-- | Color in CIE L*u*v* color space
newtype instance Color (LUV i) e = LUV (V3 e)


pattern ColorLUV :: e -> e -> e -> Color (LUV i) e
pattern $mColorLUV :: forall {r} {k} {e} {i :: k}.
Color (LUV i) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLUV :: forall {k} e (i :: k). e -> e -> e -> Color (LUV i) e
ColorLUV l' u' v' = LUV (V3 l' u' v')
{-# COMPLETE ColorLUV #-}

-- | Constructor for @LUV@ with alpha channel.
pattern ColorLUVA :: e -> e -> e -> e -> Color (Alpha (LUV i)) e
pattern $mColorLUVA :: forall {r} {k} {e} {i :: k}.
Color (Alpha (LUV i)) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLUVA :: forall {k} e (i :: k). e -> e -> e -> e -> Color (Alpha (LUV i)) e
ColorLUVA l' u' v' a = Alpha (LUV (V3 l' u' v')) a
{-# COMPLETE ColorLUVA #-}

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

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

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

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

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

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

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

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

-- | CIE1976 `LUV` color space
instance (Illuminant i, Elevator e) => ColorModel (LUV i) e where
  type Components (LUV i) e = (e, e, e)
  type ChannelCount (LUV i) = 3
  channelCount :: Proxy (Color (LUV i) e) -> Word8
channelCount Proxy (Color (LUV i) e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (LUV i) e) -> NonEmpty String
channelNames Proxy (Color (LUV i) e)
_ = String
"L" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"U", String
"V"]
  channelColors :: Proxy (Color (LUV i) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (LUV 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
:|
                  [ Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x00 Word8
0xff Word8
0xff
                  , Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x00 Word8
0x00 Word8
0x00
                  ]
  toComponents :: Color (LUV i) e -> Components (LUV i) e
toComponents (ColorLUV e
l' e
u' e
v') = (e
l', e
u', e
v')
  {-# INLINE toComponents #-}
  fromComponents :: Components (LUV i) e -> Color (LUV i) e
fromComponents (e
l', e
u', e
v') = e -> e -> e -> Color (LUV i) e
forall {k} e (i :: k). e -> e -> e -> Color (LUV i) e
ColorLUV e
l' e
u' e
v'
  {-# INLINE fromComponents #-}

instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (LUV (i :: k)) i e where
  type BaseModel (LUV i) = LUV i
  type BaseSpace (LUV i) = LUV i
  toBaseSpace :: ColorSpace (BaseSpace (LUV i)) i e =>
Color (LUV i) e -> Color (BaseSpace (LUV i)) e
toBaseSpace = Color (LUV i) e -> Color (BaseSpace (LUV i)) e
Color (LUV i) e -> Color (LUV i) e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (LUV i)) i e =>
Color (BaseSpace (LUV i)) e -> Color (LUV i) e
fromBaseSpace = Color (BaseSpace (LUV i)) e -> Color (LUV i) e
Color (LUV i) e -> Color (LUV i) e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (LUV i) e -> Color (Y i) a
luminance (ColorLUV 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 (LUV i) e -> Color X e
grayscale (Color (LUV i) e -> V3 e
forall a b. Coercible a b => a -> b
coerce -> V3 e
l e
_ e
_) = e -> Color X e
forall e. e -> Color X e
X e
l
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color (LUV i) e -> Color X e -> Color (LUV i) e
replaceGrayscale (Color (LUV i) e -> V3 e
forall a b. Coercible a b => a -> b
coerce -> V3 e
_ e
c e
h) (X e
l) = V3 e -> Color (LUV i) e
forall a b. Coercible a b => a -> b
coerce (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
l e
c e
h)
  {-# INLINE replaceGrayscale #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (LUV i) e -> Color (XYZ i) a
toColorXYZ = Color (LUV i) e -> Color (XYZ i) a
forall {k} (i :: k) a e.
(Illuminant i, Elevator e, Elevator a, RealFloat a) =>
Color (LUV i) e -> Color (XYZ i) a
luv2xyz
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color (LUV i) e
fromColorXYZ = Color (XYZ i) a -> Color (LUV i) e
forall {k} (i :: k) a e.
(Illuminant i, Elevator a, Elevator e, RealFloat e) =>
Color (XYZ i) a -> Color (LUV i) e
xyz2luv
  {-# INLINE fromColorXYZ #-}

luv2xyz ::
     forall i a e. (Illuminant i, Elevator e, Elevator a, RealFloat a)
  => Color (LUV i) e
  -> Color (XYZ i) a
luv2xyz :: forall {k} (i :: k) a e.
(Illuminant i, Elevator e, Elevator a, RealFloat a) =>
Color (LUV i) e -> Color (XYZ i) a
luv2xyz (ColorLUV e
l' e
u' e
v') = 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
    !y :: a
y = a -> a
forall a. (Fractional a, Ord a) => a -> a
ift (a -> a) -> (e -> a) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
scaleLightness (e -> a) -> e -> a
forall a b. (a -> b) -> a -> b
$ e
l'
    !wxyz :: a
wxyz = a
wx a -> a -> a
forall a. Num a => a -> a -> a
+ a
15 a -> a -> a
forall a. Num a => a -> a -> a
+ a
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
wz
    !l1 :: a
l1 = a
13 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
l'
    !a :: a
a = (a
1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
3) a -> a -> a
forall a. Num a => a -> a -> a
* ((a
4 a -> a -> a
forall a. Num a => a -> a -> a
* a
l1 a -> a -> a
forall a. Fractional 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
u' a -> a -> a
forall a. Num a => a -> a -> a
+ a
l1 a -> a -> a
forall a. Num a => a -> a -> a
* a
4 a -> a -> a
forall a. Num a => a -> a -> a
* (a
wx a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
wxyz))) a -> a -> a
forall a. Num a => a -> a -> a
- a
1) :: a
    !b :: a
b = -a
5 a -> a -> a
forall a. Num a => a -> a -> a
* a
y
    !c :: a
c = -a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
    !d :: a
d = a
y a -> a -> a
forall a. Num a => a -> a -> a
* (a
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
l1 a -> a -> a
forall a. Fractional 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
v' a -> a -> a
forall a. Num a => a -> a -> a
+ a
l1 a -> a -> a
forall a. Num a => a -> a -> a
* a
9 a -> a -> a
forall a. Num a => a -> a -> a
* (a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
wxyz)) a -> a -> a
forall a. Num a => a -> a -> a
- a
5) :: a
    !x :: a
x = (a
d a -> a -> a
forall a. Num a => a -> a -> a
- a
b) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
c)
    !z :: a
z = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
b
{-# INLINE luv2xyz #-}

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
16) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
116
{-# 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)


xyz2luv ::
     forall i a e. (Illuminant i, Elevator a, Elevator e, RealFloat e)
  => Color (XYZ i) a
  -> Color (LUV i) e
xyz2luv :: forall {k} (i :: k) a e.
(Illuminant i, Elevator a, Elevator e, RealFloat e) =>
Color (XYZ i) a -> Color (LUV i) e
xyz2luv (ColorXYZ a
x a
y a
z) = e -> e -> e -> Color (LUV i) e
forall {k} e (i :: k). e -> e -> e -> Color (LUV i) e
ColorLUV e
l' e
u' e
v'
  where
    !l' :: e
l' = e
116 e -> e -> e
forall a. Num a => a -> a -> a
* 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) e -> e -> e
forall a. Num a => a -> a -> a
- e
16
    !(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
    !xyz :: e
xyz = a -> e
forall a. (Elevator a, RealFloat a) => a -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat (a -> e) -> a -> e
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
15 a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
z
    !wxyz :: e
wxyz = e
wx e -> e -> e
forall a. Num a => a -> a -> a
+ e
15 e -> e -> e
forall a. Num a => a -> a -> a
+ e
3 e -> e -> e
forall a. Num a => a -> a -> a
* e
wz
    !u' :: e
u' = e
13 e -> e -> e
forall a. Num a => a -> a -> a
* e
l' e -> e -> e
forall a. Num a => a -> a -> a
* e
4 e -> e -> e
forall a. Num a => a -> a -> a
* (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
xyz e -> e -> e
forall a. Num a => a -> a -> a
- e
wx e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
wxyz)
    !v' :: e
v' = e
13 e -> e -> e
forall a. Num a => a -> a -> a
* e
l' e -> e -> e
forall a. Num a => a -> a -> a
* e
9 e -> e -> e
forall a. Num a => a -> a -> a
* (a -> e
forall a. (Elevator a, RealFloat a) => a -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
y e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
xyz e -> e -> e
forall a. Num a => a -> a -> a
- e
1 e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
wxyz)
{-# INLINE xyz2luv #-}

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