{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Graphics.Color.Model.HSV
( HSV
, pattern ColorHSV
, pattern ColorHSVA
, pattern ColorH360SV
, Color
, ColorModel(..)
, hc2rgb
, hsv2rgb
, rgb2hsv
) where
import Foreign.Storable
import Graphics.Color.Model.Alpha
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB
data HSV
newtype instance Color HSV e = HSV (V3 e)
pattern ColorHSV :: e -> e -> e -> Color HSV e
pattern ColorHSV h s v = HSV (V3 h s v)
{-# COMPLETE ColorHSV #-}
pattern ColorHSVA :: e -> e -> e -> e -> Color (Alpha HSV) e
pattern ColorHSVA h s v a = Alpha (ColorHSV h s v) a
{-# COMPLETE ColorHSVA #-}
pattern ColorH360SV :: Fractional e => e -> e -> e -> Color HSV e
pattern ColorH360SV h s v <- ColorHSV ((* 360) -> h) s v where
ColorH360SV h s v = ColorHSV (h / 360) s v
{-# COMPLETE ColorH360SV #-}
deriving instance Eq e => Eq (Color HSV e)
deriving instance Ord e => Ord (Color HSV e)
deriving instance Functor (Color HSV)
deriving instance Applicative (Color HSV)
deriving instance Foldable (Color HSV)
deriving instance Traversable (Color HSV)
deriving instance Storable e => Storable (Color HSV e)
instance Elevator e => Show (Color HSV e) where
showsPrec _ = showsColorModel
instance Elevator e => ColorModel HSV e where
type Components HSV e = (e, e, e)
toComponents (ColorHSV h s v) = (h, s, v)
{-# INLINE toComponents #-}
fromComponents (h, s, v) = ColorHSV h s v
{-# INLINE fromComponents #-}
hc2rgb :: RealFrac e => e -> e -> Color RGB e
hc2rgb h c
| h' < 0 = ColorRGB 0 0 0
| h' <= 1 = ColorRGB c x 0
| h' <= 2 = ColorRGB x c 0
| h' <= 3 = ColorRGB 0 c x
| h' <= 4 = ColorRGB 0 x c
| h' <= 5 = ColorRGB x 0 c
| h' <= 6 = ColorRGB c 0 x
| otherwise = ColorRGB 0 0 0
where
!h' = h * 6
!hTrunc = truncate h' :: Int
!hMod2 = fromIntegral (hTrunc `mod` 2) + (h' - fromIntegral hTrunc)
!x = c * (1 - abs (hMod2 - 1))
{-# INLINE hc2rgb #-}
hsv2rgb :: RealFrac e => Color HSV e -> Color RGB e
hsv2rgb (ColorHSV h s v) = (+ m) <$> hc2rgb h c
where
!c = v * s
!m = v - c
{-# INLINE hsv2rgb #-}
rgb2hsv :: (Ord e, Fractional e) => Color RGB e -> Color HSV e
rgb2hsv (ColorRGB r g b) = ColorHSV h s v
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 = 0
| otherwise = (max' - min') / max'
!v = max'
{-# INLINE rgb2hsv #-}