{-# LANGUAGE BangPatterns #-}
{-# 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 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 $bColorLCH :: e -> e -> e -> Color LCH e
$mColorLCH :: forall r e. Color LCH e -> (e -> e -> e -> r) -> (Void# -> r) -> r
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 $bColorLCHA :: e -> e -> e -> e -> Color (Alpha LCH) e
$mColorLCHA :: forall r e.
Color (Alpha LCH) e -> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
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)
  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 (l, c, 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 (l, x, 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 #-}