{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Graphics.Color.Space.RGB.Alternative.YCbCr
( pattern ColorYCbCr
, pattern ColorYCbCrA
, YCbCr
, Color(YCbCr)
, ycbcr2srgb
, srgb2ycbcr
, toColorYCbCr
, fromColorYCbCr
, module Graphics.Color.Space
) where
import Data.Coerce
import Data.Proxy
import Foreign.Storable
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.YCbCr as CM
import Graphics.Color.Space
import Graphics.Color.Space.RGB.SRGB
import Graphics.Color.Space.RGB.ITU.Rec601
import Graphics.Color.Space.RGB.ITU.Rec709
import Graphics.Color.Space.RGB.Luma
data YCbCr cs
newtype instance Color (YCbCr cs) e = YCbCr (Color CM.YCbCr e)
deriving instance Eq e => Eq (Color (YCbCr cs) e)
deriving instance Ord e => Ord (Color (YCbCr cs) e)
deriving instance Functor (Color (YCbCr cs))
deriving instance Applicative (Color (YCbCr cs))
deriving instance Foldable (Color (YCbCr cs))
deriving instance Traversable (Color (YCbCr cs))
deriving instance Storable e => Storable (Color (YCbCr cs) e)
instance ColorModel cs e => Show (Color (YCbCr cs) e) where
showsPrec _ = showsColorModel
pattern ColorYCbCr :: e -> e -> e -> Color (YCbCr cs) e
pattern ColorYCbCr y cb cr = YCbCr (CM.ColorYCbCr y cb cr)
{-# COMPLETE ColorYCbCr #-}
pattern ColorYCbCrA :: e -> e -> e -> e -> Color (Alpha (YCbCr cs)) e
pattern ColorYCbCrA y cb cr a = Alpha (YCbCr (CM.ColorYCbCr y cb cr)) a
{-# COMPLETE ColorYCbCrA #-}
instance ColorModel cs e => ColorModel (YCbCr cs) e where
type Components (YCbCr cs) e = (e, e, e)
toComponents (ColorYCbCr y cb cr) = (y, cb, cr)
{-# INLINE toComponents #-}
fromComponents (y, cb, cr) = ColorYCbCr y cb cr
{-# INLINE fromComponents #-}
showsColorModelName _ = ("YCbCr-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e))
instance Elevator e => ColorSpace (YCbCr (SRGB 'NonLinear)) D65 e where
type BaseModel (YCbCr (SRGB 'NonLinear)) = CM.YCbCr
type BaseSpace (YCbCr (SRGB 'NonLinear)) = SRGB 'NonLinear
toBaseSpace = fmap fromRealFloat . ycbcr2srgb . fmap toFloat
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromRealFloat . srgb2ycbcr . fmap toFloat
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance Elevator e => ColorSpace (YCbCr (BT601_525 'NonLinear)) D65 e where
type BaseModel (YCbCr (BT601_525 'NonLinear)) = CM.YCbCr
type BaseSpace (YCbCr (BT601_525 'NonLinear)) = BT601_525 'NonLinear
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance Elevator e => ColorSpace (YCbCr (BT601_625 'NonLinear)) D65 e where
type BaseModel (YCbCr (BT601_625 'NonLinear)) = CM.YCbCr
type BaseSpace (YCbCr (BT601_625 'NonLinear)) = BT601_625 'NonLinear
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance Elevator e => ColorSpace (YCbCr (BT709 'NonLinear)) D65 e where
type BaseModel (YCbCr (BT709 'NonLinear)) = CM.YCbCr
type BaseSpace (YCbCr (BT709 'NonLinear)) = BT709 'NonLinear
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance (Luma (cs i), ColorSpace (cs i 'NonLinear) i e, RedGreenBlue (cs i) i) =>
ColorSpace (YCbCr (cs i 'NonLinear)) i e where
type BaseModel (YCbCr (cs i 'NonLinear)) = CM.YCbCr
type BaseSpace (YCbCr (cs i 'NonLinear)) = cs i 'NonLinear
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
ycbcr2srgb ::
(RedGreenBlue cs i, RealFloat e) => Color (YCbCr (cs 'NonLinear)) e -> Color (cs 'NonLinear) e
ycbcr2srgb (ColorYCbCr y' cb cr) = ColorRGB r' g' b'
where
!cb05 = cb - 0.5
!cr05 = cr - 0.5
!r' = clamp01 (y' + 1.402 * cr05)
!g' = clamp01 (y' - 0.344136 * cb05 - 0.714136 * cr05)
!b' = clamp01 (y' + 1.772 * cb05)
{-# INLINE ycbcr2srgb #-}
srgb2ycbcr ::
(RedGreenBlue cs i, RealFloat e) => Color (cs 'NonLinear) e -> Color (YCbCr (cs 'NonLinear)) e
srgb2ycbcr (ColorRGB r' g' b') = ColorYCbCr y' cb cr
where
!y' = 0.299 * r' + 0.587 * g' + 0.114 * b'
!cb = 0.5 - 0.168736 * r' - 0.331264 * g' + 0.5 * b'
!cr = 0.5 + 0.5 * r' - 0.418688 * g' - 0.081312 * b'
{-# INLINE srgb2ycbcr #-}
toColorYCbCr ::
forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e)
=> Color (cs 'NonLinear) e'
-> Color (YCbCr (cs 'NonLinear)) e
toColorYCbCr rgb = YCbCr (CM.rgb2ycbcr (unColorRGB rgb) weights)
where
!weights = rgbLumaWeights rgb
{-# INLINE toColorYCbCr #-}
fromColorYCbCr ::
forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e)
=> Color (YCbCr (cs 'NonLinear)) e'
-> Color (cs 'NonLinear) e
fromColorYCbCr ycbcr = rgb
where
!rgb = mkColorRGB (CM.ycbcr2rgb (coerce ycbcr :: Color CM.YCbCr e') weights)
!weights = rgbLumaWeights rgb
{-# INLINE fromColorYCbCr #-}