{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module      : Graphics.Color.Model.X
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.X
  ( X
  -- * Constructors for X color model.
  , pattern ColorX
  , pattern ColorXA
  , Color(X)
  , Weights(..)
  , rgb2y
  ) where

import Data.Coerce
import Foreign.Storable
import Graphics.Color.Model.Internal
import Graphics.Color.Model.RGB

-------------
--- X ---
-------------

-- | A color with a single channel, most likely luminance
data X

-- | A single channel color `X`
newtype instance Color X e = X e

-- | Constructor for @X@
pattern ColorX :: e -> Color X e
pattern ColorX y = X y
{-# COMPLETE ColorX #-}

-- | Constructor for @X@ with alpha channel.
pattern ColorXA :: e -> e -> Color (Alpha X) e
pattern ColorXA y a = Alpha (X y) a
{-# COMPLETE ColorXA #-}

-- | `X` color model
deriving instance Eq e => Eq (Color X e)
-- | `X` color model
deriving instance Ord e => Ord (Color X e)
-- | `X` color model
deriving instance Storable e => Storable (Color X e)


-- | `X` color model
instance Elevator e => Show (Color X e) where
  showsPrec _ = showsColorModel

-- | `X` color model
instance Elevator e => ColorModel X e where
  type Components X e = e
  toComponents (X y) = y
  {-# INLINE toComponents #-}
  fromComponents = X
  {-# INLINE fromComponents #-}

-- | `X` color model
instance Functor (Color X) where
  fmap f (X y) = X (f y)
  {-# INLINE fmap #-}

-- | `X` color model
instance Applicative (Color X) where
  pure = X
  {-# INLINE pure #-}
  (X fy) <*> (X y) = X (fy y)
  {-# INLINE (<*>) #-}

-- | `X` color model
instance Foldable (Color X) where
  foldr f !z (X y) = f y z
  {-# INLINE foldr #-}

-- | `X` color model
instance Traversable (Color X) where
  traverse f (X y) = X <$> f y
  {-# INLINE traverse #-}

-- | Convert an RGB color model to a single channel by using the supplied weights
--
-- @since 0.1.0
rgb2y ::
     forall e e'. (Elevator e', Elevator e, RealFloat e)
  => Color RGB e'
  -> Weights e
  -> Color X e
rgb2y rgb weights =
  X (coerce (fmap toRealFloat rgb :: Color RGB e) `dotProduct` coerce weights)
{-# INLINE rgb2y #-}

-- | Weights imposed on individual channels of a 3-component color
--
-- @since 0.1.0
newtype Weights e = Weights
  { unWeights :: V3 e
  } deriving (Eq, Num, Show, Fractional, Floating, Functor)