{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module Graphics.Color.Adaptation.VonKries
(
convert
, VonKries(..)
, CAT(..)
, ICAT(..)
, ChromaticAdaptationTransform
, cat
, icat
, vonKriesAdaptation
, bradfordAdaptation
, fairchildAdaptation
, ciecat02Adaptation
, cmccat2000Adaptation
, adaptationMatrix
, CIECAM02
, ciecam02Adaptation
) where
import Data.Coerce
import Data.Proxy
import Graphics.Color.Adaptation.Internal
import Graphics.Color.Algebra
import Graphics.Color.Space.Internal
import Data.Typeable
data VonKries
= VonKries
| Bradford
| Fairchild
| CIECAT02
| CMCCAT2000
newtype CAT (t :: k) e =
CAT (M3x3 e)
deriving (Eq)
instance (Typeable t, Typeable k, Elevator e) => Show (CAT (t :: k) e) where
show m@(CAT m3x3) = asProxy m showsType "\n" ++ show m3x3
newtype ICAT (t :: k) e =
ICAT (M3x3 e)
deriving (Eq)
instance (Typeable t, Typeable k, Elevator e) => Show (ICAT (t :: k) e) where
show m@(ICAT m3x3) = asProxy m showsType "\n" ++ show m3x3
icat :: forall t e . (ChromaticAdaptationTransform t, RealFloat e) => ICAT t e
icat = ICAT (invertM3x3 m3x3)
where CAT m3x3 = cat :: CAT t e
class ChromaticAdaptationTransform (t :: VonKries) where
cat :: RealFloat e => CAT t e
instance ChromaticAdaptationTransform 'VonKries where
cat = CAT (M3x3 (V3 0.40024 0.70760 -0.08081)
(V3 -0.22630 1.16532 0.04570)
(V3 0.00000 0.00000 0.91822))
instance ChromaticAdaptationTransform 'Bradford where
cat = CAT (M3x3 (V3 0.8951 0.2664 -0.1614)
(V3 -0.7502 1.7135 0.0367)
(V3 0.0389 -0.0685 1.0296))
instance ChromaticAdaptationTransform 'Fairchild where
cat = CAT (M3x3 (V3 0.8562 0.3372 -0.1934)
(V3 -0.8360 1.8327 0.0033)
(V3 0.0357 -0.0469 1.0112))
instance ChromaticAdaptationTransform 'CIECAT02 where
cat = CAT (M3x3 (V3 0.7328 0.4296 -0.1624)
(V3 -0.7036 1.6975 0.0061)
(V3 0.0030 0.0136 0.9834))
instance ChromaticAdaptationTransform 'CMCCAT2000 where
cat = CAT (M3x3 (V3 0.7982 0.3389 -0.1371)
(V3 -0.5918 1.5512 0.0406)
(V3 0.0008 0.0239 0.9753))
instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e) =>
ChromaticAdaptation (t :: VonKries) (it :: kt) (ir :: kr) e where
newtype Adaptation (t :: VonKries) (it :: kt) (ir :: kr) e =
AdaptationMatrix (M3x3 e) deriving (Eq)
adaptColorXYZ (AdaptationMatrix m3x3) px = coerce (multM3x3byV3 m3x3 (coerce px))
{-# INLINE adaptColorXYZ #-}
data I (i :: k) = I deriving Show
instance (Illuminant it, Illuminant ir, Elevator e) =>
Show (Adaptation (t :: VonKries) (it :: kt) (ir :: kr) e) where
showsPrec _ (AdaptationMatrix m3x3) =
("AdaptationMatrix (" ++) .
showsType (Proxy :: Proxy (I (it :: kt))) .
(") (" ++) . showsType (Proxy :: Proxy (I (ir :: kr))) . (")\n" ++) . shows m3x3
adaptationMatrix ::
forall t it ir e. (ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e)
=> Adaptation (t :: VonKries) it ir e
adaptationMatrix =
AdaptationMatrix (multM3x3byM3x3 (multM3x3byV3d im3x3 diag) m3x3)
where
diag = multM3x3byV3 m3x3 wpRef / multM3x3byV3 m3x3 wpTest
CAT m3x3 = cat :: CAT t e
ICAT im3x3 = icat :: ICAT t e
wpTest = coerce (whitePointTristimulus :: Color (XYZ it) e)
wpRef = coerce (whitePointTristimulus :: Color (XYZ ir) e)
vonKriesAdaptation :: ChromaticAdaptation 'VonKries it ir e => Adaptation 'VonKries it ir e
vonKriesAdaptation = adaptationMatrix
{-# INLINE vonKriesAdaptation #-}
fairchildAdaptation :: ChromaticAdaptation 'Fairchild it ir e => Adaptation 'Fairchild it ir e
fairchildAdaptation = adaptationMatrix
{-# INLINE fairchildAdaptation #-}
bradfordAdaptation :: ChromaticAdaptation 'Bradford it ir e => Adaptation 'Bradford it ir e
bradfordAdaptation = adaptationMatrix
{-# INLINE bradfordAdaptation #-}
ciecat02Adaptation :: ChromaticAdaptation 'CIECAT02 it ir e => Adaptation 'CIECAT02 it ir e
ciecat02Adaptation = adaptationMatrix
{-# INLINE ciecat02Adaptation #-}
cmccat2000Adaptation :: ChromaticAdaptation 'CMCCAT2000 it ir e => Adaptation 'CIECAT02 it ir e
cmccat2000Adaptation = adaptationMatrix
{-# INLINE cmccat2000Adaptation #-}
type CIECAM02 = 'CIECAT02
{-# DEPRECATED CIECAM02 "In favor of a proper name 'CIECAT02'" #-}
ciecam02Adaptation :: ChromaticAdaptation CIECAM02 it ir e => Adaptation CIECAM02 it ir e
ciecam02Adaptation = adaptationMatrix
{-# INLINE ciecam02Adaptation #-}
{-# DEPRECATED ciecam02Adaptation "In favor of a proper name 'ciecat02Adaptation'" #-}
convert :: (ColorSpace cs' i' e', ColorSpace cs i e) => Color cs' e' -> Color cs e
convert = convertElevatedWith (adaptationMatrix @'Bradford @_ @_ @Double)
{-# INLINE convert #-}