{-# 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
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.HSV
  ( HSV
  -- * Constructors for an HSV color model.
  , pattern ColorHSV
  , pattern ColorHSVA
  , pattern ColorH360SV
  , Color
  , ColorModel(..)
  , hc2rgb
  , hsv2rgb
  , rgb2hsv
  ) where

import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB

-----------
--- HSV ---
-----------

-- | Hue, Saturation and Value (Brightness) color model.
data HSV

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

-- | Constructor for @HSV@.
pattern ColorHSV :: e -> e -> e -> Color HSV e
pattern $bColorHSV :: e -> e -> e -> Color HSV e
$mColorHSV :: forall r e. Color HSV e -> (e -> e -> e -> r) -> (Void# -> r) -> r
ColorHSV h s v = HSV (V3 h s v)
{-# COMPLETE ColorHSV #-}


-- | Constructor for @HSV@ with alpha channel.
pattern ColorHSVA :: e -> e -> e -> e -> Color (Alpha HSV) e
pattern $bColorHSVA :: e -> e -> e -> e -> Color (Alpha HSV) e
$mColorHSVA :: forall r e.
Color (Alpha HSV) e -> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
ColorHSVA h s v a = Alpha (ColorHSV h s v) a
{-# COMPLETE ColorHSVA #-}

-- | Constructor for an HSV color model. Difference from `ColorHSV` 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 ColorH360SV :: Fractional e => e -> e -> e -> Color HSV e
pattern $bColorH360SV :: e -> e -> e -> Color HSV e
$mColorH360SV :: forall r e.
Fractional e =>
Color HSV e -> (e -> e -> e -> r) -> (Void# -> r) -> r
ColorH360SV h s v <- ColorHSV ((* 360) -> h) s v where
        ColorH360SV e
h e
s e
v = e -> e -> e -> Color HSV e
forall e. e -> e -> e -> Color HSV e
ColorHSV (e
h e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
360) e
s e
v
{-# COMPLETE ColorH360SV #-}

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

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

-- | `HSV` color model
instance Elevator e => ColorModel HSV e where
  type Components HSV e = (e, e, e)
  toComponents :: Color HSV e -> Components HSV e
toComponents (ColorHSV e
h e
s e
v) = (e
h, e
s, e
v)
  {-# INLINE toComponents #-}
  fromComponents :: Components HSV e -> Color HSV e
fromComponents (h, s, v) = e -> e -> e -> Color HSV e
forall e. e -> e -> e -> Color HSV e
ColorHSV e
h e
s e
v
  {-# INLINE fromComponents #-}

hc2rgb :: RealFrac e => e -> e -> Color RGB e
hc2rgb :: e -> e -> Color RGB e
hc2rgb e
h e
c
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
0 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
0 e
0 e
0
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
1 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
c e
x e
0
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
2 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
x e
c e
0
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
3 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
0 e
c e
x
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
4 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
0 e
x e
c
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
5 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
x e
0 e
c
  | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
6 = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
c e
0 e
x
  | Bool
otherwise = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
0 e
0 e
0
  where
    !h' :: e
h' = e
h e -> e -> e
forall a. Num a => a -> a -> a
* e
6
    !hTrunc :: Int
hTrunc = e -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate e
h' :: Int
    !hMod2 :: e
hMod2 = Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
hTrunc Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2) e -> e -> e
forall a. Num a => a -> a -> a
+ (e
h' e -> e -> e
forall a. Num a => a -> a -> a
- Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hTrunc)
    !x :: e
x = e
c e -> e -> e
forall a. Num a => a -> a -> a
* (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e -> e
forall a. Num a => a -> a
abs (e
hMod2 e -> e -> e
forall a. Num a => a -> a -> a
- e
1))
{-# INLINE hc2rgb #-}

hsv2rgb :: RealFrac e => Color HSV e -> Color RGB e
hsv2rgb :: Color HSV e -> Color RGB e
hsv2rgb (ColorHSV e
h e
s e
v) = (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
v e -> e -> e
forall a. Num a => a -> a -> a
* e
s
    !m :: e
m = e
v e -> e -> e
forall a. Num a => a -> a -> a
- e
c
{-# INLINE hsv2rgb #-}


rgb2hsv :: (Ord e, Fractional e) => Color RGB e -> Color HSV e
rgb2hsv :: Color RGB e -> Color HSV e
rgb2hsv (ColorRGB e
r e
g e
b) = e -> e -> e -> Color HSV e
forall e. e -> e -> e -> Color HSV e
ColorHSV e
h e
s e
v
  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)
    !h' :: e
h' | 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
max' e -> e -> e
forall a. Num a => a -> a -> a
- e
min')) 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
max' e -> e -> e
forall a. Num a => a -> a -> a
- e
min')) 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
max' e -> e -> e
forall a. Num a => a -> a -> a
- e
min')) 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 = e
0
      | Bool
otherwise = (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
max'
    !v :: e
v = e
max'
{-# INLINE rgb2hsv #-}