{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module: Graphics.Color.Space.OKLAB.LCH

module Graphics.Color.Space.OKLAB.LCH
  ( pattern ColorOKLCH
  , pattern ColorOKLCHA
  , OKLCH
  , Color(OKLCH)
  ) where

import Data.Coerce
import Data.List.NonEmpty
import Data.Proxy
import Foreign.Storable
import qualified Graphics.Color.Model.LCH as CM
import Graphics.Color.Space.OKLAB
import Graphics.Color.Model.Internal
import Graphics.Color.Space.Internal
import Graphics.Color.Illuminant.ITU.Rec601 (D65)

-- | [OK L*C*H*](https://bottosson.github.io/posts/oklab/) color space
--   an LCH representation for the L*a*b* color space
data OKLCH

-- | Color in OKLCH color space
newtype instance Color OKLCH e = OKLCH (Color CM.LCH e)

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

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

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

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

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

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

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

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

-- | Constructor for a OKL*a*b* color space in a cylindrical L*C*h parameterization
pattern ColorOKLCH :: e -> e -> e -> Color OKLCH e
pattern $mColorOKLCH :: forall {r} {e}.
Color OKLCH e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorOKLCH :: forall e. e -> e -> e -> Color OKLCH e
ColorOKLCH l c h = OKLCH (CM.ColorLCH l c h)
{-# COMPLETE ColorOKLCH #-}

-- | Constructor for a @OKLCH@ with alpha
pattern ColorOKLCHA :: e -> e -> e -> e -> Color (Alpha OKLCH) e
pattern $mColorOKLCHA :: forall {r} {e}.
Color (Alpha OKLCH) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorOKLCHA :: forall e. e -> e -> e -> e -> Color (Alpha OKLCH) e
ColorOKLCHA l c h a = Alpha (OKLCH (CM.ColorLCH l c h)) a
{-# COMPLETE ColorOKLCHA #-}

-- | `OKLCH` color space
instance (Elevator e, ColorModel OKLAB e) => ColorModel OKLCH e where
  type Components OKLCH e = (e, e, e)
  type ChannelCount OKLCH = 3
  channelCount :: Proxy (Color OKLCH e) -> Word8
channelCount Proxy (Color OKLCH e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color OKLCH e) -> NonEmpty String
channelNames Proxy (Color OKLCH e)
_ = String
"L" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"Cab", String
"Hab"]
  channelColors :: Proxy (Color OKLCH e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color OKLCH 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
0xff Word8
0x31 Word8
0x8e
                  , Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x66 Word8
0x66 Word8
0xff
                  ]
  toComponents :: Color OKLCH e -> Components OKLCH e
toComponents (OKLCH Color LCH e
lch) = Color LCH e -> Components LCH e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents Color LCH e
lch
  {-# INLINE toComponents #-}
  fromComponents :: Components OKLCH e -> Color OKLCH e
fromComponents = Color LCH e -> Color OKLCH e
forall e. Color LCH e -> Color OKLCH e
OKLCH (Color LCH e -> Color OKLCH e)
-> ((e, e, e) -> Color LCH e) -> (e, e, e) -> Color OKLCH e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e, e, e) -> Color LCH e
Components LCH e -> Color LCH e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents
  {-# INLINE fromComponents #-}
  showsColorModelName :: Proxy (Color OKLCH e) -> ShowS
showsColorModelName Proxy (Color OKLCH e)
_ =
    (String
"LCH-"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (Color OKLAB e) -> ShowS
forall cs e. ColorModel cs e => Proxy (Color cs e) -> ShowS
showsColorModelName (Proxy (Color OKLAB e)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Color OKLAB e))

instance (Elevator e, ColorSpace OKLAB D65 e) => ColorSpace OKLCH D65 e where
  type BaseModel OKLCH = CM.LCH
  type BaseSpace OKLCH = OKLAB
  toBaseSpace :: ColorSpace (BaseSpace OKLCH) D65 e =>
Color OKLCH e -> Color (BaseSpace OKLCH) e
toBaseSpace (OKLCH Color LCH e
lch) = (Double -> e) -> Color OKLAB Double -> Color OKLAB e
forall a b. (a -> b) -> Color OKLAB a -> Color OKLAB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> e
forall e. Elevator e => Double -> e
fromDouble (Color OKLAB Double -> Color (BaseSpace OKLCH) e)
-> (Color LCH e -> Color OKLAB Double)
-> Color LCH e
-> Color (BaseSpace OKLCH) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double) -> Color OKLAB Double
Components OKLAB Double -> Color OKLAB Double
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents ((Double, Double, Double) -> Color OKLAB Double)
-> (Color LCH e -> (Double, Double, Double))
-> Color LCH e
-> Color OKLAB Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color LCH Double -> (Double, Double, Double)
Color LCH Double -> Components LCH Double
CM.lch2lxy (Color LCH Double -> (Double, Double, Double))
-> (Color LCH e -> Color LCH Double)
-> Color LCH e
-> (Double, Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color LCH e -> Color LCH Double
forall a b. (a -> b) -> Color LCH a -> Color LCH b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Double
forall e. Elevator e => e -> Double
toDouble (Color LCH e -> Color (BaseSpace OKLCH) e)
-> Color LCH e -> Color (BaseSpace OKLCH) e
forall a b. (a -> b) -> a -> b
$ Color LCH e
lch
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace OKLCH) D65 e =>
Color (BaseSpace OKLCH) e -> Color OKLCH e
fromBaseSpace = Color LCH e -> Color OKLCH e
forall e. Color LCH e -> Color OKLCH e
OKLCH (Color LCH e -> Color OKLCH e)
-> (Color OKLAB e -> Color LCH e) -> Color OKLAB e -> Color OKLCH e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> e) -> Color LCH Double -> Color LCH e
forall a b. (a -> b) -> Color LCH a -> Color LCH b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> e
forall e. Elevator e => Double -> e
fromDouble (Color LCH Double -> Color LCH e)
-> (Color OKLAB e -> Color LCH Double)
-> Color OKLAB e
-> Color LCH e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double) -> Color LCH Double
Components LCH Double -> Color LCH Double
CM.lxy2lch ((Double, Double, Double) -> Color LCH Double)
-> (Color OKLAB e -> (Double, Double, Double))
-> Color OKLAB e
-> Color LCH Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color OKLAB Double -> (Double, Double, Double)
Color OKLAB Double -> Components OKLAB Double
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color OKLAB Double -> (Double, Double, Double))
-> (Color OKLAB e -> Color OKLAB Double)
-> Color OKLAB e
-> (Double, Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color OKLAB e -> Color OKLAB Double
forall a b. (a -> b) -> Color OKLAB a -> Color OKLAB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Double
forall e. Elevator e => e -> Double
toDouble
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color OKLCH e -> Color (Y D65) a
luminance = Color OKLAB e -> Color (Y D65) a
forall a.
(Elevator a, RealFloat a) =>
Color OKLAB e -> Color (Y D65) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (Y i) a
luminance (Color OKLAB e -> Color (Y D65) a)
-> (Color OKLCH e -> Color OKLAB e)
-> Color OKLCH e
-> Color (Y D65) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color OKLCH e -> Color (BaseSpace OKLCH) e
Color OKLCH e -> Color OKLAB e
forall k cs (i :: k) e.
(ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) =>
Color cs e -> Color (BaseSpace cs) e
toBaseSpace
  {-# INLINE luminance #-}
  grayscale :: Color OKLCH e -> Color X e
grayscale (Color OKLCH 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 OKLCH e -> Color X e -> Color OKLCH e
replaceGrayscale (Color OKLCH e -> V3 e
forall a b. Coercible a b => a -> b
coerce -> V3 e
_ e
c e
h) (X e
l) = V3 e -> Color OKLCH 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 #-}