{-# LANGUAGE BangPatterns #-}
{-# 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
( HSL
, pattern ColorHSL
, pattern ColorHSLA
, pattern ColorH360SL
, Color
, ColorModel(..)
, hc2rgb
, hsl2rgb
, rgb2hsl
) where
import Foreign.Storable
import Graphics.Color.Model.HSV (hc2rgb)
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB
data HSL
newtype instance Color HSL e = HSL (V3 e)
pattern ColorHSL :: e -> e -> e -> Color HSL e
pattern ColorHSL h s l = HSL (V3 h s l)
{-# COMPLETE ColorHSL #-}
pattern ColorHSLA :: e -> e -> e -> e -> Color (Alpha HSL) e
pattern ColorHSLA h s l a = Alpha (ColorHSL h s l) a
{-# COMPLETE ColorHSLA #-}
pattern ColorH360SL :: Fractional e => e -> e -> e -> Color HSL e
pattern ColorH360SL h s l <- ColorHSL ((* 360) -> h) s l where
ColorH360SL h s l = ColorHSL (h / 360) s l
{-# COMPLETE ColorH360SL #-}
deriving instance Eq e => Eq (Color HSL e)
deriving instance Ord e => Ord (Color HSL e)
deriving instance Functor (Color HSL)
deriving instance Applicative (Color HSL)
deriving instance Foldable (Color HSL)
deriving instance Traversable (Color HSL)
deriving instance Storable e => Storable (Color HSL e)
instance Elevator e => Show (Color HSL e) where
showsPrec _ = showsColorModel
instance Elevator e => ColorModel HSL e where
type Components HSL e = (e, e, e)
toComponents (ColorHSL h s l) = (h, s, l)
{-# INLINE toComponents #-}
fromComponents (h, s, l) = ColorHSL h s l
{-# INLINE fromComponents #-}
hsl2rgb :: RealFrac e => Color HSL e -> Color RGB e
hsl2rgb (ColorHSL h s l) = (+ m) <$> hc2rgb h c
where
!c = (1 - abs (2 * l - 1)) * s
!m = l - c / 2
{-# INLINE hsl2rgb #-}
rgb2hsl :: (Ord e, Floating e) => Color RGB e -> Color HSL e
rgb2hsl (ColorRGB r g b) = ColorHSL h s l
where
!max' = max r (max g b)
!min' = min r (min g b)
!h' | max' == r = ( (g - b) / (max' - min')) / 6
| max' == g = (2 + (b - r) / (max' - min')) / 6
| max' == b = (4 + (r - g) / (max' - min')) / 6
| otherwise = 0
!h
| h' < 0 = h' + 1
| otherwise = h'
!s
| max' == 0 || min' == 1 = 0
| otherwise = (max' - l) / min l (1 - l)
!l = (max' + min') / 2
{-# INLINE rgb2hsl #-}