{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Graphics.Color.Space.Internal
( Color(Luminance, XYZ, CIExyY)
, ColorSpace(..)
, Chromaticity(..)
, Primary(.., Primary)
, xPrimary
, yPrimary
, zPrimary
, primaryXZ
, primaryTristimulus
, Illuminant(..)
, WhitePoint(.., WhitePoint)
, xWhitePoint
, yWhitePoint
, zWhitePoint
, whitePointXZ
, whitePointTristimulus
, CCT(..)
, Y
, pattern Y
, pattern YA
, XYZ
, pattern ColorXYZ
, pattern ColorXYZA
, CIExyY
, pattern ColorCIExy
, pattern ColorCIExyY
, module GHC.TypeNats
, module Graphics.Color.Algebra
, module Graphics.Color.Model.Internal
) where
import Foreign.Storable
import Graphics.Color.Model.Alpha
import Graphics.Color.Model.Internal
import qualified Graphics.Color.Model.Y as CM
import Graphics.Color.Algebra
import Data.Typeable
import Data.Coerce
import GHC.TypeNats
import Data.Kind
class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e, Typeable (Opaque cs)) =>
ColorSpace cs (i :: k) e | cs -> i where
type BaseModel cs :: Type
type BaseSpace cs :: Type
type BaseSpace cs = cs
toBaseModel :: Color cs e -> Color (BaseModel cs) e
default toBaseModel ::
Coercible (Color cs e) (Color (BaseModel cs) e) => Color cs e -> Color (BaseModel cs) e
toBaseModel = coerce
fromBaseModel :: Color (BaseModel cs) e -> Color cs e
default fromBaseModel ::
Coercible (Color (BaseModel cs) e) (Color cs e) => Color (BaseModel cs) e -> Color cs e
fromBaseModel = coerce
toBaseSpace :: ColorSpace (BaseSpace cs) i e => Color cs e -> Color (BaseSpace cs) e
fromBaseSpace :: ColorSpace (BaseSpace cs) i e => Color (BaseSpace cs) e -> Color cs e
luminance :: (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a
toColorXYZ :: (Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a
default toColorXYZ ::
(ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a
toColorXYZ = toColorXYZ . toBaseSpace
{-# INLINE toColorXYZ #-}
fromColorXYZ :: (Elevator a, RealFloat a) => Color (XYZ i) a -> Color cs e
default fromColorXYZ ::
(ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color (XYZ i) a -> Color cs e
fromColorXYZ = fromBaseSpace . fromColorXYZ
{-# INLINE fromColorXYZ #-}
instance ( ColorSpace cs i e
, ColorSpace (BaseSpace cs) i e
, ColorSpace (Alpha (BaseSpace cs)) i e
, cs ~ Opaque (Alpha cs)
, BaseModel cs ~ Opaque (Alpha (BaseModel cs))
) =>
ColorSpace (Alpha cs) i e where
type BaseModel (Alpha cs) = Alpha (BaseModel cs)
type BaseSpace (Alpha cs) = Alpha (BaseSpace cs)
toBaseModel = modifyOpaque toBaseModel
{-# INLINE toBaseModel #-}
fromBaseModel = modifyOpaque fromBaseModel
{-# INLINE fromBaseModel #-}
toColorXYZ = toColorXYZ . dropAlpha
{-# INLINE toColorXYZ #-}
fromColorXYZ = (`addAlpha` maxValue) . fromColorXYZ
{-# INLINE fromColorXYZ #-}
luminance = luminance . dropAlpha
{-# INLINE luminance #-}
toBaseSpace = modifyOpaque toBaseSpace
{-# INLINE toBaseSpace #-}
fromBaseSpace = modifyOpaque fromBaseSpace
{-# INLINE fromBaseSpace #-}
newtype Chromaticity i e =
Chromaticity (Color (CIExyY i) e)
deriving (Eq, Show)
newtype CCT (i :: k) = CCT
{ unCCT :: Double
} deriving (Eq, Show)
class (Typeable i, Typeable k, KnownNat (Temperature i)) => Illuminant (i :: k) where
type Temperature i :: n
whitePoint :: RealFloat e => WhitePoint i e
colorTemperature :: CCT i
colorTemperature = CCT (fromIntegral (natVal (Proxy :: Proxy (Temperature i))))
newtype WhitePoint (i :: k) e =
WhitePointChromaticity (Chromaticity i e)
deriving (Eq)
instance (Illuminant i, Elevator e) => Show (WhitePoint (i :: k) e) where
showsPrec n (WhitePointChromaticity wp)
| n == 0 = inner
| otherwise = ('(' :) . inner . (')' :)
where
inner = ("WhitePoint (" ++) . shows wp . (')' :)
pattern WhitePoint :: e -> e -> WhitePoint i e
pattern WhitePoint x y <- (coerce -> (V2 x y)) where
WhitePoint x y = coerce (V2 x y)
{-# COMPLETE WhitePoint #-}
xWhitePoint :: WhitePoint i e -> e
xWhitePoint (coerce -> V2 x _) = x
{-# INLINE xWhitePoint #-}
yWhitePoint :: WhitePoint i e -> e
yWhitePoint (coerce -> V2 _ y) = y
{-# INLINE yWhitePoint #-}
zWhitePoint :: Num e => WhitePoint i e -> e
zWhitePoint wp = 1 - xWhitePoint wp - yWhitePoint wp
{-# INLINE zWhitePoint #-}
whitePointTristimulus ::
forall i e. (Illuminant i, RealFloat e, Elevator e)
=> Color (XYZ i) e
whitePointTristimulus = toColorXYZ (coerce (whitePoint :: WhitePoint i e) :: Color (CIExyY i) e)
{-# INLINE whitePointTristimulus #-}
whitePointXZ ::
Fractional e
=> e
-> WhitePoint i e
-> Color (XYZ i) e
whitePointXZ vY (coerce -> V2 x y) = ColorXYZ (vYy * x) vY (vYy * (1 - x - y))
where !vYy = vY / y
{-# INLINE whitePointXZ #-}
newtype Primary (i :: k) e = PrimaryChromaticity (Chromaticity i e)
deriving (Eq, Show)
pattern Primary :: e -> e -> Primary i e
pattern Primary x y <- (coerce -> V2 x y) where
Primary x y = coerce (V2 x y)
{-# COMPLETE Primary #-}
xPrimary :: Primary i e -> e
xPrimary (coerce -> V2 x _) = x
{-# INLINE xPrimary #-}
yPrimary :: Primary i e -> e
yPrimary (coerce -> V2 _ y) = y
{-# INLINE yPrimary #-}
zPrimary :: Num e => Primary i e -> e
zPrimary p = 1 - xPrimary p - yPrimary p
{-# INLINE zPrimary #-}
primaryTristimulus ::
forall i e. (Illuminant i, RealFloat e, Elevator e)
=> Primary i e
-> Color (XYZ i) e
primaryTristimulus xy = toColorXYZ (coerce xy :: Color (CIExyY i) e)
{-# INLINE primaryTristimulus #-}
primaryXZ ::
Fractional e =>
e
-> Primary i e
-> Color (XYZ i) e
primaryXZ vY (Primary x y) = ColorXYZ (vYy * x) vY (vYy * (1 - x - y))
where !vYy = vY / y
{-# INLINE primaryXZ #-}
data XYZ i
newtype instance Color (XYZ i) e = XYZ (V3 e)
pattern ColorXYZ :: e -> e -> e -> Color (XYZ i) e
pattern ColorXYZ x y z = XYZ (V3 x y z)
{-# COMPLETE ColorXYZ #-}
pattern ColorXYZA :: e -> e -> e -> e -> Color (Alpha (XYZ i)) e
pattern ColorXYZA x y z a = Alpha (XYZ (V3 x y z)) a
{-# COMPLETE ColorXYZA #-}
deriving instance Eq e => Eq (Color (XYZ i) e)
deriving instance Ord e => Ord (Color (XYZ i) e)
deriving instance Functor (Color (XYZ i))
deriving instance Applicative (Color (XYZ i))
deriving instance Foldable (Color (XYZ i))
deriving instance Traversable (Color (XYZ i))
deriving instance Storable e => Storable (Color (XYZ i) e)
instance (Illuminant i, Elevator e) => Show (Color (XYZ (i :: k)) e) where
showsPrec _ = showsColorModel
instance (Illuminant i, Elevator e) => ColorModel (XYZ (i :: k)) e where
type Components (XYZ i) e = (e, e, e)
toComponents (ColorXYZ x y z) = (x, y, z)
{-# INLINE toComponents #-}
fromComponents (x, y, z) = ColorXYZ x y z
{-# INLINE fromComponents #-}
instance (Illuminant i, Elevator e) => ColorSpace (XYZ i) i e where
type BaseModel (XYZ i) = XYZ i
toBaseModel = id
fromBaseModel = id
toBaseSpace = id
fromBaseSpace = id
luminance (ColorXYZ _ y _) = Y (toRealFloat y)
{-# INLINE luminance #-}
toColorXYZ (ColorXYZ x y z) = ColorXYZ (toRealFloat x) (toRealFloat y) (toRealFloat z)
{-# INLINE toColorXYZ #-}
fromColorXYZ (ColorXYZ x y z) = ColorXYZ (fromRealFloat x) (fromRealFloat y) (fromRealFloat z)
{-# INLINE fromColorXYZ #-}
{-# RULES
"toColorXYZ :: Color (XYZ i) a -> Color (XYZ i) a" toColorXYZ = id
"fromColorXYZ :: Color (XYZ i) a -> Color (XYZ i) a" fromColorXYZ = id
#-}
data CIExyY (i :: k)
newtype instance Color (CIExyY i) e = CIExyY (V2 e)
pattern ColorCIExy :: e -> e -> Color (CIExyY i) e
pattern ColorCIExy x y = CIExyY (V2 x y)
{-# COMPLETE ColorCIExy #-}
pattern ColorCIExyY :: Num e => e -> e -> e -> Color (CIExyY i) e
pattern ColorCIExyY x y y' <- (addY -> V3 x y y')
{-# COMPLETE ColorCIExyY #-}
addY :: Num e => Color (CIExyY i) e -> V3 e
addY (CIExyY (V2 x y)) = V3 x y 1
{-# INLINE addY #-}
deriving instance Eq e => Eq (Color (CIExyY i) e)
deriving instance Ord e => Ord (Color (CIExyY i) e)
deriving instance Functor (Color (CIExyY i))
deriving instance Applicative (Color (CIExyY i))
deriving instance Foldable (Color (CIExyY i))
deriving instance Traversable (Color (CIExyY i))
deriving instance Storable e => Storable (Color (CIExyY i) e)
instance (Illuminant i, Elevator e) => Show (Color (CIExyY (i :: k)) e) where
showsPrec _ = showsColorModel
instance (Illuminant i, Elevator e) => ColorModel (CIExyY (i :: k)) e where
type Components (CIExyY i) e = (e, e)
toComponents (CIExyY (V2 x y)) = (x, y)
{-# INLINE toComponents #-}
fromComponents (x, y) = CIExyY (V2 x y)
{-# INLINE fromComponents #-}
showsColorModelName _ = showsType (Proxy :: Proxy (CIExyY i))
instance (Illuminant i, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where
type BaseModel (CIExyY i) = CIExyY i
toBaseModel = id
fromBaseModel = id
toBaseSpace = id
fromBaseSpace = id
luminance _ = Y 1
{-# INLINE luminance #-}
toColorXYZ xy = ColorXYZ (x / y) 1 ((1 - x - y) / y)
where ColorCIExy x y = toRealFloat <$> xy
{-# INLINE toColorXYZ #-}
fromColorXYZ xyz = fromRealFloat <$> ColorCIExy (x / s) (y / s)
where
ColorXYZ x y z = xyz
!s = x + y + z
{-# INLINE fromColorXYZ #-}
data Y (i :: k)
newtype instance Color (Y i) e = Luminance (CM.Color CM.Y e)
pattern Y :: e -> Color (Y i) e
pattern Y y = Luminance (CM.Y y)
{-# COMPLETE Y #-}
pattern YA :: e -> e -> Color (Alpha (Y i)) e
pattern YA y a = Alpha (Luminance (CM.Y y)) a
{-# COMPLETE YA #-}
deriving instance Eq e => Eq (Color (Y i) e)
deriving instance Ord e => Ord (Color (Y i) e)
deriving instance Functor (Color (Y i))
deriving instance Applicative (Color (Y i))
deriving instance Foldable (Color (Y i))
deriving instance Traversable (Color (Y i))
deriving instance Storable e => Storable (Color (Y i) e)
instance (Illuminant i, Elevator e) => Show (Color (Y i) e) where
showsPrec _ = showsColorModel
instance (Illuminant i, Elevator e) => ColorModel (Y i) e where
type Components (Y i) e = e
toComponents = coerce
{-# INLINE toComponents #-}
fromComponents = coerce
{-# INLINE fromComponents #-}
instance (Illuminant i, Elevator e) => ColorSpace (Y i) i e where
type BaseModel (Y i) = CM.Y
toBaseSpace = id
fromBaseSpace = id
luminance = fmap toRealFloat
{-# INLINE luminance #-}
toColorXYZ (Y y) = ColorXYZ 0 (toRealFloat y) 0
{-# INLINE toColorXYZ #-}
fromColorXYZ (ColorXYZ _ y _) = Y (fromRealFloat y)
{-# INLINE fromColorXYZ #-}
{-# RULES
"luminance :: RealFloat a => Color Y a -> Color Y a" luminance = id
#-}