{-# 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.OKLAB
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.OKLAB
  ( -- * Constructors for an CIE L*a*b* color space.
    pattern OKLAB
  , pattern ColorOKLAB
  , pattern ColorOKLABA
  , OKLAB
  ) where

import Data.List.NonEmpty
import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Space.Internal
import Graphics.Color.Illuminant.ITU.Rec601 (D65)

--------------
--- OKLAB ---
--------------

-- | [OK L*a*b*](https://bottosson.github.io/posts/oklab/) color space
--
-- Values for matrices used in conversion to and from @CIEXYZ@ where taken from
-- [W3 CSS specification](https://www.w3.org/TR/css-color-4/#color-conversion-code) 
-- instead of the original blogpost about the OKLab color space.
data OKLAB

-- | Color in OK L*a*b* color space
newtype instance Color OKLAB e = OKLAB (V3 e)


pattern ColorOKLAB :: e -> e -> e -> Color OKLAB e
pattern $mColorOKLAB :: forall {r} {e}.
Color OKLAB e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorOKLAB :: forall e. e -> e -> e -> Color OKLAB e
ColorOKLAB l' a' b' = OKLAB (V3 l' a' b')
{-# COMPLETE ColorOKLAB #-}

-- | Constructor for @OKLAB@ with alpha channel.
pattern ColorOKLABA :: e -> e -> e -> e -> Color (Alpha OKLAB) e
pattern $mColorOKLABA :: forall {r} {e}.
Color (Alpha OKLAB) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorOKLABA :: forall e. e -> e -> e -> e -> Color (Alpha OKLAB) e
ColorOKLABA l' a' b' a = Alpha (OKLAB (V3 l' a' b')) a
{-# COMPLETE ColorOKLABA #-}

-- | `OKLAB` color space
deriving instance Eq e => Eq (Color OKLAB e)

-- | `OKLAB` color space
deriving instance Ord e => Ord (Color OKLAB e)

-- | `OKLAB` color space
deriving instance Functor (Color OKLAB)

-- | `OKLAB` color space
deriving instance Applicative (Color OKLAB)

-- | `OKLAB` color space
deriving instance Foldable (Color OKLAB)

-- | `OKLAB` color space
deriving instance Traversable (Color OKLAB)

-- | `OKLAB` color space
deriving instance Storable e => Storable (Color OKLAB e)

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

-- | `OKLAB` color space
instance (Elevator e) => ColorModel OKLAB e where
  type Components OKLAB e = (e, e, e)
  type ChannelCount OKLAB = 3
  channelCount :: Proxy (Color OKLAB e) -> Word8
channelCount Proxy (Color OKLAB e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color OKLAB e) -> NonEmpty String
channelNames Proxy (Color OKLAB e)
_ = String
"L*" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"a*", String
"b*"]
  channelColors :: Proxy (Color OKLAB e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color OKLAB 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
0xb5 Word8
0x00 Word8
0x5e    -- dark magenta
                  , Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x00 Word8
0x00 Word8
0x8b    -- dark gold
                  ]
  toComponents :: Color OKLAB e -> Components OKLAB e
toComponents (ColorOKLAB e
l' e
a' e
b') = (e
l', e
a', e
b')
  {-# INLINE toComponents #-}
  fromComponents :: Components OKLAB e -> Color OKLAB e
fromComponents (e
l', e
a', e
b') = e -> e -> e -> Color OKLAB e
forall e. e -> e -> e -> Color OKLAB e
ColorOKLAB e
l' e
a' e
b'
  {-# INLINE fromComponents #-}

instance (Elevator e, RealFloat e) => ColorSpace OKLAB D65 e where
  type BaseModel OKLAB = OKLAB
  type BaseSpace OKLAB = OKLAB
  toBaseSpace :: ColorSpace (BaseSpace OKLAB) D65 e =>
Color OKLAB e -> Color (BaseSpace OKLAB) e
toBaseSpace = Color OKLAB e -> Color (BaseSpace OKLAB) e
Color OKLAB e -> Color OKLAB e
forall a. a -> a
id
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace OKLAB) D65 e =>
Color (BaseSpace OKLAB) e -> Color OKLAB e
fromBaseSpace = Color (BaseSpace OKLAB) e -> Color OKLAB e
Color OKLAB e -> Color OKLAB e
forall a. a -> a
id
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color OKLAB e -> Color (Y D65) a
luminance Color OKLAB e
c = a -> Color (Y D65) a
forall {k} e (i :: k). e -> Color (Y i) e
Y (a -> Color (Y D65) a) -> a -> Color (Y D65) a
forall a b. (a -> b) -> a -> b
$ Color OKLAB e -> a
forall a e.
(Elevator e, Elevator a, RealFloat e, RealFloat a) =>
Color OKLAB e -> a
lab2luminance Color OKLAB e
c
  {-# INLINE luminance #-}
  toColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color OKLAB e -> Color (XYZ D65) a
toColorXYZ = Color OKLAB e -> Color (XYZ D65) a
forall a e.
(Elevator e, Elevator a, RealFloat e, RealFloat a) =>
Color OKLAB e -> Color (XYZ D65) a
lab2xyz
  {-# INLINE toColorXYZ #-}
  fromColorXYZ :: forall a.
(Elevator a, RealFloat a) =>
Color (XYZ D65) a -> Color OKLAB e
fromColorXYZ = Color (XYZ D65) a -> Color OKLAB e
forall a e.
(Elevator a, Elevator e, RealFloat a, RealFloat e) =>
Color (XYZ D65) a -> Color OKLAB e
xyz2lab
  {-# INLINE fromColorXYZ #-}
  grayscale :: Color OKLAB e -> Color X e
grayscale (ColorOKLAB e
l' e
_ e
_) = e -> Color X e
forall e. e -> Color X e
X e
l'
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color OKLAB e -> Color X e -> Color OKLAB e
replaceGrayscale (ColorOKLAB e
_ e
a' e
b') (X e
l') = e -> e -> e -> Color OKLAB e
forall e. e -> e -> e -> Color OKLAB e
ColorOKLAB e
l' e
a' e
b'
  {-# INLINE replaceGrayscale #-}

lab2luminance :: forall a e. (Elevator e, Elevator a, RealFloat e, RealFloat a)
  => Color OKLAB e
  -> a
lab2luminance :: forall a e.
(Elevator e, Elevator a, RealFloat e, RealFloat a) =>
Color OKLAB e -> a
lab2luminance (ColorOKLAB e
ll e
a e
b) = e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y
  where
    !l' :: e
l' = e
ll e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.3963377773761749 e -> e -> e
forall a. Num a => a -> a -> a
* e
a e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.2158037573099136 e -> e -> e
forall a. Num a => a -> a -> a
* e
b
    !m' :: e
m' = e
ll e -> e -> e
forall a. Num a => a -> a -> a
- e
0.1055613458156586 e -> e -> e
forall a. Num a => a -> a -> a
* e
a e -> e -> e
forall a. Num a => a -> a -> a
- e
0.0638541728258133 e -> e -> e
forall a. Num a => a -> a -> a
* e
b
    !s' :: e
s' = e
ll e -> e -> e
forall a. Num a => a -> a -> a
- e
0.0894841775298119 e -> e -> e
forall a. Num a => a -> a -> a
* e
a e -> e -> e
forall a. Num a => a -> a -> a
- e
1.2914855480194092 e -> e -> e
forall a. Num a => a -> a -> a
* e
b
    !l :: e
l = e
l' e -> Int -> e
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
    !m :: e
m = e
m' e -> Int -> e
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
    !s :: e
s = e
s' e -> Int -> e
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
    !y :: e
y = (-e
0.0405757452148008) e -> e -> e
forall a. Num a => a -> a -> a
* e
l e -> e -> e
forall a. Num a => a -> a -> a
+ e
1.1122868032803170 e -> e -> e
forall a. Num a => a -> a -> a
* e
m e -> e -> e
forall a. Num a => a -> a -> a
- e
0.0717110580655164 e -> e -> e
forall a. Num a => a -> a -> a
* e
s
{-# INLINE lab2luminance #-}

lab2xyz ::
     forall a e. (Elevator e, Elevator a, RealFloat e, RealFloat a)
  => Color OKLAB e
  -> Color (XYZ D65) a
lab2xyz :: forall a e.
(Elevator e, Elevator a, RealFloat e, RealFloat a) =>
Color OKLAB e -> Color (XYZ D65) a
lab2xyz (ColorOKLAB e
ll e
a e
b) = a -> a -> a -> Color (XYZ D65) a
forall {k} e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ a
rfX a
rfY a
rfZ
  where
    !l' :: e
l' = e
ll e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.3963377773761749 e -> e -> e
forall a. Num a => a -> a -> a
* e
a e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.2158037573099136 e -> e -> e
forall a. Num a => a -> a -> a
* e
b
    !m' :: e
m' = e
ll e -> e -> e
forall a. Num a => a -> a -> a
- e
0.1055613458156586 e -> e -> e
forall a. Num a => a -> a -> a
* e
a e -> e -> e
forall a. Num a => a -> a -> a
- e
0.0638541728258133 e -> e -> e
forall a. Num a => a -> a -> a
* e
b
    !s' :: e
s' = e
ll e -> e -> e
forall a. Num a => a -> a -> a
- e
0.0894841775298119 e -> e -> e
forall a. Num a => a -> a -> a
* e
a e -> e -> e
forall a. Num a => a -> a -> a
- e
1.2914855480194092 e -> e -> e
forall a. Num a => a -> a -> a
* e
b
    !l :: e
l = e
l' e -> Int -> e
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
    !m :: e
m = e
m' e -> Int -> e
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
    !s :: e
s = e
s' e -> Int -> e
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)
    !x :: e
x =  e
1.2268798758459243   e -> e -> e
forall a. Num a => a -> a -> a
* e
l e -> e -> e
forall a. Num a => a -> a -> a
- e
0.5578149944602171 e -> e -> e
forall a. Num a => a -> a -> a
* e
m e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.2813910456659647 e -> e -> e
forall a. Num a => a -> a -> a
* e
s
    !y :: e
y = (-e
0.0405757452148008) e -> e -> e
forall a. Num a => a -> a -> a
* e
l e -> e -> e
forall a. Num a => a -> a -> a
+ e
1.1122868032803170 e -> e -> e
forall a. Num a => a -> a -> a
* e
m e -> e -> e
forall a. Num a => a -> a -> a
- e
0.0717110580655164 e -> e -> e
forall a. Num a => a -> a -> a
* e
s
    !z :: e
z = (-e
0.0763729366746601) e -> e -> e
forall a. Num a => a -> a -> a
* e
l e -> e -> e
forall a. Num a => a -> a -> a
- e
0.4214933324022432 e -> e -> e
forall a. Num a => a -> a -> a
* e
m e -> e -> e
forall a. Num a => a -> a -> a
+ e
1.5869240198367816 e -> e -> e
forall a. Num a => a -> a -> a
* e
s
    !rfX :: a
rfX = e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
x
    !rfY :: a
rfY = e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
y
    !rfZ :: a
rfZ = e -> a
forall a. (Elevator a, RealFloat a) => e -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat e
z
{-# INLINE lab2xyz #-}

signedCubeRoot :: RealFloat e => e -> e
signedCubeRoot :: forall e. RealFloat e => e -> e
signedCubeRoot e
x =
  if e
x e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
0
    then -((-e
x) e -> e -> e
forall a. Floating a => a -> a -> a
** (e
1 e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
3))
    else e
x e -> e -> e
forall a. Floating a => a -> a -> a
** (e
1 e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
3)
{-# INLINE signedCubeRoot #-}

xyz2lab ::
     forall a e. (Elevator a, Elevator e, RealFloat a, RealFloat e)
  => Color (XYZ D65) a
  -> Color OKLAB e
xyz2lab :: forall a e.
(Elevator a, Elevator e, RealFloat a, RealFloat e) =>
Color (XYZ D65) a -> Color OKLAB e
xyz2lab (ColorXYZ a
x a
y a
z) = e -> e -> e -> Color OKLAB e
forall e. e -> e -> e -> Color OKLAB e
ColorOKLAB e
rfL e
rfA e
rfB
  where
    !l :: a
l = a
0.8190224379967030 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.3619062600528904 a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
0.1288737815209879 a -> a -> a
forall a. Num a => a -> a -> a
* a
z
    !m :: a
m = a
0.0329836539323885 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.9292868615863434 a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.0361446663506424 a -> a -> a
forall a. Num a => a -> a -> a
* a
z
    !s :: a
s = a
0.0481771893596242 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.2642395317527308 a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.6335478284694309 a -> a -> a
forall a. Num a => a -> a -> a
* a
z
    !l' :: a
l' = a -> a
forall e. RealFloat e => e -> e
signedCubeRoot a
l
    !m' :: a
m' = a -> a
forall e. RealFloat e => e -> e
signedCubeRoot a
m
    !s' :: a
s' = a -> a
forall e. RealFloat e => e -> e
signedCubeRoot a
s
    !ll :: a
ll = a
0.2104542683093140 a -> a -> a
forall a. Num a => a -> a -> a
* a
l' a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.7936177747023054 a -> a -> a
forall a. Num a => a -> a -> a
* a
m' a -> a -> a
forall a. Num a => a -> a -> a
- a
0.0040720430116193 a -> a -> a
forall a. Num a => a -> a -> a
* a
s'
    !a :: a
a  = a
1.9779985324311684 a -> a -> a
forall a. Num a => a -> a -> a
* a
l' a -> a -> a
forall a. Num a => a -> a -> a
- a
2.4285922420485799 a -> a -> a
forall a. Num a => a -> a -> a
* a
m' a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.4505937096174110 a -> a -> a
forall a. Num a => a -> a -> a
* a
s'
    !b :: a
b  = a
0.0259040424655478 a -> a -> a
forall a. Num a => a -> a -> a
* a
l' a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.7827717124575296 a -> a -> a
forall a. Num a => a -> a -> a
* a
m' a -> a -> a
forall a. Num a => a -> a -> a
- a
0.8086757549230774 a -> a -> a
forall a. Num a => a -> a -> a
* a
s'
    !rfL :: e
rfL = a -> e
forall a. (Elevator a, RealFloat a) => a -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
ll
    !rfA :: e
rfA = a -> e
forall a. (Elevator a, RealFloat a) => a -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
a
    !rfB :: e
rfB = a -> e
forall a. (Elevator a, RealFloat a) => a -> a
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat a
b
{-# INLINE xyz2lab #-}