{-# 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.Model.YCbCr
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.YCbCr
  ( pattern ColorYCbCr
  , pattern ColorYCbCrA
  , YCbCr
  , Color(YCbCr)
  , rgb2ycbcr
  , ycbcr2rgb
  ) where

import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB
import Graphics.Color.Model.X

-- | `YCbCr` color model
data YCbCr

-- | `YCbCr` color model
newtype instance Color YCbCr e = YCbCr (V3 e)

-- | `YCbCr` color model
deriving instance Eq e => Eq (Color YCbCr e)
-- | `YCbCr` color model
deriving instance Ord e => Ord (Color YCbCr e)
-- | `YCbCr` color model
deriving instance Functor (Color YCbCr)
-- | `YCbCr` color model
deriving instance Applicative (Color YCbCr)
-- | `YCbCr` color model
deriving instance Foldable (Color YCbCr)
-- | `YCbCr` color model
deriving instance Traversable (Color YCbCr)
-- | `YCbCr` color model
deriving instance Storable e => Storable (Color YCbCr e)

-- | `YCbCr` color model
instance Elevator e => Show (Color YCbCr e) where
  showsPrec :: Int -> Color YCbCr e -> ShowS
showsPrec Int
_ = Color YCbCr e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModel

-- | Constructor for an RGB color model in an alternative YCbCr color model
pattern ColorYCbCr :: e -> e -> e -> Color YCbCr e
pattern $bColorYCbCr :: e -> e -> e -> Color YCbCr e
$mColorYCbCr :: forall r e.
Color YCbCr e -> (e -> e -> e -> r) -> (Void# -> r) -> r
ColorYCbCr y cb cr = YCbCr (V3 y cb cr)
{-# COMPLETE ColorYCbCr #-}

-- | Constructor for @YCbCr@ with alpha channel.
pattern ColorYCbCrA :: e -> e -> e -> e -> Color (Alpha YCbCr) e
pattern $bColorYCbCrA :: e -> e -> e -> e -> Color (Alpha YCbCr) e
$mColorYCbCrA :: forall r e.
Color (Alpha YCbCr) e
-> (e -> e -> e -> e -> r) -> (Void# -> r) -> r
ColorYCbCrA y cb cr a = Alpha (YCbCr (V3 y cb cr)) a
{-# COMPLETE ColorYCbCrA #-}


-- | `YCbCr` color model
instance Elevator e => ColorModel YCbCr e where
  type Components YCbCr e = (e, e, e)
  toComponents :: Color YCbCr e -> Components YCbCr e
toComponents (ColorYCbCr e
y e
cb e
cr) = (e
y, e
cb, e
cr)
  {-# INLINE toComponents #-}
  fromComponents :: Components YCbCr e -> Color YCbCr e
fromComponents (y, cb, cr) = e -> e -> e -> Color YCbCr e
forall e. e -> e -> e -> Color YCbCr e
ColorYCbCr e
y e
cb e
cr
  {-# INLINE fromComponents #-}
  showsColorModelName :: Proxy (Color YCbCr e) -> ShowS
showsColorModelName Proxy (Color YCbCr e)
_ = (String
"YCbCr" String -> ShowS
forall a. [a] -> [a] -> [a]
++)


rgb2ycbcr :: (Elevator e', Elevator e, RealFloat e) => Color RGB e' -> Weights e -> Color YCbCr e
rgb2ycbcr :: Color RGB e' -> Weights e -> Color YCbCr e
rgb2ycbcr Color RGB e'
rgb' weights :: Weights e
weights@(Weights (V3 e
kr e
_ e
kb)) = e -> e -> e -> Color YCbCr e
forall e. e -> e -> e -> Color YCbCr e
ColorYCbCr e
y' e
cb e
cr
  where
    rgb :: Color RGB e
rgb@(ColorRGB e
r' e
_ e
b') = e' -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat (e' -> e) -> Color RGB e' -> Color RGB e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Color RGB e'
rgb'
    ColorX e
y' = Color RGB e -> Weights e -> Color X e
forall e e'.
(Elevator e', Elevator e, RealFloat e) =>
Color RGB e' -> Weights e -> Color X e
rgb2y Color RGB e
rgb Weights e
weights
    !cb :: e
cb = e
0.5 e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.5 e -> e -> e
forall a. Num a => a -> a -> a
* (e
b' e -> e -> e
forall a. Num a => a -> a -> a
- e
y') e -> e -> e
forall a. Fractional a => a -> a -> a
/ (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e
kb)
    !cr :: e
cr = e
0.5 e -> e -> e
forall a. Num a => a -> a -> a
+ e
0.5 e -> e -> e
forall a. Num a => a -> a -> a
* (e
r' e -> e -> e
forall a. Num a => a -> a -> a
- e
y') e -> e -> e
forall a. Fractional a => a -> a -> a
/ (e
1 e -> e -> e
forall a. Num a => a -> a -> a
- e
kr)
{-# INLINE rgb2ycbcr #-}


ycbcr2rgb :: (Elevator e', Elevator e, RealFloat e) => Color YCbCr e' -> Weights e -> Color RGB e
ycbcr2rgb :: Color YCbCr e' -> Weights e -> Color RGB e
ycbcr2rgb Color YCbCr e'
ycbcr (Weights (V3 e
kr e
kg e
kb)) = e -> e -> e -> Color RGB e
forall e. e -> e -> e -> Color RGB e
ColorRGB e
r' e
g' e
b'
  where
    ColorYCbCr e
y' e
cb e
cr = e' -> e
forall e a. (Elevator e, Elevator a, RealFloat a) => e -> a
toRealFloat (e' -> e) -> Color YCbCr e' -> Color YCbCr e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Color YCbCr e'
ycbcr
    !r' :: e
r' = e -> e
forall a. RealFloat a => a -> a
clamp01 (e
y' e -> e -> e
forall a. Num a => a -> a -> a
+ (e
2 e -> e -> e
forall a. Num a => a -> a -> a
- e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
kr) e -> e -> e
forall a. Num a => a -> a -> a
* (e
cr e -> e -> e
forall a. Num a => a -> a -> a
- e
0.5))
    !b' :: e
b' = e -> e
forall a. RealFloat a => a -> a
clamp01 (e
y' e -> e -> e
forall a. Num a => a -> a -> a
+ (e
2 e -> e -> e
forall a. Num a => a -> a -> a
- e
2 e -> e -> e
forall a. Num a => a -> a -> a
* e
kb) e -> e -> e
forall a. Num a => a -> a -> a
* (e
cb e -> e -> e
forall a. Num a => a -> a -> a
- e
0.5))
    !g' :: e
g' = e -> e
forall a. RealFloat a => a -> a
clamp01 ((e
y' e -> e -> e
forall a. Num a => a -> a -> a
- e
kr e -> e -> e
forall a. Num a => a -> a -> a
* e
r' e -> e -> e
forall a. Num a => a -> a -> a
- e
kb e -> e -> e
forall a. Num a => a -> a -> a
* e
b') e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
kg)
{-# INLINE ycbcr2rgb #-}