{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module      : Graphics.Color.Model.HSL
-- Copyright   : (c) Alexey Kuleshevich 2018-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.HSL
  ( HSL
  -- * Constructors for an HSL color model.
  , pattern ColorHSL
  , pattern ColorHSLA
  , pattern ColorH360SL
  , Color(..)
  , ColorModel(..)
  , hc2rgb
  , hsl2rgb
  , rgb2hsl
  ) where

import Data.List.NonEmpty
import Foreign.Storable
import Graphics.Color.Model.HSV (hc2rgb)
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB

-----------
--- HSL ---
-----------

-- | Hue, Saturation and Luminance (Lightness) color model.
data HSL

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

-- | Constructor for @HSL@.
pattern ColorHSL :: e -> e -> e -> Color HSL e
pattern $mColorHSL :: forall {r} {e}.
Color HSL e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorHSL :: forall e. e -> e -> e -> Color HSL e
ColorHSL h s l = HSL (V3 h s l)
{-# COMPLETE ColorHSL #-}


-- | Constructor for @HSL@ with alpha channel.
pattern ColorHSLA :: e -> e -> e -> e -> Color (Alpha HSL) e
pattern $mColorHSLA :: forall {r} {e}.
Color (Alpha HSL) e -> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorHSLA :: forall e. e -> e -> e -> e -> Color (Alpha HSL) e
ColorHSLA h s l a = Alpha (ColorHSL h s l) a
{-# COMPLETE ColorHSLA #-}

-- | Constructor for an HSL color model. Difference from `ColorHSL` is that channels are
-- restricted to `Double` and the hue is specified in 0 to 360 degree range, rather than 0
-- to 1. Note, that this is not checked.
pattern ColorH360SL :: Fractional e => e -> e -> e -> Color HSL e
pattern $mColorH360SL :: forall {r} {e}.
Fractional e =>
Color HSL e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorH360SL :: forall e. Fractional e => e -> e -> e -> Color HSL e
ColorH360SL h s l <- ColorHSL ((* 360) -> h) s l where
        ColorH360SL e
h e
s e
l = e -> e -> e -> Color HSL e
forall e. e -> e -> e -> Color HSL e
ColorHSL (e
h e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
360) e
s e
l
{-# COMPLETE ColorH360SL #-}

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

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

-- | `HSL` color model
instance Elevator e => ColorModel HSL e where
  type Components HSL e = (e, e, e)
  type ChannelCount HSL = 3
  channelCount :: Proxy (Color HSL e) -> Word8
channelCount Proxy (Color HSL e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color HSL e) -> NonEmpty String
channelNames Proxy (Color HSL e)
_ = String
"Hue" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"Saturation", String
"Lightness"]
  channelColors :: Proxy (Color HSL e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color HSL e)
_ = Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0x94 Word8
0x00 Word8
0xd3 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
0x8c Word8
0x00, Word8 -> Word8 -> Word8 -> V3 Word8
forall a. a -> a -> a -> V3 a
V3 Word8
0xaf Word8
0xee Word8
0xee]
  toComponents :: Color HSL e -> Components HSL e
toComponents (ColorHSL e
h e
s e
l) = (e
h, e
s, e
l)
  {-# INLINE toComponents #-}
  fromComponents :: Components HSL e -> Color HSL e
fromComponents (e
h, e
s, e
l) = e -> e -> e -> Color HSL e
forall e. e -> e -> e -> Color HSL e
ColorHSL e
h e
s e
l
  {-# INLINE fromComponents #-}

hsl2rgb :: RealFrac e => Color HSL e -> Color RGB e
hsl2rgb :: forall e. RealFrac e => Color HSL e -> Color RGB e
hsl2rgb (ColorHSL e
h e
s e
l) = (e -> e -> e
forall a. Num a => a -> a -> a
+ e
m) (e -> e) -> Color RGB e -> Color RGB e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> e -> Color RGB e
forall e. RealFrac e => e -> e -> Color RGB e
hc2rgb e
h e
c
  where
    !c :: e
c = (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e -> e
forall a. Num a => a -> a
abs (e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
l e -> e -> e
forall a. Num a => a -> a -> a
- e
1)) e -> e -> e
forall a. Num a => a -> a -> a
* e
s
    !m :: e
m = e
l e -> e -> e
forall a. Num a => a -> a -> a
- e
c e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
2
{-# INLINE hsl2rgb #-}


rgb2hsl :: (Ord e, Floating e) => Color RGB e -> Color HSL e
rgb2hsl :: forall e. (Ord e, Floating e) => Color RGB e -> Color HSL e
rgb2hsl (ColorRGB e
r e
g e
b) = e -> e -> e -> Color HSL e
forall e. e -> e -> e -> Color HSL e
ColorHSL e
h e
s e
l
  where
    !max' :: e
max' = e -> e -> e
forall a. Ord a => a -> a -> a
max e
r (e -> e -> e
forall a. Ord a => a -> a -> a
max e
g e
b)
    !min' :: e
min' = e -> e -> e
forall a. Ord a => a -> a -> a
min e
r (e -> e -> e
forall a. Ord a => a -> a -> a
min e
g e
b)
    !c' :: e
c' = e
max' e -> e -> e
forall a. Num a => a -> a -> a
- e
min'
    !h' :: e
h' | e
c'   e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
0 = e
0
        | e
max' e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
r = (    (e
g e -> e -> e
forall a. Num a => a -> a -> a
- e
b) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
c') e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
6
        | e
max' e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
g = (e
2 e -> e -> e
forall a. Num a => a -> a -> a
+ (e
b e -> e -> e
forall a. Num a => a -> a -> a
- e
r) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
c') e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
6
        | e
max' e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
b = (e
4 e -> e -> e
forall a. Num a => a -> a -> a
+ (e
r e -> e -> e
forall a. Num a => a -> a -> a
- e
g) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
c') e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
6
        | Bool
otherwise = e
0
    !h :: e
h
      | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
0 = e
h' e -> e -> e
forall a. Num a => a -> a -> a
+ e
1
      | Bool
otherwise = e
h'
    !s :: e
s
      | e
max' e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
0 Bool -> Bool -> Bool
|| e
min' e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
1 = e
0
      | Bool
otherwise = (e
max' e -> e -> e
forall a. Num a => a -> a -> a
- e
l) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e -> e -> e
forall a. Ord a => a -> a -> a
min e
l (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e
l)
    !l :: e
l = (e
max' e -> e -> e
forall a. Num a => a -> a -> a
+ e
min') e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
2
{-# INLINE rgb2hsl #-}