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

-- |
-- Module: Graphics.Color.Space.CIE1976.LAB.LCH

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

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 $bColorLCHab :: e -> e -> e -> Color (LCHab i) e
$mColorLCHab :: forall r k e (i :: k).
Color (LCHab i) e -> (e -> e -> e -> r) -> (Void# -> r) -> r
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 $bColorLCHabA :: e -> e -> e -> e -> Color (Alpha (LCHab i)) e
$mColorLCHabA :: forall r k e (i :: k).
Color (Alpha (LCHab i)) e
-> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
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)
  toComponents :: Color (LCHab i) e -> Components (LCHab i) e
toComponents = Color LCH e -> (e, e, e)
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color LCH e -> (e, e, e))
-> (Color (LCHab i) e -> Color LCH e)
-> Color (LCHab i) e
-> (e, e, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LCHab i) e -> Color LCH e
coerce
  {-# INLINE toComponents #-}
  fromComponents :: Components (LCHab i) e -> Color (LCHab i) e
fromComponents = Color LCH e -> Color (LCHab i) e
coerce (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
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 :: Color (LCHab i) e -> Color (BaseSpace (LCHab i)) e
toBaseSpace = (Double -> e) -> Color (LAB i) Double -> Color (LAB i) e
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 (LAB i) e)
-> (Color (LCHab i) e -> Color (LAB i) Double)
-> Color (LCHab i) e
-> Color (LAB i) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, 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 (LCHab i) e -> (Double, Double, Double))
-> Color (LCHab i) 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 (LCHab i) e -> Color LCH Double)
-> Color (LCHab i) e
-> (Double, Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color LCH e -> Color LCH Double
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 LCH Double)
-> (Color (LCHab i) e -> Color LCH e)
-> Color (LCHab i) e
-> Color LCH Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LCHab i) e -> Color LCH e
coerce
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: Color (BaseSpace (LCHab i)) e -> Color (LCHab i) e
fromBaseSpace = Color LCH e -> Color (LCHab i) e
coerce (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 (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)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Double
forall e. Elevator e => e -> Double
toDouble
  {-# INLINE fromBaseSpace #-}
  luminance :: Color (LCHab i) e -> Color (Y i) a
luminance = 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 (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 #-}