{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Color.Space.RGB.Luma
(
pattern Y'
, pattern Y'A
, pattern Luma
, Y'
, Luma(..)
, Weight(..)
, Weights(..)
, rgbLuma
, rgbLumaWeights
) where
import Data.Kind
import Data.Coerce
import Foreign.Storable
import Graphics.Color.Model.RGB as CM
import Graphics.Color.Model.Internal
import Graphics.Color.Model.Y as CM
import Graphics.Color.Space.RGB.Internal
data Y'
newtype instance Color Y' e = Luma (CM.Color CM.Y e)
pattern Y' :: e -> Color Y' e
pattern Y' y = Luma (CM.Y y)
{-# COMPLETE Y' #-}
pattern Y'A :: e -> e -> Color (Alpha Y') e
pattern Y'A y a = Alpha (Luma (CM.Y y)) a
{-# COMPLETE Y'A #-}
deriving instance Eq e => Eq (Color Y' e)
deriving instance Ord e => Ord (Color Y' e)
deriving instance Functor (Color Y')
deriving instance Applicative (Color Y')
deriving instance Foldable (Color Y')
deriving instance Traversable (Color Y')
deriving instance Storable e => Storable (Color Y' e)
instance Elevator e => Show (Color Y' e) where
showsPrec _ = showsColorModel
instance Elevator e => ColorModel Y' e where
type Components Y' e = e
toComponents (Y' y) = y
{-# INLINE toComponents #-}
fromComponents = Y'
{-# INLINE fromComponents #-}
class Luma (cs :: Linearity -> Type) where
{-# MINIMAL (rWeight, gWeight)|(rWeight, bWeight)|(gWeight, bWeight) #-}
rWeight :: RealFloat e => Weight cs e
rWeight = 1 - bWeight - gWeight
{-# INLINE rWeight #-}
gWeight :: RealFloat e => Weight cs e
gWeight = 1 - rWeight - bWeight
{-# INLINE gWeight #-}
bWeight :: RealFloat e => Weight cs e
bWeight = 1 - rWeight - gWeight
{-# INLINE bWeight #-}
newtype Weight cs e = Weight
{ unWeight :: e
} deriving (Eq, Show, Num, Fractional, Floating, Functor)
rgbLumaWeights ::
forall cs e' e. (Luma cs, RealFloat e)
=> Color (cs 'NonLinear) e'
-> Weights e
rgbLumaWeights _ =
Weights (V3 (coerce (rWeight :: Weight cs e) :: e)
(coerce (gWeight :: Weight cs e) :: e)
(coerce (bWeight :: Weight cs e) :: e))
{-# INLINE rgbLumaWeights #-}
rgbLuma ::
forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e)
=> Color (cs 'NonLinear) e'
-> Color Y' e
rgbLuma rgb' = Y' (coerce (fmap toRealFloat rgb :: Color CM.RGB e) `dotProduct` coerce weights)
where
!rgb = unColorRGB rgb'
!weights = rgbLumaWeights rgb' :: Weights e
{-# INLINE rgbLuma #-}