{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
-- |
-- Module      : Graphics.Color.Adaptation.VonKries
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Adaptation.VonKries
  ( -- * Color conversion
    convert
    -- * Von Kries adaptation
  , VonKries(..)
  , CAT(..)
  , ICAT(..)
  , ChromaticAdaptationTransform
  , cat
  , icat
  , vonKriesAdaptation
  , bradfordAdaptation
  , fairchildAdaptation
  , ciecat02Adaptation
  , cmccat2000Adaptation
  , adaptationMatrix
  ) 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
  -- ^ VonKries chromatic adaptation transform
  --
  -- >>> cat :: CAT 'VonKries Float
  -- CAT VonKries 'VonKries Float
  -- [ [ 0.40024000, 0.70760000,-0.08081000 ]
  -- , [-0.22630000, 1.16532000, 0.04570000 ]
  -- , [ 0.00000000, 0.00000000, 0.91822000 ] ]
  -- >>> icat :: ICAT 'VonKries Float
  -- ICAT VonKries 'VonKries Float
  -- [ [ 1.85993650,-1.12938170, 0.21989742 ]
  -- , [ 0.36119142, 0.63881250,-0.00000637 ]
  -- , [-0.00000000,-0.00000000, 1.08906360 ] ]
  --
  -- @since 0.1.0
  | Bradford
  -- ^ Bradford chromatic adaptation transform
  --
  -- >>> cat :: CAT 'Bradford Float
  -- CAT VonKries 'Bradford Float
  -- [ [ 0.89510000, 0.26640000,-0.16140000 ]
  -- , [-0.75020000, 1.71350000, 0.03670000 ]
  -- , [ 0.03890000,-0.06850000, 1.02960000 ] ]
  -- >>> icat :: ICAT 'Bradford Float
  -- ICAT VonKries 'Bradford Float
  -- [ [ 0.98699290,-0.14705427, 0.15996265 ]
  -- , [ 0.43230528, 0.51836026, 0.04929122 ]
  -- , [-0.00852867, 0.04004282, 0.96848667 ] ]
  --
  -- @since 0.1.0
  | Fairchild
  -- ^ Fairchild chromatic adaptation transform
  --
  -- >>> cat :: CAT 'Fairchild Float
  -- CAT VonKries 'Fairchild Float
  -- [ [ 0.85620000, 0.33720000,-0.19340000 ]
  -- , [-0.83600000, 1.83270000, 0.00330000 ]
  -- , [ 0.03570000,-0.04690000, 1.01120000 ] ]
  -- >>> icat :: ICAT 'Fairchild Float
  -- ICAT VonKries 'Fairchild Float
  -- [ [ 0.98739994,-0.17682500, 0.18942511 ]
  -- , [ 0.45043513, 0.46493286, 0.08463200 ]
  -- , [-0.01396833, 0.02780657, 0.98616177 ] ]
  --
  -- @since 0.1.0
  | CIECAT02
  -- ^ CIECAT02 chromatic adaptation transform
  --
  -- >>> cat :: CAT 'CIECAT02 Float
  -- CAT VonKries 'CIECAT02 Float
  -- [ [ 0.73280000, 0.42960000,-0.16240000 ]
  -- , [-0.70360000, 1.69750000, 0.00610000 ]
  -- , [ 0.00300000, 0.01360000, 0.98340000 ] ]
  -- >>> icat :: ICAT 'CIECAT02 Float
  -- ICAT VonKries 'CIECAT02 Float
  -- [ [ 1.09612380,-0.27886900, 0.18274519 ]
  -- , [ 0.45436904, 0.47353318, 0.07209781 ]
  -- , [-0.00962761,-0.00569803, 1.01532570 ] ]
  --
  -- @since 0.1.3
  | CMCCAT2000
  -- ^ CMCCAT2000 chromatic adaptation transform
  --
  -- >>> cat :: CAT 'CMCCAT2000 Float
  -- CAT VonKries 'CMCCAT2000 Float
  -- [ [ 0.79820000, 0.33890000,-0.13710000 ]
  -- , [-0.59180000, 1.55120000, 0.04060000 ]
  -- , [ 0.00080000, 0.02390000, 0.97530000 ] ]
  -- >>> icat :: ICAT 'CMCCAT2000 Float
  -- ICAT VonKries 'CMCCAT2000 Float
  -- [ [ 1.07645010,-0.23766239, 0.16121234 ]
  -- , [ 0.41096430, 0.55434180, 0.03469386 ]
  -- , [-0.01095376,-0.01338936, 1.02434310 ] ]
  --
  -- @since 0.1.3

-- | Chromatic adaptation transformation matrix
newtype CAT (t :: k) e =
  CAT (M3x3 e)
  deriving (CAT t e -> CAT t e -> Bool
(CAT t e -> CAT t e -> Bool)
-> (CAT t e -> CAT t e -> Bool) -> Eq (CAT t e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (t :: k) e. Eq e => CAT t e -> CAT t e -> Bool
/= :: CAT t e -> CAT t e -> Bool
$c/= :: forall k (t :: k) e. Eq e => CAT t e -> CAT t e -> Bool
== :: CAT t e -> CAT t e -> Bool
$c== :: forall k (t :: k) e. Eq e => CAT t e -> CAT t e -> Bool
Eq)

instance (Typeable t, Typeable k, Elevator e) => Show (CAT (t :: k) e) where
  show :: CAT t e -> String
show m :: CAT t e
m@(CAT M3x3 e
m3x3) = CAT t e -> (Proxy (CAT t e) -> ShowS) -> ShowS
forall p t. p -> (Proxy p -> t) -> t
asProxy CAT t e
m Proxy (CAT t e) -> ShowS
forall k (t :: k) (proxy :: k -> *). Typeable t => proxy t -> ShowS
showsType String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ M3x3 e -> String
forall a. Show a => a -> String
show M3x3 e
m3x3

-- | Inverse of chromatic adaptation transformation matrix
newtype ICAT (t :: k) e =
  ICAT (M3x3 e)
  deriving (ICAT t e -> ICAT t e -> Bool
(ICAT t e -> ICAT t e -> Bool)
-> (ICAT t e -> ICAT t e -> Bool) -> Eq (ICAT t e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (t :: k) e. Eq e => ICAT t e -> ICAT t e -> Bool
/= :: ICAT t e -> ICAT t e -> Bool
$c/= :: forall k (t :: k) e. Eq e => ICAT t e -> ICAT t e -> Bool
== :: ICAT t e -> ICAT t e -> Bool
$c== :: forall k (t :: k) e. Eq e => ICAT t e -> ICAT t e -> Bool
Eq)

instance (Typeable t, Typeable k, Elevator e) => Show (ICAT (t :: k) e) where
  show :: ICAT t e -> String
show m :: ICAT t e
m@(ICAT M3x3 e
m3x3) = ICAT t e -> (Proxy (ICAT t e) -> ShowS) -> ShowS
forall p t. p -> (Proxy p -> t) -> t
asProxy ICAT t e
m Proxy (ICAT t e) -> ShowS
forall k (t :: k) (proxy :: k -> *). Typeable t => proxy t -> ShowS
showsType String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ M3x3 e -> String
forall a. Show a => a -> String
show M3x3 e
m3x3

icat :: forall t e . (ChromaticAdaptationTransform t, RealFloat e) => ICAT t e
icat :: ICAT t e
icat = M3x3 e -> ICAT t e
forall k (t :: k) e. M3x3 e -> ICAT t e
ICAT (M3x3 e -> M3x3 e
forall a. Fractional a => M3x3 a -> M3x3 a
invertM3x3 M3x3 e
m3x3)
  where CAT M3x3 e
m3x3 = CAT t e
forall (t :: VonKries) e.
(ChromaticAdaptationTransform t, RealFloat e) =>
CAT t e
cat :: CAT t e

class ChromaticAdaptationTransform (t :: VonKries) where
  cat :: RealFloat e => CAT t e

instance ChromaticAdaptationTransform 'VonKries where
  cat :: CAT 'VonKries e
cat = M3x3 e -> CAT 'VonKries e
forall k (t :: k) e. M3x3 e -> CAT t e
CAT (V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.40024 e
0.70760 e
-0.08081)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
-0.22630 e
1.16532  e
0.04570)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.00000 e
0.00000  e
0.91822))

