{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module : Graphics.Color.Model.LCH
module Graphics.Color.Model.LCH
  ( LCH
  -- * Constructors for an LCH color model.
  , pattern ColorLCH
  , pattern ColorLCHA
  , Color(..)
  , ColorModel(..)
  , lch2lxy
  , lxy2lch
  ) where

import Data.Complex (Complex(..), polar, mkPolar)
import Data.Fixed (mod')
import Data.List.NonEmpty
import Foreign.Storable
import Graphics.Color.Model.Internal

-----------
--- LCH ---
-----------

-- | CIEL*C*H color model, representing a cylindrical reparameterization
--   of CIEL*a*b* or CIEL*u*v*.
data LCH

-- | `LCH` color model
newtype instance Color LCH e = LCH (V3 e)

-- | Constructor for @LCH@.
pattern ColorLCH :: e -> e -> e -> Color LCH e
pattern $mColorLCH :: forall {r} {e}.
Color LCH e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLCH :: forall e. e -> e -> e -> Color LCH e
ColorLCH l c h = LCH (V3 l c h)
{-# COMPLETE ColorLCH #-}


-- | Constructor for @LCH@ with alpha channel.
pattern ColorLCHA :: e -> e -> e -> e -> Color (Alpha LCH) e
pattern $mColorLCHA :: forall {r} {e}.
Color (Alpha LCH) e -> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorLCHA :: forall e. e -> e -> e -> e -> Color (Alpha LCH) e
ColorLCHA l c h a = Alpha (ColorLCH l c h) a
{-# COMPLETE ColorLCHA #-}

-- | `LCH` color model
deriving instance Eq e => Eq (Color LCH e)
-- | `LCH` color model
deriving instance Ord e => Ord (Color LCH e)
-- | `LCH` color model
deriving instance Functor (Color LCH)
-- | `LCH` color model
deriving instance Applicative (Color LCH)
-- | `LCH` color model
deriving instance Foldable (Color LCH)
-- | `LCH` color model
deriving instance Traversable (Color LCH)
-- | `LCH` color model
deriving instance Storable e => Storable (Color LCH e)

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

-- | `LCH` color model
instance Elevator e => ColorModel LCH e where
  type Components LCH e = (e, e, e)
  type ChannelCount LCH = 3
  channelCount :: Proxy (Color LCH e) -> Word8
channelCount Proxy (Color LCH e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color LCH e) -> NonEmpty String
channelNames Proxy (Color LCH e)
_ = String
"Luminance" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"Chroma", String
"Hue"]
  channelColors :: Proxy (Color LCH e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color LCH 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
0x00 Word8
0xff
                  , Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0xcc Word8
0xff Word8
0x33
                  ]
  toComponents :: Color LCH e -> Components LCH e
toComponents (ColorLCH e
l e
c e
h) = (e
l, e
c, e
h)
  {-# INLINE toComponents #-}
  fromComponents :: Components LCH e -> Color LCH e
fromComponents (e
l, e
c, e
h) = e -> e -> e -> Color LCH e
forall e. e -> e -> e -> Color LCH e
ColorLCH e
l e
c e
h
  {-# INLINE fromComponents #-}

lch2lxy :: Color LCH Double -> Components LCH Double
lch2lxy :: Color LCH Double -> Components LCH Double
lch2lxy (ColorLCH Double
l Double
c Double
h) = (Double
l, Double
x, Double
y)
 where
  !h' :: Double
h' = Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
180
  (Double
x :+ Double
y) = Double -> Double -> Complex Double
forall a. Floating a => a -> a -> Complex a
mkPolar Double
c Double
h'
{-# INLINE lch2lxy #-}

lxy2lch :: Components LCH Double -> Color LCH Double
lxy2lch :: Components LCH Double -> Color LCH Double
lxy2lch (Double
l, Double
x, Double
y) = Double -> Double -> Double -> Color LCH Double
forall e. e -> e -> e -> Color LCH e
ColorLCH Double
l Double
c Double
h
 where
  (Double
c,Double
h') = Complex Double -> (Double, Double)
forall a. RealFloat a => Complex a -> (a, a)
polar (Double
x Double -> Double -> Complex Double
forall a. a -> a -> Complex a
:+ Double
y)
  !h :: Double
h = (Double
h' Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
180 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi) Double -> Double -> Double
forall a. Real a => a -> a -> a
`mod'` Double
360
{-# INLINE lxy2lch #-}