{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Color.Space.RGB.Derived.CIERGB
( CIERGB
, CIERGB.primaries
, castLinearity
, module Graphics.Color.Space
) where
import Data.Coerce
import Data.Typeable
import Foreign.Storable
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space
import qualified Graphics.Color.Space.CIE1931.RGB as CIERGB
data CIERGB (i :: k) (l :: Linearity)
newtype instance Color (CIERGB i l) e = CIERGB (Color CM.RGB e)
deriving instance Eq e => Eq (Color (CIERGB i l) e)
deriving instance Ord e => Ord (Color (CIERGB i l) e)
deriving instance Functor (Color (CIERGB i l))
deriving instance Applicative (Color (CIERGB i l))
deriving instance Foldable (Color (CIERGB i l))
deriving instance Traversable (Color (CIERGB i l))
deriving instance Storable e => Storable (Color (CIERGB i l) e)
instance (Typeable l, Illuminant i, Elevator e) => Show (Color (CIERGB (i :: k) l) e) where
showsPrec _ = showsColorModel
instance (Typeable l, Illuminant i, Elevator e) => ColorModel (CIERGB (i :: k) l) e where
type Components (CIERGB i l) e = (e, e, e)
toComponents = toComponents . unColorRGB
{-# INLINE toComponents #-}
fromComponents = mkColorRGB . fromComponents
{-# INLINE fromComponents #-}
instance (Illuminant i, Typeable l, Elevator e) => ColorSpace (CIERGB i l) i e where
type BaseModel (CIERGB i l) = CM.RGB
toBaseSpace = id
{-# INLINE toBaseSpace #-}
fromBaseSpace = id
{-# INLINE fromBaseSpace #-}
luminance = rgbLinearLuminance . castLinearity . fmap toRealFloat
{-# INLINE luminance #-}
toColorXYZ = rgbLinear2xyz . fmap toRealFloat . castLinearity
{-# INLINE toColorXYZ #-}
fromColorXYZ xyz = castLinearity (fromRealFloat <$> (xyz2rgbLinear @(CIERGB i) xyz))
{-# INLINE fromColorXYZ #-}
instance Illuminant i => RedGreenBlue (CIERGB i) i where
gamut = CIERGB.primaries
ecctf = coerce
{-# INLINE ecctf #-}
dcctf = coerce
{-# INLINE dcctf #-}
castLinearity :: Color (CIERGB i l') e -> Color (CIERGB i l) e
castLinearity = coerce