{-# 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.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 #-}