{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module      : Graphics.Color.Adaptation.Internal
-- Copyright   : (c) Alexey Kuleshevich 2019-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Adaptation.Internal
  ( ChromaticAdaptation(..)
  , Adaptation(..)
  , chromaticAdaptation
  , convertWith
  , convertElevatedWith
  , convertNoAdaptation
  ) where

import Graphics.Color.Space.Internal
import Graphics.Color.Space.RGB.Internal
import Data.Kind


class (Illuminant it, Illuminant ir, Elevator e, RealFloat e) =>
      ChromaticAdaptation (t :: k) (it :: kt) (ir :: kr) e
  where
  data Adaptation t it ir e :: Type
  adaptColorXYZ :: Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e

-- | This performs no adaptation, but only when illuminants are exactly the same
data ExactNoAdaptation

instance (Illuminant i, Elevator e, RealFloat e) =>
         ChromaticAdaptation ExactNoAdaptation i i e where
  data Adaptation ExactNoAdaptation i i e = ExactNoAdaptation
  adaptColorXYZ :: Adaptation ExactNoAdaptation i i e
-> Color (XYZ i) e -> Color (XYZ i) e
adaptColorXYZ Adaptation ExactNoAdaptation i i e
_ = Color (XYZ i) e -> Color (XYZ i) e
forall a. a -> a
id

-- | This performs no adaptation, but only when illuminants are almost the same.
data ApproximateNoAdaptation

instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e, Temperature it ~ Temperature ir) =>
         ChromaticAdaptation ApproximateNoAdaptation it ir e where
  data Adaptation ApproximateNoAdaptation it ir e = ApproximateNoAdaptation
  adaptColorXYZ :: Adaptation ApproximateNoAdaptation it ir e
-> Color (XYZ it) e -> Color (XYZ ir) e
adaptColorXYZ Adaptation ApproximateNoAdaptation it ir e
_ (ColorXYZ e
x e
y e
z) = e -> e -> e -> Color (XYZ ir) e
forall k e (i :: k). e -> e -> e -> Color (XYZ i) e
ColorXYZ e
x e
y e
z

chromaticAdaptation ::
     ChromaticAdaptation t it ir e
  => Adaptation t it ir e
  -> Gamut cs it e
  -> Gamut cs ir e
chromaticAdaptation :: Adaptation t it ir e -> Gamut cs it e -> Gamut cs ir e
chromaticAdaptation Adaptation t it ir e
adaptation Gamut cs it e
g = Primary ir e -> Primary ir e -> Primary ir e -> Gamut cs ir e
forall k (cs :: Linearity -> *) (i :: k) e.
Primary i e -> Primary i e -> Primary i e -> Gamut cs i e
Gamut Primary ir e
redPrimary Primary ir e
greenPrimary Primary ir e
bluePrimary
  where
    applyMatrix :: Primary it e -> Primary ir e
applyMatrix Primary it e
primary =
      Chromaticity ir e -> Primary ir e
