{-# 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) D65 e where
type BaseModel (YCbCr SRGB) = CM.YCbCr
type BaseSpace (YCbCr SRGB) = SRGB
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) D65 e where
type BaseModel (YCbCr BT601_525) = CM.YCbCr
type BaseSpace (YCbCr BT601_525) = BT601_525
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance Elevator e => ColorSpace (YCbCr BT601_625) D65 e where
type BaseModel (YCbCr BT601_625) = CM.YCbCr
type BaseSpace (YCbCr BT601_625) = BT601_625
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance Elevator e => ColorSpace (YCbCr BT709) D65 e where
type BaseModel (YCbCr BT709) = CM.YCbCr
type BaseSpace (YCbCr BT709) = BT709
toBaseSpace = fmap fromDouble . fromColorYCbCr
{-# INLINE toBaseSpace #-}
fromBaseSpace = fmap fromDouble . toColorYCbCr
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}
instance (Luma (cs i), ColorSpace (cs i) i e, RedGreenBlue (cs i) i) =>
ColorSpace (YCbCr (cs i)) i e where
type BaseModel (YCbCr (cs i)) = CM.YCbCr
type BaseSpace (YCbCr (cs i)) = cs i
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) e -> Color cs 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 e -> Color (YCbCr cs) 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 e'
-> Color (YCbCr cs) 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) e'
-> Color cs e
fromColorYCbCr ycbcr = rgb
where
!rgb = mkColorRGB (CM.ycbcr2rgb (coerce ycbcr :: Color CM.YCbCr e') weights)
!weights = rgbLumaWeights rgb
{-# INLINE fromColorYCbCr #-}