instance ChromaticAdaptationTransform 'Bradford where
  cat :: CAT 'Bradford e
cat = M3x3 e -> CAT 'Bradford e
forall k (t :: k) e. M3x3 e -> CAT t e
CAT (V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.8951  e
0.2664 e
-0.1614)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
-0.7502  e
1.7135  e
0.0367)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.0389 e
-0.0685  e
1.0296))

instance ChromaticAdaptationTransform 'Fairchild where
  cat :: CAT 'Fairchild e
cat = M3x3 e -> CAT 'Fairchild e
forall k (t :: k) e. M3x3 e -> CAT t e
CAT (V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.8562  e
0.3372 e
-0.1934)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
-0.8360  e
1.8327  e
0.0033)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.0357 e
-0.0469  e
1.0112))

instance ChromaticAdaptationTransform 'CIECAT02 where
  cat :: CAT 'CIECAT02 e
cat = M3x3 e -> CAT 'CIECAT02 e
forall k (t :: k) e. M3x3 e -> CAT t e
CAT (V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.7328  e
0.4296 e
-0.1624)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
-0.7036  e
1.6975  e
0.0061)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.0030  e
0.0136  e
0.9834))

instance ChromaticAdaptationTransform 'CMCCAT2000 where
  cat :: CAT 'CMCCAT2000 e
