{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Graphics.Color.Space.RGB.Internal
( pattern ColorRGB
, pattern ColorRGBA
, RedGreenBlue(..)
, Linearity(..)
, Gamut(..)
, rgb2xyz
, rgbLinear2xyz
, xyz2rgb
, xyz2rgbLinear
, rgbLuminance
, rgbLinearLuminance
, NPM(..)
, npmApply
, npmDerive
, INPM(..)
, inpmApply
, inpmDerive
, rgbColorGamut
, pixelWhitePoint
, gamutWhitePoint
, module Graphics.Color.Algebra
) where
import Data.Coerce
import Graphics.Color.Algebra
import qualified Graphics.Color.Model.RGB as CM
import Graphics.Color.Space.Internal
import Data.Kind
data Linearity = Linear | NonLinear
class Illuminant i => RedGreenBlue (cs :: Linearity -> Type) (i :: k) | cs -> i where
gamut :: RealFloat e => Gamut cs i e
ecctf :: (RealFloat a, Elevator a) => Color (cs 'Linear) a -> Color (cs 'NonLinear) a
dcctf :: (RealFloat a, Elevator a) => Color (cs 'NonLinear) a -> Color (cs 'Linear) a
npm :: (ColorSpace (cs 'Linear) i a, RealFloat a) => NPM cs a
npm = npmDerive gamut
{-# INLINE npm #-}
inpm :: (ColorSpace (cs 'Linear) i a, RealFloat a) => INPM cs a
inpm = inpmDerive gamut
{-# INLINE inpm #-}
mkColorRGB :: Color CM.RGB e -> Color (cs l) e
default mkColorRGB ::
Coercible (Color CM.RGB e) (Color (cs l) e) => Color CM.RGB e -> Color (cs l) e
mkColorRGB = coerce
unColorRGB :: Color (cs l) e -> Color CM.RGB e
default unColorRGB ::
Coercible (Color (cs l) e) (Color CM.RGB e) => Color (cs l) e -> Color CM.RGB e
unColorRGB = coerce
data Gamut cs i e = Gamut
{ gamutRedPrimary :: !(Primary i e)
, gamutGreenPrimary :: !(Primary i e)
, gamutBluePrimary :: !(Primary i e)
}
deriving instance Eq e => Eq (Gamut cs i e)
instance (RealFloat e, Elevator e, Illuminant i) => Show (Gamut cs i e) where
show Gamut {..} =
unlines
[ "Gamut:"
, " Red: " <> show (primaryChromaticity gamutRedPrimary)
, " Green: " <> show (primaryChromaticity gamutGreenPrimary)
, " Blue: " <> show (primaryChromaticity gamutBluePrimary)
]
gamutWhitePoint :: (RedGreenBlue cs i, RealFloat e) => Gamut cs i e -> WhitePoint i e
gamutWhitePoint _ = whitePoint
{-# INLINE gamutWhitePoint #-}
npmApply ::
(RedGreenBlue cs i, Elevator e)
=> NPM cs e
-> Color (cs 'Linear) e
-> Color (XYZ i) e
npmApply (NPM npm') = coerce . multM3x3byV3 npm' . coerce . unColorRGB
{-# INLINE npmApply #-}
inpmApply ::
(RedGreenBlue cs i, Elevator e)
=> INPM cs e
-> Color (XYZ i) e
-> Color (cs 'Linear) e
inpmApply (INPM inpm') = mkColorRGB . coerce . multM3x3byV3 inpm' . coerce
{-# INLINE inpmApply #-}
rgbLinearLuminance ::
forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e)
=> Color (cs 'Linear) e
-> Color (Y i) e
rgbLinearLuminance px =
Y (m3x3row1 (unNPM (npm :: NPM cs e)) `dotProduct` coerce (unColorRGB px))
{-# INLINE rgbLinearLuminance #-}
rgbLuminance ::
(RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e)
=> Color (cs 'NonLinear) e
-> Color (Y i) e
rgbLuminance = rgbLinearLuminance . dcctf
{-# INLINE rgbLuminance #-}
rgb2xyz ::
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e)
=> Color (cs 'NonLinear) e
-> Color (XYZ i) e
rgb2xyz = npmApply npm . dcctf
{-# INLINE rgb2xyz #-}
xyz2rgb ::
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e)
=> Color (XYZ i) e
-> Color (cs 'NonLinear) e
xyz2rgb = ecctf . inpmApply inpm
{-# INLINE xyz2rgb #-}
rgbLinear2xyz ::
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e)
=> Color (cs 'Linear) e
-> Color (XYZ i) e
rgbLinear2xyz = npmApply npm
{-# INLINE rgbLinear2xyz #-}
xyz2rgbLinear ::
forall cs i e.
(RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e)
=> Color (XYZ i) e
-> Color (cs 'Linear) e
xyz2rgbLinear = inpmApply inpm
{-# INLINE xyz2rgbLinear #-}
pattern ColorRGB :: RedGreenBlue cs i => e -> e -> e -> Color (cs l) e
pattern ColorRGB r g b <- (unColorRGB -> CM.ColorRGB r g b) where
ColorRGB r g b = mkColorRGB (CM.ColorRGB r g b)
{-# COMPLETE ColorRGB #-}
pattern ColorRGBA :: RedGreenBlue cs i => e -> e -> e -> e -> Color (Alpha (cs l)) e
pattern ColorRGBA r g b a <- Alpha (unColorRGB -> CM.ColorRGB r g b) a where
ColorRGBA r g b a = Alpha (mkColorRGB (CM.ColorRGB r g b)) a
{-# COMPLETE ColorRGBA #-}
newtype NPM cs e = NPM
{ unNPM :: M3x3 e
} deriving (Eq, Functor, Applicative, Foldable, Traversable)
instance Elevator e => Show (NPM cs e) where
show = show . unNPM
newtype INPM cs e = INPM
{ unINPM :: M3x3 e
} deriving (Eq, Functor, Applicative, Foldable, Traversable)
instance Elevator e => Show (INPM cs e) where
show = show . unINPM
npmDerive ::
forall cs i e. (ColorSpace (cs 'Linear) i e, RealFloat e)
=> Gamut cs i e
-> NPM cs e
npmDerive (Gamut r g b) = NPM (primaries' * M3x3 coeff coeff coeff)
where
!primaries' =
toRealFloat <$>
M3x3
(V3 (xPrimary r) (xPrimary g) (xPrimary b))
(V3 (yPrimary r) (yPrimary g) (yPrimary b))
(V3 (zPrimary r) (zPrimary g) (zPrimary b))
!coeff = invertM3x3 primaries' `multM3x3byV3` coerce (whitePointTristimulus :: Color (XYZ i) e)
{-# INLINE npmDerive #-}
inpmDerive ::
forall cs i e. (ColorSpace (cs 'Linear) i e, RealFloat e)
=> Gamut cs i e
-> INPM cs e
inpmDerive = INPM . invertM3x3 . unNPM . npmDerive
{-# INLINE inpmDerive #-}
rgbColorGamut :: (RedGreenBlue cs i, RealFloat e) => Color (cs l) a -> Gamut cs i e
rgbColorGamut _ = gamut
{-# INLINE rgbColorGamut #-}
pixelWhitePoint ::
forall e cs a i l. (RedGreenBlue cs i, RealFloat e)
=> Color (cs l) a
-> WhitePoint i e
pixelWhitePoint _ = whitePoint
{-# INLINE pixelWhitePoint #-}