{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Color.Space.RGB.AdobeRGB
(
pattern AdobeRGB
, pattern ColorAdobeRGB
, pattern ColorAdobeRGBA
, AdobeRGB
, D65
, primaries
, npmStandard
, inpmStandard
, transfer
, itransfer
, module Graphics.Color.Space
) where
import Data.Typeable
import Data.Coerce
import Foreign.Storable
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space
import Graphics.Color.Space.RGB.ITU.Rec601 (D65)
data AdobeRGB (l :: Linearity)
newtype instance Color (AdobeRGB l) e = AdobeRGB (Color CM.RGB e)
pattern ColorAdobeRGB :: e -> e -> e -> Color (AdobeRGB l) e
pattern ColorAdobeRGB r g b = AdobeRGB (CM.ColorRGB r g b)
{-# COMPLETE ColorAdobeRGB #-}
pattern ColorAdobeRGBA :: e -> e -> e -> e -> Color (Alpha (AdobeRGB l)) e
pattern ColorAdobeRGBA r g b a = Alpha (AdobeRGB (CM.ColorRGB r g b)) a
{-# COMPLETE ColorAdobeRGBA #-}
deriving instance Eq e => Eq (Color (AdobeRGB l) e)
deriving instance Ord e => Ord (Color (AdobeRGB l) e)
deriving instance Functor (Color (AdobeRGB l))
deriving instance Applicative (Color (AdobeRGB l))
deriving instance Foldable (Color (AdobeRGB l))
deriving instance Traversable (Color (AdobeRGB l))
deriving instance Storable e => Storable (Color (AdobeRGB l) e)
instance (Typeable l, Elevator e) => Show (Color (AdobeRGB l) e) where
showsPrec _ = showsColorModel
instance (Typeable l, Elevator e) => ColorModel (AdobeRGB l) e where
type Components (AdobeRGB l) e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance Elevator e => ColorSpace (AdobeRGB 'Linear) D65 e where
type BaseModel (AdobeRGB 'Linear) = CM.RGB
toBaseSpace = id
{-# INLINE toBaseSpace #-}
fromBaseSpace = id
{-# INLINE fromBaseSpace #-}
luminance = rgbLinearLuminance . fmap toRealFloat
{-# INLINE luminance #-}
toColorXYZ = rgbLinear2xyz . fmap toRealFloat
{-# INLINE toColorXYZ #-}
fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear
{-# INLINE fromColorXYZ #-}
instance Elevator e => ColorSpace (AdobeRGB 'NonLinear) D65 e where
type BaseModel (AdobeRGB 'NonLinear) = CM.RGB
toBaseSpace = id
{-# INLINE toBaseSpace #-}
fromBaseSpace = id
{-# INLINE fromBaseSpace #-}
luminance = rgbLuminance . fmap toRealFloat
{-# INLINE luminance #-}
toColorXYZ = rgb2xyz . fmap toRealFloat
{-# INLINE toColorXYZ #-}
fromColorXYZ = fmap fromRealFloat . xyz2rgb
{-# INLINE fromColorXYZ #-}
instance RedGreenBlue AdobeRGB D65 where
gamut = primaries
npm = npmStandard
inpm = inpmStandard
ecctf = AdobeRGB . fmap transfer . coerce
{-# INLINE ecctf #-}
dcctf = AdobeRGB . fmap itransfer . coerce
{-# INLINE dcctf #-}
npmStandard :: RealFloat e => NPM AdobeRGB e
npmStandard = NPM $ M3x3 (V3 0.57667 0.18556 0.18823)
(V3 0.29734 0.62736 0.07529)
(V3 0.02703 0.07069 0.99134)
inpmStandard :: RealFloat e => INPM AdobeRGB e
inpmStandard = INPM $ M3x3 (V3 2.04159 -0.56501 -0.34473)
(V3 -0.96924 1.87597 0.04156)
(V3 0.01344 -0.11836 1.01517)
transfer :: Floating a => a -> a
transfer u = u ** (256 / 563)
{-# INLINE transfer #-}
itransfer :: Floating a => a -> a
itransfer u = u ** 2.19921875
{-# INLINE itransfer #-}
primaries :: RealFloat e => Gamut rgb i e
primaries = Gamut (Primary 0.64 0.33)
(Primary 0.21 0.71)
(Primary 0.15 0.06)