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

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

module Graphics.Color.Space.CIE1976.LUV.LCH
  ( pattern ColorLCHuv
  , pattern ColorLCHuvA
  , LCHuv
  , Color(LCHuv)
  ) where

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

-- | [CIE L*C*Huv](https://en.wikipedia.org/wiki/CIELUV_color_space),
--   an LCH representation for the L*u*v* color space
data LCHuv (i :: k)

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

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

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

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

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

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

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

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

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

-- | Constructor for a CIEL*u*v* color space in a cylindrical L*C*h parameterization
pattern ColorLCHuv :: e -> e -> e -> Color (LCHuv i) e
pattern $bColorLCHuv :: e -> e -> e -> Color (LCHuv i) e
$mColorLCHuv :: forall r k e (i :: k).
Color (LCHuv i) e -> (e -> e -> e -> r) -> (Void# -> r) -> r
ColorLCHuv l c h = LCHuv (CM.ColorLCH l c h)
{-# COMPLETE ColorLCHuv #-}

-- | Constructor for a @LCHuv@ with alpha
pattern ColorLCHuvA :: e -> e -> e -> e -> Color (Alpha (LCHuv i)) e
pattern $bColorLCHuvA :: e -> e -> e -> e -> Color (Alpha (LCHuv i)) e
$mColorLCHuvA :: forall r k e (i :: k).
Color (Alpha (LCHuv i)) e
-> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
ColorLCHuvA l c h a = Alpha (LCHuv (CM.ColorLCH l c h)) a
{-# COMPLETE ColorLCHuvA #-}

-- | CIE1976 `LCHuv` color space
instance (Illuminant i, Elevator e, ColorModel (LUV i) e) => ColorModel (LCHuv i) e where
  type Components (LCHuv i) e = (e, e, e)
  toComponents :: Color (LCHuv i) e -> Components (LCHuv 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 (LCHuv i) e -> Color LCH e)
-> Color (LCHuv i) e
-> (e, e, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LCHuv i) e -> Color LCH e
coerce
  {-# INLINE toComponents #-}
  fromComponents :: Components (LCHuv i) e -> Color (LCHuv i) e
fromComponents = Color LCH e -> Color (LCHuv i) e
coerce (Color LCH e -> Color (LCHuv i) e)
-> ((e, e, e) -> Color LCH e) -> (e, e, e) -> Color (LCHuv 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 (LCHuv i) e) -> ShowS
showsColorModelName Proxy (Color (LCHuv 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 (LUV i) e) -> ShowS
forall cs e. ColorModel cs e => Proxy (Color cs e) -> ShowS
showsColorModelName (Proxy (Color (LUV i) e)
forall k (t :: k). Proxy t
Proxy :: Proxy (Color (LUV i) e))

instance (Illuminant i, Elevator e, ColorSpace (LUV i) i e) => ColorSpace (LCHuv i) i e where
  type BaseModel (LCHuv i) = CM.LCH
  type BaseSpace (LCHuv i) = LUV i
  toBaseSpace :: Color (LCHuv i) e -> Color (BaseSpace (LCHuv i)) e
toBaseSpace = (Double -> e) -> Color (LUV i) Double -> Color (LUV 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 (LUV i) Double -> Color (LUV i) e)
-> (Color (LCHuv i) e -> Color (LUV i) Double)
-> Color (LCHuv i) e
-> Color (LUV i) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double) -> Color (LUV i) Double
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents ((Double, Double, Double) -> Color (LUV i) Double)
-> (Color (LCHuv i) e -> (Double, Double, Double))
-> Color (LCHuv i) e
-> Color (LUV 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 (LCHuv i) e -> Color LCH Double)
-> Color (LCHuv 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 (LCHuv i) e -> Color LCH e)
-> Color (LCHuv i) e
-> Color LCH Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LCHuv i) e -> Color LCH e
coerce
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: Color (BaseSpace (LCHuv i)) e -> Color (LCHuv i) e
fromBaseSpace = Color LCH e -> Color (LCHuv i) e
coerce (Color LCH e -> Color (LCHuv i) e)
-> (Color (LUV i) e -> Color LCH e)
-> Color (LUV i) e
-> Color (LCHuv 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 (LUV i) e -> Color LCH Double)
-> Color (LUV 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 (LUV i) e -> (Double, Double, Double))
-> Color (LUV i) e
-> Color LCH Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LUV i) Double -> (Double, Double, Double)
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color (LUV i) Double -> (Double, Double, Double))
-> (Color (LUV i) e -> Color (LUV i) Double)
-> Color (LUV i) e
-> (Double, Double, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color (LUV i) e -> Color (LUV 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 (LCHuv i) e -> Color (Y i) a
luminance = Color (LUV 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 (LUV i) e -> Color (Y i) a)
-> (Color (LCHuv i) e -> Color (LUV i) e)
-> Color (LCHuv i) e
-> Color (Y i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (LCHuv i) e -> Color (LUV 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 #-}