{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module      : Graphics.Color.Model.Internal
-- Copyright   : (c) Alexey Kuleshevich 2018-2020
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.Internal
  ( ColorModel(..)
  , module Graphics.Color.Algebra
  , showsColorModel
  , showsColorModelOpen
  -- * Alpha
  , Alpha
  , Opaque
  , addAlpha
  , getAlpha
  , setAlpha
  , dropAlpha
  , modifyAlpha
  , modifyOpaque
  , Color(..)
  -- * Helpers
  , foldr3
  , foldr4
  , traverse3
  , traverse4
  , sizeOfN
  , alignmentN
  , peek3
  , poke3
  , peek4
  , poke4
  , VU.MVector(MV_Color)
  , VU.Vector(V_Color)
  ) where

import Control.Applicative
import Control.DeepSeq (NFData(rnf), deepseq)
import Data.Default.Class (Default(..))
import Data.Foldable
import Data.Kind
import Data.Typeable
import qualified Data.Vector.Generic as V
import qualified Data.Vector.Generic.Mutable as VM
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import Foreign.Ptr
import Foreign.Storable
import GHC.TypeLits
import Graphics.Color.Algebra

-- | A Color family with a color space and a precision of elements.
data family Color cs e :: Type

class ( Functor (Color cs)
      , Applicative (Color cs)
      , Foldable (Color cs)
      , Traversable (Color cs)
      , Eq (Color cs e)
      , Show (Color cs e)
      , VU.Unbox (Components cs e)
      , VS.Storable (Color cs e)
      , Typeable cs
      , Elevator e
      , Typeable (Opaque cs)
      ) =>
      ColorModel cs e where
  type Components cs e :: Type
  -- | Convert a Color to a representation suitable for storage as an unboxed
  -- element, usually a tuple of channels.
  toComponents :: Color cs e -> Components cs e
  -- | Convert from an elemnt representation back to a Color.
  fromComponents :: Components cs e -> Color cs e

  -- | Display the @cs@ portion of the pixel. Color itself will not be evaluated.
  --
  -- @since 0.1.0
  showsColorModelName :: Proxy (Color cs e) -> ShowS
  showsColorModelName Proxy (Color cs e)
_ = Proxy cs -> ShowS
forall k (t :: k) (proxy :: k -> *). Typeable t => proxy t -> ShowS
showsType (Proxy cs
forall k (t :: k). Proxy t
Proxy :: Proxy cs)


instance ColorModel cs e => Default (Color cs e) where
  def :: Color cs e
def = e -> Color cs e
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
0
  {-# INLINE def #-}


instance ColorModel cs e => Num (Color cs e) where
  + :: Color cs e -> Color cs e -> Color cs e
(+)         = (e -> e -> e) -> Color cs e -> Color cs e -> Color cs e
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 e -> e -> e
forall a. Num a => a -> a -> a
(+)
  {-# INLINE (+) #-}
  (-)         = (e -> e -> e) -> Color cs e -> Color cs e -> Color cs e
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (-)
  {-# INLINE (-) #-}
  * :: Color cs e -> Color cs e -> Color cs e
(*)         = (e -> e -> e) -> Color cs e -> Color cs e -> Color cs e
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 e -> e -> e
forall a. Num a => a -> a -> a
(*)
  {-# INLINE (*) #-}
  abs :: Color cs e -> Color cs e
abs         = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Num a => a -> a
abs
  {-# INLINE abs #-}
  signum :: Color cs e -> Color cs e
signum      = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Num a => a -> a
signum
  {-# INLINE signum #-}
  fromInteger :: Integer -> Color cs e
fromInteger = e -> Color cs e
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Color cs e) -> (Integer -> e) -> Integer -> Color cs e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> e
forall a. Num a => Integer -> a
fromInteger
  {-# INLINE fromInteger #-}


instance (ColorModel cs e, Fractional e) => Fractional (Color cs e) where
  / :: Color cs e -> Color cs e -> Color cs e
(/)          = (e -> e -> e) -> Color cs e -> Color cs e -> Color cs e
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 e -> e -> e
forall a. Fractional a => a -> a -> a
(/)
  {-# INLINE (/) #-}
  recip :: Color cs e -> Color cs e
recip        = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Fractional a => a -> a
recip
  {-# INLINE recip #-}
  fromRational :: Rational -> Color cs e
fromRational = e -> Color cs e
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Color cs e) -> (Rational -> e) -> Rational -> Color cs e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> e
forall a. Fractional a => Rational -> a
fromRational
  {-# INLINE fromRational #-}


instance (ColorModel cs e, Floating e) => Floating (Color cs e) where
  pi :: Color cs e
pi      = e -> Color cs e
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
forall a. Floating a => a
pi
  {-# INLINE pi #-}
  exp :: Color cs e -> Color cs e
exp     = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
exp
  {-# INLINE exp #-}
  log :: Color cs e -> Color cs e
log     = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
log
  {-# INLINE log #-}
  sin :: Color cs e -> Color cs e
sin     = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
sin
  {-# INLINE sin #-}
  cos :: Color cs e -> Color cs e
cos     = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
cos
  {-# INLINE cos #-}
  asin :: Color cs e -> Color cs e
asin    = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
asin
  {-# INLINE asin #-}
  atan :: Color cs e -> Color cs e
atan    = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
atan
  {-# INLINE atan #-}
  acos :: Color cs e -> Color cs e
acos    = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
acos
  {-# INLINE acos #-}
  sinh :: Color cs e -> Color cs e
sinh    = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
sinh
  {-# INLINE sinh #-}
  cosh :: Color cs e -> Color cs e
cosh    = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
cosh
  {-# INLINE cosh #-}
  asinh :: Color cs e -> Color cs e
asinh   = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
asinh
  {-# INLINE asinh #-}
  atanh :: Color cs e -> Color cs e
atanh   = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
atanh
  {-# INLINE atanh #-}
  acosh :: Color cs e -> Color cs e
acosh   = (e -> e) -> Color cs e -> Color cs e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
forall a. Floating a => a -> a
acosh
  {-# INLINE acosh #-}

instance ColorModel cs e => Bounded (Color cs e) where
  maxBound :: Color cs e
maxBound = e -> Color cs e
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
forall e. Elevator e => e
maxValue
  {-# INLINE maxBound #-}
  minBound :: Color cs e
minBound = e -> Color cs e
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
forall e. Elevator e => e
minValue
  {-# INLINE minBound #-}

instance (ColorModel cs e, NFData e) => NFData (Color cs e) where
  rnf :: Color cs e -> ()
rnf = (e -> () -> ()) -> () -> Color cs e -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' e -> () -> ()
forall a b. NFData a => a -> b -> b
deepseq ()
  {-# INLINE rnf #-}


-- | Unboxing of a `Color`.
instance ColorModel cs e => VU.Unbox (Color cs e)

newtype instance VU.MVector s (Color cs e) = MV_Color (VU.MVector s (Components cs e))

instance ColorModel cs e => VM.MVector VU.MVector (Color cs e) where
  basicLength :: MVector s (Color cs e) -> Int
basicLength (MV_Color mvec) = MVector s (Components cs e) -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
VM.basicLength MVector s (Components cs e)
mvec
  {-# INLINE basicLength #-}
  basicUnsafeSlice :: Int -> Int -> MVector s (Color cs e) -> MVector s (Color cs e)
basicUnsafeSlice Int
idx Int
len (MV_Color mvec) = MVector s (Components cs e) -> MVector s (Color cs e)
forall s cs e.
MVector s (Components cs e) -> MVector s (Color cs e)
MV_Color (Int
-> Int
-> MVector s (Components cs e)
-> MVector s (Components cs e)
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VM.basicUnsafeSlice Int
idx Int
len MVector s (Components cs e)
mvec)
  {-# INLINE basicUnsafeSlice #-}
  basicOverlaps :: MVector s (Color cs e) -> MVector s (Color cs e) -> Bool
basicOverlaps (MV_Color mvec) (MV_Color mvec') = MVector s (Components cs e) -> MVector s (Components cs e) -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
VM.basicOverlaps MVector s (Components cs e)
mvec MVector s (Components cs e)
mvec'
  {-# INLINE basicOverlaps #-}
  basicUnsafeNew :: Int -> m (MVector (PrimState m) (Color cs e))
basicUnsafeNew Int
len = MVector (PrimState m) (Components cs e)
-> MVector (PrimState m) (Color cs e)
forall s cs e.
MVector s (Components cs e) -> MVector s (Color cs e)
MV_Color (MVector (PrimState m) (Components cs e)
 -> MVector (PrimState m) (Color cs e))
-> m (MVector (PrimState m) (Components cs e))
-> m (MVector (PrimState m) (Color cs e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) (Components cs e))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> m (v (PrimState m) a)
VM.basicUnsafeNew Int
len
  {-# INLINE basicUnsafeNew #-}
  basicUnsafeReplicate :: Int -> Color cs e -> m (MVector (PrimState m) (Color cs e))
basicUnsafeReplicate Int
len Color cs e
val = MVector (PrimState m) (Components cs e)
-> MVector (PrimState m) (Color cs e)
forall s cs e.
MVector s (Components cs e) -> MVector s (Color cs e)
MV_Color (MVector (PrimState m) (Components cs e)
 -> MVector (PrimState m) (Color cs e))
-> m (MVector (PrimState m) (Components cs e))
-> m (MVector (PrimState m) (Color cs e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Components cs e -> m (MVector (PrimState m) (Components cs e))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> a -> m (v (PrimState m) a)
VM.basicUnsafeReplicate Int
len (Color cs e -> Components cs e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents Color cs e
val)
  {-# INLINE basicUnsafeReplicate #-}
  basicUnsafeRead :: MVector (PrimState m) (Color cs e) -> Int -> m (Color cs e)
basicUnsafeRead (MV_Color mvec) Int
idx = Components cs e -> Color cs e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents (Components cs e -> Color cs e)
-> m (Components cs e) -> m (Color cs e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) (Components cs e)
-> Int -> m (Components cs e)
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> m a
VM.basicUnsafeRead MVector (PrimState m) (Components cs e)
mvec Int
idx
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeWrite :: MVector (PrimState m) (Color cs e) -> Int -> Color cs e -> m ()
basicUnsafeWrite (MV_Color mvec) Int
idx Color cs e
val = MVector (PrimState m) (Components cs e)
-> Int -> Components cs e -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> a -> m ()
VM.basicUnsafeWrite MVector (PrimState m) (Components cs e)
mvec Int
idx (Color cs e -> Components cs e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents Color cs e
val)
  {-# INLINE basicUnsafeWrite #-}
  basicClear :: MVector (PrimState m) (Color cs e) -> m ()
basicClear (MV_Color mvec) = MVector (PrimState m) (Components cs e) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
VM.basicClear MVector (PrimState m) (Components cs e)
mvec
  {-# INLINE basicClear #-}
  basicSet :: MVector (PrimState m) (Color cs e) -> Color cs e -> m ()
basicSet (MV_Color mvec) Color cs e
val = MVector (PrimState m) (Components cs e) -> Components cs e -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> a -> m ()
VM.basicSet MVector (PrimState m) (Components cs e)
mvec (Color cs e -> Components cs e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents Color cs e
val)
  {-# INLINE basicSet #-}
  basicUnsafeCopy :: MVector (PrimState m) (Color cs e)
-> MVector (PrimState m) (Color cs e) -> m ()
basicUnsafeCopy (MV_Color mvec) (MV_Color mvec') = MVector (PrimState m) (Components cs e)
-> MVector (PrimState m) (Components cs e) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
VM.basicUnsafeCopy MVector (PrimState m) (Components cs e)
mvec MVector (PrimState m) (Components cs e)
mvec'
  {-# INLINE basicUnsafeCopy #-}
  basicUnsafeMove :: MVector (PrimState m) (Color cs e)
-> MVector (PrimState m) (Color cs e) -> m ()
basicUnsafeMove (MV_Color mvec) (MV_Color mvec') = MVector (PrimState m) (Components cs e)
-> MVector (PrimState m) (Components cs e) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
VM.basicUnsafeMove MVector (PrimState m) (Components cs e)
mvec MVector (PrimState m) (Components cs e)
mvec'
  {-# INLINE basicUnsafeMove #-}
  basicUnsafeGrow :: MVector (PrimState m) (Color cs e)
-> Int -> m (MVector (PrimState m) (Color cs e))
basicUnsafeGrow (MV_Color mvec) Int
len = MVector (PrimState m) (Components cs e)
-> MVector (PrimState m) (Color cs e)
forall s cs e.
MVector s (Components cs e) -> MVector s (Color cs e)
MV_Color (MVector (PrimState m) (Components cs e)
 -> MVector (PrimState m) (Color cs e))
-> m (MVector (PrimState m) (Components cs e))
-> m (MVector (PrimState m) (Color cs e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) (Components cs e)
-> Int -> m (MVector (PrimState m) (Components cs e))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> m (v (PrimState m) a)
VM.basicUnsafeGrow MVector (PrimState m) (Components cs e)
mvec Int
len
  {-# INLINE basicUnsafeGrow #-}
  basicInitialize :: MVector (PrimState m) (Color cs e) -> m ()
basicInitialize (MV_Color mvec) = MVector (PrimState m) (Components cs e) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
VM.basicInitialize MVector (PrimState m) (Components cs e)
mvec
  {-# INLINE basicInitialize #-}


newtype instance VU.Vector (Color cs e) = V_Color (VU.Vector (Components cs e))

instance (ColorModel cs e) => V.Vector VU.Vector (Color cs e) where
  basicUnsafeFreeze :: Mutable Vector (PrimState m) (Color cs e)
-> m (Vector (Color cs e))
basicUnsafeFreeze (MV_Color mvec) = Vector (Components cs e) -> Vector (Color cs e)
forall cs e. Vector (Components cs e) -> Vector (Color cs e)
V_Color (Vector (Components cs e) -> Vector (Color cs e))
-> m (Vector (Components cs e)) -> m (Vector (Color cs e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mutable Vector (PrimState m) (Components cs e)
-> m (Vector (Components cs e))
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
V.basicUnsafeFreeze MVector (PrimState m) (Components cs e)
Mutable Vector (PrimState m) (Components cs e)
mvec
  {-# INLINE basicUnsafeFreeze #-}
  basicUnsafeThaw :: Vector (Color cs e)
-> m (Mutable Vector (PrimState m) (Color cs e))
basicUnsafeThaw (V_Color vec) = MVector (PrimState m) (Components cs e)
-> MVector (PrimState m) (Color cs e)
forall s cs e.
MVector s (Components cs e) -> MVector s (Color cs e)
MV_Color (MVector (PrimState m) (Components cs e)
 -> MVector (PrimState m) (Color cs e))
-> m (MVector (PrimState m) (Components cs e))
-> m (MVector (PrimState m) (Color cs e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Components cs e)
-> m (Mutable Vector (PrimState m) (Components cs e))
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
v a -> m (Mutable v (PrimState m) a)
V.basicUnsafeThaw Vector (Components cs e)
vec
  {-# INLINE basicUnsafeThaw #-}
  basicLength :: Vector (Color cs e) -> Int
basicLength (V_Color vec) = Vector (Components cs e) -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
V.basicLength Vector (Components cs e)
vec
  {-# INLINE basicLength #-}
  basicUnsafeSlice :: Int -> Int -> Vector (Color cs e) -> Vector (Color cs e)
basicUnsafeSlice Int
idx Int
len (V_Color vec) = Vector (Components cs e) -> Vector (Color cs e)
forall cs e. Vector (Components cs e) -> Vector (Color cs e)
V_Color (Int -> Int -> Vector (Components cs e) -> Vector (Components cs e)
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
V.basicUnsafeSlice Int
idx Int
len Vector (Components cs e)
vec)
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeIndexM :: Vector (Color cs e) -> Int -> m (Color cs e)
basicUnsafeIndexM (V_Color vec) Int
idx = Components cs e -> Color cs e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents (Components cs e -> Color cs e)
-> m (Components cs e) -> m (Color cs e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Components cs e) -> Int -> m (Components cs e)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, Monad m) =>
v a -> Int -> m a
V.basicUnsafeIndexM Vector (Components cs e)
vec Int
idx
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeCopy :: Mutable Vector (PrimState m) (Color cs e)
-> Vector (Color cs e) -> m ()
basicUnsafeCopy (MV_Color mvec) (V_Color vec) = Mutable Vector (PrimState m) (Components cs e)
-> Vector (Components cs e) -> m ()
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> v a -> m ()
V.basicUnsafeCopy MVector (PrimState m) (Components cs e)
Mutable Vector (PrimState m) (Components cs e)
mvec Vector (Components cs e)
vec
  {-# INLINE basicUnsafeCopy #-}
  elemseq :: Vector (Color cs e) -> Color cs e -> b -> b
elemseq (V_Color vec) Color cs e
val = Vector (Components cs e) -> Components cs e -> b -> b
forall (v :: * -> *) a b. Vector v a => v a -> a -> b -> b
V.elemseq Vector (Components cs e)
vec (Color cs e -> Components cs e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents Color cs e
val)
  {-# INLINE elemseq #-}

channelSeparator :: Char
channelSeparator :: Char
channelSeparator = Char
','

showsColorModel :: ColorModel cs e => Color cs e -> ShowS
showsColorModel :: Color cs e -> ShowS
showsColorModel Color cs e
px = (Char
'<' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color cs e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModelOpen Color cs e
px ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'>' Char -> ShowS
forall a. a -> [a] -> [a]
:)

showsColorModelOpen :: ColorModel cs e => Color cs e -> ShowS
showsColorModelOpen :: Color cs e -> ShowS
showsColorModelOpen Color cs e
px = ShowS
t ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
":(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
channels ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')' Char -> ShowS
forall a. a -> [a] -> [a]
:)
  where
    t :: ShowS
t = Color cs e -> (Proxy (Color cs e) -> ShowS) -> ShowS
forall p t. p -> (Proxy p -> t) -> t
asProxy Color cs e
px Proxy (Color cs e) -> ShowS
forall cs e. ColorModel cs e => Proxy (Color cs e) -> ShowS
showsColorModelName
    channels :: ShowS
channels =
      case Color cs e -> [e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Color cs e
px of
        [] -> ShowS
forall a. a -> a
id
        (e
x:[e]
xs) -> (ShowS -> e -> ShowS) -> ShowS -> [e] -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ShowS
facc e
y -> ShowS
facc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
channelSeparator Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ShowS
forall e. Elevator e => e -> ShowS
toShowS e
y) (e -> ShowS
forall e. Elevator e => e -> ShowS
toShowS e
x) [e]
xs

-- TODO: consolidate those helpers into algebra by means of: V2, V3, V4 and V5.
-- Foldable helpers.

foldr3 :: (e -> a -> a) -> a -> e -> e -> e -> a
foldr3 :: (e -> a -> a) -> a -> e -> e -> e -> a
foldr3 e -> a -> a
f a
acc e
c0 e
c1 e
c2 = e -> a -> a
f e
c0 (e -> a -> a
f e
c1 (e -> a -> a
f e
c2 a
acc))
{-# INLINE foldr3 #-}

foldr4 :: (e -> a -> a) -> a -> e -> e -> e -> e -> a
foldr4 :: (e -> a -> a) -> a -> e -> e -> e -> e -> a
foldr4 e -> a -> a
f a
acc e
c0 e
c1 e
c2 e
c3 = e -> a -> a
f e
c0 (e -> a -> a
f e
c1 (e -> a -> a
f e
c2 (e -> a -> a
f e
c3 a
acc)))
{-# INLINE foldr4 #-}

traverse3 :: Applicative f => (a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> f b
traverse3 :: (a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> f b
traverse3 a -> a -> a -> b
g t -> f a
f t
c0 t
c1 t
c2 = a -> a -> a -> b
g (a -> a -> a -> b) -> f a -> f (a -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> f a
f t
c0 f (a -> a -> b) -> f a -> f (a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> f a
f t
c1 f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> f a
f t
c2
{-# INLINE traverse3 #-}

traverse4 :: Applicative f => (a -> a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> t -> f b
traverse4 :: (a -> a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> t -> f b
traverse4 a -> a -> a -> a -> b
g t -> f a
f t
c0 t
c1 t
c2 t
c3 = a -> a -> a -> a -> b
g (a -> a -> a -> a -> b) -> f a -> f (a -> a -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> f a
f t
c0 f (a -> a -> a -> b) -> f a -> f (a -> a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> f a
f t
c1 f (a -> a -> b) -> f a -> f (a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> f a
f t
c2 f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> f a
f t
c3
{-# INLINE traverse4 #-}

-- Storable helpers

sizeOfN :: forall cs e . Storable e => Int -> Color cs e -> Int
sizeOfN :: Int -> Color cs e -> Int
sizeOfN Int
n Color cs e
_ = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* e -> Int
forall a. Storable a => a -> Int
sizeOf (e
forall a. HasCallStack => a
undefined :: e)
{-# INLINE sizeOfN #-}

alignmentN :: forall cs e . Storable e => Int -> Color cs e -> Int
alignmentN :: Int -> Color cs e -> Int
alignmentN Int
_ Color cs e
_ = e -> Int
forall a. Storable a => a -> Int
alignment (e
forall a. HasCallStack => a
undefined :: e)
{-# INLINE alignmentN #-}

peek3 :: Storable e => (e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e)
peek3 :: (e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e)
peek3 e -> e -> e -> Color cs e
f Ptr (Color cs e)
p = do
  let q :: Ptr e
q = Ptr (Color cs e) -> Ptr e
forall a b. Ptr a -> Ptr b
castPtr Ptr (Color cs e)
p
  e
c0 <- Ptr e -> IO e
forall a. Storable a => Ptr a -> IO a
peek Ptr e
q
  e
c1 <- Ptr e -> Int -> IO e
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr e
q Int
1
  e
c2 <- Ptr e -> Int -> IO e
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr e
q Int
2
  Color cs e -> IO (Color cs e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Color cs e -> IO (Color cs e)) -> Color cs e -> IO (Color cs e)
forall a b. (a -> b) -> a -> b
$! e -> e -> e -> Color cs e
f e
c0 e
c1 e
c2
{-# INLINE peek3 #-}

poke3 :: Storable e => Ptr (Color cs e) -> e -> e -> e -> IO ()
poke3 :: Ptr (Color cs e) -> e -> e -> e -> IO ()
poke3 Ptr (Color cs e)
p e
c0 e
c1 e
c2 = do
  let q :: Ptr e
q = Ptr (Color cs e) -> Ptr e
forall a b. Ptr a -> Ptr b
castPtr Ptr (Color cs e)
p
  Ptr e -> e -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr e
q e
c0
  Ptr e -> Int -> e -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr e
q Int
1 e
c1
  Ptr e -> Int -> e -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr e
q Int
2 e
c2
{-# INLINE poke3 #-}

peek4 ::
     forall cs e. Storable e
  => (e -> e -> e -> e -> Color cs e)
  -> Ptr (Color cs e)
  -> IO (Color cs e)
peek4 :: (e -> e -> e -> e -> Color cs e)
-> Ptr (Color cs e) -> IO (Color cs e)
peek4 e -> e -> e -> e -> Color cs e
f Ptr (Color cs e)
p = do
  e
c0 <- Ptr e -> IO e
forall a. Storable a => Ptr a -> IO a
peek (Ptr (Color cs e) -> Ptr e
forall a b. Ptr a -> Ptr b
castPtr Ptr (Color cs e)
p)
  (e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e)
forall e cs.
Storable e =>
(e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e)
peek3 (e -> e -> e -> e -> Color cs e
f e
c0) (Ptr (Color cs e)
p Ptr (Color cs e) -> Int -> Ptr (Color cs e)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` e -> Int
forall a. Storable a => a -> Int
sizeOf (e
forall a. HasCallStack => a
undefined :: e))
{-# INLINE peek4 #-}

poke4 :: forall cs e . Storable e => Ptr (Color cs e) -> e -> e -> e -> e -> IO ()
poke4 :: Ptr (Color cs e) -> e -> e -> e -> e -> IO ()
poke4 Ptr (Color cs e)
p e
c0 e
c1 e
c2 e
c3 = do
  Ptr e -> e -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (Color cs e) -> Ptr e
forall a b. Ptr a -> Ptr b
castPtr Ptr (Color cs e)
p) e
c0
  Ptr (Color Any e) -> e -> e -> e -> IO ()
forall e cs. Storable e => Ptr (Color cs e) -> e -> e -> e -> IO ()
poke3 (Ptr (Color cs e)
p Ptr (Color cs e) -> Int -> Ptr (Color Any e)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` e -> Int
forall a. Storable a => a -> Int
sizeOf (e
forall a. HasCallStack => a
undefined :: e)) e
c1 e
c2 e
c3
{-# INLINE poke4 #-}


-----------
-- Alpha --
-----------



data Alpha cs

data instance Color (Alpha cs) e = Alpha
  { Color (Alpha cs) e -> Color cs e
_opaque :: !(Color cs e)
  , Color (Alpha cs) e -> e
_alpha :: !e
  }

-- | Get the alpha channel value for the pixel
--
-- @since 0.1.0
getAlpha :: Color (Alpha cs) e -> e
getAlpha :: Color (Alpha cs) e -> e
getAlpha = Color (Alpha cs) e -> e
forall cs e. Color (Alpha cs) e -> e
_alpha
{-# INLINE getAlpha #-}

-- | Get the opaque pixel value, while leaving alpha channel intact.
--
-- @since 0.1.0
dropAlpha :: Color (Alpha cs) e -> Color cs e
dropAlpha :: Color (Alpha cs) e -> Color cs e
dropAlpha = Color (Alpha cs) e -> Color cs e
forall cs e. Color (Alpha cs) e -> Color cs e
_opaque
{-# INLINE dropAlpha #-}

-- | Add an alpha channel value to an opaque pixel
--
-- @since 0.1.0
addAlpha :: Color cs e -> e -> Color (Alpha cs) e
addAlpha :: Color cs e -> e -> Color (Alpha cs) e
addAlpha = Color cs e -> e -> Color (Alpha cs) e
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha
{-# INLINE addAlpha #-}

-- | Change the alpha channel value for the pixel
--
-- @since 0.1.0
setAlpha :: Color (Alpha cs) e -> e -> Color (Alpha cs) e
setAlpha :: Color (Alpha cs) e -> e -> Color (Alpha cs) e
setAlpha Color (Alpha cs) e
px e
a = Color (Alpha cs) e
R:ColorAlphae cs e
px { _alpha :: e
_alpha = e
a }
{-# INLINE setAlpha #-}

-- | Change the alpha channel value for the pixel
--
-- @since 0.1.0
modifyAlpha :: (e -> e) -> Color (Alpha cs) e -> Color (Alpha cs) e
modifyAlpha :: (e -> e) -> Color (Alpha cs) e -> Color (Alpha cs) e
modifyAlpha e -> e
f Color (Alpha cs) e
px = Color (Alpha cs) e
R:ColorAlphae cs e
px { _alpha :: e
_alpha = e -> e
f (Color (Alpha cs) e -> e
forall cs e. Color (Alpha cs) e -> e
_alpha Color (Alpha cs) e
px) }
{-# INLINE modifyAlpha #-}

-- | Change the opaque pixel value, while leaving alpha channel intact.
--
-- @since 0.1.0
modifyOpaque :: (Color cs e -> Color cs' e) -> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque :: (Color cs e -> Color cs' e)
-> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque Color cs e -> Color cs' e
fpx Color (Alpha cs) e
pxa = Color (Alpha cs) e
R:ColorAlphae cs e
pxa { _opaque :: Color cs' e
_opaque = Color cs e -> Color cs' e
fpx (Color (Alpha cs) e -> Color cs e
forall cs e. Color (Alpha cs) e -> Color cs e
_opaque Color (Alpha cs) e
pxa) }
{-# INLINE modifyOpaque #-}

instance (Eq (Color cs e), Eq e) => Eq (Color (Alpha cs) e) where
  == :: Color (Alpha cs) e -> Color (Alpha cs) e -> Bool
(==) (Alpha px1 a1) (Alpha px2 a2) = Color cs e
px1 Color cs e -> Color cs e -> Bool
forall a. Eq a => a -> a -> Bool
== Color cs e
px2 Bool -> Bool -> Bool
&& e
a1 e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
a2
  {-# INLINE (==) #-}

instance (ColorModel cs e, cs ~ Opaque (Alpha cs)) =>
         Show (Color (Alpha cs) e) where
  showsPrec :: Int -> Color (Alpha cs) e -> ShowS
showsPrec Int
_ = Color (Alpha cs) e -> ShowS
forall cs e. ColorModel cs e => Color cs e -> ShowS
showsColorModel

type family Opaque cs where
  Opaque (Alpha (Alpha cs)) = TypeError ('Text "Nested alpha channels are not allowed")
  Opaque (Alpha cs) = cs
  Opaque cs = cs

instance (ColorModel cs e, cs ~ Opaque (Alpha cs)) =>
         ColorModel (Alpha cs) e where
  type Components (Alpha cs) e = (Components cs e, e)
  toComponents :: Color (Alpha cs) e -> Components (Alpha cs) e
toComponents (Alpha px a) = (Color cs e -> Components cs e
forall cs e. ColorModel cs e => Color cs e -> Components cs e
toComponents Color cs e
px, e
a)
  {-# INLINE toComponents #-}
  fromComponents :: Components (Alpha cs) e -> Color (Alpha cs) e
fromComponents (pxc, a) = Color cs e -> e -> Color (Alpha cs) e
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha (Components cs e -> Color cs e
forall cs e. ColorModel cs e => Components cs e -> Color cs e
fromComponents Components cs e
pxc) e
a
  {-# INLINE fromComponents #-}
  showsColorModelName :: Proxy (Color (Alpha cs) e) -> ShowS
showsColorModelName Proxy (Color (Alpha cs) e)
_ = ([Char]
"Alpha (" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (Color cs e) -> ShowS
forall cs e. ColorModel cs e => Proxy (Color cs e) -> ShowS
showsColorModelName (Proxy (Color cs e)
forall k (t :: k). Proxy t
Proxy :: Proxy (Color cs e)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')'Char -> ShowS
forall a. a -> [a] -> [a]
:)


instance Functor (Color cs) => Functor (Color (Alpha cs)) where
  fmap :: (a -> b) -> Color (Alpha cs) a -> Color (Alpha cs) b
fmap a -> b
f (Alpha px a) = Color cs b -> b -> Color (Alpha cs) b
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha ((a -> b) -> Color cs a -> Color cs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Color cs a
px) (a -> b
f a
a)
  {-# INLINE fmap #-}

instance Applicative (Color cs) => Applicative (Color (Alpha cs)) where
  pure :: a -> Color (Alpha cs) a
pure a
e = Color cs a -> a -> Color (Alpha cs) a
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha (a -> Color cs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
e) a
e
  {-# INLINE pure #-}
  (Alpha fpx fa) <*> :: Color (Alpha cs) (a -> b)
-> Color (Alpha cs) a -> Color (Alpha cs) b
<*> (Alpha px a) = Color cs b -> b -> Color (Alpha cs) b
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha (Color cs (a -> b)
fpx Color cs (a -> b) -> Color cs a -> Color cs b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Color cs a
px) (a -> b
fa a
a)
  {-# INLINE (<*>) #-}

instance Foldable (Color cs) => Foldable (Color (Alpha cs)) where
  foldr :: (a -> b -> b) -> b -> Color (Alpha cs) a -> b
foldr a -> b -> b
f b
acc (Alpha px a) = (a -> b -> b) -> b -> Color cs a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f (a -> b -> b
f a
a b
acc) Color cs a
px
  {-# INLINE foldr #-}
  foldr1 :: (a -> a -> a) -> Color (Alpha cs) a -> a
foldr1 a -> a -> a
f (Alpha px a) = (a -> a -> a) -> a -> Color cs a -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
f a
a Color cs a
px
  {-# INLINE foldr1 #-}

instance Traversable (Color cs) => Traversable (Color (Alpha cs)) where
  traverse :: (a -> f b) -> Color (Alpha cs) a -> f (Color (Alpha cs) b)
traverse a -> f b
f (Alpha px a) = Color cs b -> b -> Color (Alpha cs) b
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha (Color cs b -> b -> Color (Alpha cs) b)
-> f (Color cs b) -> f (b -> Color (Alpha cs) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Color cs a -> f (Color cs b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Color cs a
px f (b -> Color (Alpha cs) b) -> f b -> f (Color (Alpha cs) b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
a
  {-# INLINE traverse #-}

instance (Storable (Color cs e), Storable e) => Storable (Color (Alpha cs) e) where
  sizeOf :: Color (Alpha cs) e -> Int
sizeOf Color (Alpha cs) e
_ = Color cs e -> Int
forall a. Storable a => a -> Int
sizeOf (Color cs e
forall a. HasCallStack => a
undefined :: Color cs e) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ e -> Int
forall a. Storable a => a -> Int
sizeOf (e
forall a. HasCallStack => a
undefined :: e)
  {-# INLINE sizeOf #-}
  alignment :: Color (Alpha cs) e -> Int
alignment Color (Alpha cs) e
_ = e -> Int
forall a. Storable a => a -> Int
alignment (e
forall a. HasCallStack => a
undefined :: e)
  {-# INLINE alignment #-}
  peek :: Ptr (Color (Alpha cs) e) -> IO (Color (Alpha cs) e)
peek Ptr (Color (Alpha cs) e)
ptr = do
    Color cs e
px <- Ptr (Color cs e) -> IO (Color cs e)
forall a. Storable a => Ptr a -> IO a
peek (Ptr (Color (Alpha cs) e) -> Ptr (Color cs e)
forall a b. Ptr a -> Ptr b
castPtr Ptr (Color (Alpha cs) e)
ptr)
    Color cs e -> e -> Color (Alpha cs) e
forall cs e. Color cs e -> e -> Color (Alpha cs) e
Alpha Color cs e
px (e -> Color (Alpha cs) e) -> IO e -> IO (Color (Alpha cs) e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (Color (Alpha cs) e) -> Int -> IO e
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Color (Alpha cs) e)
ptr (Color cs e -> Int
forall a. Storable a => a -> Int
sizeOf Color cs e
px)
  {-# INLINE peek #-}
  poke :: Ptr (Color (Alpha cs) e) -> Color (Alpha cs) e -> IO ()
poke Ptr (Color (Alpha cs) e)
ptr (Alpha px a) = do
    Ptr (Color cs e) -> Color cs e -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr (Color (Alpha cs) e) -> Ptr (Color cs e)
forall a b. Ptr a -> Ptr b
castPtr Ptr (Color (Alpha cs) e)
ptr) Color cs e
px
    Ptr (Color (Alpha cs) e) -> Int -> e -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Color (Alpha cs) e)
ptr (Color cs e -> Int
forall a. Storable a => a -> Int
sizeOf Color cs e
px) e
a
  {-# INLINE poke #-}