{-# 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.HSI
-- Copyright   : (c) Alexey Kuleshevich 2018-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.HSI
  ( HSI
  -- * Constructors for an HSI color model.
  , pattern ColorHSI
  , pattern ColorHSIA
  , pattern ColorH360SI
  , Color(..)
  , ColorModel(..)
  , hsi2rgb
  , rgb2hsi
  ) where

import Data.List.NonEmpty
import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB

-----------
--- HSI ---
-----------

-- | Hue, Saturation and Intensity color model.
data HSI

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

-- | Constructor for @HSI@.
pattern ColorHSI :: e -> e -> e -> Color HSI e
pattern $mColorHSI :: forall {r} {e}.
Color HSI e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorHSI :: forall e. e -> e -> e -> Color HSI e
ColorHSI h s i = HSI (V3 h s i)
{-# COMPLETE ColorHSI #-}


-- | Constructor for @HSI@ with alpha channel.
pattern ColorHSIA :: e -> e -> e -> e -> Color (Alpha HSI) e
pattern $mColorHSIA :: forall {r} {e}.
Color (Alpha HSI) e -> (e -> e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorHSIA :: forall e. e -> e -> e -> e -> Color (Alpha HSI) e
ColorHSIA h s i a = Alpha (ColorHSI h s i) a
{-# COMPLETE ColorHSIA #-}

-- | Constructor for an HSI color model. Difference from `ColorHSI` 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 ColorH360SI :: Fractional e => e -> e -> e -> Color HSI e
pattern $mColorH360SI :: forall {r} {e}.
Fractional e =>
Color HSI e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorH360SI :: forall e. Fractional e => e -> e -> e -> Color HSI e
ColorH360SI h s i <- ColorHSI ((* 360) -> h) s i where
        ColorH360SI e
h e
s e
i = e -> e -> e -> Color HSI e
forall e. e -> e -> e -> Color HSI e
ColorHSI (e
h e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
360) e
s e
i
{-# COMPLETE ColorH360SI #-}


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

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

-- | `HSI` color model
instance Elevator e => ColorModel HSI e where
  type Components HSI e = (e, e, e)
  type ChannelCount HSI = 3
  channelCount :: Proxy (Color HSI e) -> Word8
channelCount Proxy (Color HSI e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color HSI e) -> NonEmpty String
channelNames Proxy (Color HSI e)
_ = String
"Hue" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String
"Saturation", String
"Intensity"]
  channelColors :: Proxy (Color HSI e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color HSI 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
0x00 Word8
0xce Word8
0xd1]
  toComponents :: Color HSI e -> Components HSI e
toComponents (ColorHSI e
h e
s e
i) = (e
h, e
s, e
i)
  {-# INLINE toComponents #-}
  fromComponents :: Components HSI e -> Color HSI e
fromComponents (e
h, e
s, e
i) = e -> e -> e -> Color HSI e
forall e. e -> e -> e -> Color HSI e
ColorHSI e
h e
s e
i
  {-# INLINE fromComponents #-}


hsi2rgb :: (Ord e, Floating e) => Color HSI e -> Color RGB e
hsi2rgb :: forall e. (Ord e, Floating e) => Color HSI e -> Color RGB e
hsi2rgb (ColorHSI e
h' e
s e
i) = e -> Color RGB e
getRGB (e
h' e -> e -> e
forall a. Num a => a -> a -> a
* e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
forall a. Floating a => a
pi)
  where
    !is :: e
is = e
i e -> e -> e
forall a. Num a => a -> a -> a
* e
s
    !second :: e
second = e
i e -> e -> e
forall a. Num a => a -> a -> a
- e
is
    !pi3 :: e
pi3 = e
forall a. Floating a => a
pi e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
3
    getFirst :: e -> e -> e
getFirst !e
a !e
b = e
i e -> e -> e
forall a. Num a => a -> a -> a
+ e
is e -> e -> e
forall a. Num a => a -> a -> a
* e -> e
forall a. Floating a => a -> a
cos e
a e -> e -> e
forall a. Fractional a => a -> a -> a
/ e -> e
forall a. Floating a => a -> a
cos e
b
    {-# INLINE getFirst #-}
    getThird :: e -> e -> e
getThird !e
v1 !e
v2 = e
i e -> e -> e
forall a. Num a => a -> a -> a
+ e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
is e -> e -> e
forall a. Num a => a -> a -> a
+ e
v1 e -> e -> e
forall a. Num a => a -> a -> a
- e
v2
    {-# INLINE getThird #-}
    getRGB :: e -> Color RGB e
getRGB e
h
      | 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
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
pi3 =
        let !r :: e
r = e -> e -> e
getFirst e
h (e
pi3 e -> e -> e
forall a. Num a => a -> a -> a
- e
h)
            !b :: e
b = e
second
            !g :: e
g = e -> e -> e
getThird e
b e
r
         in e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
r e
g e
b
      | e
h e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
4 e -> e -> e
forall a. Num a => a -> a -> a
* e
pi3 =
        let !g :: e
g = e -> e -> e
getFirst (e
h e -> e -> e
forall a. Num a => a -> a -> a
- e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
pi3) (e
h e -> e -> e
forall a. Num a => a -> a -> a
+ e
forall a. Floating a => a
pi)
            !r :: e
r = e
second
            !b :: e
b = e -> e -> e
getThird e
r e
g
         in e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
r e
g e
b
      | e
h e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
forall a. Floating a => a
pi =
        let !b :: e
b = e -> e -> e
getFirst (e
h e -> e -> e
forall a. Num a => a -> a -> a
- e
4 e -> e -> e
forall a. Num a => a -> a -> a
* e
pi3) (e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
forall a. Floating a => a
pi e -> e -> e
forall a. Num a => a -> a -> a
- e
pi3 e -> e -> e
forall a. Num a => a -> a -> a
- e
h)
            !g :: e
g = e
second
            !r :: e
r = e -> e -> e
getThird e
g e
b
         in e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
r e
g e
b
      | Bool
otherwise = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
0 e
0 e
0
    {-# INLINE getRGB #-}
{-# INLINE hsi2rgb #-}


rgb2hsi :: RealFloat e => Color RGB e -> Color HSI e
rgb2hsi :: forall e. RealFloat e => Color RGB e -> Color HSI e
rgb2hsi (ColorRGB e
r e
g e
b) = e -> e -> e -> Color HSI e
forall e. e -> e -> e -> Color HSI e
ColorHSI e
h e
s e
i
  where
    !h' :: e
h' = e -> e -> e
forall a. RealFloat a => a -> a -> a
atan2 e
y e
x
    !h'2pi :: e
h'2pi = e
h' e -> e -> e
forall a. Fractional a => a -> a -> a
/ (e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
forall a. Floating a => a
pi)
    !h :: e
h
      | e
h' e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
0 = e
h'2pi e -> e -> e
forall a. Num a => a -> a -> a
+ e
1
      | Bool
otherwise = e
h'2pi
    !s :: e
s
      | e
i e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
0 = e
0
      | Bool
otherwise = e
1 e -> e -> e
forall a. Num a => a -> a -> a
- 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) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
i
    !i :: e
i = (e
r e -> e -> e
forall a. Num a => a -> a -> a
+ 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
3
    !x :: e
x = (e
2 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. Num a => a -> a -> a
- e
b) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
2.449489742783178
    !y :: e
y = (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
1.4142135623730951
{-# INLINE rgb2hsi #-}