content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ViewPatterns #-}
  -- |
  -- Module      : Graphics.Color.Space.CIE1976.LUV
  --
  module Graphics.Color.Space.CIE1976.LUV
    ( -- * Constructors for an CIE L*u*v* color space.
      pattern LUV
    , pattern ColorLUV
    , pattern ColorLUVA
    , LUV
    ) where
  
  import Data.Coerce
  import Data.List.NonEmpty
  import Foreign.Storable
  import Graphics.Color.Model.Internal
  import Graphics.Color.Space.Internal
  
  --------------
  --- CIELUV ---
  --------------
  
  -- | [CIE L*u*v*](https://en.wikipedia.org/wiki/CIELUV_color_space) color space
  data LUV (i :: k)
  
  -- | Color in CIE L*u*v* color space
  newtype instance Color (LUV i) e = LUV (V3 e)
  
  
  pattern ColorLUV :: e -> e -> e -> Color (LUV i) e
  pattern ColorLUV l' u' v' = LUV (V3 l' u' v')
  {-# COMPLETE ColorLUV #-}
  
  -- | Constructor for @LUV@ with alpha channel.
  pattern ColorLUVA :: e -> e -> e -> e -> Color (Alpha (LUV i)) e
  pattern ColorLUVA l' u' v' a = Alpha (LUV (V3 l' u' v')) a
  {-# COMPLETE ColorLUVA #-}
  
  -- | CIE1976 `LUV` color space
  deriving instance Eq e => Eq (Color (LUV i) e)
  
  -- | CIE1976 `LUV` color space
  deriving instance Ord e => Ord (Color (LUV i) e)
  
  -- | CIE1976 `LUV` color space
  deriving instance Functor (Color (LUV i))
  
  -- | CIE1976 `LUV` color space
  deriving instance Applicative (Color (LUV i))
  
  -- | CIE1976 `LUV` color space
  deriving instance Foldable (Color (LUV i))
  
  -- | CIE1976 `LUV` color space
  deriving instance Traversable (Color (LUV i))
  
  -- | CIE1976 `LUV` color space
  deriving instance Storable e => Storable (Color (LUV i) e)
  
  -- | CIE1976 `LUV` color space
  instance (Illuminant i, Elevator e) => Show (Color (LUV i) e) where
    showsPrec _ = showsColorModel
  
  -- | CIE1976 `LUV` color space
  instance (Illuminant i, Elevator e) => ColorModel (LUV i) e where
    type Components (LUV i) e = (e, e, e)
    type ChannelCount (LUV i) = 3
    channelCount _ = 3
    {-# INLINE channelCount #-}
    channelNames _ = "L" :| ["U", "V"]
    channelColors _ = V3 0x80 0x80 0x80 :|
                    [ V3 0x00 0xff 0xff
                    , V3 0x00 0x00 0x00
                    ]
    toComponents (ColorLUV l' u' v') = (l', u', v')
    {-# INLINE toComponents #-}
    fromComponents (l', u', v') = ColorLUV l' u' v'
    {-# INLINE fromComponents #-}
  
  instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (LUV (i :: k)) i e where
    type BaseModel (LUV i) = LUV i
    type BaseSpace (LUV i) = LUV i
    toBaseSpace = id
    {-# INLINE toBaseSpace #-}
    fromBaseSpace = id
    {-# INLINE fromBaseSpace #-}
    luminance (ColorLUV l' _ _) = Y (ift (scaleLightness l'))
    {-# INLINE luminance #-}
    grayscale (coerce -> V3 l _ _) = X l
    {-# INLINE grayscale #-}
    replaceGrayscale (coerce -> V3 _ c h) (X l) = coerce (V3 l c h)
    {-# INLINE replaceGrayscale #-}
    toColorXYZ = luv2xyz
    {-# INLINE toColorXYZ #-}
    fromColorXYZ = xyz2luv
    {-# INLINE fromColorXYZ #-}
  
  luv2xyz ::
       forall i a e. (Illuminant i, Elevator e, Elevator a, RealFloat a)
    => Color (LUV i) e
    -> Color (XYZ i) a
  luv2xyz (ColorLUV l' u' v') = ColorXYZ x y z
    where
      !(ColorXYZ wx _ wz) = whitePointTristimulus :: Color (XYZ i) a
      !y = ift . scaleLightness $ l'
      !wxyz = wx + 15 + 3 * wz
      !l1 = 13 * toRealFloat l'
      !a = (1/3) * ((4 * l1 / (toRealFloat u' + l1 * 4 * (wx / wxyz))) - 1) :: a
      !b = -5 * y
      !c = -1 / 3
      !d = y * (3 * l1 / (toRealFloat v' + l1 * 9 * (1 / wxyz)) - 5) :: a
      !x = (d - b) / (a - c)
      !z = x * a + b
  {-# INLINE luv2xyz #-}
  
  scaleLightness :: (Elevator e, Elevator a, RealFloat a) => e -> a
  scaleLightness l' = (toRealFloat l' + 16) / 116
  {-# INLINE scaleLightness #-}
  
  ift :: (Fractional a, Ord a) => a -> a
  ift t
    | t > 6 / 29 = t ^ (3 :: Int)
    | otherwise = (108 / 841) * (t - 4 / 29)
  
  
  xyz2luv ::
       forall i a e. (Illuminant i, Elevator a, Elevator e, RealFloat e)
    => Color (XYZ i) a
    -> Color (LUV i) e
  xyz2luv (ColorXYZ x y z) = ColorLUV l' u' v'
    where
      !l' = 116 * ft (toRealFloat y) - 16
      !(ColorXYZ wx _ wz) = whitePointTristimulus :: Color (XYZ i) e
      !xyz = toRealFloat $ x + 15 * y + 3 * z
      !wxyz = wx + 15 + 3 * wz
      !u' = 13 * l' * 4 * (toRealFloat x / xyz - wx / wxyz)
      !v' = 13 * l' * 9 * (toRealFloat y / xyz - 1 / wxyz)
  {-# INLINE xyz2luv #-}
  
  ft :: RealFloat a => a -> a
  ft t
    | t > t0 = t ** (1 / 3)
    | otherwise = t * m + 4 / 29
  {-# INLINE ft #-}
  
  m :: RealFloat a => a
  m = 841 / 108
  
  t0 :: RealFloat a => a
  t0 = 216 / 24389
    -- where
    --   m = 1/3 * δ^-2 = 841/108 =~ 7.787[037]
    --   t0 = δ^3 =~ 0.008856
    --   δ = 6/29 =~ 0.2069
  