{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeSynonymInstances #-}

{-# LANGUAGE FunctionalDependencies #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE Rank2Types #-}

{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE CPP #-}

{-# LANGUAGE DeriveDataTypeable #-}

-- | Module provides basic types for image manipulation in the library.

-- Defined types are used to store all of those __Juicy Pixels__

module Codec.Picture.Types( -- * Types

                            -- ** Image types

                            Image( .. )

                          , MutableImage( .. )

                          , DynamicImage( .. )

                          , PalettedImage( .. )

                          , Palette

                          , Palette'( .. )



                            -- ** Image functions

                          , createMutableImage

                          , newMutableImage

                          , freezeImage

                          , unsafeFreezeImage

                          , thawImage

                          , unsafeThawImage



                            -- ** Image Lenses

                          , Traversal

                          , imagePixels

                          , imageIPixels



                            -- ** Pixel types

                          , Pixel8

                          , Pixel16

                          , Pixel32

                          , PixelF

                          , PixelYA8( .. )

                          , PixelYA16( .. )

                          , PixelRGB8( .. )

                          , PixelRGB16( .. )

                          , PixelRGBF( .. )

                          , PixelRGBA8( .. )

                          , PixelRGBA16( .. )

                          , PixelCMYK8( .. )

                          , PixelCMYK16( .. )

                          , PixelYCbCr8( .. )

                          , PixelYCbCrK8( .. )



                          -- * Type classes

                          , ColorConvertible( .. )

                          , Pixel(..)

                          -- $graph

                          , ColorSpaceConvertible( .. )

                          , LumaPlaneExtractable( .. )

                          , TransparentPixel( .. )



                            -- * Helper functions

                          , pixelMap

                          , pixelMapXY

                          , pixelFold

                          , pixelFoldM

                          , pixelFoldMap



                          , dynamicMap

                          , dynamicPixelMap

                          , palettedToTrueColor

                          , palettedAsImage

                          , dropAlphaLayer

                          , withImage

                          , zipPixelComponent3

                          , generateImage

                          , generateFoldImage

                          , gammaCorrection

                          , toneMapping



                            -- * Color plane extraction

                          , ColorPlane ( )



                          , PlaneRed( .. )

                          , PlaneGreen( .. )

                          , PlaneBlue( .. )

                          , PlaneAlpha( .. )

                          , PlaneLuma( .. )

                          , PlaneCr( .. )

                          , PlaneCb( .. )

                          , PlaneCyan( .. )

                          , PlaneMagenta( .. )

                          , PlaneYellow( .. )

                          , PlaneBlack( .. )



                          , extractComponent

                          , unsafeExtractComponent



                            -- * Packeable writing (unsafe but faster)

                          , PackeablePixel( .. )

                          , fillImageWith

                          , readPackedPixelAt

                          , writePackedPixelAt

                          , unsafeWritePixelBetweenAt

                          ) where



#if !MIN_VERSION_base(4,8,0)

import Data.Monoid( Monoid, mempty )

import Control.Applicative( Applicative, pure, (<*>), (<$>) )

#endif



import Data.Monoid( (<>) )

import Control.Monad( foldM, liftM, ap )

import Control.DeepSeq( NFData( .. ) )

import Control.Monad.ST( ST, runST )

import Control.Monad.Primitive ( PrimMonad, PrimState )

import Foreign.ForeignPtr( castForeignPtr )

import Foreign.Storable ( Storable )

import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) )

import Data.Typeable ( Typeable )

import Data.Word( Word8, Word16, Word32, Word64 )

import Data.Vector.Storable ( (!) )

import qualified Data.Vector.Storable as V

import qualified Data.Vector.Storable.Mutable as M



#include "ConvGraph.hs"



-- | The main type of this package, one that most

-- functions work on, is Image.

--

-- Parameterized by the underlying pixel format it

-- forms a rigid type. If you wish to store images

-- of different or unknown pixel formats use 'DynamicImage'.

--

-- Image is essentially a rectangular pixel buffer

-- of specified width and height. The coordinates are

-- assumed to start from the upper-left corner

-- of the image, with the horizontal position first

-- and vertical second.

data Image a = Image

    { -- | Width of the image in pixels

      imageWidth  :: {-# UNPACK #-} !Int

      -- | Height of the image in pixels.

    , imageHeight :: {-# UNPACK #-} !Int



      -- | Image pixel data. To extract pixels at a given position

      -- you should use the helper functions.

      --

      -- Internally pixel data is stored as consecutively packed

      -- lines from top to bottom, scanned from left to right

      -- within individual lines, from first to last color

      -- component within each pixel.

    , imageData   :: V.Vector (PixelBaseComponent a)

    }

    deriving (Typeable)



-- | Type for the palette used in Gif & PNG files.

type Palette = Image PixelRGB8



-- | Class used to describle plane present in the pixel

-- type. If a pixel has a plane description associated,

-- you can use the plane name to extract planes independently.

class ColorPlane pixel planeToken where

    -- | Retrieve the index of the component in the

    -- given pixel type.

    toComponentIndex :: pixel -> planeToken -> Int



-- | Define the plane for the red color component

data PlaneRed = PlaneRed

    deriving (Typeable)



-- | Define the plane for the green color component

data PlaneGreen = PlaneGreen

    deriving (Typeable)



-- | Define the plane for the blue color component

data PlaneBlue = PlaneBlue

    deriving (Typeable)



-- | Define the plane for the alpha (transparency) component

data PlaneAlpha = PlaneAlpha

    deriving (Typeable)



-- | Define the plane for the luma component

data PlaneLuma = PlaneLuma

    deriving (Typeable)



-- | Define the plane for the Cr component

data PlaneCr = PlaneCr

    deriving (Typeable)



-- | Define the plane for the Cb component

data PlaneCb = PlaneCb

    deriving (Typeable)



-- | Define plane for the cyan component of the

-- CMYK color space.

data PlaneCyan = PlaneCyan

    deriving (Typeable)



-- | Define plane for the magenta component of the

-- CMYK color space.

data PlaneMagenta = PlaneMagenta

    deriving (Typeable)



-- | Define plane for the yellow component of the

-- CMYK color space.

data PlaneYellow = PlaneYellow

    deriving (Typeable)



-- | Define plane for the black component of

-- the CMYK color space.

data PlaneBlack = PlaneBlack

    deriving (Typeable)



-- | Extract a color plane from an image given a present plane in the image

-- examples:

--

-- @

--  extractRedPlane :: Image PixelRGB8 -> Image Pixel8

--  extractRedPlane = extractComponent PlaneRed

-- @

--

extractComponent :: forall px plane. ( Pixel px

                                     , Pixel (PixelBaseComponent px)

                                     , PixelBaseComponent (PixelBaseComponent px)

                                                    ~ PixelBaseComponent px

                                     , ColorPlane px plane )

                 => plane -> Image px -> Image (PixelBaseComponent px)

extractComponent plane = unsafeExtractComponent idx

    where idx = toComponentIndex (undefined :: px) plane



-- | Extract a plane of an image. Returns the requested color

-- component as a greyscale image.

--

-- If you ask for a component out of bound, the `error` function will

-- be called.

unsafeExtractComponent :: forall a

                        . ( Pixel a

                          , Pixel (PixelBaseComponent a)

                          , PixelBaseComponent (PixelBaseComponent a)

                                              ~ PixelBaseComponent a)

                       => Int     -- ^ The component index, beginning at 0 ending at (componentCount - 1)

                       -> Image a -- ^ Source image

                       -> Image (PixelBaseComponent a)

unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h })

  | comp >= padd = error $ "extractComponent : invalid component index ("

                         ++ show comp ++ ", max:" ++ show padd ++ ")"

  | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane }

      where plane = stride img padd comp

            padd = componentCount (undefined :: a)



-- | For any image with an alpha component (transparency),

-- drop it, returning a pure opaque image.

dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b

dropAlphaLayer = pixelMap dropTransparency



-- | Class modeling transparent pixel, should provide a method

-- to combine transparent pixels

class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where

    -- | Just return the opaque pixel value

    dropTransparency :: a -> b



    -- | access the transparency (alpha layer) of a given

    -- transparent pixel type.

    getTransparency :: a -> PixelBaseComponent a

{-# DEPRECATED getTransparency "please use 'pixelOpacity' instead" #-}



instance TransparentPixel PixelRGBA8 PixelRGB8 where

    {-# INLINE dropTransparency #-}

    dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b

    {-# INLINE getTransparency #-}

    getTransparency (PixelRGBA8 _ _ _ a) = a



lineFold :: (Monad m) => a -> Int -> (a -> Int -> m a) -> m a

{-# INLINE lineFold #-}

lineFold initial count f = go 0 initial

  where go n acc | n >= count = return acc

        go n acc = f acc n >>= go (n + 1)



stride :: (Storable (PixelBaseComponent a))

       => Image a -> Int -> Int -> V.Vector (PixelBaseComponent a)

stride Image { imageWidth = w, imageHeight = h, imageData = array }

        padd firstComponent = runST $ do

    let cell_count = w * h

    outArray <- M.new cell_count



    let go writeIndex _ | writeIndex >= cell_count = return ()

        go writeIndex readIndex = do

          (outArray `M.unsafeWrite` writeIndex) $ array `V.unsafeIndex` readIndex

          go (writeIndex + 1) $ readIndex + padd



    go 0 firstComponent

    V.unsafeFreeze outArray



instance NFData (Image a) where

    rnf (Image width height dat) = width  `seq`

                                   height `seq`

                                   dat    `seq`

                                   ()



-- | Image or pixel buffer, the coordinates are assumed to start

-- from the upper-left corner of the image, with the horizontal

-- position first, then the vertical one. The image can be transformed in place.

data MutableImage s a = MutableImage

    { -- | Width of the image in pixels

      mutableImageWidth  :: {-# UNPACK #-} !Int



      -- | Height of the image in pixels.

    , mutableImageHeight :: {-# UNPACK #-} !Int



      -- | The real image, to extract pixels at some position

      -- you should use the helpers functions.

    , mutableImageData   :: M.STVector s (PixelBaseComponent a)

    }

    deriving (Typeable)



-- | `O(n)` Yield an immutable copy of an image by making a copy of it

freezeImage :: (Storable (PixelBaseComponent px), PrimMonad m)

            => MutableImage (PrimState m) px -> m (Image px)

freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d



-- | `O(n)` Yield a mutable copy of an image by making a copy of it.

thawImage :: (Storable (PixelBaseComponent px), PrimMonad m)

          => Image px -> m (MutableImage (PrimState m) px)

thawImage (Image w h d) = MutableImage w h `liftM` V.thaw d



-- | `O(1)` Unsafe convert an imutable image to an mutable one without copying.

-- The source image shouldn't be used after this operation.

unsafeThawImage :: (Storable (PixelBaseComponent px), PrimMonad m)

                => Image px -> m (MutableImage (PrimState m) px)

{-# NOINLINE unsafeThawImage #-}

unsafeThawImage (Image w h d) = MutableImage w h `liftM` V.unsafeThaw d



-- | `O(1)` Unsafe convert a mutable image to an immutable one without copying.

-- The mutable image may not be used after this operation.

unsafeFreezeImage ::  (Storable (PixelBaseComponent a), PrimMonad m)

                  => MutableImage (PrimState m) a -> m (Image a)

unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d



-- | Create a mutable image, filled with the given background color.

createMutableImage :: (Pixel px, PrimMonad m)

                   => Int -- ^ Width

                   -> Int -- ^ Height

                   -> px  -- ^ Background color

                   -> m (MutableImage (PrimState m) px)

createMutableImage width height background =

   generateMutableImage (\_ _ -> background) width height



-- | Create a mutable image with garbage as content. All data

-- is uninitialized.

newMutableImage :: forall px m. (Pixel px, PrimMonad m)

                => Int -- ^ Width

                -> Int -- ^ Height

                -> m (MutableImage (PrimState m) px)

newMutableImage w h = MutableImage w h `liftM` M.new (w * h * compCount)

  where compCount = componentCount (undefined :: px)



instance NFData (MutableImage s a) where

    rnf (MutableImage width height dat) = width  `seq`

                                          height `seq`

                                          dat    `seq`

                                          ()



-- | Image type enumerating all predefined pixel types.

-- It enables loading and use of images of different

-- pixel types.

data DynamicImage =

       -- | A greyscale image.

       ImageY8    (Image Pixel8)

       -- | A greyscale image with 16bit components

     | ImageY16   (Image Pixel16)

       -- | A greyscale HDR image

     | ImageYF    (Image PixelF)

       -- | An image in greyscale with an alpha channel.

     | ImageYA8   (Image PixelYA8)

      -- | An image in greyscale with alpha channel on 16 bits.

     | ImageYA16  (Image PixelYA16)

       -- | An image in true color.

     | ImageRGB8  (Image PixelRGB8)

       -- | An image in true color with 16bit depth.

     | ImageRGB16 (Image PixelRGB16)

       -- | An image with HDR pixels

     | ImageRGBF  (Image PixelRGBF)

       -- | An image in true color and an alpha channel.

     | ImageRGBA8 (Image PixelRGBA8)

       -- | A true color image with alpha on 16 bits.

     | ImageRGBA16 (Image PixelRGBA16)

       -- | An image in the colorspace used by Jpeg images.

     | ImageYCbCr8 (Image PixelYCbCr8)

       -- | An image in the colorspace CMYK

     | ImageCMYK8  (Image PixelCMYK8)

       -- | An image in the colorspace CMYK and 16 bits precision

     | ImageCMYK16 (Image PixelCMYK16)

    deriving (Typeable)



-- | Type used to expose a palette extracted during reading.

-- Use palettedAsImage to convert it to a palette usable for

-- writing.

data Palette' px = Palette'

  { -- | Number of element in pixels.

    _paletteSize :: !Int

    -- | Real data used by the palette.

  , _paletteData :: !(V.Vector (PixelBaseComponent px))

  }

  deriving Typeable



-- | Convert a palette to an image. Used mainly for

-- backward compatibility.

palettedAsImage :: Palette' px -> Image px

palettedAsImage p = Image (_paletteSize p) 1 $ _paletteData p



-- | Describe an image and it's potential associated

-- palette. If no palette is present, fallback to a

-- DynamicImage

data PalettedImage

  = TrueColorImage DynamicImage -- ^ Fallback

  | PalettedY8    (Image Pixel8) (Palette' Pixel8)

  | PalettedRGB8  (Image Pixel8) (Palette' PixelRGB8)

  | PalettedRGBA8 (Image Pixel8) (Palette' PixelRGBA8)

  | PalettedRGB16 (Image Pixel8) (Palette' PixelRGB16)

  deriving (Typeable)



-- | Flatten a PalettedImage to a DynamicImage

palettedToTrueColor :: PalettedImage -> DynamicImage

palettedToTrueColor img = case img of

  TrueColorImage d -> d

  PalettedY8    i p -> ImageY8 $ toTrueColor 1 (_paletteData p) i

  PalettedRGB8  i p -> ImageRGB8 $ toTrueColor 3 (_paletteData p) i

  PalettedRGBA8 i p -> ImageRGBA8 $ toTrueColor 4 (_paletteData p) i

  PalettedRGB16 i p -> ImageRGB16 $ toTrueColor 3 (_paletteData p) i

  where 

    toTrueColor c vec = pixelMap (unsafePixelAt vec . (c *) . fromIntegral)



-- | Helper function to help extract information from dynamic

-- image. To get the width of a dynamic image, you can use

-- the following snippet:

--

-- > dynWidth :: DynamicImage -> Int

-- > dynWidth img = dynamicMap imageWidth img

--

dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a)

           -> DynamicImage -> a

dynamicMap f (ImageY8    i) = f i

dynamicMap f (ImageY16   i) = f i

dynamicMap f (ImageYF    i) = f i

dynamicMap f (ImageYA8   i) = f i

dynamicMap f (ImageYA16  i) = f i

dynamicMap f (ImageRGB8  i) = f i

dynamicMap f (ImageRGB16 i) = f i

dynamicMap f (ImageRGBF  i) = f i

dynamicMap f (ImageRGBA8 i) = f i

dynamicMap f (ImageRGBA16 i) = f i

dynamicMap f (ImageYCbCr8 i) = f i

dynamicMap f (ImageCMYK8 i) = f i

dynamicMap f (ImageCMYK16 i) = f i



-- | Equivalent of the `pixelMap` function for the dynamic images.

-- You can perform pixel colorspace independant operations with this

-- function.

--

-- For instance, if you want to extract a square crop of any image,

-- without caring about colorspace, you can use the following snippet.

--

-- > dynSquare :: DynamicImage -> DynamicImage

-- > dynSquare = dynamicPixelMap squareImage

-- >

-- > squareImage :: Pixel a => Image a -> Image a

-- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge

-- >    where edge = min (imageWidth img) (imageHeight img)

--

dynamicPixelMap :: (forall pixel . (Pixel pixel) => Image pixel -> Image pixel)

                -> DynamicImage -> DynamicImage

dynamicPixelMap f = aux

  where

    aux (ImageY8    i) = ImageY8 (f i)

    aux (ImageY16   i) = ImageY16 (f i)

    aux (ImageYF    i) = ImageYF (f i)

    aux (ImageYA8   i) = ImageYA8 (f i)

    aux (ImageYA16  i) = ImageYA16 (f i)

    aux (ImageRGB8  i) = ImageRGB8 (f i)

    aux (ImageRGB16 i) = ImageRGB16 (f i)

    aux (ImageRGBF  i) = ImageRGBF (f i)

    aux (ImageRGBA8 i) = ImageRGBA8 (f i)

    aux (ImageRGBA16 i) = ImageRGBA16 (f i)

    aux (ImageYCbCr8 i) = ImageYCbCr8 (f i)

    aux (ImageCMYK8 i) = ImageCMYK8 (f i)

    aux (ImageCMYK16 i) = ImageCMYK16 (f i)



instance NFData DynamicImage where

    rnf (ImageY8 img)     = rnf img

    rnf (ImageY16 img)    = rnf img

    rnf (ImageYF img)     = rnf img

    rnf (ImageYA8 img)    = rnf img

    rnf (ImageYA16 img)   = rnf img

    rnf (ImageRGB8 img)   = rnf img

    rnf (ImageRGB16 img)  = rnf img

    rnf (ImageRGBF img)   = rnf img

    rnf (ImageRGBA8 img)  = rnf img

    rnf (ImageRGBA16 img) = rnf img

    rnf (ImageYCbCr8 img) = rnf img

    rnf (ImageCMYK8 img)  = rnf img

    rnf (ImageCMYK16 img)  = rnf img



-- | Type alias for 8bit greyscale pixels. For simplicity,

-- greyscale pixels use plain numbers instead of a separate type.

type Pixel8 = Word8



-- | Type alias for 16bit greyscale pixels.

type Pixel16 = Word16



-- | Type alias for 32bit greyscale pixels.

type Pixel32 = Word32



-- | Type alias for 32bit floating point greyscale pixels. The standard

-- bounded value range is mapped to the closed interval [0,1] i.e.

--

-- > map promotePixel [0, 1 .. 255 :: Pixel8] == [0/255, 1/255 .. 1.0 :: PixelF]

type PixelF = Float



-- | Pixel type storing 8bit Luminance (Y) and alpha (A) information.

-- Values are stored in the following order:

--

--  * Luminance

--

--  * Alpha

--

data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8  -- Luminance

                         {-# UNPACK #-} !Pixel8  -- Alpha value

              deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing 16bit Luminance (Y) and alpha (A) information.

-- Values are stored in the following order:

--

--  * Luminance

--

--  * Alpha

--

data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16  -- Luminance

                           {-# UNPACK #-} !Pixel16  -- Alpha value

              deriving (Eq, Ord, Show, Typeable)



-- | Classic pixel type storing 8bit red, green and blue (RGB) information.

-- Values are stored in the following order:

--

--  * Red

--

--  * Green

--

--  * Blue

--

data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red

                           {-# UNPACK #-} !Pixel8 -- Green

                           {-# UNPACK #-} !Pixel8 -- Blue

               deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing value for the YCCK color space:

--

-- * Y (Luminance)

--

-- * Cb

--

-- * Cr

--

-- * Black

--

data PixelYCbCrK8 = PixelYCbCrK8 {-# UNPACK #-} !Pixel8

                                 {-# UNPACK #-} !Pixel8

                                 {-# UNPACK #-} !Pixel8

                                 {-# UNPACK #-} !Pixel8

               deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing 16bit red, green and blue (RGB) information.

-- Values are stored in the following order:

--

--  * Red

--

--  * Green

--

--  * Blue

--

data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red

                             {-# UNPACK #-} !Pixel16 -- Green

                             {-# UNPACK #-} !Pixel16 -- Blue

               deriving (Eq, Ord, Show, Typeable)



-- | HDR pixel type storing floating point 32bit red, green and blue (RGB) information.

-- Same value range and comments apply as for 'PixelF'.

-- Values are stored in the following order:

--

--  * Red

--

--  * Green

--

--  * Blue

--

data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red

                           {-# UNPACK #-} !PixelF -- Green

                           {-# UNPACK #-} !PixelF -- Blue

               deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing 8bit luminance, blue difference and red difference (YCbCr) information.

-- Values are stored in the following order:

--

--  * Y (luminance)

--

--  * Cb

--

--  * Cr

--

data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance

                               {-# UNPACK #-} !Pixel8 -- Cb blue difference

                               {-# UNPACK #-} !Pixel8 -- Cr red difference

                 deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing 8bit cyan, magenta, yellow and black (CMYK) information.

-- Values are stored in the following order:

--

--   * Cyan

--

--   * Magenta

--

--   * Yellow

--

--   * Black

--

data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan

                             {-# UNPACK #-} !Pixel8 -- Magenta

                             {-# UNPACK #-} !Pixel8 -- Yellow

                             {-# UNPACK #-} !Pixel8 -- Black

                 deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing 16bit cyan, magenta, yellow and black (CMYK) information.

-- Values are stored in the following order:

--

--   * Cyan

--

--   * Magenta

--

--   * Yellow

--

--   * Black

--

data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan

                               {-# UNPACK #-} !Pixel16 -- Magenta

                               {-# UNPACK #-} !Pixel16 -- Yellow

                               {-# UNPACK #-} !Pixel16 -- Black

                 deriving (Eq, Ord, Show, Typeable)





-- | Classical pixel type storing 8bit red, green, blue and alpha (RGBA) information.

-- Values are stored in the following order:

--

--  * Red

--

--  * Green

--

--  * Blue

--

--  * Alpha

--

data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red

                             {-# UNPACK #-} !Pixel8 -- Green

                             {-# UNPACK #-} !Pixel8 -- Blue

                             {-# UNPACK #-} !Pixel8 -- Alpha

                deriving (Eq, Ord, Show, Typeable)



-- | Pixel type storing 16bit red, green, blue and alpha (RGBA) information.

-- Values are stored in the following order:

--

--  * Red

--

--  * Green

--

--  * Blue

--

--  * Alpha

--

data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red

                               {-# UNPACK #-} !Pixel16 -- Green

                               {-# UNPACK #-} !Pixel16 -- Blue

                               {-# UNPACK #-} !Pixel16 -- Alpha

                deriving (Eq, Ord, Show, Typeable)



-- | Definition of pixels used in images. Each pixel has a color space, and a representative

-- component (Word8 or Float).

class ( Storable (PixelBaseComponent a)

      , Num (PixelBaseComponent a), Eq a ) => Pixel a where

    -- | Type of the pixel component, "classical" images

    -- would have Word8 type as their PixelBaseComponent,

    -- HDR image would have Float for instance

    type PixelBaseComponent a :: *



    -- | Call the function for every component of the pixels.

    -- For example for RGB pixels mixWith is declared like this:

    --

    -- > mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) =

    -- >    PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)

    --

    mixWith :: (Int -> PixelBaseComponent a -> PixelBaseComponent a -> PixelBaseComponent a)

            -> a -> a -> a



    -- | Extension of the `mixWith` which separate the treatment

    -- of the color components of the alpha value (transparency component).

    -- For pixel without alpha components, it is equivalent to mixWith.

    --

    -- > mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGB8 rb gb bb ab) =

    -- >    PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab)

    --

    mixWithAlpha :: (Int -> PixelBaseComponent a -> PixelBaseComponent a

                         -> PixelBaseComponent a)  -- ^ Function for color component

                 -> (PixelBaseComponent a -> PixelBaseComponent a

                         -> PixelBaseComponent a) -- ^ Function for alpha component

                 -> a -> a -> a

    {-# INLINE mixWithAlpha #-}

    mixWithAlpha f _ = mixWith f



    -- | Return the opacity of a pixel, if the pixel has an

    -- alpha layer, return the alpha value. If the pixel

    -- doesn't have an alpha value, return a value

    -- representing the opaqueness.

    pixelOpacity :: a -> PixelBaseComponent a



    -- | Return the number of components of the pixel

    componentCount :: a -> Int



    -- | Apply a function to each component of a pixel.

    -- If the color type possess an alpha (transparency channel),

    -- it is treated like the other color components.

    colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a



    -- | Calculate the index for the begining of the pixel

    pixelBaseIndex :: Image a -> Int -> Int -> Int

    pixelBaseIndex (Image { imageWidth = w }) x y =

            (x + y * w) * componentCount (undefined :: a)



    -- | Calculate theindex for the begining of the pixel at position x y

    mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int

    mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y =

            (x + y * w) * componentCount (undefined :: a)



    -- | Extract a pixel at a given position, (x, y), the origin

    -- is assumed to be at the corner top left, positive y to the

    -- bottom of the image

    pixelAt :: Image a -> Int -> Int -> a



    -- | Same as pixelAt but for mutable images.

    readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a



    -- | Write a pixel in a mutable image at position x y

    writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m ()



    -- | Unsafe version of pixelAt, read a pixel at the given

    -- index without bound checking (if possible).

    -- The index is expressed in number (PixelBaseComponent a)

    unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a



    -- | Unsafe version of readPixel,  read a pixel at the given

    -- position without bound checking (if possible). The index

    -- is expressed in number (PixelBaseComponent a)

    unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a



    -- | Unsafe version of writePixel, write a pixel at the

    -- given position without bound checking. This can be _really_ unsafe.

    -- The index is expressed in number (PixelBaseComponent a)

    unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m ()





-- | Implement upcasting for pixel types.

-- Minimal declaration of `promotePixel`.

-- It is strongly recommended to overload promoteImage to keep

-- performance acceptable

class (Pixel a, Pixel b) => ColorConvertible a b where

    -- | Convert a pixel type to another pixel type. This

    -- operation should never lose any data.

    promotePixel :: a -> b



    -- | Change the underlying pixel type of an image by performing a full copy

    -- of it.

    promoteImage :: Image a -> Image b

    promoteImage = pixelMap promotePixel



-- | This class abstract colorspace conversion. This

-- conversion can be lossy, which ColorConvertible cannot

class (Pixel a, Pixel b) => ColorSpaceConvertible a b where

    -- | Pass a pixel from a colorspace (say RGB) to the second one

    -- (say YCbCr)

    convertPixel :: a -> b



    -- | Helper function to convert a whole image by taking a

    -- copy it.

    convertImage :: Image a -> Image b

    convertImage = pixelMap convertPixel



generateMutableImage :: forall m px. (Pixel px, PrimMonad m)

                     => (Int -> Int -> px)  -- ^ Generating function, with `x` and `y` params.

                     -> Int        -- ^ Width in pixels

                     -> Int        -- ^ Height in pixels

                     -> m (MutableImage (PrimState m) px)

{-# INLINE generateMutableImage #-}

generateMutableImage f w h = MutableImage w h `liftM` generated where

  compCount = componentCount (undefined :: px)



  generated = do

    arr <- M.new (w * h * compCount)

    let lineGenerator _ !y | y >= h = return ()

        lineGenerator !lineIdx y = column lineIdx 0

          where column !idx !x | x >= w = lineGenerator idx $ y + 1

                column idx x = do

                    unsafeWritePixel arr idx $ f x y

                    column (idx + compCount) $ x + 1

    lineGenerator 0 0

    return arr



-- | Create an image given a function to generate pixels.

-- The function will receive values from 0 to width-1 for the x parameter

-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper

-- left corner of the image, and (width-1, height-1) the lower right corner.

--

-- for example, to create a small gradient image:

--

-- > imageCreator :: String -> IO ()

-- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300

-- >    where pixelRenderer x y = PixelRGB8 (fromIntegral x) (fromIntegral y) 128

--

generateImage :: forall px. (Pixel px)

              => (Int -> Int -> px)  -- ^ Generating function, with `x` and `y` params.

              -> Int        -- ^ Width in pixels

              -> Int        -- ^ Height in pixels

              -> Image px

{-# INLINE generateImage #-}

generateImage f w h = runST img where

  img :: ST s (Image px)

  img = generateMutableImage f w h >>= unsafeFreezeImage



-- | Create an image using a monadic initializer function.

-- The function will receive values from 0 to width-1 for the x parameter

-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper

-- left corner of the image, and (width-1, height-1) the lower right corner.

--

-- The function is called for each pixel in the line from left to right (0 to width - 1)

-- and for each line (0 to height - 1).

withImage :: forall m pixel. (Pixel pixel, PrimMonad m)

          => Int                     -- ^ Image width

          -> Int                     -- ^ Image height

          -> (Int -> Int -> m pixel) -- ^ Generating functions

          -> m (Image pixel)

withImage width height pixelGenerator = do

  let pixelComponentCount = componentCount (undefined :: pixel)

  arr <- M.new (width * height * pixelComponentCount)

  let mutImage = MutableImage

        { mutableImageWidth = width

        , mutableImageHeight = height

        , mutableImageData = arr

        }



  let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]]

  sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx

                        | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]]

  unsafeFreezeImage mutImage



-- | Create an image given a function to generate pixels.

-- The function will receive values from 0 to width-1 for the x parameter

-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper

-- left corner of the image, and (width-1, height-1) the lower right corner.

--

-- the acc parameter is a user defined one.

--

-- The function is called for each pixel in the line from left to right (0 to width - 1)

-- and for each line (0 to height - 1).

generateFoldImage :: forall a acc. (Pixel a)

                  => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y

                  -> acc        -- ^ Initial state

                  -> Int        -- ^ Width in pixels

                  -> Int        -- ^ Height in pixels

                  -> (acc, Image a)

generateFoldImage f intialAcc w h =

 (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated })

  where compCount = componentCount (undefined :: a)

        (finalState, generated) = runST $ do

            arr <- M.new (w * h * compCount)

            let mutImage = MutableImage {

                                mutableImageWidth = w,

                                mutableImageHeight = h,

                                mutableImageData = arr }

            foldResult <- foldM (\acc (x,y) -> do

                    let (acc', px) = f acc x y

                    writePixel mutImage x y px

                    return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]]



            frozen <- V.unsafeFreeze arr

            return (foldResult, frozen)



-- | Fold over the pixel of an image with a raster scan order:

-- from top to bottom, left to right

{-# INLINE pixelFold #-}

pixelFold :: forall acc pixel. (Pixel pixel)

          => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc

pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =

  columnFold 0 initialAccumulator 0

    where

      !compCount = componentCount (undefined :: pixel)

      !vec = imageData img



      lfold !y acc !x !idx

        | x >= w = columnFold (y + 1) acc idx

        | otherwise = 

            lfold y (f acc x y $ unsafePixelAt vec idx) (x + 1) (idx + compCount)



      columnFold !y lineAcc !readIdx

        | y >= h = lineAcc

        | otherwise = lfold y lineAcc 0 readIdx



-- | Fold over the pixel of an image with a raster scan order:

-- from top to bottom, left to right, carrying out a state

pixelFoldM :: (Pixel pixel, Monad m)

           => (acc -> Int -> Int -> pixel -> m acc) -- ^ monadic mapping function

           -> acc                              -- ^ Initial state

           -> Image pixel                       -- ^ Image to fold over

           -> m acc

{-# INLINE pixelFoldM  #-}

pixelFoldM action initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =

  lineFold initialAccumulator h columnFold

    where

      pixelFolder y acc x = action acc x y $ pixelAt img x y

      columnFold lineAcc y = lineFold lineAcc w (pixelFolder y)





-- | Fold over the pixel of an image with a raster scan order:

-- from top to bottom, left to right. This functions is analog

-- to the foldMap from the 'Foldable' typeclass, but due to the

-- Pixel constraint, Image cannot be made an instance of it.

pixelFoldMap :: forall m px. (Pixel px, Monoid m) => (px -> m) -> Image px -> m

pixelFoldMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = folder 0

  where

    compCount = componentCount (undefined :: px)

    maxi = w * h * compCount



    folder idx | idx >= maxi = mempty

    folder idx = f (unsafePixelAt vec idx) <> folder (idx + compCount)



-- | `map` equivalent for an image, working at the pixel level.

-- Little example : a brightness function for an rgb image

--

-- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8

-- > brightnessRGB8 add = pixelMap brightFunction

-- >      where up v = fromIntegral (fromIntegral v + add)

-- >            brightFunction (PixelRGB8 r g b) =

-- >                    PixelRGB8 (up r) (up g) (up b)

--

pixelMap :: forall a b. (Pixel a, Pixel b)

         => (a -> b) -> Image a -> Image b

{-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-}

{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-}

{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-}

{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-}

{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-}

{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-}

{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-}

pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } =

  Image w h pixels

    where sourceComponentCount = componentCount (undefined :: a)

          destComponentCount = componentCount (undefined :: b)



          pixels = runST $ do

            newArr <- M.new (w * h * destComponentCount)

            let lineMapper _ _ y | y >= h = return ()

                lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0

                  where colMapper readIdx writeIdx x

                            | x >= w = lineMapper readIdx writeIdx $ y + 1

                            | otherwise = do

                                unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx

                                colMapper (readIdx + sourceComponentCount)

                                          (writeIdx + destComponentCount)

                                          (x + 1)

            lineMapper 0 0 0



            -- unsafeFreeze avoids making a second copy and it will be

            -- safe because newArray can't be referenced as a mutable array

            -- outside of this where block

            V.unsafeFreeze newArr





-- | Helpers to embed a rankNTypes inside an Applicative

newtype GenST a = GenST { genAction :: forall s. ST s (M.STVector s a) }



-- | Traversal type matching the definition in the Lens package.

type Traversal s t a b =

    forall f. Applicative f => (a -> f b) -> s -> f t 



writePx :: Pixel px

        => Int -> GenST (PixelBaseComponent px) -> px -> GenST (PixelBaseComponent px)

{-# INLINE writePx #-}

writePx idx act px = GenST $ do

   vec <- genAction act

   unsafeWritePixel vec idx px

   return vec



freezeGenST :: Pixel px

            => Int -> Int -> GenST (PixelBaseComponent px) -> Image px

freezeGenST w h act =

  Image w h (runST (genAction act >>= V.unsafeFreeze))



-- | Traversal in "raster" order, from left to right the top to bottom.

-- This traversal is matching pixelMap in spirit.

--

-- Since 3.2.4

imagePixels :: forall pxa pxb. (Pixel pxa, Pixel pxb)

            => Traversal (Image pxa) (Image pxb) pxa pxb

{-# INLINE imagePixels #-}

imagePixels f Image { imageWidth = w, imageHeight = h, imageData = vec } =

  freezeGenST w h <$> pixels

  where

    sourceComponentCount = componentCount (undefined :: pxa)

    destComponentCount = componentCount (undefined :: pxb)



    maxi = w * h * sourceComponentCount

    pixels =

      go (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0



    go act readIdx _ | readIdx >= maxi = act

    go act readIdx writeIdx =

      go newAct (readIdx + sourceComponentCount) (writeIdx + destComponentCount)

      where

        px = f (unsafePixelAt vec readIdx)

        newAct = writePx writeIdx <$> act <*> px



-- | Traversal providing the pixel position with it's value.

-- The traversal in raster order, from lef to right, then top

-- to bottom. The traversal match pixelMapXY in spirit.

--

-- Since 3.2.4

imageIPixels :: forall pxa pxb. (Pixel pxa, Pixel pxb)

             => Traversal (Image pxa) (Image pxb) (Int, Int, pxa) pxb

{-# INLINE imageIPixels #-}

imageIPixels f Image { imageWidth = w, imageHeight = h, imageData = vec } =

  freezeGenST w h <$> pixels

  where

    sourceComponentCount = componentCount (undefined :: pxa)

    destComponentCount = componentCount (undefined :: pxb)



    pixels =

      lineMapper (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 0



    lineMapper act _ _ y | y >= h = act

    lineMapper act readIdxLine writeIdxLine y =

        go act readIdxLine writeIdxLine 0

      where

        go cact readIdx writeIdx x

          | x >= w = lineMapper cact readIdx writeIdx $ y + 1

          | otherwise = do

             let px = f (x, y, unsafePixelAt vec readIdx)

             go (writePx writeIdx <$> cact <*> px)

                (readIdx + sourceComponentCount)

                (writeIdx + destComponentCount)

                (x + 1)



-- | Just like `pixelMap` only the function takes the pixel coordinates as

--   additional parameters.

pixelMapXY :: forall a b. (Pixel a, Pixel b)

           => (Int -> Int -> a -> b) -> Image a -> Image b

{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelYCbCr8 -> PixelRGB8)
                                 -> Image PixelYCbCr8 -> Image PixelRGB8 #-}

{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelYCbCr8)
                                 -> Image PixelRGB8 -> Image PixelYCbCr8 #-}

{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGB8)
                                 -> Image PixelRGB8 -> Image PixelRGB8 #-}

{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGBA8)
                                 -> Image PixelRGB8 -> Image PixelRGBA8 #-}

{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGBA8 -> PixelRGBA8)
                                 -> Image PixelRGBA8 -> Image PixelRGBA8 #-}

{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> Pixel8 -> PixelRGB8)
                                 -> Image Pixel8 -> Image PixelRGB8 #-}

pixelMapXY f Image { imageWidth = w, imageHeight = h, imageData = vec } =

  Image w h pixels

    where sourceComponentCount = componentCount (undefined :: a)

          destComponentCount = componentCount (undefined :: b)



          pixels = runST $ do

            newArr <- M.new (w * h * destComponentCount)

            let lineMapper _ _ y | y >= h = return ()

                lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0

                  where colMapper readIdx writeIdx x

                            | x >= w = lineMapper readIdx writeIdx $ y + 1

                            | otherwise = do

                                unsafeWritePixel newArr writeIdx . f x y $ unsafePixelAt vec readIdx

                                colMapper (readIdx + sourceComponentCount)

                                          (writeIdx + destComponentCount)

                                          (x + 1)

            lineMapper 0 0 0



            -- unsafeFreeze avoids making a second copy and it will be

            -- safe because newArray can't be referenced as a mutable array

            -- outside of this where block

            V.unsafeFreeze newArr



-- | Combine, pixel by pixel and component by component

-- the values of 3 different images. Usage example:

--

-- > averageBrightNess c1 c2 c3 = clamp $ toInt c1 + toInt c2 + toInt c3

-- >   where clamp = fromIntegral . min 0 . max 255

-- >         toInt :: a -> Int

-- >         toInt = fromIntegral

-- > ziPixelComponent3 averageBrightNess img1 img2 img3

--

zipPixelComponent3

    :: forall px. ( V.Storable (PixelBaseComponent px))

    => (PixelBaseComponent px -> PixelBaseComponent px -> PixelBaseComponent px

            -> PixelBaseComponent px)

    -> Image px -> Image px -> Image px -> Image px

{-# INLINE zipPixelComponent3 #-}

zipPixelComponent3 f i1@(Image { imageWidth = w, imageHeight = h }) i2 i3

  | not isDimensionEqual = error "Different image size zipPairwisePixelComponent"

  | otherwise = Image { imageWidth = w

                      , imageHeight = h

                      , imageData = V.zipWith3 f data1 data2 data3

                      }

       where data1 = imageData i1

             data2 = imageData i2

             data3 = imageData i3



             isDimensionEqual =

                 w == imageWidth i2 && w == imageWidth i3 &&

                     h == imageHeight i2 && h == imageHeight i3



-- | Helper class to help extract a luma plane out

-- of an image or a pixel

class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where

    -- | Compute the luminance part of a pixel

    computeLuma      :: a -> PixelBaseComponent a



    -- | Extract a luma plane out of an image. This

    -- method is in the typeclass to help performant

    -- implementation.

    --

    -- > jpegToGrayScale :: FilePath -> FilePath -> IO ()

    -- > jpegToGrayScale source dest

    extractLumaPlane :: Image a -> Image (PixelBaseComponent a)

    extractLumaPlane = pixelMap computeLuma



instance LumaPlaneExtractable Pixel8 where

    {-# INLINE computeLuma #-}

    computeLuma = id

    extractLumaPlane = id



instance LumaPlaneExtractable Pixel16 where

    {-# INLINE computeLuma #-}

    computeLuma = id

    extractLumaPlane = id



instance LumaPlaneExtractable Pixel32 where

    {-# INLINE computeLuma #-}

    computeLuma = id

    extractLumaPlane = id



instance LumaPlaneExtractable PixelF where

    {-# INLINE computeLuma #-}

    computeLuma = id

    extractLumaPlane = id



instance LumaPlaneExtractable PixelRGBF where

    {-# INLINE computeLuma #-}

    computeLuma (PixelRGBF r g b) =

        0.3 * r + 0.59 * g + 0.11 * b



instance LumaPlaneExtractable PixelRGBA8 where

    {-# INLINE computeLuma #-}

    computeLuma (PixelRGBA8 r g b _) =

       floor $ (0.3 :: Double) * fromIntegral r

             + 0.59 * fromIntegral g

             + 0.11 * fromIntegral b



instance LumaPlaneExtractable PixelYCbCr8 where

    {-# INLINE computeLuma #-}

    computeLuma (PixelYCbCr8 y _ _) = y

    extractLumaPlane = extractComponent PlaneLuma



-- | Free promotion for identic pixel types

instance (Pixel a) => ColorConvertible a a where

    {-# INLINE promotePixel #-}

    promotePixel = id



    {-# INLINE promoteImage #-}

    promoteImage = id



--------------------------------------------------

----            Pixel8 instances

--------------------------------------------------

instance Pixel Pixel8 where

    type PixelBaseComponent Pixel8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f = f 0



    {-# INLINE colorMap #-}

    colorMap f = f



    {-# INLINE componentCount #-}

    componentCount _ = 1



    {-# INLINE pixelAt #-}

    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.read` mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.write` mutablePixelBaseIndex image x y



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt = V.unsafeIndex

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel = M.unsafeRead

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel = M.unsafeWrite



instance ColorConvertible Pixel8 PixelYA8 where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelYA8 c 255



instance ColorConvertible Pixel8 PixelF where

    {-# INLINE promotePixel #-}

    promotePixel c = fromIntegral c / 255.0



instance ColorConvertible Pixel8 Pixel16 where

    {-# INLINE promotePixel #-}

    promotePixel c = fromIntegral c * 257



instance ColorConvertible Pixel8 PixelRGB8 where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelRGB8 c c c



instance ColorConvertible Pixel8 PixelRGBA8 where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelRGBA8 c c c 255



--------------------------------------------------

----            Pixel16 instances

--------------------------------------------------

instance Pixel Pixel16 where

    type PixelBaseComponent Pixel16 = Word16



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f = f 0



    {-# INLINE colorMap #-}

    colorMap f = f



    {-# INLINE componentCount #-}

    componentCount _ = 1

    {-# INLINE pixelAt #-}

    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.read` mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.write` mutablePixelBaseIndex image x y



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt = V.unsafeIndex

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel = M.unsafeRead

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel = M.unsafeWrite



instance ColorConvertible Pixel16 PixelYA16 where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelYA16 c maxBound



instance ColorConvertible Pixel16 PixelRGB16 where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelRGB16 c c c



instance ColorConvertible Pixel16 PixelRGBA16 where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelRGBA16 c c c maxBound



--------------------------------------------------

----            Pixel32 instances

--------------------------------------------------

instance Pixel Pixel32 where

    type PixelBaseComponent Pixel32 = Word32



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f = f 0



    {-# INLINE colorMap #-}

    colorMap f = f



    {-# INLINE componentCount #-}

    componentCount _ = 1



    {-# INLINE pixelAt #-}

    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.read` mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.write` mutablePixelBaseIndex image x y



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt = V.unsafeIndex

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel = M.unsafeRead

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel = M.unsafeWrite



--------------------------------------------------

----            PixelF instances

--------------------------------------------------

instance Pixel PixelF where

    type PixelBaseComponent PixelF = Float



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const 1.0



    {-# INLINE mixWith #-}

    mixWith f = f 0



    {-# INLINE colorMap #-}

    colorMap f = f

    {-# INLINE componentCount #-}

    componentCount _ = 1

    {-# INLINE pixelAt #-}

    pixelAt (Image { imageWidth = w, imageData = arr }) x y =

        arr ! (x + y * w)



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.read` mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y =

        arr `M.write` mutablePixelBaseIndex image x y



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt = V.unsafeIndex

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel = M.unsafeRead

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel = M.unsafeWrite



instance ColorConvertible PixelF PixelRGBF where

    {-# INLINE promotePixel #-}

    promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59)  (c / 0.11)



--------------------------------------------------

----            PixelYA8 instances

--------------------------------------------------

instance Pixel PixelYA8 where

    type PixelBaseComponent PixelYA8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity (PixelYA8 _ a) = a



    {-# INLINE mixWith #-}

    mixWith f (PixelYA8 ya aa) (PixelYA8 yb ab) =

        PixelYA8 (f 0 ya yb) (f 1 aa ab)





    {-# INLINE colorMap #-}

    colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a)

    {-# INLINE componentCount #-}

    componentCount _ = 2

    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y =

        PixelYA8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        yv <- arr `M.read` baseIdx

        av <- arr `M.read` (baseIdx + 1)

        return $ PixelYA8 yv av

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) yv

        (arr `M.write` (baseIdx + 1)) av



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelYA8 y a) =

        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a



instance ColorConvertible PixelYA8 PixelRGB8 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelYA8 y _) = PixelRGB8 y y y



instance ColorConvertible PixelYA8 PixelRGBA8 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a



instance ColorPlane PixelYA8 PlaneLuma where

    toComponentIndex _ _ = 0



instance ColorPlane PixelYA8 PlaneAlpha where

    toComponentIndex _ _ = 1



instance TransparentPixel PixelYA8 Pixel8 where

    {-# INLINE dropTransparency #-}

    dropTransparency (PixelYA8 y _) = y

    {-# INLINE getTransparency #-}

    getTransparency (PixelYA8 _ a) = a



instance LumaPlaneExtractable PixelYA8 where

    {-# INLINE computeLuma #-}

    computeLuma (PixelYA8 y _) = y

    extractLumaPlane = extractComponent PlaneLuma



--------------------------------------------------

----            PixelYA16 instances

--------------------------------------------------

instance Pixel PixelYA16 where

    type PixelBaseComponent PixelYA16 = Word16



    {-# INLINE pixelOpacity #-}

    pixelOpacity (PixelYA16 _ a) = a



    {-# INLINE mixWith #-}

    mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) =

        PixelYA16 (f 0 ya yb) (f 1 aa ab)



    {-# INLINE mixWithAlpha #-}

    mixWithAlpha f fa (PixelYA16 ya aa) (PixelYA16 yb ab) =

        PixelYA16 (f 0 ya yb) (fa aa ab)



    {-# INLINE colorMap #-}

    colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a)

    {-# INLINE componentCount #-}

    componentCount _ = 2

    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0))

                                                              (arr ! (baseIdx + 1))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        yv <- arr `M.read` baseIdx

        av <- arr `M.read` (baseIdx + 1)

        return $ PixelYA16 yv av

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) yv

        (arr `M.write` (baseIdx + 1)) av



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelYA16 y a) =

        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a



instance ColorConvertible PixelYA16 PixelRGBA16 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a



instance ColorPlane PixelYA16 PlaneLuma where

    toComponentIndex _ _ = 0



instance ColorPlane PixelYA16 PlaneAlpha where

    toComponentIndex _ _ = 1



instance TransparentPixel PixelYA16 Pixel16 where

    {-# INLINE dropTransparency #-}

    dropTransparency (PixelYA16 y _) = y

    {-# INLINE getTransparency #-}

    getTransparency (PixelYA16 _ a) = a



--------------------------------------------------

----            PixelRGBF instances

--------------------------------------------------

instance Pixel PixelRGBF where

    type PixelBaseComponent PixelRGBF = PixelF



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const 1.0



    {-# INLINE mixWith #-}

    mixWith f (PixelRGBF ra ga ba) (PixelRGBF rb gb bb) =

        PixelRGBF (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)



    {-# INLINE colorMap #-}

    colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b)



    {-# INLINE componentCount #-}

    componentCount _ = 3



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0))

                                                              (arr ! (baseIdx + 1))

                                                              (arr ! (baseIdx + 2))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        return $ PixelRGBF rv gv bv

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelRGBF `liftM` M.unsafeRead vec idx

                  `ap` M.unsafeRead vec (idx + 1)

                  `ap` M.unsafeRead vec (idx + 2)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelRGBF r g b) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b



instance ColorPlane PixelRGBF PlaneRed where

    toComponentIndex _ _ = 0



instance ColorPlane PixelRGBF PlaneGreen where

    toComponentIndex _ _ = 1



instance ColorPlane PixelRGBF PlaneBlue where

    toComponentIndex _ _ = 2



--------------------------------------------------

----            PixelRGB16 instances

--------------------------------------------------

instance Pixel PixelRGB16 where

    type PixelBaseComponent PixelRGB16 = Pixel16



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f (PixelRGB16 ra ga ba) (PixelRGB16 rb gb bb) =

        PixelRGB16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)



    {-# INLINE colorMap #-}

    colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b)



    {-# INLINE componentCount #-}

    componentCount _ = 3



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0))

                                                               (arr ! (baseIdx + 1))

                                                               (arr ! (baseIdx + 2))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        return $ PixelRGB16 rv gv bv

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelRGB16 `liftM` M.unsafeRead vec idx

                   `ap` M.unsafeRead vec (idx + 1)

                   `ap` M.unsafeRead vec (idx + 2)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelRGB16 r g b) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b



instance ColorPlane PixelRGB16 PlaneRed where

    toComponentIndex _ _ = 0



instance ColorPlane PixelRGB16 PlaneGreen where

    toComponentIndex _ _ = 1



instance ColorPlane PixelRGB16 PlaneBlue where

    toComponentIndex _ _ = 2



instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where

    {-# INLINE convertPixel #-}

    convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b)



instance ColorConvertible PixelRGB16 PixelRGBA16 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound



instance LumaPlaneExtractable PixelRGB16 where

    {-# INLINE computeLuma #-}

    computeLuma (PixelRGB16 r g b) =

        floor $ (0.3 :: Double) * fromIntegral r

              + 0.59 * fromIntegral g

              + 0.11 * fromIntegral b



--------------------------------------------------

----            PixelRGB8 instances

--------------------------------------------------

instance Pixel PixelRGB8 where

    type PixelBaseComponent PixelRGB8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) =

        PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)



    {-# INLINE colorMap #-}

    colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b)



    {-# INLINE componentCount #-}

    componentCount _ = 3



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0))

                                                              (arr ! (baseIdx + 1))

                                                              (arr ! (baseIdx + 2))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        return $ PixelRGB8 rv gv bv

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelRGB8 `liftM` M.unsafeRead vec idx

                  `ap` M.unsafeRead vec (idx + 1)

                  `ap` M.unsafeRead vec (idx + 2)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelRGB8 r g b) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b



instance ColorConvertible PixelRGB8 PixelRGBA8 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound



instance ColorConvertible PixelRGB8 PixelRGBF where

    {-# INLINE promotePixel #-}

    promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b)

        where toF v = fromIntegral v / 255.0



instance ColorConvertible PixelRGB8 PixelRGB16 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelRGB8 r g b) = PixelRGB16 (promotePixel r) (promotePixel g) (promotePixel b)



instance ColorConvertible PixelRGB8 PixelRGBA16 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelRGB8 r g b) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) maxBound



instance ColorPlane PixelRGB8 PlaneRed where

    toComponentIndex _ _ = 0



instance ColorPlane PixelRGB8 PlaneGreen where

    toComponentIndex _ _ = 1



instance ColorPlane PixelRGB8 PlaneBlue where

    toComponentIndex _ _ = 2



instance LumaPlaneExtractable PixelRGB8 where

    {-# INLINE computeLuma #-}

    computeLuma (PixelRGB8 r g b) =

        floor $ (0.3 :: Double) * fromIntegral r

              + 0.59 * fromIntegral g

              + 0.11 * fromIntegral b



--------------------------------------------------

----            PixelRGBA8 instances

--------------------------------------------------

instance Pixel PixelRGBA8 where

    type PixelBaseComponent PixelRGBA8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity (PixelRGBA8 _ _ _ a) = a



    {-# INLINE mixWith #-}

    mixWith f (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) =

        PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab)



    {-# INLINE mixWithAlpha #-}

    mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) =

        PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab)



    {-# INLINE colorMap #-}

    colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a)



    {-# INLINE componentCount #-}

    componentCount _ = 4



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0))

                                                               (arr ! (baseIdx + 1))

                                                               (arr ! (baseIdx + 2))

                                                               (arr ! (baseIdx + 3))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        av <- arr `M.read` (baseIdx + 3)

        return $ PixelRGBA8 rv gv bv av

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv

        (arr `M.write` (baseIdx + 3)) av



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelRGBA8 (V.unsafeIndex v idx)

                   (V.unsafeIndex v $ idx + 1)

                   (V.unsafeIndex v $ idx + 2)

                   (V.unsafeIndex v $ idx + 3)



    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelRGBA8 `liftM` M.unsafeRead vec idx

                   `ap` M.unsafeRead vec (idx + 1)

                   `ap` M.unsafeRead vec (idx + 2)

                   `ap` M.unsafeRead vec (idx + 3)



    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelRGBA8 r g b a) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b

                              >> M.unsafeWrite v (idx + 3) a



instance ColorConvertible PixelRGBA8 PixelRGBA16 where

    {-# INLINE promotePixel #-}

    promotePixel (PixelRGBA8 r g b a) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) (promotePixel a)



instance ColorPlane PixelRGBA8 PlaneRed where

    toComponentIndex _ _ = 0



instance ColorPlane PixelRGBA8 PlaneGreen where

    toComponentIndex _ _ = 1



instance ColorPlane PixelRGBA8 PlaneBlue where

    toComponentIndex _ _ = 2



instance ColorPlane PixelRGBA8 PlaneAlpha where

    toComponentIndex _ _ = 3



--------------------------------------------------

----            PixelRGBA16 instances

--------------------------------------------------

instance Pixel PixelRGBA16 where

    type PixelBaseComponent PixelRGBA16 = Pixel16



    {-# INLINE pixelOpacity #-}

    pixelOpacity (PixelRGBA16 _ _ _ a) = a



    {-# INLINE mixWith #-}

    mixWith f (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) =

        PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab)



    {-# INLINE mixWithAlpha #-}

    mixWithAlpha f fa (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) =

        PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab)



    {-# INLINE colorMap #-}

    colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a)



    {-# INLINE componentCount #-}

    componentCount _ = 4



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y =

                PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))

                            (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        av <- arr `M.read` (baseIdx + 3)

        return $ PixelRGBA16 rv gv bv av

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv

        (arr `M.write` (baseIdx + 3)) av



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelRGBA16 (V.unsafeIndex v idx)

                    (V.unsafeIndex v $ idx + 1)

                    (V.unsafeIndex v $ idx + 2)

                    (V.unsafeIndex v $ idx + 3)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelRGBA16 `liftM` M.unsafeRead vec idx

                    `ap` M.unsafeRead vec (idx + 1)

                    `ap` M.unsafeRead vec (idx + 2)

                    `ap` M.unsafeRead vec (idx + 3)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelRGBA16 r g b a) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b

                              >> M.unsafeWrite v (idx + 3) a





instance TransparentPixel PixelRGBA16 PixelRGB16 where

    {-# INLINE dropTransparency #-}

    dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b

    {-# INLINE getTransparency #-}

    getTransparency (PixelRGBA16 _ _ _ a) = a



instance ColorPlane PixelRGBA16 PlaneRed where

    toComponentIndex _ _ = 0



instance ColorPlane PixelRGBA16 PlaneGreen where

    toComponentIndex _ _ = 1



instance ColorPlane PixelRGBA16 PlaneBlue where

    toComponentIndex _ _ = 2



instance ColorPlane PixelRGBA16 PlaneAlpha where

    toComponentIndex _ _ = 3



--------------------------------------------------

----            PixelYCbCr8 instances

--------------------------------------------------

instance Pixel PixelYCbCr8 where

    type PixelBaseComponent PixelYCbCr8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f (PixelYCbCr8 ya cba cra) (PixelYCbCr8 yb cbb crb) =

        PixelYCbCr8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb)



    {-# INLINE colorMap #-}

    colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr)

    {-# INLINE componentCount #-}

    componentCount _ = 3

    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0))

                                                                (arr ! (baseIdx + 1))

                                                                (arr ! (baseIdx + 2))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        yv <- arr `M.read` baseIdx

        cbv <- arr `M.read` (baseIdx + 1)

        crv <- arr `M.read` (baseIdx + 2)

        return $ PixelYCbCr8 yv cbv crv

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) yv

        (arr `M.write` (baseIdx + 1)) cbv

        (arr `M.write` (baseIdx + 2)) crv



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)

    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelYCbCr8 `liftM` M.unsafeRead vec idx

                    `ap` M.unsafeRead vec (idx + 1)

                    `ap` M.unsafeRead vec (idx + 2)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelYCbCr8 y cb cr) =

        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb

                              >> M.unsafeWrite v (idx + 2) cr



instance (Pixel a) => ColorSpaceConvertible a a where

    convertPixel = id

    convertImage = id



scaleBits, oneHalf :: Int

scaleBits = 16

oneHalf = 1 `unsafeShiftL` (scaleBits - 1)



fix :: Float -> Int

fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5





rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int

rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ]

gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ]

bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ]

rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ]

gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ]

bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ]

gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ]

bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ]





instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where

    {-# INLINE convertPixel #-}

    convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr)

      where ri = fromIntegral r

            gi = fromIntegral g

            bi = fromIntegral b



            y  = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits

            cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits

            cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits



    convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData

        where maxi = w * h



              rY  = fix 0.29900

              gY  = fix 0.58700

              bY  = fix 0.11400

              rCb = - fix 0.16874

              gCb = - fix 0.33126

              bCb = fix 0.5

              gCr = - fix 0.41869

              bCr = - fix 0.08131



              newData = runST $ do

                block <- M.new $ maxi * 3

                let traductor _ idx | idx >= maxi = return block

                    traductor readIdx idx = do

                        let ri = fromIntegral $ d `V.unsafeIndex` readIdx

                            gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1)

                            bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2)



                            y  = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits

                            cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits

                            cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits



                        (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y

                        (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb

                        (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr

                        traductor (readIdx + 3) (idx + 1)



                traductor 0 0 >>= V.freeze



crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int

crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]]

cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]]

crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]]

cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]]



instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where

    {-# INLINE convertPixel #-}

    convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)

        where clampWord8 = fromIntegral . max 0 . min 255

              yi = fromIntegral y

              cbi = fromIntegral cb

              cri = fromIntegral cr



              r = yi +  crRTab `V.unsafeIndex` cri

              g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits

              b = yi +  cbBTab `V.unsafeIndex` cbi



    convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData

        where maxi = w * h

              clampWord8 v | v < 0 = 0

                           | v > 255 = 255

                           | otherwise = fromIntegral v



              newData = runST $ do

                block <- M.new $ maxi * 3

                let traductor _ idx | idx >= maxi = return block

                    traductor readIdx idx = do

                        let yi =  fromIntegral $ d `V.unsafeIndex` readIdx

                            cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1)

                            cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2)



                            r = yi +  crRTab `V.unsafeIndex` cri

                            g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits

                            b = yi +  cbBTab `V.unsafeIndex` cbi



                        (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r

                        (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g

                        (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b

                        traductor (readIdx + 3) (idx + 1)



                traductor 0 0 >>= V.freeze



instance ColorPlane PixelYCbCr8 PlaneLuma where

    toComponentIndex _ _ = 0



instance ColorPlane PixelYCbCr8 PlaneCb where

    toComponentIndex _ _ = 1



instance ColorPlane PixelYCbCr8 PlaneCr where

    toComponentIndex _ _ = 2



--------------------------------------------------

----            PixelCMYK8 instances

--------------------------------------------------

instance Pixel PixelCMYK8 where

    type PixelBaseComponent PixelCMYK8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f (PixelCMYK8 ca ma ya ka) (PixelCMYK8 cb mb yb kb) =

        PixelCMYK8 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb)



    {-# INLINE colorMap #-}

    colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k)



    {-# INLINE componentCount #-}

    componentCount _ = 4



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0))

                                                               (arr ! (baseIdx + 1))

                                                               (arr ! (baseIdx + 2))

                                                               (arr ! (baseIdx + 3))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        av <- arr `M.read` (baseIdx + 3)

        return $ PixelCMYK8 rv gv bv av

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv

        (arr `M.write` (baseIdx + 3)) av



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelCMYK8 (V.unsafeIndex v idx)

                   (V.unsafeIndex v $ idx + 1)

                   (V.unsafeIndex v $ idx + 2)

                   (V.unsafeIndex v $ idx + 3)



    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelCMYK8 `liftM` M.unsafeRead vec idx

                   `ap` M.unsafeRead vec (idx + 1)

                   `ap` M.unsafeRead vec (idx + 2)

                   `ap` M.unsafeRead vec (idx + 3)



    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelCMYK8 r g b a) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b

                              >> M.unsafeWrite v (idx + 3) a



instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where

  convertPixel (PixelCMYK8 c m y k) =

      PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)

    where

      clampWord8 = fromIntegral . max 0 . min 255 . (`div` 255)

      ik :: Int

      ik = 255 - fromIntegral k



      r = (255 - fromIntegral c) * ik

      g = (255 - fromIntegral m) * ik

      b = (255 - fromIntegral y) * ik



--------------------------------------------------

----            PixelYCbCrK8 instances

--------------------------------------------------

instance Pixel PixelYCbCrK8 where

    type PixelBaseComponent PixelYCbCrK8 = Word8



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f (PixelYCbCrK8 ya cba cra ka) (PixelYCbCrK8 yb cbb crb kb) =

        PixelYCbCrK8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) (f 3 ka kb)



    {-# INLINE colorMap #-}

    colorMap f (PixelYCbCrK8 y cb cr k) = PixelYCbCrK8 (f y) (f cb) (f cr) (f k)



    {-# INLINE componentCount #-}

    componentCount _ = 4



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y =

        PixelYCbCrK8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))

                     (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        yv <- arr `M.read` baseIdx

        cbv <- arr `M.read` (baseIdx + 1)

        crv <- arr `M.read` (baseIdx + 2)

        kv <- arr `M.read` (baseIdx + 3)

        return $ PixelYCbCrK8 yv cbv crv kv

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCrK8 yv cbv crv kv) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) yv

        (arr `M.write` (baseIdx + 1)) cbv

        (arr `M.write` (baseIdx + 2)) crv

        (arr `M.write` (baseIdx + 3)) kv



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelYCbCrK8 (V.unsafeIndex v idx)

                     (V.unsafeIndex v $ idx + 1)

                     (V.unsafeIndex v $ idx + 2)

                     (V.unsafeIndex v $ idx + 3)



    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

      PixelYCbCrK8 `liftM` M.unsafeRead vec idx

                   `ap` M.unsafeRead vec (idx + 1)

                   `ap` M.unsafeRead vec (idx + 2)

                   `ap` M.unsafeRead vec (idx + 3)



    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelYCbCrK8 y cb cr k) =

        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb

                              >> M.unsafeWrite v (idx + 2) cr

                              >> M.unsafeWrite v (idx + 3) k



instance ColorSpaceConvertible PixelYCbCrK8 PixelRGB8 where

  convertPixel (PixelYCbCrK8 y cb cr _k) = PixelRGB8 (clamp r) (clamp g) (clamp b)

    where

      tof :: Word8 -> Float

      tof = fromIntegral



      clamp :: Float -> Word8

      clamp = floor . max 0 . min 255



      yf = tof y



      r = yf + 1.402 * tof cr - 179.456

      g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589

      b = yf + 1.772 * tof cb - 226.816



instance ColorSpaceConvertible PixelYCbCrK8 PixelCMYK8 where

  convertPixel (PixelYCbCrK8 y cb cr k) = PixelCMYK8 c m ye k

    where

      tof :: Word8 -> Float

      tof = fromIntegral



      clamp :: Float -> Word8

      clamp = floor . max 0 . min 255



      yf = tof y



      r = yf + 1.402 * tof cr - 179.456

      g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589

      b = yf + 1.772 * tof cb - 226.816



      c = clamp $ 255 - r

      m = clamp $ 255 - g

      ye = clamp $ 255 - b



{-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b)
                                 -> (Word8, Word8, Word8) -> b #-}

{-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b)
                                 -> (Word16, Word16, Word16) -> b #-}

integralRGBToCMYK :: (Bounded a, Integral a)

                  => (a -> a -> a -> a -> b)    -- ^ Pixel building function

                  -> (a, a, a)                  -- ^ RGB sample

                  -> b                          -- ^ Resulting sample

integralRGBToCMYK build (r, g, b) =

  build (clamp c) (clamp m) (clamp y) (fromIntegral kInt)

    where maxi = maxBound



          ir = fromIntegral $ maxi - r :: Int

          ig = fromIntegral $ maxi - g

          ib = fromIntegral $ maxi - b



          kInt = minimum [ir, ig, ib]

          ik = fromIntegral maxi - kInt



          c = (ir - kInt) `div` ik

          m = (ig - kInt) `div` ik

          y = (ib - kInt) `div` ik



          clamp = fromIntegral . max 0



instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where

  convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b)



instance ColorPlane PixelCMYK8 PlaneCyan where

    toComponentIndex _ _ = 0



instance ColorPlane PixelCMYK8 PlaneMagenta where

    toComponentIndex _ _ = 1



instance ColorPlane PixelCMYK8 PlaneYellow where

    toComponentIndex _ _ = 2



instance ColorPlane PixelCMYK8 PlaneBlack where

    toComponentIndex _ _ = 3



--------------------------------------------------

----            PixelCMYK16 instances

--------------------------------------------------

instance Pixel PixelCMYK16 where

    type PixelBaseComponent PixelCMYK16 = Word16



    {-# INLINE pixelOpacity #-}

    pixelOpacity = const maxBound



    {-# INLINE mixWith #-}

    mixWith f (PixelCMYK16 ca ma ya ka) (PixelCMYK16 cb mb yb kb) =

        PixelCMYK16 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb)



    {-# INLINE colorMap #-}

    colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k)



    {-# INLINE componentCount #-}

    componentCount _ = 4



    {-# INLINE pixelAt #-}

    pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0))

                                                               (arr ! (baseIdx + 1))

                                                               (arr ! (baseIdx + 2))

                                                               (arr ! (baseIdx + 3))

        where baseIdx = pixelBaseIndex image x y



    {-# INLINE readPixel #-}

    readPixel image@(MutableImage { mutableImageData = arr }) x y = do

        rv <- arr `M.read` baseIdx

        gv <- arr `M.read` (baseIdx + 1)

        bv <- arr `M.read` (baseIdx + 2)

        av <- arr `M.read` (baseIdx + 3)

        return $ PixelCMYK16 rv gv bv av

        where baseIdx = mutablePixelBaseIndex image x y



    {-# INLINE writePixel #-}

    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do

        let baseIdx = mutablePixelBaseIndex image x y

        (arr `M.write` (baseIdx + 0)) rv

        (arr `M.write` (baseIdx + 1)) gv

        (arr `M.write` (baseIdx + 2)) bv

        (arr `M.write` (baseIdx + 3)) av



    {-# INLINE unsafePixelAt #-}

    unsafePixelAt v idx =

        PixelCMYK16 (V.unsafeIndex v idx)

                   (V.unsafeIndex v $ idx + 1)

                   (V.unsafeIndex v $ idx + 2)

                   (V.unsafeIndex v $ idx + 3)



    {-# INLINE unsafeReadPixel #-}

    unsafeReadPixel vec idx =

        PixelCMYK16 `liftM` M.unsafeRead vec idx

                   `ap` M.unsafeRead vec (idx + 1)

                   `ap` M.unsafeRead vec (idx + 2)

                   `ap` M.unsafeRead vec (idx + 3)

    {-# INLINE unsafeWritePixel #-}

    unsafeWritePixel v idx (PixelCMYK16 r g b a) =

        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g

                              >> M.unsafeWrite v (idx + 2) b

                              >> M.unsafeWrite v (idx + 3) a



instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where

  convertPixel (PixelCMYK16 c m y k) =

      PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b)

    where

          clampWord16 = fromIntegral . (`unsafeShiftR` 16)

          ik :: Int

          ik = 65535 - fromIntegral k



          r = (65535 - fromIntegral c) * ik

          g = (65535 - fromIntegral m) * ik

          b = (65535 - fromIntegral y) * ik



instance ColorPlane PixelCMYK16 PlaneCyan where

    toComponentIndex _ _ = 0



instance ColorPlane PixelCMYK16 PlaneMagenta where

    toComponentIndex _ _ = 1



instance ColorPlane PixelCMYK16 PlaneYellow where

    toComponentIndex _ _ = 2



instance ColorPlane PixelCMYK16 PlaneBlack where

    toComponentIndex _ _ = 3



-- | Perform a gamma correction for an image with HDR pixels.

gammaCorrection :: PixelF          -- ^ Gamma value, should be between 0.5 and 3.0

                -> Image PixelRGBF -- ^ Image to treat.

                -> Image PixelRGBF

gammaCorrection gammaVal = pixelMap gammaCorrector

  where gammaExponent = 1.0 / gammaVal

        fixVal v = v ** gammaExponent

        gammaCorrector (PixelRGBF r g b) =

            PixelRGBF (fixVal r) (fixVal g) (fixVal b)



-- | Perform a tone mapping operation on an High dynamic range image.

toneMapping :: PixelF          -- ^ Exposure parameter

            -> Image PixelRGBF -- ^ Image to treat.

            -> Image PixelRGBF

toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData

 where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0);

       maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img

       scaledData = V.map (* coeff) $ imageData img



--------------------------------------------------

----            Packable pixel

--------------------------------------------------



-- | This typeclass exist for performance reason, it allow

-- to pack a pixel value to a simpler "primitive" data

-- type to allow faster writing to moemory.

class PackeablePixel a where

    -- | Primitive type asociated to the current pixel

    -- It's Word32 for PixelRGBA8 for instance

    type PackedRepresentation a



    -- | The packing function, allowing to transform

    -- to a primitive.

    packPixel :: a -> PackedRepresentation a



    -- | Inverse transformation, to speed up

    -- reading

    unpackPixel :: PackedRepresentation a -> a



instance PackeablePixel Pixel8 where

    type PackedRepresentation Pixel8 = Pixel8

    packPixel = id

    {-# INLINE packPixel #-}

    unpackPixel = id

    {-# INLINE unpackPixel #-}



instance PackeablePixel Pixel16 where

    type PackedRepresentation Pixel16 = Pixel16

    packPixel = id

    {-# INLINE packPixel #-}

    unpackPixel = id

    {-# INLINE unpackPixel #-}



instance PackeablePixel Pixel32 where

    type PackedRepresentation Pixel32 = Pixel32

    packPixel = id

    {-# INLINE packPixel #-}

    unpackPixel = id

    {-# INLINE unpackPixel #-}



instance PackeablePixel PixelF where

    type PackedRepresentation PixelF = PixelF

    packPixel = id

    {-# INLINE packPixel #-}

    unpackPixel = id

    {-# INLINE unpackPixel #-}





instance PackeablePixel PixelRGBA8 where

    type PackedRepresentation PixelRGBA8 = Word32

    {-# INLINE packPixel #-}

    packPixel (PixelRGBA8 r g b a) =

        (fi r `unsafeShiftL` (0 * bitCount)) .|.

        (fi g `unsafeShiftL` (1 * bitCount)) .|.

        (fi b `unsafeShiftL` (2 * bitCount)) .|.

        (fi a `unsafeShiftL` (3 * bitCount))

      where fi = fromIntegral

            bitCount = 8



    {-# INLINE unpackPixel #-}

    unpackPixel w =

        PixelRGBA8 (low w)

                   (low $ w `unsafeShiftR` bitCount)

                   (low $ w `unsafeShiftR` (2 * bitCount))

                   (low $ w `unsafeShiftR` (3 * bitCount))

      where

        low v = fromIntegral (v .&. 0xFF)

        bitCount = 8



instance PackeablePixel PixelRGBA16 where

    type PackedRepresentation PixelRGBA16 = Word64

    {-# INLINE packPixel #-}

    packPixel (PixelRGBA16 r g b a) =

        (fi r `unsafeShiftL` (0 * bitCount)) .|.

        (fi g `unsafeShiftL` (1 * bitCount)) .|.

        (fi b `unsafeShiftL` (2 * bitCount)) .|.

        (fi a `unsafeShiftL` (3 * bitCount))

      where fi = fromIntegral

            bitCount = 16



    {-# INLINE unpackPixel #-}

    unpackPixel w =

        PixelRGBA16 (low w)

                    (low $ w `unsafeShiftR` bitCount)

                    (low $ w `unsafeShiftR` (2 * bitCount))

                    (low $ w `unsafeShiftR` (3 * bitCount))

      where

        low v = fromIntegral (v .&. 0xFFFF)

        bitCount = 16



instance PackeablePixel PixelCMYK8 where

    type PackedRepresentation PixelCMYK8 = Word32

    {-# INLINE packPixel #-}

    packPixel (PixelCMYK8 c m y k) =

        (fi c `unsafeShiftL` (0 * bitCount)) .|.

        (fi m `unsafeShiftL` (1 * bitCount)) .|.

        (fi y `unsafeShiftL` (2 * bitCount)) .|.

        (fi k `unsafeShiftL` (3 * bitCount))

      where fi = fromIntegral

            bitCount = 8



    {-# INLINE unpackPixel #-}

    unpackPixel w =

        PixelCMYK8 (low w)

                   (low $ w `unsafeShiftR` bitCount)

                   (low $ w `unsafeShiftR` (2 * bitCount))

                   (low $ w `unsafeShiftR` (3 * bitCount))

      where

        low v = fromIntegral (v .&. 0xFF)

        bitCount = 8



instance PackeablePixel PixelCMYK16 where

    type PackedRepresentation PixelCMYK16 = Word64

    {-# INLINE packPixel #-}

    packPixel (PixelCMYK16 c m y k) =

        (fi c `unsafeShiftL` (0 * bitCount)) .|.

        (fi m `unsafeShiftL` (1 * bitCount)) .|.

        (fi y `unsafeShiftL` (2 * bitCount)) .|.

        (fi k `unsafeShiftL` (3 * bitCount))

      where fi = fromIntegral

            bitCount = 16



    {-# INLINE unpackPixel #-}

    unpackPixel w =

        PixelCMYK16 (low w)

                    (low $ w `unsafeShiftR` bitCount)

                    (low $ w `unsafeShiftR` (2 * bitCount))

                    (low $ w `unsafeShiftR` (3 * bitCount))

      where

        low v = fromIntegral (v .&. 0xFFFF)

        bitCount = 16



instance PackeablePixel PixelYA16 where

    type PackedRepresentation PixelYA16 = Word32

    {-# INLINE packPixel #-}

    packPixel (PixelYA16 y a) =

        (fi y `unsafeShiftL` (0 * bitCount)) .|.

        (fi a `unsafeShiftL` (1 * bitCount))

      where fi = fromIntegral

            bitCount = 16



    {-# INLINE unpackPixel #-}

    unpackPixel w = PixelYA16 (low w) (low $ w `unsafeShiftR` bitCount)

      where

        low v = fromIntegral (v .&. 0xFFFF)

        bitCount = 16



instance PackeablePixel PixelYA8 where

    type PackedRepresentation PixelYA8 = Word16

    {-# INLINE packPixel #-}

    packPixel (PixelYA8 y a) =

        (fi y `unsafeShiftL` (0 * bitCount)) .|.

        (fi a `unsafeShiftL` (1 * bitCount))