{-# 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.SRGB
(
pattern SRGB
, pattern ColorSRGB
, pattern ColorSRGBA
, SRGB
, D50
, D65
, primaries
, npmStandard
, inpmStandard
, transfer
, itransfer
) where
import Foreign.Storable
import Graphics.Color.Model.Alpha
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space.Internal
import Graphics.Color.Space.RGB.Internal
import Graphics.Color.Space.RGB.Luma
import Graphics.Color.Illuminant.ICC.PCS (D50)
import Graphics.Color.Space.RGB.ITU.Rec709 (D65, primaries)
data SRGB
newtype instance Color SRGB e = SRGB (Color CM.RGB e)
pattern ColorSRGB :: e -> e -> e -> Color SRGB e
pattern ColorSRGB r g b = SRGB (CM.ColorRGB r g b)
{-# COMPLETE ColorSRGB #-}
pattern ColorSRGBA :: e -> e -> e -> e -> Color (Alpha SRGB) e
pattern ColorSRGBA r g b a = Alpha (SRGB (CM.ColorRGB r g b)) a
{-# COMPLETE ColorSRGBA #-}
deriving instance Eq e => Eq (Color SRGB e)
deriving instance Ord e => Ord (Color SRGB e)
deriving instance Functor (Color SRGB)
deriving instance Applicative (Color SRGB)
deriving instance Foldable (Color SRGB)
deriving instance Traversable (Color SRGB)
deriving instance Storable e => Storable (Color SRGB e)
instance Elevator e => Show (Color SRGB e) where
showsPrec _ = showsColorModel
instance Elevator e => ColorModel SRGB e where
type Components SRGB e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance Elevator e => ColorSpace SRGB D65 e where
type BaseModel SRGB = 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 SRGB D65 where
gamut = primaries
npm = npmStandard
inpm = inpmStandard
ecctf = fmap transfer
{-# INLINE ecctf #-}
dcctf = fmap itransfer
{-# INLINE dcctf #-}
instance Luma SRGB where
rWeight = 0.299
gWeight = 0.587
bWeight = 0.114
npmStandard :: RealFloat a => NPM SRGB a
npmStandard = NPM $ M3x3 (V3 0.4124 0.3576 0.1805)
(V3 0.2126 0.7152 0.0722)
(V3 0.0193 0.1192 0.9505)
inpmStandard :: RealFloat a => INPM SRGB a
inpmStandard = INPM $ M3x3 (V3 3.2406 -1.5372 -0.4986)
(V3 -0.9689 1.8758 0.0415)
(V3 0.0557 -0.2040 1.0570)
transfer :: (Ord a, Floating a) => a -> a
transfer u
| u <= 0.0031308 = 12.92 * u
| otherwise = 1.055 * (u ** (1 / 2.4)) - 0.055
{-# INLINE transfer #-}
itransfer :: (Ord a, Floating a) => a -> a
itransfer u
| u <= 0.04045 = u / 12.92
| otherwise = ((u + 0.055) / 1.055) ** 2.4
{-# INLINE itransfer #-}