{-# LANGUAGE BangPatterns #-}
{-# 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.ITU.Rec601
( pattern BT601_525
, BT601_525
, pattern BT601_625
, BT601_625
, D65
, primaries525
, primaries625
, transfer
, itransfer
, module Graphics.Color.Space
) where
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.Rec470 (primaries625)
import Graphics.Color.Space.RGB.Luma
import Graphics.Color.Illuminant.ITU.Rec601
data BT601_525
newtype instance Color BT601_525 e = BT601_525 (Color CM.RGB e)
deriving instance Eq e => Eq (Color BT601_525 e)
deriving instance Ord e => Ord (Color BT601_525 e)
deriving instance Functor (Color BT601_525)
deriving instance Applicative (Color BT601_525)
deriving instance Foldable (Color BT601_525)
deriving instance Traversable (Color BT601_525)
deriving instance Storable e => Storable (Color BT601_525 e)
instance Elevator e => Show (Color BT601_525 e) where
showsPrec _ = showsColorModel
instance Elevator e => ColorModel BT601_525 e where
type Components BT601_525 e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance Elevator e => ColorSpace BT601_525 D65 e where
type BaseModel BT601_525 = 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 BT601_525 D65 where
gamut = primaries525
ecctf = fmap transfer
{-# INLINE ecctf #-}
dcctf = fmap itransfer
{-# INLINE dcctf #-}
data BT601_625
newtype instance Color BT601_625 e = BT601_625 (Color CM.RGB e)
deriving instance Eq e => Eq (Color BT601_625 e)
deriving instance Ord e => Ord (Color BT601_625 e)
deriving instance Functor (Color BT601_625)
deriving instance Applicative (Color BT601_625)
deriving instance Foldable (Color BT601_625)
deriving instance Traversable (Color BT601_625)
deriving instance Storable e => Storable (Color BT601_625 e)
instance Elevator e => Show (Color BT601_625 e) where
showsPrec _ = showsColorModel
instance Elevator e => ColorModel BT601_625 e where
type Components BT601_625 e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance Elevator e => ColorSpace BT601_625 D65 e where
type BaseModel BT601_625 = 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 BT601_625 D65 where
gamut = primaries625
ecctf = fmap transfer
{-# INLINE ecctf #-}
dcctf = fmap itransfer
{-# INLINE dcctf #-}
instance Luma BT601_525 where
rWeight = 0.299
gWeight = 0.587
bWeight = 0.114
instance Luma BT601_625 where
rWeight = 0.299
gWeight = 0.587
bWeight = 0.114
transfer :: (Ord a, Floating a) => a -> a
transfer l
| l < 0.018 = 4.5 * l
| otherwise = 1.099 * (l ** 0.45 ) - 0.099
{-# INLINE transfer #-}
itransfer :: (Ord a, Floating a) => a -> a
itransfer e
| e < inv0018 = e / 4.5
| otherwise = ((e + 0.099) / 1.099) ** (1 / 0.45)
where
!inv0018 = transfer 0.018
{-# INLINE itransfer #-}
primaries525 :: RealFloat e => Gamut rgb i e
primaries525 = Gamut (Primary 0.630 0.340)
(Primary 0.310 0.595)
(Primary 0.155 0.070)