{-# 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.CIE1976.LAB.LCH

module Graphics.Color.Space.CIE1976.LAB.LCH
  ( pattern ColorLCHab
  , pattern ColorLCHabA
  , LCHab
  , Color(LCHab)
  ) where

import Data.List.NonEmpty
import Data.Coerce
import Data.Proxy
import Foreign.Storable
import qualified Graphics.Color.Model.LCH as CM
import Graphics.Color.Space.CIE1976.LAB
import Graphics.Color.Model.Internal
import Graphics.Color.Space.Internal

-- | [CIE L*C*Hab](https://en.wikipedia.org/wiki/CIELAB_color_space),
--   an LCH representation for the L*a*b* color space
data LCHab (i :: k)

-- | Color in CIE L*C*Hab color space
newtype instance Color (LCHab i) e = LCHab (Color CM.LCH e)

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

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

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

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

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

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

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

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

-- | Constructor for a CIEL*a*b* color space in a cylindrical L*C*h parameterization
pattern ColorLCHab :: e -> e -> e -> Color (LCHab i) e
pattern $mColorLCHab :: forall {r} {k} {e} {i :: k}.
Color (LCHab i) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLCHab :: forall {k} e (i :: k). e -> e -> e -> Color (LCHab i) e
ColorLCHab l c h = LCHab (CM.ColorLCH l c h)
{-# COMPLETE ColorLCHab #-}

-- | Constructor for a @LCHab@ with alpha
pattern ColorLCHabA :: e -> e -> e -> e -> Color (Alpha (LCHab i)) e
pattern $mColorLCHabA :: forall {r} {k} {e} {i :: k}.
Color (Alpha (LCHab i)) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLCHabA :: forall {k} e (i :: k).
e -> e -> e -> e -> Color (Alpha (LCHab i)) e
ColorLCHabA l c h a = Alpha (LCHab (CM.ColorLCH l c h)) a
{-# COMPLETE ColorLCHabA #-}

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

instance (Illuminant i, Elevator e, ColorSpace (LAB i) i e) => ColorSpace (LCHab i) i e where
  type BaseModel (LCHab i) = CM.LCH
  type BaseSpace (LCHab i) = LAB i
  toBaseSpace :: ColorSpace (BaseSpace (LCHab i)) i e =>
Color (LCHab i) e -> Color (BaseSpace (LCHab i)) e
toBaseSpace (LCHab Color LCH e
lch) = (Double -> e) -> Color (LAB i) Double -> Color (LAB i) e
forall a b. (a -> b) -> Color (LAB i) a -> Color (LAB i) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> e
forall e. Elevator e => Double -> e
fromDouble (Color (LAB i) Double -> Color (BaseSpace (LCHab i)) e)
-> (Color LCH e -> Color (LAB i) Double)
-> Color LCH e
-> Color (BaseSpace (LCHab i)) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double) -> Color (LAB i) Double
Components (LAB i) Double -> Color (LAB i) Double
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents ((Double, Double, Double) -> Color (LAB i) Double)
-> (Color LCH e -> (Double, Double, Double))
-> Color LCH e
-> Color (LAB i) 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 (LCHab i)) e)
-> Color LCH e -> Color (BaseSpace (LCHab i)) e
forall a b. (a -> b) -> a -> b
$ Color LCH e
lch
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (LCHab i)) i e =>
Color (BaseSpace (LCHab i)) e -> Color (LCHab i) e
fromBaseSpace = Color LCH e -> Color (LCHab i) e
forall k (i :: k) e. Color LCH e -> Color (LCHab i) e
LCHab (Color LCH e -> Color (LCHab i) e)
-> (Color (LAB i) e -> Color LCH e)
-> Color (LAB i) e
-> Color (LCHab i) 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 (LAB i) e -> Color LCH Double)
-> Color (LAB i) 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 (LAB i) e -> (Double, Double, Double))
-> Color (LAB i) e
-> Color LCH Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LAB i) Double -> (Double, Double, Double)
Color (LAB i) Double -> Components (LAB i) Double
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color (LAB i) Double -> (Double, Double, Double))
-> (Color (LAB i) e -> Color (LAB i) Double)
-> Color (LAB i) e
-> (Double, Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color (LAB i) e -> Color (LAB i) Double
forall a b. (a -> b) -> Color (LAB i) a -> Color (LAB i) 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 (LCHab i) e -> Color (Y i) a
luminance = Color (LAB i) e -> Color (Y i) a
forall a.
(Elevator a, RealFloat a) =>
Color (LAB i) e -> Color (Y i) 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 (LAB i) e -> Color (Y i) a)
-> (Color (LCHab i) e -> Color (LAB i) e)
-> Color (LCHab i) e
-> Color (Y i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LCHab i) e -> Color (BaseSpace (LCHab i)) e
Color (LCHab i) e -> Color (LAB i) 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 (LCHab i) e -> Color X e
grayscale (Color (LCHab 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 (LCHab i) e -> Color X e -> Color (LCHab i) e
replaceGrayscale (Color (LCHab 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 (LCHab 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 #-}