cat = M3x3 e -> CAT 'CMCCAT2000 e
forall k (t :: k) e. M3x3 e -> CAT t e
CAT (V3 e -> V3 e -> V3 e -> M3x3 e
forall a. V3 a -> V3 a -> V3 a -> M3x3 a
M3x3 (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.7982  e
0.3389 e
-0.1371)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3 e
-0.5918  e
1.5512  e
0.0406)
                  (e -> e -> e -> V3 e
forall a. a -> a -> a -> V3 a
V3  e
0.0008  e
0.0239  e
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 (Adaptation t it ir e -> Adaptation t it ir e -> Bool
(Adaptation t it ir e -> Adaptation t it ir e -> Bool)
-> (Adaptation t it ir e -> Adaptation t it ir e -> Bool)
-> Eq (Adaptation t it ir e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: VonKries) kt (it :: kt) kr (ir :: kr) e.
Eq e =>
Adaptation t it ir e -> Adaptation t it ir e -> Bool
/= :: Adaptation t it ir e -> Adaptation t it ir e -> Bool
$c/= :: forall (t :: VonKries) kt (it :: kt) kr (ir :: kr) e.
Eq e =>
Adaptation t it ir e -> Adaptation t it ir e -> Bool
== :: Adaptation t it ir e -> Adaptation t it ir e -> Bool
$c== :: forall (t :: VonKries) kt (it :: kt) kr (ir :: kr) e.
Eq e =>
Adaptation t it ir e -> Adaptation t it ir e -> Bool
Eq)
  adaptColorXYZ :: Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e
adaptColorXYZ (AdaptationMatrix m3x3) Color (XYZ it) e
px = V3 e -> Color (XYZ ir) e
coerce (M3x3 e -> V3 e -> V3 e
forall a. Num a => M3x3 a -> V3 a -> V3 a
multM3x3byV3 M3x3 e
m3x3 (Color (XYZ it) e -> V3 e
coerce Color (XYZ it) e
px))
  {-# INLINE adaptColorXYZ #-}

-- | Helper show type for the poly kinded illuminant
data I (i :: k) = I deriving Int -> I i -> ShowS
[I i] -> ShowS
I i -> String
(Int -> I i -> ShowS)
-> (I i -> String) -> ([I i] -> ShowS) -> Show (I i)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (i :: k). Int -> I i -> ShowS
forall k (i :: k). [I i] -> ShowS
forall k (i :: k). I i -> String
showList :: [I i] -> ShowS
$cshowList :: forall k (i :: k). [I i] -> ShowS
show :: I i -> String
$cshow :: forall k (i :: k). I i -> String
showsPrec :: Int -> I i -> ShowS
$cshowsPrec :: forall k (i :: k). Int -> I i -> ShowS
Show

instance (Illuminant it, Illuminant ir, Elevator e) =>
         Show (Adaptation (t :: VonKries) (it :: kt) (ir :: kr) e) where
  showsPrec :: Int -> Adaptation t it ir e -> ShowS
showsPrec Int
_ (AdaptationMatrix m3x3) =
    (String
"AdaptationMatrix (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Proxy (I it) -> ShowS
forall k (t :: k) (proxy :: k -> *). Typeable t => proxy t -> ShowS
showsType (Proxy (I it)
forall k (t :: k). Proxy t
Proxy :: Proxy (I (it :: kt))) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String
") (" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (I ir) -> ShowS
forall k (t :: k) (proxy :: k -> *). Typeable t => proxy t -> ShowS
showsType (Proxy (I ir)
forall k (t :: k). Proxy t
Proxy :: Proxy (I (ir :: kr))) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
")\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M3x3 e -> ShowS
forall a. Show a => a -> ShowS
shows M3x3 e
m3x3

adaptationMatrix ::
     forall t it ir e. (ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e)
  => Adaptation (t :: VonKries) it ir e
adaptationMatrix :: Adaptation t it ir e
adaptationMatrix =
  M3x3 e -> Adaptation t it ir e
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
M3x3 e -> Adaptation t it ir e
AdaptationMatrix (M3x3 e -> M3x3 e -> M3x3 e
forall a. Num a => M3x3 a -> M3x3 a -> M3x3 a
multM3x3byM3x3 (M3x3 e -> V3 e -> M3x3 e
forall a. Num a => M3x3 a -> V3 a -> M3x3 a
multM3x3byV3d M3x3 e
im3x3 V3 e
diag) M3x3 e
m3x3)
  where
    diag :: V3 e
diag = M3x3 e -> V3 e -> V3 e
forall a. Num a => M3x3 a -> V3 a -> V3 a
multM3x3byV3 M3x3 e
m3x3 V3 e
wpRef V3 e -> V3 e -> V3 e
forall a. Fractional a => a -> a -> a
/ M3x3 e -> V3 e -> V3 e
forall a. Num a => M3x3 a -> V3 a -> V3 a
multM3x3byV3 M3x3 e
m3x3 V3 e
wpTest
    CAT M3x3 e
m3x3 = CAT t e
forall (t :: VonKries) e.
(ChromaticAdaptationTransform t, RealFloat e) =>
CAT t e
cat :: CAT t e
    ICAT M3x3 e
im3x3 = ICAT t e
forall (t :: VonKries) e.
(ChromaticAdaptationTransform t, RealFloat e) =>
ICAT t e
icat :: ICAT t e
    wpTest :: V3 e
wpTest = Color (XYZ it) e -> V3 e
coerce (Color (XYZ it) e
forall k (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Color (XYZ i) e
whitePointTristimulus :: Color (XYZ it) e)
    wpRef :: V3 e
wpRef = Color (XYZ ir) e -> V3 e
coerce (Color (XYZ ir) e
forall k (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Color (XYZ i) e
whitePointTristimulus :: Color (XYZ ir) e)

-- | `VonKries` chromatic adaptation transform.
--
-- @since 0.1.2
vonKriesAdaptation :: ChromaticAdaptation 'VonKries it ir e => Adaptation 'VonKries it ir e
vonKriesAdaptation :: Adaptation 'VonKries it ir e
vonKriesAdaptation = Adaptation 'VonKries it ir e
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
(ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) =>
Adaptation t it ir e
adaptationMatrix
{-# INLINE vonKriesAdaptation #-}

-- | `Fairchild` chromatic adaptation transform.
--
-- @since 0.1.2
fairchildAdaptation :: ChromaticAdaptation 'Fairchild it ir e => Adaptation 'Fairchild it ir e
fairchildAdaptation :: Adaptation 'Fairchild it ir e
fairchildAdaptation = Adaptation 'Fairchild it ir e
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
(ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) =>
Adaptation t it ir e
adaptationMatrix
{-# INLINE fairchildAdaptation #-}

-- | `Bradford` chromatic adaptation transform, as defined in the
-- [CIECAM97s](https://en.wikipedia.org/wiki/Color_appearance_model#CIECAM97s) color
-- appearance model.
--
-- @since 0.1.2
bradfordAdaptation :: ChromaticAdaptation 'Bradford it ir e => Adaptation 'Bradford it ir e
bradfordAdaptation :: Adaptation 'Bradford it ir e
bradfordAdaptation = Adaptation 'Bradford it ir e
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
(ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) =>
Adaptation t it ir e
adaptationMatrix
{-# INLINE bradfordAdaptation #-}

-- | `CIECAT02` chromatic adaptation as defined it
-- [CIECAM02](https://en.wikipedia.org/wiki/CIECAM02) color appearance model
--
-- @since 0.1.3
ciecat02Adaptation :: ChromaticAdaptation 'CIECAT02 it ir e => Adaptation 'CIECAT02 it ir e
ciecat02Adaptation :: Adaptation 'CIECAT02 it ir e
ciecat02Adaptation = Adaptation 'CIECAT02 it ir e
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
(ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) =>
Adaptation t it ir e
adaptationMatrix
{-# INLINE ciecat02Adaptation #-}

-- | `CMCCAT2000` chromatic adaptation. Predecessor of `CIECAT02`. as defined it
-- [CIECAM02](https://en.wikipedia.org/wiki/CIECAM02) color appearance model
--
-- @since 0.1.3
cmccat2000Adaptation :: ChromaticAdaptation 'CMCCAT2000 it ir e => Adaptation 'CIECAT02 it ir e
cmccat2000Adaptation :: Adaptation 'CIECAT02 it ir e
cmccat2000Adaptation = Adaptation 'CIECAT02 it ir e
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
(ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) =>
Adaptation t it ir e
adaptationMatrix
{-# INLINE cmccat2000Adaptation #-}

-- | This function allows conversion of a color between any two color spaces. It uses a
-- very common `VonKries` chromatic adaptation transform with `Bradford` matrix. One of
-- more general functions `Graphics.Color.Adaptation.convertWith` or
-- `Graphics.Color.Adaptation.convertElevatedWith` can be used for selecting another
-- chromatic adaptation algorithm.
--
-- @since 0.1.0
convert :: (ColorSpace cs' i' e', ColorSpace cs i e) => Color cs' e' -> Color cs e
convert :: Color cs' e' -> Color cs e
convert = Adaptation 'Bradford i' i Double -> Color cs' e' -> Color cs e
forall k kt kr (t :: k) (i' :: kt) (i :: kr) a cs' e' cs e.
(ChromaticAdaptation t i' i a, ColorSpace cs' i' e',
 ColorSpace cs i e) =>
Adaptation t i' i a -> Color cs' e' -> Color cs e
convertElevatedWith ((ChromaticAdaptationTransform 'Bradford,
 ChromaticAdaptation 'Bradford i' i Double) =>
Adaptation 'Bradford i' i Double
forall kt kr (t :: VonKries) (it :: kt) (ir :: kr) e.
(ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) =>
Adaptation t it ir e
adaptationMatrix @'Bradford @_ @_ @Double)
{-# INLINE convert #-}