forall k (i :: k) e. Chromaticity i e -> Primary i e
PrimaryChromaticity
        (Color (CIExyY ir) e -> Chromaticity ir e
forall k (i :: k) e. Color (CIExyY i) e -> Chromaticity i e
Chromaticity (Color (XYZ ir) e -> Color (CIExyY ir) e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ (Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e
forall k kt kr (t :: k) (i' :: kt) (i :: kr) e cs' cs.
(ChromaticAdaptation t i' i e, ColorSpace cs' i' e,
 ColorSpace cs i e) =>
Adaptation t i' i e -> Color cs' e -> Color cs e
convertWith Adaptation t it ir e
adaptation (Primary it e -> Color (XYZ it) e
forall k (i :: k) e.
(Illuminant i, RealFloat e, Elevator e) =>
Primary i e -> Color (XYZ i) e
primaryTristimulus Primary it e
primary))))
    redPrimary :: Primary ir e
redPrimary = Primary it e -> Primary ir e
applyMatrix (Gamut cs it e -> Primary it e
forall (cs :: Linearity -> *) k (i :: k) e.
Gamut cs i e -> Primary i e
gamutRedPrimary Gamut cs it e
g)
    greenPrimary :: Primary ir e
greenPrimary = Primary it e -> Primary ir e
applyMatrix (Gamut cs it e -> Primary it e
forall (cs :: Linearity -> *) k (i :: k) e.
Gamut cs i e -> Primary i e
gamutGreenPrimary Gamut cs it e
g)
    bluePrimary :: Primary ir e
bluePrimary = Primary it e -> Primary ir e
applyMatrix (Gamut cs it e -> Primary it e
forall (cs :: Linearity -> *) k (i :: k) e.
Gamut cs i e -> Primary i e
gamutBluePrimary Gamut cs it e
g)


convertWith ::
     (ChromaticAdaptation t i' i e, ColorSpace cs' i' e, ColorSpace cs i e)
  => Adaptation t i' i e
  -> Color cs' e
  -> Color cs e
convertWith :: Adaptation t i' i e -> Color cs' e -> Color cs e
convertWith = Adaptation t i' i e -> 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
{-# INLINE convertWith #-}

convertElevatedWith ::
     (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 :: Adaptation t i' i a -> Color cs' e' -> Color cs e
convertElevatedWith Adaptation t i' i a
adaptation = Color (XYZ i) a -> Color cs e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ (Color (XYZ i) a -> Color cs e)
-> (Color cs' e' -> Color (XYZ i) a) -> Color cs' e' -> Color cs e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Adaptation t i' i a -> Color (XYZ i') a -> Color (XYZ i) a
forall k kt kr (t :: k) (it :: kt) (ir :: kr) e.
ChromaticAdaptation t it ir e =>
Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e
adaptColorXYZ Adaptation t i' i a
adaptation (Color (XYZ i') a -> Color (XYZ i) a)
-> (Color cs' e' -> Color (XYZ i') a)
-> Color cs' e'
-> Color (XYZ i) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color cs' e' -> Color (XYZ i') a
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ
{-# INLINE[2] convertElevatedWith #-}

-- | Convert a color from one color space into another one with the same illuminant, thus
-- not requiring a chromatic adaptation.
--
-- @since 0.1.0
convertNoAdaptation ::
     forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e)
  => Color cs' e'
  -> Color cs e
convertNoAdaptation :: Color cs' e' -> Color cs e
convertNoAdaptation = Color (XYZ i) Double -> Color cs e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ (Color (XYZ i) Double -> Color cs e)
-> (Color cs' e' -> Color (XYZ i) Double)
-> Color cs' e'
-> Color cs e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color cs' e' -> Color (XYZ i) Double
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ :: Color cs' e' -> Color (XYZ i) Double)
{-# INLINE convertNoAdaptation #-}

convertNoAdaptationFloat ::
     forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e)
  => Color cs' e'
  -> Color cs e
convertNoAdaptationFloat :: Color cs' e' -> Color cs e
convertNoAdaptationFloat = Color (XYZ i) Float -> Color cs e
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color (XYZ i) a -> Color cs e
fromColorXYZ (Color (XYZ i) Float -> Color cs e)
-> (Color cs' e' -> Color (XYZ i) Float)
-> Color cs' e'
-> Color cs e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color cs' e' -> Color (XYZ i) Float
forall k cs (i :: k) e a.
(ColorSpace cs i e, Elevator a, RealFloat a) =>
Color cs e -> Color (XYZ i) a
toColorXYZ :: Color cs' e' -> Color (XYZ i) Float)
{-# INLINE convertNoAdaptationFloat #-}

{-# RULES
"convertElevatedWith (Float)"[~2] forall (a :: Adaptation t i i Float) . convertElevatedWith a = convertNoAdaptationFloat
"convertElevatedWith (Double)"[~2] forall (a :: Adaptation t i i Double) . convertElevatedWith a = convertNoAdaptation
  #-}


-- toword8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptationMatrix :: VonKriesAdaptationMatrix Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double)