{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Color.Space.RGB.ITU.Rec470
( pattern BT470_525
, BT470_525
, C
, pattern BT470_625
, BT470_625
, D65
, primaries525
, primaries625
, module Graphics.Color.Space
) where
import Data.Coerce
import Data.Typeable
import Foreign.Storable
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space
import Graphics.Color.Illuminant.ITU.Rec470
data BT470_525 (l :: Linearity)
newtype instance Color (BT470_525 l) e = BT470_525 (Color CM.RGB e)
deriving instance Eq e => Eq (Color (BT470_525 l) e)
deriving instance Ord e => Ord (Color (BT470_525 l) e)
deriving instance Functor (Color (BT470_525 l))
deriving instance Applicative (Color (BT470_525 l))
deriving instance Foldable (Color (BT470_525 l))
deriving instance Traversable (Color (BT470_525 l))
deriving instance Storable e => Storable (Color (BT470_525 l) e)
instance (Typeable l, Elevator e) => Show (Color (BT470_525 l) e) where
showsPrec _ = showsColorModel
instance (Typeable l, Elevator e) => ColorModel (BT470_525 l) e where
type Components (BT470_525 l) e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance Elevator e => ColorSpace (BT470_525 'Linear) C e where
type BaseModel (BT470_525 '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 (BT470_525 'NonLinear) C e where
type BaseModel (BT470_525 '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 BT470_525 C where
gamut = primaries525
ecctf c = BT470_525 (fmap (gamma 2.2) (coerce c))
{-# INLINE ecctf #-}
dcctf c = BT470_525 (fmap (igamma 2.2) (coerce c))
{-# INLINE dcctf #-}
data BT470_625 (l :: Linearity)
newtype instance Color (BT470_625 l) e = BT470_625 (Color CM.RGB e)
deriving instance Eq e => Eq (Color (BT470_625 l) e)
deriving instance Ord e => Ord (Color (BT470_625 l) e)
deriving instance Functor (Color (BT470_625 l))
deriving instance Applicative (Color (BT470_625 l))
deriving instance Foldable (Color (BT470_625 l))
deriving instance Traversable (Color (BT470_625 l))
deriving instance Storable e => Storable (Color (BT470_625 l) e)
instance (Typeable l, Elevator e) => Show (Color (BT470_625 l) e) where
showsPrec _ = showsColorModel
instance (Typeable l, Elevator e) => ColorModel (BT470_625 l) e where
type Components (BT470_625 l) e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance Elevator e => ColorSpace (BT470_625 'Linear) D65 e where
type BaseModel (BT470_625 '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 (BT470_625 'NonLinear) D65 e where
type BaseModel (BT470_625 '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 BT470_625 D65 where
gamut = primaries625
ecctf c = BT470_625 (fmap (gamma 2.8) (coerce c))
{-# INLINE ecctf #-}
dcctf c = BT470_625 (fmap (igamma 2.8) (coerce c))
{-# INLINE dcctf #-}
gamma :: Floating a => a -> a -> a
gamma p v = v ** p
{-# INLINE gamma #-}
igamma :: Floating a => a -> a -> a
igamma p v = v ** (1 / p)
{-# INLINE igamma #-}
primaries525 :: RealFloat e => Gamut rgb i e
primaries525 = Gamut (Primary 0.67 0.33)
(Primary 0.21 0.71)
(Primary 0.14 0.08)
primaries625 :: RealFloat e => Gamut rgb i e
primaries625 = Gamut (Primary 0.64 0.33)
(Primary 0.29 0.60)
(Primary 0.15 0.06)