{-# 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
( pattern ColorHSV
, pattern ColorHSVA
, pattern ColorH360SV
, HSV
, Color(HSV)
, module Graphics.Color.Space
) 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
data HSV cs
newtype instance Color (HSV cs) e = HSV (Color CM.HSV e)
deriving instance Eq e => Eq (Color (HSV cs) e)
deriving instance Ord e => Ord (Color (HSV cs) e)
deriving instance Functor (Color (HSV cs))
deriving instance Applicative (Color (HSV cs))
deriving instance Foldable (Color (HSV cs))
deriving instance Traversable (Color (HSV cs))
deriving instance Storable e => Storable (Color (HSV cs) e)
instance ColorModel cs e => Show (Color (HSV cs) e) where
showsPrec _ = showsColorModel
pattern ColorHSV :: e -> e -> e -> Color (HSV cs) e
pattern ColorHSV h s i = HSV (CM.ColorHSV h s i)
{-# COMPLETE ColorHSV #-}
pattern ColorHSVA :: e -> e -> e -> e -> Color (Alpha (HSV cs)) e
pattern ColorHSVA h s i a = Alpha (HSV (CM.ColorHSV h s i)) a
{-# COMPLETE ColorHSVA #-}
pattern ColorH360SV :: Fractional e => e -> e -> e -> Color (HSV cs) e
pattern ColorH360SV h s i <- ColorHSV ((* 360) -> h) s i where
ColorH360SV h s i = ColorHSV (h / 360) s i
{-# COMPLETE ColorH360SV #-}
instance ColorModel cs e => ColorModel (HSV cs) e where
type Components (HSV cs) e = (e, e, e)
toComponents = toComponents . coerce
{-# INLINE toComponents #-}
fromComponents = coerce . fromComponents
{-# INLINE fromComponents #-}
showsColorModelName _ = ("HSV-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e))
instance (ColorSpace cs i e, RedGreenBlue cs i) => ColorSpace (HSV cs) i e where
type BaseModel (HSV cs) = CM.HSV
type BaseSpace (HSV cs) = cs
toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsv2rgb . fmap toDouble . coerce
{-# INLINE toBaseSpace #-}
fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsv . fmap toDouble . unColorRGB
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}