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

module Graphics.Color.Space.CIE1976.LUV.LCH
  ( pattern ColorLCHuv
  , pattern ColorLCHuvA
  , LCHuv
  , Color(LCHuv)
  ) 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.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 $mColorLCHuv :: forall {r} {k} {e} {i :: k}.
Color (LCHuv i) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLCHuv :: forall {k} e (i :: k). e -> e -> e -> Color (LCHuv i) e
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 $mColorLCHuvA :: forall {r} {k} {e} {i :: k}.
Color (Alpha (LCHuv i)) e
-> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLCHuvA :: forall {k} e (i :: k).
e -> e -> e -> e -> Color (Alpha (LCHuv i)) e
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)
  type ChannelCount (LCHuv i) = 3
  channelCount :: Proxy (Color (LCHuv i) e) -> Word8
channelCount Proxy (Color (LCHuv i) e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (LCHuv i) e) -> NonEmpty String
channelNames Proxy (Color (LCHuv i) e)
_ = String
"L" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"Cuv", String
"Huv"]
  channelColors :: Proxy (Color (LCHuv i) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (LCHuv 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
0x00 Word8
0x99
                  , Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x99 Word8
0xcc Word8
0x00
                  ]
  toComponents :: Color (LCHuv i) e -> Components (LCHuv i) e
toComponents (LCHuv 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 (LCHuv i) e -> Color (LCHuv i) e
fromComponents = Color LCH e -> Color (LCHuv i) e
forall k (i :: k) e. Color LCH e -> Color (LCHuv i) e
LCHuv (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
Components LCH 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 :: ColorSpace (BaseSpace (LCHuv i)) i e =>
Color (LCHuv i) e -> Color (BaseSpace (LCHuv i)) e
toBaseSpace (LCHuv Color LCH e
lch) = (Double -> e) -> Color (LUV i) Double -> Color (LUV i) e
forall a b. (a -> b) -> Color (LUV i) a -> Color (LUV 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 (LUV i) Double -> Color (BaseSpace (LCHuv i)) e)
-> (Color LCH e -> Color (LUV i) Double)
-> Color LCH e
-> Color (BaseSpace (LCHuv i)) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double) -> Color (LUV i) Double
Components (LUV i) 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 LCH e -> (Double, Double, Double))
-> Color LCH 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 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 (LCHuv i)) e)
-> Color LCH e -> Color (BaseSpace (LCHuv i)) e
forall a b. (a -> b) -> a -> b
$ Color LCH e
lch
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (LCHuv i)) i e =>
Color (BaseSpace (LCHuv i)) e -> Color (LCHuv i) e
fromBaseSpace = Color LCH e -> Color (LCHuv i) e
forall k (i :: k) e. Color LCH e -> Color (LCHuv i) e
LCHuv (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 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 (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)
Color (LUV i) Double -> Components (LUV i) 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 a b. (a -> b) -> Color (LUV i) a -> Color (LUV 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 (LCHuv i) e -> Color (Y i) a
luminance = Color (LUV i) e -> Color (Y i) a
forall a.
(Elevator a, RealFloat a) =>
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 (BaseSpace (LCHuv i)) e
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 #-}
  grayscale :: Color (LCHuv i) e -> Color X e
grayscale (Color (LCHuv 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 (LCHuv i) e -> Color X e -> Color (LCHuv i) e
replaceGrayscale (Color (LCHuv 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 (LCHuv 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 #-}