{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module      : Graphics.Color.Space.RGB.Alternative.HSV
-- Copyright   : (c) Alexey Kuleshevich 2019-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Space.RGB.Alternative.HSV
  ( pattern ColorHSV
  , pattern ColorHSVA
  , pattern ColorH360SV
  , HSV
  , Color(HSV)
  ) where

import Data.Coerce
import Data.Proxy
import Foreign.Storable
import qualified Graphics.Color.Model.HSV as CM
import Graphics.Color.Model.Internal
import Graphics.Color.Space.Internal
import Graphics.Color.Space.RGB.Internal

-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
data HSV cs

-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
newtype instance Color (HSV cs) e = HSV (Color CM.HSV e)

-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Eq e => Eq (Color (HSV cs) e)
-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Ord e => Ord (Color (HSV cs) e)
-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Functor (Color (HSV cs))
-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Applicative (Color (HSV cs))
-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Foldable (Color (HSV cs))
-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Traversable (Color (HSV cs))
-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
deriving instance Storable e => Storable (Color (HSV cs) e)

-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
instance ColorModel cs e => Show (Color (HSV cs) e) where
  showsPrec :: Int -> Color (HSV cs) e -> ShowS
showsPrec Int
_ = Color (HSV cs) e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModel

-- | Constructor for an RGB color space in an alternative HSV color model
pattern ColorHSV :: e -> e -> e -> Color (HSV cs) e
pattern $mColorHSV :: forall {r} {k} {e} {cs :: k}.
Color (HSV cs) e -> (e -> e -> e -> r) -> ((# #) -> r) -> r
$bColorHSV :: forall {k} e (cs :: k). e -> e -> e -> Color (HSV cs) e
ColorHSV h s i = HSV (CM.ColorHSV h s i)
{-# COMPLETE ColorHSV #-}

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


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

-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
instance ColorModel cs e => ColorModel (HSV cs) e where
  type Components (HSV cs) e = (e, e, e)
  type ChannelCount (HSV cs) = 3
  channelCount :: Proxy (Color (HSV cs) e) -> Word8
channelCount Proxy (Color (HSV cs) e)
_ = Word8
3
  {-# INLINE channelCount #-}
  channelNames :: Proxy (Color (HSV cs) e) -> NonEmpty String
channelNames Proxy (Color (HSV cs) e)
_ = Proxy (Color HSV e) -> NonEmpty String
forall cs e.
ColorModel cs e =>
Proxy (Color cs e) -> NonEmpty String
channelNames (Proxy (Color HSV e)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Color CM.HSV e))
  channelColors :: Proxy (Color (HSV cs) e) -> NonEmpty (V3 Word8)
channelColors Proxy (Color (HSV cs) e)
_ = Proxy (Color HSV e) -> NonEmpty (V3 Word8)
forall cs e.
ColorModel cs e =>
Proxy (Color cs e) -> NonEmpty (V3 Word8)
channelColors (Proxy (Color HSV e)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Color CM.HSV e))
  toComponents :: Color (HSV cs) e -> Components (HSV cs) e
toComponents = Color HSV e -> (e, e, e)
Color HSV e -> Components HSV e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents (Color HSV e -> (e, e, e))
-> (Color (HSV cs) e -> Color HSV e)
-> Color (HSV cs) e
-> (e, e, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color (HSV cs) e -> Color HSV e
forall a b. Coercible a b => a -> b
coerce :: Color (HSV cs) e -> Color CM.HSV e)
  {-# INLINE toComponents #-}
  fromComponents :: Components (HSV cs) e -> Color (HSV cs) e
fromComponents = (Color HSV e -> Color (HSV cs) e
forall a b. Coercible a b => a -> b
coerce :: Color CM.HSV e -> Color (HSV cs) e) (Color HSV e -> Color (HSV cs) e)
-> ((e, e, e) -> Color HSV e) -> (e, e, e) -> Color (HSV cs) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e, e, e) -> Color HSV e
Components HSV e -> Color HSV e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents
  {-# INLINE fromComponents #-}
  showsColorModelName :: Proxy (Color (HSV cs) e) -> ShowS
showsColorModelName Proxy (Color (HSV cs) e)
_ = (String
"HSV-" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (Color cs e) -> ShowS
forall cs e. ColorModel cs e => Proxy (Color cs e) -> ShowS
showsColorModelName (Proxy (Color cs e)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Color cs e))


-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space
instance (ColorSpace (cs l) i e, RedGreenBlue cs i) => ColorSpace (HSV (cs l)) i e where
  type BaseModel (HSV (cs l)) = CM.HSV
  type BaseSpace (HSV (cs l)) = cs l
  toBaseSpace :: ColorSpace (BaseSpace (HSV (cs l))) i e =>
Color (HSV (cs l)) e -> Color (BaseSpace (HSV (cs l))) e
toBaseSpace = Color RGB e -> Color (cs l) e
forall e (l :: Linearity). Color RGB e -> Color (cs l) e
forall k (cs :: Linearity -> *) (i :: k) e (l :: Linearity).
RedGreenBlue cs i =>
Color RGB e -> Color (cs l) e
mkColorRGB (Color RGB e -> Color (cs l) e)
-> (Color (HSV (cs l)) e -> Color RGB e)
-> Color (HSV (cs l)) e
-> Color (cs l) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> e) -> Color RGB Double -> Color RGB e
forall a b. (a -> b) -> Color RGB a -> Color RGB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> e
forall e. Elevator e => Double -> e
fromDouble (Color RGB Double -> Color RGB e)
-> (Color (HSV (cs l)) e -> Color RGB Double)
-> Color (HSV (cs l)) e
-> Color RGB e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color HSV Double -> Color RGB Double
forall e. RealFrac e => Color HSV e -> Color RGB e
CM.hsv2rgb (Color HSV Double -> Color RGB Double)
-> (Color (HSV (cs l)) e -> Color HSV Double)
-> Color (HSV (cs l)) e
-> Color RGB Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color HSV e -> Color HSV Double
forall a b. (a -> b) -> Color HSV a -> Color HSV b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Double
forall e. Elevator e => e -> Double
toDouble (Color HSV e -> Color HSV Double)
-> (Color (HSV (cs l)) e -> Color HSV e)
-> Color (HSV (cs l)) e
-> Color HSV Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (HSV (cs l)) e -> Color HSV e
Color (HSV (cs l)) e -> Color (BaseModel (HSV (cs l))) e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color cs e -> Color (BaseModel cs) e
toBaseModel
  {-# INLINE toBaseSpace #-}
  fromBaseSpace :: ColorSpace (BaseSpace (HSV (cs l))) i e =>
Color (BaseSpace (HSV (cs l))) e -> Color (HSV (cs l)) e
fromBaseSpace = Color HSV e -> Color (HSV (cs l)) e
Color (BaseModel (HSV (cs l))) e -> Color (HSV (cs l)) e
forall k cs (i :: k) e.
ColorSpace cs i e =>
Color (BaseModel cs) e -> Color cs e
fromBaseModel (Color HSV e -> Color (HSV (cs l)) e)
-> (Color (cs l) e -> Color HSV e)
-> Color (cs l) e
-> Color (HSV (cs l)) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> e) -> Color HSV Double -> Color HSV e
forall a b. (a -> b) -> Color HSV a -> Color HSV b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> e
forall e. Elevator e => Double -> e
fromDouble (Color HSV Double -> Color HSV e)
-> (Color (cs l) e -> Color HSV Double)
-> Color (cs l) e
-> Color HSV e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color RGB Double -> Color HSV Double
forall e. (Ord e, Fractional e) => Color RGB e -> Color HSV e
CM.rgb2hsv (Color RGB Double -> Color HSV Double)
-> (Color (cs l) e -> Color RGB Double)
-> Color (cs l) e
-> Color HSV Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Double) -> Color RGB e -> Color RGB Double
forall a b. (a -> b) -> Color RGB a -> Color RGB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Double
forall e. Elevator e => e -> Double
toDouble (Color RGB e -> Color RGB Double)
-> (Color (cs l) e -> Color RGB e)
-> Color (cs l) e
-> Color RGB Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (cs l) e -> Color RGB e
forall k (cs :: Linearity -> *) (i :: k) (l :: Linearity) e.
RedGreenBlue cs i =>
Color (cs l) e -> Color RGB e
forall (l :: Linearity) e. Color (cs l) e -> Color RGB e
unColorRGB
  {-# INLINE fromBaseSpace #-}
  luminance :: forall a.
(Elevator a, RealFloat a) =>
Color (HSV (cs l)) e -> Color (Y i) a
luminance = Color (cs l) e -> Color (Y i) a
forall a.
(Elevator a, RealFloat a) =>
Color (cs l) e -> Color (Y i) a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (Y i) a
luminance (Color (cs l) e -> Color (Y i) a)
-> (Color (HSV (cs l)) e -> Color (cs l) e)
-> Color (HSV (cs l)) e
-> Color (Y i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color (HSV (cs l)) e -> Color (cs l) e
Color (HSV (cs l)) e -> Color (BaseSpace (HSV (cs l))) e
forall k cs (i :: k) e.
(ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) =>
Color cs e -> Color (BaseSpace cs) e
toBaseSpace
  {-# INLINE luminance #-}
  grayscale :: Color (HSV (cs l)) e -> Color X e
grayscale (Color (HSV (cs l)) e -> V3 e
forall a b. Coercible a b => a -> b
coerce -> V3 e
_ e
_ e
v) = e -> Color X e
forall e. e -> Color X e
X e
v
  {-# INLINE grayscale #-}
  replaceGrayscale :: Color (HSV (cs l)) e -> Color X e -> Color (HSV (cs l)) e
replaceGrayscale (Color (HSV (cs l)) e -> V3 e
forall a b. Coercible a b => a -> b
coerce -> V3 e
h e
s e
_) (X e
v) = V3 e -> Color (HSV (cs l)) e
forall a b. Coercible a b => a -> b
coerce (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
h e
s e
v)
  {-# INLINE replaceGrayscale #-}