content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  -- |
  -- Module      : Graphics.Color.Space.RGB.Luma
  -- Copyright   : (c) Alexey Kuleshevich 2018-2025
  -- License     : BSD3
  -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
  -- Stability   : experimental
  -- Portability : non-portable
  --
  module Graphics.Color.Space.RGB.Luma
    ( -- * Luma
      pattern Y'
    , pattern Y'A
    , pattern Luma
    , Y'
    , Luma(..)
    , Weight(..)
    , Weights(..)
    , rgbLuma
    , rgbLumaWeights
    , toBaseLinearSpace
    ) where
  
  import Data.Coerce
  import Data.Kind
  import Data.List.NonEmpty
  import Data.Typeable
  import Foreign.Storable
  import Graphics.Color.Model.Internal
  import Graphics.Color.Model.RGB as CM
  import Graphics.Color.Model.X as CM
  import Graphics.Color.Space.Internal
  import Graphics.Color.Space.RGB.Internal
  
  -------------
  --- Luma ----
  -------------
  
  -- | [Luma](https://en.wikipedia.org/wiki/Luma_(video\)) of a non-linear gamma corrected
  -- RGB color space. (Not to be confused with luminance `Y`)
  data Y' (cs :: Linearity -> Type)
  
  -- | Constructor for Luma.
  newtype instance Color (Y' cs) e = Luma (CM.Color CM.X e)
  
  -- | Constructor for Luma `Y'`. (Not to be confused with luminance `Y`)
  --
  -- @since 0.1.0
  pattern Y' :: e -> Color (Y' cs) e
  pattern Y' y = Luma (CM.X y)
  {-# COMPLETE Y' #-}
  
  -- | Constructor for `Y'` with alpha channel. (Not to be confused with luminance `Y`)
  --
  -- @since 0.1.4
  pattern Y'A :: e -> e -> Color (Alpha (Y' cs)) e
  pattern Y'A y a = Alpha (Luma (CM.X y)) a
  {-# COMPLETE Y'A #-}
  
  -- | `Y'` - luma of a color space
  deriving instance Eq e => Eq (Color (Y' cs) e)
  -- | `Y'` - luma of a color space
  deriving instance Ord e => Ord (Color (Y' cs) e)
  -- | `Y'` - luma of a color space
  deriving instance Functor (Color (Y' cs))
  -- | `Y'` - luma of a color space
  deriving instance Applicative (Color (Y' cs))
  -- | `Y'` - luma of a color space
  deriving instance Foldable (Color (Y' cs))
  -- | `Y'` - luma of a color space
  deriving instance Traversable (Color (Y' cs))
  -- | `Y'` - luma of a color space
  deriving instance Storable e => Storable (Color (Y' cs) e)
  
  
  -- | `Y'` - as a color model
  instance (Typeable cs, Elevator e) => Show (Color (Y' cs) e) where
    showsPrec _ = showsColorModel
  
  -- | `Y'` - as a color model
  instance (Typeable cs, Elevator e) => ColorModel (Y' cs) e where
    type Components (Y' cs) e = e
    type ChannelCount (Y' cs) = 1
    channelCount _ = 1
    {-# INLINE channelCount #-}
    channelNames _ = "Luma" :| []
    channelColors _ = V3 0x80 0x80 0x80 :| []
    toComponents (Y' y) = y
    {-# INLINE toComponents #-}
    fromComponents = Y'
    {-# INLINE fromComponents #-}
  
  
  instance ( Typeable cs
           , ColorSpace (cs 'Linear) i e
           , ColorSpace (cs 'NonLinear) i e
           , Luma cs
           , RedGreenBlue cs i
           ) =>
           ColorSpace (Y' cs) i e where
    type BaseModel (Y' cs) = CM.X
    type BaseSpace (Y' cs) = cs 'NonLinear
    toBaseSpace y = pure (coerce y :: e)
    {-# INLINE toBaseSpace #-}
    fromBaseSpace = fmap fromDouble . rgbLuma
    {-# INLINE fromBaseSpace #-}
    grayscale = coerce
    {-# INLINE grayscale #-}
    applyGrayscale c f = coerce (f (coerce c))
    {-# INLINE applyGrayscale #-}
    replaceGrayscale _ = coerce
    {-# INLINE replaceGrayscale #-}
    luminance = luminance . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble
    {-# INLINE luminance #-}
    toColorXYZ = toColorXYZ . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble
    {-# INLINE toColorXYZ #-}
  
  -- | Convert Luma directly into the linear version of base space. This is equivalent to
  -- `dcctf . toBaseSpace`, but is a bit faster, since inverse transfer function is applied
  -- only once
  --
  -- @since 0.3.0
  toBaseLinearSpace ::
       forall cs e i. (RedGreenBlue cs i, Applicative (Color (cs 'Linear)), RealFloat e)
    => Color (Y' cs) e
    -> Color (cs 'Linear) e
  toBaseLinearSpace y = pure (itransfer @_ @cs (coerce y :: e))
  {-# INLINE toBaseLinearSpace #-}
  
  ------------------
  -- Luma Weights --
  ------------------
  
  class Luma (cs :: Linearity -> Type) where
    {-# MINIMAL (rWeight, gWeight)|(rWeight, bWeight)|(gWeight, bWeight) #-}
    rWeight :: RealFloat e => Weight cs e
    rWeight = 1 - bWeight - gWeight
    {-# INLINE rWeight #-}
  
    gWeight :: RealFloat e => Weight cs e
    gWeight = 1 - rWeight - bWeight
    {-# INLINE gWeight #-}
  
    bWeight :: RealFloat e => Weight cs e
    bWeight = 1 - rWeight - gWeight
    {-# INLINE bWeight #-}
  
  newtype Weight cs e = Weight
    { unWeight :: e
    } deriving (Eq, Show, Num, Fractional, Floating, Functor)
  
  -- | Get the weights of a non-linear RGB color space that can be used for converting to `Luma`
  --
  -- @since 0.1.4
  rgbLumaWeights ::
       forall cs e' e. (Luma cs, RealFloat e)
    => Color (cs 'NonLinear) e'
    -> Weights e
  rgbLumaWeights _ =
    Weights (V3 (coerce (rWeight :: Weight cs e) :: e)
                (coerce (gWeight :: Weight cs e) :: e)
                (coerce (bWeight :: Weight cs e) :: e))
  {-# INLINE rgbLumaWeights #-}
  
  -- | Convert a non-linear RGB pixel to a luma pixel
  --
  -- @since 0.1.0
  rgbLuma ::
       forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e)
    => Color (cs 'NonLinear) e'
    -> Color (Y' cs) e
  rgbLuma rgb' = Y' (coerce (fmap toRealFloat rgb :: Color CM.RGB e) `dotProduct` coerce weights)
    where
      !rgb = unColorRGB rgb'
      !weights = rgbLumaWeights rgb' :: Weights e
  {-# INLINE rgbLuma #-}
  