packages feed

hip (empty) → 1.0.0.0

raw patch · 56 files changed

+5843/−0 lines, 56 filesdep +JuicyPixelsdep +basedep +bytestringsetup-changedbinary-added

Dependencies added: JuicyPixels, base, bytestring, deepseq, filepath, netpbm, primitive, process, repa, temporary, vector, vector-th-unbox

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2016, Alexey Kuleshevich+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of hip nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main :: IO ()+main = defaultMain
+ hip.cabal view
@@ -0,0 +1,91 @@+Name:              hip+Version:           1.0.0.0+License:           BSD3+License-File:      LICENSE+Author:            Alexey Kuleshevich+Stability:         experimental+Maintainer:        lehins@yandex.ru+Category:          Image Processing, Graphics+Synopsis:          Haskell Image Processing (HIP) Library.+Description:+            .+            Haskell Image Processing (HIP) Library provides an easy to use interface with a whole variaty of image manipulation capabilities.+            .+            Processing can be done sequentially as well as in parallel, with an inherited fusion capabily, all through <https://hackage.haskell.org/package/repa repa> and <https://hackage.haskell.org/package/vector vector> packages. It is highly extendable, with an ability to add custom color spaces or use some other underlying data structure.+            .+            It is capable of reading and writing a number of popular image formats by using <https://hackage.haskell.org/package/JuicyPixels JuciyPixels> and <https://hackage.haskell.org/package/netpbm netpbm> packages. Being a pure Haskell library it does not require any external programs, but it can display images using a program of your choice.+Homepage:          https://github.com/lehins/hip+Bug-Reports:       https://github.com/lehins/hip/issues+Cabal-Version:     >= 1.10+Build-Type:        Simple+Extra-Doc-Files:   images/*.jpg+                 , images/*.png++Library+  Default-Language: Haskell2010+  HS-Source-Dirs: src+  Build-Depends: base            >= 4.5     && < 5+               , bytestring      >= 0.9.0.4+               , deepseq         >= 1.1+--               , easyplot        >= 1.0+               , filepath        >= 1.0+               , JuicyPixels     >= 3.2.7+               , netpbm          >= 1.0.1+               , primitive       >= 0.4+               , process         >= 1.1.0.0+               , repa            >= 3.2.1.1 && < 4+               , temporary       >= 1.1.1+               , vector          >= 0.9     && < 0.11+               , vector-th-unbox >= 0.2.1.0+	  +  Other-Extensions: BangPatterns+                  , ConstraintKinds+                  , GADTs+                  , FlexibleContexts+                  , FlexibleInstances+                  , FunctionalDependencies+                  , MultiParamTypeClasses+                  , MultiWayIf+                  , ScopedTypeVariables+                  , TemplateHaskell+                  , TypeFamilies+                  , UndecidableInstances+                  , ViewPatterns+                    +  Exposed-Modules: Graphics.Image+                 , Graphics.Image.ColorSpace+                 , Graphics.Image.IO+                 , Graphics.Image.IO.External+                 , Graphics.Image.Interface+                 , Graphics.Image.Interface.Repa+                 , Graphics.Image.Interface.Vector+                 , Graphics.Image.Processing+                 , Graphics.Image.Processing.Binary+                 , Graphics.Image.Processing.Complex+                   +  Other-Modules:   Graphics.Image.ColorSpace.Binary+                 , Graphics.Image.ColorSpace.CMYK+                 , Graphics.Image.ColorSpace.Complex+                 , Graphics.Image.ColorSpace.Gray+                 , Graphics.Image.ColorSpace.HSI+                 , Graphics.Image.ColorSpace.Luma+                 , Graphics.Image.ColorSpace.RGB+                 , Graphics.Image.ColorSpace.YCbCr+                 , Graphics.Image.IO.Base+                 , Graphics.Image.IO.External.JuicyPixels+                 , Graphics.Image.IO.External.Netpbm+                 , Graphics.Image.Interface.Repa.Internal+                 , Graphics.Image.Interface.Vector.Unboxed+                 , Graphics.Image.Processing.Convolution+                 , Graphics.Image.Processing.Complex.Fourier+                 , Graphics.Image.Processing.Geometric+                 , Graphics.Image.Processing.Interpolation+                  +  GHC-Options:+              -Wall+              -Odph+              -fcpr-off++Source-Repository head+  Type:     git+  Location: https://github.com/lehins/hip.git
+ images/centaurus.jpg view

binary file changed (absent → 97355 bytes)

+ images/cluster.jpg view

binary file changed (absent → 117160 bytes)

+ images/figure.png view

binary file changed (absent → 381 bytes)

+ images/figure_close.png view

binary file changed (absent → 384 bytes)

+ images/figure_dialate.png view

binary file changed (absent → 390 bytes)

+ images/figure_erode.png view

binary file changed (absent → 411 bytes)

+ images/figure_open.png view

binary file changed (absent → 404 bytes)

+ images/frog.jpg view

binary file changed (absent → 82430 bytes)

+ images/frog_blue.jpg view

binary file changed (absent → 43529 bytes)

+ images/frog_eye_grid.png view

binary file changed (absent → 5280 bytes)

+ images/frog_flipH.jpg view

binary file changed (absent → 128816 bytes)

+ images/frog_flipV.jpg view

binary file changed (absent → 128903 bytes)

+ images/frog_green.jpg view

binary file changed (absent → 42484 bytes)

+ images/frog_rbg.jpg view

binary file changed (absent → 128923 bytes)

+ images/frog_red.jpg view

binary file changed (absent → 43523 bytes)

+ images/frog_resize.jpg view

binary file changed (absent → 107627 bytes)

+ images/frog_rotate180.jpg view

binary file changed (absent → 128872 bytes)

+ images/frog_rotate270.jpg view

binary file changed (absent → 129279 bytes)

+ images/frog_rotate90.jpg view

binary file changed (absent → 129336 bytes)

+ images/grad_color.png view

binary file changed (absent → 156954 bytes)

+ images/grad_fromLists.png view

binary file changed (absent → 7779 bytes)

+ images/grad_fromVector.png view

binary file changed (absent → 1336 bytes)

+ images/grad_gray.png view

binary file changed (absent → 72931 bytes)

+ images/struct.png view

binary file changed (absent → 94 bytes)

+ images/yield.jpg view

binary file changed (absent → 52372 bytes)

+ images/yield_bin.png view

binary file changed (absent → 1029 bytes)

+ src/Graphics/Image.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE BangPatterns, FlexibleContexts #-}+-- |+-- Module      : Graphics.Image.Unboxed+-- Copyright   : (c) Alexey Kuleshevich 2016+-- License     : MIT+--+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+-- Haskell Image Processing (HIP) library is a wrapper around any array like+-- data structure and is fully agnostic to the underlying representation. All of+-- the functionality in this library relies on few type classes that those+-- representations implement:+--+-- * @__`Array` arr cs e__@ - this is a base class for every __@`Image`@ @arr@ @cs@ @e@__,+-- where @__arr__@ stands for an underlying array representation, @__cs__@ is the+-- `ColorSpace` of an image and @__e__@ is the type denoting precision of an+-- image.+--+-- * @__`ManifestArray` arr cs e__@ - is a kind of array that is represented by an+-- actual data in memory.+--+-- * @__`SequentialArray` arr cs e__@ - contains functionality that can only be+-- computed sequentially.+--+-- * @__`MutableArray` arr cs e__@ - allows mutation on __@`MImage`@ @st@ @arr@ @cs@ @e@__,+-- which is `Image`'s mutable cousin.+--+-- Array representation type and the above classes it is installed in determine+-- operations that can be done on the image with that representation.+--+-- Representations using <http://hackage.haskell.org/package/vector Vector> and+-- <http://hackage.haskell.org/package/repa Repa> packages:+--+-- * `VU` - Unboxed Vector representation. (Default)+-- * `RD` - Delayed Repa array representation.+-- * `RS` - Unboxed Repa array representation (computation is done sequentially).+-- * `RP` - Unboxed Repa array representation (computation is done in parallel).+--+-- Images with `RD` type hold functions rather then actual data, so this+-- representation should be used for fusing computation together, and later+-- changed to `RS` or `RP` using `exchange`, which in turn performs the fused+-- computation.+-- +module Graphics.Image (+  -- * Color Space+  -- $colorspace+  module Graphics.Image.ColorSpace,++  -- * Creation+  --+  -- If it is necessary to create an image in an other representation+  -- or with some specific 'Pixel' precision, you can use 'makeImage' from+  -- "Graphics.Image.Interface" module and manually specifying function's output+  -- type, ex:+  --+  -- @ makeImage (256, 256) (PixelY . fromIntegral . fst) :: Image RP Y Word8 @+  --+  makeImage, fromLists,+  -- * IO+  -- ** Reading+  -- | Read any supported image file into an 'Image' with 'VU' (Vector Unboxed)+  -- representation and pixels with 'Double' precision. In order to read an+  -- image with different representation, color space and precision 'readImage'+  -- or 'readImageExact' from <Graphics-Image-IO.html Graphics.Image.IO> can be+  -- used.+  readImageY, readImageYA, readImageRGB, readImageRGBA, readImageExact,+  -- ** Writing+  writeImage, writeImageExact, displayImage,+  -- * Accessors+  -- ** Dimensions+  rows, cols, dims,+  -- ** Indexing+  index, defaultIndex, maybeIndex,+  -- * Transformation+  -- ** Pointwise+  map, imap, zipWith, izipWith,+  -- ** Geometric+  traverse, traverse2,+  transpose, backpermute,+  (|*|), +  -- * Reduction+  fold, sum, product, maximum, minimum, normalize,+  -- * Representations+  exchange,+  VU(..), RD(..), RS(..), RP(..),+  ) where+import Prelude hiding (map, zipWith, sum, product, maximum, minimum)+import qualified Data.Foldable as F+import Graphics.Image.ColorSpace+import Graphics.Image.IO+import Graphics.Image.Interface+import Graphics.Image.Interface.Vector+import Graphics.Image.Interface.Repa (RD(..), RS(..), RP(..))++--import Graphics.Image.Processing+--import Graphics.Image.Processing.Complex+--import Graphics.Image.Processing.Binary++++--------------------------------------------------------------------------------+---- Creation and Transformation -----------------------------------------------+--------------------------------------------------------------------------------++++-- | Get the number of rows in an image.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> frog+-- <Image RepaDelayed RGB: 200x320>+-- >>> rows frog+-- 200+--+rows :: Array arr cs e => Image arr cs e -> Int+rows = fst . dims+{-# INLINE rows #-}+++-- | Get the number of columns in an image.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> frog+-- <Image RepaDelayed RGB: 200x320>+-- >>> cols frog+-- 320+--+cols :: Array arr cs e => Image arr cs e -> Int+cols = snd . dims+{-# INLINE cols #-}+++-- | Sum all pixels in the image.+sum :: ManifestArray arr cs e => Image arr cs e -> Pixel cs e+sum = fold (+) 0+{-# INLINE sum #-}+++-- | Multiply all pixels in the image.+product :: ManifestArray arr cs e => Image arr cs e -> Pixel cs e+product = fold (+) 1+{-# INLINE product #-}+++-- | Retrieve the biggest pixel from an image+maximum :: (ManifestArray arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e+maximum !img = fold max (index img (0, 0)) img+{-# INLINE maximum #-}+++-- | Retrieve the smallest pixel from an image+minimum :: (ManifestArray arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e+minimum !img = fold min (index img (0, 0)) img+{-# INLINE minimum #-}+++-- | Scales all of the pixels to be in the range @[0, 1]@.+normalize :: (ManifestArray arr cs e, ManifestArray arr Gray e, Fractional e, Ord e) =>+             Image arr cs e -> Image arr cs e+normalize !img = if l == s+                 then (if s < 0 then (*0) else if s > 1 then (*1) else id) img+                 else map normalizer img+  where+    !(PixelGray l, PixelGray s) = (maximum $ map (PixelGray . F.maximum) img,+                                   minimum $ map (PixelGray . F.minimum) img)+    normalizer !px = (px - pure s) / (pure (l - s))+    {-# INLINE normalizer #-}+{-# INLINE normalize #-}+++-- $colorspace+-- Here is a list of default Pixels with their respective constructors:+--+-- @+--     * __'Pixel' 'Y' e      = PixelY e__ - Luma, also commonly denoted as __Y'__.+--     * __'Pixel' 'YA' e     = PixelYA e__ - Luma with alpha.+--     * __'Pixel' 'RGB' e    = PixelRGB e__ - Red, Green and Blue.+--     * __'Pixel' 'RGBA' e   = PixelRGBA e__ - RGB with alpha+--     * __'Pixel' 'HSI' e    = PixelHSI e__ - Hue, Saturation and Intensity.+--     * __'Pixel' 'HSIA' e   = PixelHSIA e__ - HSI with alpha+--     * __'Pixel' 'CMYK' e   = PixelCMYK e__ - Cyan, Magenta, Yellow and Key (Black).+--     * __'Pixel' 'CMYKA' e  = PixelCMYKA e__ - CMYK with alpha.+--     * __'Pixel' 'YCbCr' e  = PixelYCbCr e__ - Luma, blue-difference and red-difference chromas.+--     * __'Pixel' 'YCbCrA' e = PixelYCbCrA e__ - YCbCr with alpha.+--       ------------------------------------------------------------------------------------------+--     * __'Pixel' 'Binary' 'Bit'     = 'on' | 'off'__ - Bi-tonal.+--     * __'Pixel' 'Gray' e         = PixelGray e__ - Used for separating channels from other color spaces.+--     * __'Pixel' cs ('Complex' e) = ('Pixel' cs e) '+:' ('Pixel' cs e)__ - Complex pixels with any color space.+-- @+--+-- Every 'Pixel' is an instance of 'Functor', 'Applicative', 'F.Foldable' and+-- 'Num', as well as 'Floating' and 'Fractional' if __e__ is also an instance.+--+-- All of the functionality related to every 'ColorSpace' is re-exported from here+-- for convenience.
+ src/Graphics/Image/ColorSpace.hs view
@@ -0,0 +1,411 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances,+             MultiParamTypeClasses, MultiWayIf, ViewPatterns #-}+module Graphics.Image.ColorSpace (+  -- * ColorSpace+  ColorSpace(..), Alpha(..),+  -- * Luma+  module Graphics.Image.ColorSpace.Luma,+  -- * RGB+  module Graphics.Image.ColorSpace.RGB,+  -- * HSI+  module Graphics.Image.ColorSpace.HSI,+  -- * CMYK+  module Graphics.Image.ColorSpace.CMYK,+  -- * YCbCr+  module Graphics.Image.ColorSpace.YCbCr,+  -- * Gray+  module Graphics.Image.ColorSpace.Gray,+  -- * Binary+  Binary, Bit, on, off, isOn, isOff, fromBool, complement,+  toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary,+  -- * Complex+  module Graphics.Image.ColorSpace.Complex,+  -- * Re-exports+  Applicative(..), (<$>), (<$), (<**>), liftA, liftA2, liftA3,+  Word8, Word16, Word32, Word64+  ) where++++import Control.Applicative+import Data.Word+import GHC.Float+import Graphics.Image.Interface hiding (map)+import Graphics.Image.ColorSpace.Binary+import Graphics.Image.ColorSpace.Gray+import Graphics.Image.ColorSpace.Luma+import Graphics.Image.ColorSpace.RGB+import Graphics.Image.ColorSpace.HSI+import Graphics.Image.ColorSpace.CMYK+import Graphics.Image.ColorSpace.YCbCr+import Graphics.Image.ColorSpace.Complex+import qualified Graphics.Image.Interface as I (map)+++++-- Binary:+++toPixelBinary :: (ColorSpace cs, Eq (Pixel cs e), Num e) => Pixel cs e -> Pixel Binary Bit+toPixelBinary px = if px == 0 then on else off+{-# INLINE toPixelBinary #-}+++fromPixelBinary :: Pixel Binary Bit -> Pixel Y Word8+fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound+{-# INLINE fromPixelBinary #-}+++toImageBinary :: (Array arr cs e, Array arr Binary Bit, Eq (Pixel cs e)) =>+              Image arr cs e+           -> Image arr Binary Bit+toImageBinary = I.map toPixelBinary+{-# INLINE toImageBinary #-}+++fromImageBinary :: (Array arr Binary Bit, Array arr Y Word8) =>+                Image arr Binary Bit+             -> Image arr Y Word8+fromImageBinary = I.map fromPixelBinary+{-# INLINE fromImageBinary #-}+++-- Conversion:+++instance ToY Gray where+  toPixelY (PixelGray y) = PixelY y+  {-# INLINE toPixelY #-}++-- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @+instance ToY RGB where+  toPixelY (PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b)+  {-# INLINE toPixelY #-}++instance ToYA RGBA where++instance ToY HSI where+  toPixelY = toPixelY . toPixelRGB+  {-# INLINE toPixelY #-}++instance ToYA HSIA where++instance ToY CMYK where+  toPixelY = toPixelY . toPixelRGB+  {-# INLINE toPixelY #-}++  +instance ToY YCbCr where+  toPixelY (PixelYCbCr y _ _) = PixelY y+  {-# INLINE toPixelY #-}+  +instance ToYA YCbCrA where+  +instance ToRGB Y where+  toPixelRGB (PixelY g) = fromChannel g+  {-# INLINE toPixelRGB #-}++instance ToRGBA YA where++instance ToRGB HSI where+  toPixelRGB (PixelHSI h s i) = +    let !is = i*s+        !second = i - is+        getFirst !a !b = i + is*cos a/cos b+        {-# INLINE getFirst #-}+        getThird !v1 !v2 = i + 2*is + v1 - v2+        {-# INLINE getThird #-}+    in if | h < 2*pi/3 -> let !r = getFirst h (pi/3 - h)+                              !b = second+                              !g = getThird b r+                          in PixelRGB r g b+          | h < 4*pi/3 -> let !g = getFirst (h - 2*pi/3) (h + pi)+                              !r = second+                              !b = getThird r g+                          in PixelRGB r g b+          | h < 2*pi   -> let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h)+                              !g = second+                              !r = getThird g b+                          in PixelRGB r g b+          | otherwise  -> error ("HSI pixel is not properly scaled, Hue: "++show h)+  {-# INLINE toPixelRGB #-}++instance ToRGBA HSIA where+++instance ToRGB YCbCr where++  toPixelRGB (PixelYCbCr y cb cr) = PixelRGB r g b where+    !r = y                      +   1.402*(cr - 0.5)+    !g = y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5)+    !b = y +   1.772*(cb - 0.5)+  {-# INLINE toPixelRGB #-}++instance ToRGBA YCbCrA where++instance ToRGB CMYK where++  toPixelRGB (PixelCMYK c m y k) = PixelRGB r g b where+    !r = (1-c)*(1-k)+    !g = (1-m)*(1-k)+    !b = (1-y)*(1-k)+  {-# INLINE toPixelRGB #-}+  +instance ToRGBA CMYKA where++  +instance ToHSI Y where+  toPixelHSI (PixelY g) = PixelHSI 0 0 g+  {-# INLINE toPixelHSI #-}++instance ToHSIA YA where+  +instance ToHSI RGB where+  toPixelHSI (PixelRGB r g b) = PixelHSI h s i where+    !h' = atan2 y x+    !h = if h' < 0 then h' + 2*pi else h'+    !s = if i == 0 then 0 else 1 - minimum [r, g, b] / i+    !i = (r + g + b) / 3+    !x = (2*r - g - b) / 2.449489742783178+    !y = (g - b) / 1.4142135623730951+  {-# INLINE toPixelHSI #-}+    +instance ToHSIA RGBA where+++instance ToYCbCr RGB where++  toPixelYCbCr (PixelRGB r g b) = PixelYCbCr y cb cr where+    !y  =          0.299*r +    0.587*g +    0.114*b+    !cb = 0.5 - 0.168736*r - 0.331264*g +      0.5*b+    !cr = 0.5 +      0.5*r - 0.418688*g - 0.081312*b+  {-# INLINE toPixelYCbCr #-}++instance ToYCbCrA RGBA where+  ++instance ToCMYK RGB where++  toPixelCMYK (PixelRGB r g b) = PixelCMYK c m y k where+    !c = (1 - r - k)/(1 - k)+    !m = (1 - g - k)/(1 - k)+    !y = (1 - b - k)/(1 - k)+    !k = 1 - max r (max g b)++instance ToCMYKA RGBA where++  +-- | Values are scaled to @[0, 255]@ range.+instance Elevator Word8 where++  toWord8 = id+  {-# INLINE toWord8 #-}++  toWord16 = liftA toWord16' where+    toWord16' !e = fromIntegral e * ((maxBound :: Word16) `div` fromIntegral (maxBound :: Word8)) +    {-# INLINE toWord16' #-}+  {-# INLINE toWord16 #-}++  toWord32 = liftA toWord32' where+    toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word8)) +    {-# INLINE toWord32' #-}+  {-# INLINE toWord32 #-}++  toWord64 = liftA toWord64' where+    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word8))+    {-# INLINE toWord64' #-}+  {-# INLINE toWord64 #-}++  toFloat = liftA toFloat' where+    toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word8))+    {-# INLINE toFloat' #-}+  {-# INLINE toFloat #-}++  toDouble = liftA toDouble' where+    toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word8))+    {-# INLINE toDouble' #-}+  {-# INLINE toDouble #-}++  fromDouble = toWord8+  {-# INLINE fromDouble #-}+++-- | Values are scaled to @[0, 65535]@ range.+instance Elevator Word16 where++  toWord8 = liftA toWord8' where+    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word16) `div`+                                                      fromIntegral (maxBound :: Word8)) +    {-# INLINE toWord8' #-}+  {-# INLINE toWord8 #-}++  toWord16 = id+  {-# INLINE toWord16 #-}+  +  toWord32 = liftA toWord32' where+    toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word16)) +    {-# INLINE toWord32' #-}+  {-# INLINE toWord32 #-}++  toWord64 = liftA toWord64' where+    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word16))+    {-# INLINE toWord64' #-}+  {-# INLINE toWord64 #-}++  toFloat = liftA toFloat' where+    toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word16))+    {-# INLINE toFloat' #-}+  {-# INLINE toFloat #-}++  toDouble = liftA toDouble' where+    toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word16))+    {-# INLINE toDouble' #-}+  {-# INLINE toDouble #-}++  fromDouble = toWord16+  {-# INLINE fromDouble #-}+++-- | Values are scaled to @[0, 4294967295]@ range.+instance Elevator Word32 where++  toWord8 = liftA toWord8' where+    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div`+                                                       fromIntegral (maxBound :: Word8)) +    {-# INLINE toWord8' #-}+  {-# INLINE toWord8 #-}++  toWord16 = liftA toWord16' where+    toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div`+                                                        fromIntegral (maxBound :: Word16)) +    {-# INLINE toWord16' #-}+  {-# INLINE toWord16 #-}++  toWord32 = id+  {-# INLINE toWord32 #-}++  toWord64 = liftA toWord64' where+    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word32))+    {-# INLINE toWord64' #-}+  {-# INLINE toWord64 #-}++  toFloat = liftA toFloat' where+    toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word32))+    {-# INLINE toFloat' #-}+  {-# INLINE toFloat #-}++  toDouble = liftA toDouble' where+    toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word32))+    {-# INLINE toDouble' #-}+  {-# INLINE toDouble #-}++  fromDouble = toWord32+  {-# INLINE fromDouble #-}+++-- | Values are scaled to @[0, 18446744073709551615]@ range.+instance Elevator Word64 where++  toWord8 = liftA toWord8' where+    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`+                                                       fromIntegral (maxBound :: Word8)) +    {-# INLINE toWord8' #-}+  {-# INLINE toWord8 #-}++  toWord16 = liftA toWord16' where+    toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`+                                                        fromIntegral (maxBound :: Word16)) +    {-# INLINE toWord16' #-}+  {-# INLINE toWord16 #-}++  toWord32 = liftA toWord32' where+    toWord32' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`+                                                        fromIntegral (maxBound :: Word32)) +    {-# INLINE toWord32' #-}+  {-# INLINE toWord32 #-}++  toWord64 = id+  {-# INLINE toWord64 #-}++  toFloat = liftA toFloat' where+    toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word64))+    {-# INLINE toFloat' #-}+  {-# INLINE toFloat #-}++  toDouble = liftA toDouble' where+    toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word64))+    {-# INLINE toDouble' #-}+  {-# INLINE toDouble #-}++  fromDouble = toWord64+  {-# INLINE fromDouble #-}+++-- | Values are scaled to @[0.0, 1.0]@ range.+instance Elevator Float where++  toWord8 = liftA toWord8' where+    toWord8' !e = round (fromIntegral (maxBound :: Word8) * e)+    {-# INLINE toWord8' #-}+  {-# INLINE toWord8 #-}++  toWord16 = liftA toWord16' where+    toWord16' !e = round (fromIntegral (maxBound :: Word16) * e)+    {-# INLINE toWord16' #-}+  {-# INLINE toWord16 #-}++  toWord32 = liftA toWord32' where+    toWord32' !e = round (fromIntegral (maxBound :: Word32) * e)+    {-# INLINE toWord32' #-}+  {-# INLINE toWord32 #-}++  toWord64 = liftA toWord64' where+    toWord64' !e = round (fromIntegral (maxBound :: Word64) * e)+    {-# INLINE toWord64' #-}+  {-# INLINE toWord64 #-}++  toFloat = id+  {-# INLINE toFloat #-}++  toDouble = liftA float2Double+  {-# INLINE toDouble #-}++  fromDouble = toFloat+  {-# INLINE fromDouble #-}+++-- | Values are scaled to @[0.0, 1.0]@ range.+instance Elevator Double where++  toWord8 = liftA toWord8' where+    toWord8' !e = round (fromIntegral (maxBound :: Word8) * e)+    {-# INLINE toWord8' #-}+  {-# INLINE toWord8 #-}++  toWord16 = liftA toWord16' where+    toWord16' !e = round (fromIntegral (maxBound :: Word16) * e)+    {-# INLINE toWord16' #-}+  {-# INLINE toWord16 #-}++  toWord32 = liftA toWord32' where+    toWord32' !e = round (fromIntegral (maxBound :: Word32) * e)+    {-# INLINE toWord32' #-}+  {-# INLINE toWord32 #-}++  toWord64 = liftA toWord64' where+    toWord64' !e = round (fromIntegral (maxBound :: Word64) * e)+    {-# INLINE toWord64' #-}+  {-# INLINE toWord64 #-}++  toFloat = liftA double2Float+  {-# INLINE toFloat #-}++  toDouble = id+  {-# INLINE toDouble #-}++  fromDouble = id+  {-# INLINE fromDouble #-}++
+ src/Graphics/Image/ColorSpace/Binary.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             TypeFamilies #-}+module Graphics.Image.ColorSpace.Binary (+  Binary(..), Bit(..), on, off, isOn, isOff, fromBool, complement+  ) where++import Prelude hiding (map)+import Data.Word (Word8)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend, mempty)++-- | This is a Binary colorspace, pixel's of which can be created using+-- these __/constructors/__:+--+--   [@'on'@] Represents value @1@ or 'True'. It's a foreground pixel and is+--   displayed in black.+--+--   [@'off'@] Represents value @0@ or 'False'. It's a background pixel and is+--   displayed in white.+--+-- Note, that values are inverted before writing to or reading from file, since+-- grayscale images represent black as a @0@ value and white as @1@ on a+-- @[0,1]@ scale.+--+-- Binary pixels also behave as binary numbers with a size of 1-bit, for instance:+--+-- >>> on + on -- equivalent to: 1 .|. 1+-- <Binary:(1)>+-- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0+-- <Binary:(0)>+-- >>> (on + on) - on+-- <Binary:(0)>+--+data Binary = Binary deriving (Eq, Enum, Show, Typeable)+++-- | Under the hood, Binary pixels are represented as 'Word8' that can only take+-- values of @0@ or @1@.+newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable)+++-- | Represents value 'True' or @1@ in binary. Often also called a foreground+-- pixel of an object.+on :: Pixel Binary Bit+on = PixelBinary (Bit 1)+{-# INLINE on #-}+++-- | Represents value 'False' or @0@ in binary. Often also called a background+-- pixel.+off :: Pixel Binary Bit+off = PixelBinary (Bit 0)+{-# INLINE off #-}+++-- | Convert a 'Bool' to a 'PixelBin' pixel.+--+-- >>> isOn (fromBool True)+-- True+--+fromBool :: Bool -> Pixel Binary Bit+fromBool False = off+fromBool True  = on+{-# INLINE fromBool #-}+++-- | Test if Pixel's value is 'on'.+isOn :: Pixel Binary Bit -> Bool+isOn (PixelBinary (Bit 0)) = False+isOn _                     = True+{-# INLINE isOn #-}+++-- | Test if Pixel's value is 'off'.+isOff :: Pixel Binary Bit -> Bool+isOff = not . isOn+{-# INLINE isOff #-}+++-- | Invert value of a pixel. Equivalent of 'not' for Bool's.+complement :: Pixel Binary Bit -> Pixel Binary Bit+complement = fromBool . isOff+{-# INLINE complement #-}++++instance ColorSpace Binary where+  type PixelElt Binary e = e+  data Pixel Binary e = PixelBinary !e deriving Eq++  fromChannel = PixelBinary+  {-# INLINE fromChannel #-}++  fromElt = PixelBinary+  {-# INLINE fromElt #-}++  toElt (PixelBinary b) = b+  {-# INLINE toElt #-}++  getPxCh (PixelBinary b) _ = b+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelBinary b) = PixelBinary (f Binary b)+  {-# INLINE chOp #-}++  pxOp !f (PixelBinary b) = PixelBinary (f b)+  {-# INLINE pxOp #-}++  chApp (PixelBinary f) (PixelBinary b) = PixelBinary (f b)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelBinary b) = f b `mappend` mempty+  {-# INLINE pxFoldMap #-}+++instance Show (Pixel Binary Bit) where+  show (PixelBinary (Bit 0)) = "<Binary:(0)>"+  show _                     = "<Binary:(1)>"+++instance Num Bit where+  (Bit 0) + (Bit 0) = Bit 0+  _       + _       = Bit 1+  {-# INLINE (+) #-}+  +  _ - (Bit 1) = Bit 0+  _ - _       = Bit 1+  {-# INLINE (-) #-}+  +  _       * (Bit 0) = Bit 0+  (Bit 0) * _       = Bit 0+  _       * _       = Bit 1+  {-# INLINE (*) #-}+  +  abs         = id+  {-# INLINE abs #-}+  +  signum      = id+  {-# INLINE signum #-}+  +  fromInteger 0 = Bit 0+  fromInteger _ = Bit 1+  {-# INLINE fromInteger #-}
+ src/Graphics/Image/ColorSpace/CMYK.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             TypeFamilies #-}+module Graphics.Image.ColorSpace.CMYK (+  CMYK(..), CMYKA(..), Pixel(..), +  ToCMYK(..), ToCMYKA(..)+  ) where++import Prelude hiding (map)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend)++data CMYK = CyanCMYK -- ^ Cyan+          | MagCMYK  -- ^ Mahenta+          | YelCMYK  -- ^ Yellow+          | KeyCMYK  -- ^ Key (Black)+          deriving (Eq, Enum, Typeable)++data CMYKA = CyanCMYKA  -- ^ Cyan+           | MagCMYKA   -- ^ Mahenta+           | YelCMYKA   -- ^ Yellow+           | KeyCMYKA   -- ^ Key (Black)+           | AlphaCMYKA -- ^ Alpha +           deriving (Eq, Enum, Typeable)+++class ColorSpace cs => ToCMYK cs where++  toPixelCMYK :: Pixel cs Double -> Pixel CMYK Double++  toImageCMYK :: (Array arr cs Double, Array arr CMYK Double) =>+                 Image arr cs Double+              -> Image arr CMYK Double+  toImageCMYK = map toPixelCMYK+  {-# INLINE toImageCMYK #-}+++class (ToCMYK (Opaque cs), Alpha cs) => ToCMYKA cs where++  toPixelCMYKA :: Pixel cs Double -> Pixel CMYKA Double+  toPixelCMYKA px = addAlpha (getAlpha px) (toPixelCMYK (dropAlpha px))++  toImageCMYKA :: (Array arr cs Double, Array arr CMYKA Double) =>+                  Image arr cs Double+               -> Image arr CMYKA Double+  toImageCMYKA = map toPixelCMYKA+  {-# INLINE toImageCMYKA #-}++  +instance ColorSpace CMYK where+  type PixelElt CMYK e = (e, e, e, e)+  data Pixel CMYK e = PixelCMYK !e !e !e !e deriving Eq++  fromChannel !e = PixelCMYK e e e e+  {-# INLINE fromChannel #-}++  fromElt !(c, m, y, k) = PixelCMYK c m y k+  {-# INLINE fromElt #-}++  toElt (PixelCMYK c m y k) = (c, m, y, k)+  {-# INLINE toElt #-}++  getPxCh (PixelCMYK c _ _ _) CyanCMYK = c+  getPxCh (PixelCMYK _ m _ _) MagCMYK  = m+  getPxCh (PixelCMYK _ _ y _) YelCMYK  = y+  getPxCh (PixelCMYK _ _ _ k) KeyCMYK  = k+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelCMYK c m y k) =+    PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k)+  {-# INLINE chOp #-}++  pxOp !f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k)+  {-# INLINE pxOp #-}++  chApp (PixelCMYK fc fm fy fk) (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelCMYK c m y k) = f c `mappend` f m `mappend` f y `mappend` f k+  {-# INLINE pxFoldMap #-}++++instance ColorSpace CMYKA where+  type PixelElt CMYKA e = (e, e, e, e, e)+  data Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq++  fromChannel !e = PixelCMYKA e e e e e+  {-# INLINE fromChannel #-}++  fromElt (c, m, y, k, a) = PixelCMYKA c m y k a+  {-# INLINE fromElt #-}++  toElt (PixelCMYKA c m y k a) = (c, m, y, k, a)+  {-# INLINE toElt #-}++  getPxCh (PixelCMYKA c _ _ _ _) CyanCMYKA  = c+  getPxCh (PixelCMYKA _ m _ _ _) MagCMYKA   = m+  getPxCh (PixelCMYKA _ _ y _ _) YelCMYKA   = y+  getPxCh (PixelCMYKA _ _ _ k _) KeyCMYKA   = k+  getPxCh (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelCMYKA c m y k a) =+    PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a)+  {-# INLINE chOp #-}++  pxOp !f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a)+  {-# INLINE pxOp #-}++  chApp (PixelCMYKA fc fm fy fk fa) (PixelCMYKA c m y k a) =+    PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelCMYKA c m y k a) = f c `mappend` f m `mappend` f y `mappend` f k `mappend` f a+  {-# INLINE pxFoldMap #-}+++instance Alpha CMYKA where+  type Opaque CMYKA = CMYK++  getAlpha (PixelCMYKA _ _ _ _ a) = a+  {-# INLINE getAlpha #-}+  +  addAlpha !a (PixelCMYK c m y k) = PixelCMYKA c m y k a+  {-# INLINE addAlpha #-}++  dropAlpha (PixelCMYKA c m y k _) = PixelCMYK c m y k+  {-# INLINE dropAlpha #-}+++instance Show CMYK where+  show CyanCMYK = "Cyan"+  show MagCMYK  = "Magenta"+  show YelCMYK  = "Yellow"+  show KeyCMYK  = "Black"++instance Show CMYKA where+  show CyanCMYKA  = "Cyan"+  show MagCMYKA   = "Magenta"+  show YelCMYKA   = "Yellow"+  show KeyCMYKA   = "Black"+  show AlphaCMYKA = "Alpha"+  +instance Show e => Show (Pixel CMYK e) where+  show (PixelCMYK c m y k) = "<CMYK:("++show c++"|"++show m++"|"++show y++"|"++show k++")>"+++instance Show e => Show (Pixel CMYKA e) where+  show (PixelCMYKA c m y k a) =+    "<CMYKA:("++show c++"|"++show m++"|"++show y++"|"++show k++"|"++show a++")>"+++
+ src/Graphics/Image/ColorSpace/Complex.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE BangPatterns #-}+module Graphics.Image.ColorSpace.Complex (+  -- ** Rectangular form+  Complex(..), (+:), realPart, imagPart,+  -- ** Polar form+  mkPolar, cis, polar, magnitude, phase,+  -- ** Conjugate+  conjugate+  ) where++import Graphics.Image.Interface (ColorSpace(..))+import Control.Applicative+import Data.Complex (Complex(..))+import qualified Data.Complex as C hiding (Complex(..))++++infix 6 +:++-- | Constrcut a complex pixel from two pixels containing real and imaginary parts.+--+-- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @+--+(+:) :: ColorSpace cs => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)+(+:) = liftA2 (:+)+{-# INLINE (+:) #-}++-- | Extracts the real part of a complex pixel.+realPart :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+realPart = liftA C.realPart+{-# INLINE realPart #-}++-- | Extracts the imaginary part of a complex pixel.+imagPart :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+imagPart = liftA C.imagPart+{-# INLINE imagPart #-}++-- | Form a complex pixel from polar components of magnitude and phase.+mkPolar :: (ColorSpace cs, RealFloat e) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)+mkPolar = liftA2 C.mkPolar+{-# INLINE mkPolar #-}++-- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@).+cis :: (ColorSpace cs, RealFloat e) => Pixel cs e -> Pixel cs (Complex e)+cis = liftA C.cis+{-# INLINE cis #-}++-- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase)+-- pair of pixels in canonical form: the magnitude is nonnegative, and the phase+-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.+polar :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e)+polar !zPx = (magnitude zPx, phase zPx)+{-# INLINE polar #-}++-- | The nonnegative magnitude of a complex pixel.+magnitude :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+magnitude = liftA C.magnitude+{-# INLINE magnitude #-}++-- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the+-- magnitude is zero, then so is the phase.+phase :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+phase = liftA C.phase+{-# INLINE phase #-}++-- | The conjugate of a complex pixel.+conjugate :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e)+conjugate = liftA C.conjugate+{-# INLINE conjugate #-}++
+ src/Graphics/Image/ColorSpace/Gray.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             ScopedTypeVariables, TypeFamilies #-}+module Graphics.Image.ColorSpace.Gray (+  Gray(..), Pixel(..), toGrayImages, fromGrayImages+  ) where++import Prelude hiding (map, zipWith)+import qualified Prelude as P (map)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend, mempty)++-- ^ This is a signgle channel colorspace, that is designed to hold any channel+-- from any other colorspace, hence it is not convertible to and from, but+-- rather is here to allow separation of channels from other multichannel+-- colorspaces. If you are looking for a true grayscale colorspace+-- 'Graphics.Image.ColorSpace.Luma.Y' should be used instead.+data Gray = Gray deriving (Eq, Enum, Show, Typeable)+++-- | Separate an image into a list of images with 'Gray' pixels containing every+-- channel from the source image.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> let [frog_red, frog_green, frog_blue] = toGrayImages frog+-- >>> writeImage "images/frog_red.png" $ toImageY frog_red+-- >>> writeImage "images/frog_green.jpg" $ toImageY frog_green+-- >>> writeImage "images/frog_blue.jpg" $ toImageY frog_blue+--+-- <<images/frog_red.jpg>> <<images/frog_green.jpg>> <<images/frog_blue.jpg>>+--+toGrayImages :: (Array arr cs e, Array arr Gray e) => Image arr cs e -> [Image arr Gray e]+toGrayImages !img = P.map getCh (enumFrom (toEnum 0)) where+  getCh !ch = map (PixelGray . (`getPxCh` ch)) img+  {-# INLINE getCh #-}+{-# INLINE toGrayImages #-}+++-- | Combine a list of images with 'Gray' pixels into an image of any color+-- space, by supplying an order of color space channels.+--+-- For example here is a frog with swapped 'BlueRGB' and 'GreenRGB' channels.+--+-- >>> writeImage "images/frog_rbg.jpg" $ fromGrayImages [frog_red, frog_green, frog_blue] [RedRGB, BlueRGB, GreenRGB]+--+-- <<images/frog.jpg>> <<images/frog_rbg.jpg>>+--+-- It is worth noting though, that separating image channels can be sometimes+-- pretty useful, the same effect as above can be achieved in a much simpler and+-- more efficient way:+--+-- @ map (\(PixelRGB r g b) -> PixelRGB r b g) frog @+--+fromGrayImages :: forall arr cs e . (Array arr Gray e, Array arr cs e) =>+                  [Image arr Gray e] -> [cs] -> Image arr cs e+fromGrayImages imgs chs =+  fromGrays (singleton (fromChannel 0)) imgs chs where+    updateCh ch px (PixelGray e) = chOp (\ !ch' !e' -> if ch' == ch then e else e') px+    {-# INLINE updateCh #-}+    fromGrays img []     _      = img+    fromGrays img _      []     = img+    fromGrays img (i:is) (c:cs) = fromGrays (zipWith (updateCh c) img i) is cs+    {-# INLINE fromGrays #-}+{-# INLINE fromGrayImages #-}+++instance ColorSpace Gray where+  type PixelElt Gray e = e+  data Pixel Gray e = PixelGray !e deriving (Ord, Eq)++  fromChannel = PixelGray+  {-# INLINE fromChannel #-}++  fromElt = PixelGray+  {-# INLINE fromElt #-}++  toElt (PixelGray g) = g+  {-# INLINE toElt #-}++  getPxCh (PixelGray g) _ = g+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelGray g) = PixelGray (f Gray g)+  {-# INLINE chOp #-}+  +  pxOp !f (PixelGray g) = PixelGray (f g)+  {-# INLINE pxOp #-}++  chApp (PixelGray f) (PixelGray g) = PixelGray (f g)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelGray g) = f g `mappend` mempty+  {-# INLINE pxFoldMap #-}++  +instance Show e => Show (Pixel Gray e) where+  show (PixelGray g) = "<Gray:("++show g++")>"++
+ src/Graphics/Image/ColorSpace/HSI.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             TypeFamilies #-}+module Graphics.Image.ColorSpace.HSI (+  HSI(..), HSIA(..), Pixel(..), +  ToHSI(..), ToHSIA(..)+  ) where++import Prelude hiding (map)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend)++data HSI = HueHSI+         | SatHSI+         | IntHSI deriving (Eq, Enum, Typeable)++data HSIA = HueHSIA+          | SatHSIA+          | IntHSIA+          | AlphaHSIA deriving (Eq, Enum, Typeable)+++class ColorSpace cs => ToHSI cs where++  toPixelHSI :: Pixel cs Double -> Pixel HSI Double++  toImageHSI :: (Array arr cs Double, Array arr HSI Double) =>+                Image arr cs Double+             -> Image arr HSI Double+  toImageHSI = map toPixelHSI+  {-# INLINE toImageHSI #-}+++class (ToHSI (Opaque cs), Alpha cs) => ToHSIA cs where++  toPixelHSIA :: Pixel cs Double -> Pixel HSIA Double+  toPixelHSIA px = addAlpha (getAlpha px) (toPixelHSI (dropAlpha px))++  toImageHSIA :: (Array arr cs Double, Array arr HSIA Double) =>+                 Image arr cs Double+              -> Image arr HSIA Double+  toImageHSIA = map toPixelHSIA+  {-# INLINE toImageHSIA #-}++  +instance ColorSpace HSI where+  type PixelElt HSI e = (e, e, e)+  data Pixel HSI e = PixelHSI !e !e !e deriving Eq++  fromChannel !e = PixelHSI e e e+  {-# INLINE fromChannel #-}++  fromElt !(h, s, i) = PixelHSI h s i+  {-# INLINE fromElt #-}++  toElt (PixelHSI h s i) = (h, s, i)+  {-# INLINE toElt #-}++  getPxCh (PixelHSI h _ _) HueHSI   = h+  getPxCh (PixelHSI _ s _) SatHSI = s+  getPxCh (PixelHSI _ _ i) IntHSI  = i+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i)+  {-# INLINE chOp #-}++  pxOp !f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i)+  {-# INLINE pxOp #-}++  chApp (PixelHSI fh fs fi) (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelHSI h s i) = f h `mappend` f s `mappend` f i +  {-# INLINE pxFoldMap #-}++++instance ColorSpace HSIA where+  type PixelElt HSIA e = (e, e, e, e)+  data Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq++  fromChannel !e = PixelHSIA e e e e+  {-# INLINE fromChannel #-}++  fromElt (h, s, i, a) = PixelHSIA h s i a+  {-# INLINE fromElt #-}++  toElt (PixelHSIA h s i a) = (h, s, i, a)+  {-# INLINE toElt #-}++  getPxCh (PixelHSIA r _ _ _) HueHSIA   = r+  getPxCh (PixelHSIA _ g _ _) SatHSIA = g+  getPxCh (PixelHSIA _ _ b _) IntHSIA  = b+  getPxCh (PixelHSIA _ _ _ a) AlphaHSIA = a+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelHSIA h s i a) =+    PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a)+  {-# INLINE chOp #-}++  pxOp !f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a)+  {-# INLINE pxOp #-}++  chApp (PixelHSIA fh fs fi fa) (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelHSIA h s i a) = f h `mappend` f s `mappend` f i `mappend` f a+  {-# INLINE pxFoldMap #-}+++instance Alpha HSIA where+  type Opaque HSIA = HSI++  getAlpha (PixelHSIA _ _ _ a) = a+  {-# INLINE getAlpha #-}+  +  addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a+  {-# INLINE addAlpha #-}++  dropAlpha (PixelHSIA h s i _) = PixelHSI h s i+  {-# INLINE dropAlpha #-}+++instance Show HSI where+  show HueHSI = "Hue"+  show SatHSI = "Saturation"+  show IntHSI = "Intensity"++instance Show HSIA where+  show HueHSIA   = "Hue"+  show SatHSIA   = "Saturation"+  show IntHSIA   = "Intensity"+  show AlphaHSIA = "Alpha"+ +instance Show e => Show (Pixel HSI e) where+  show (PixelHSI h s i) = "<HSI:("++show h++"|"++show s++"|"++show i++")>"+++instance Show e => Show (Pixel HSIA e) where+  show (PixelHSIA h s i a) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show a++")>"+++
+ src/Graphics/Image/ColorSpace/Luma.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             TypeFamilies #-}+module Graphics.Image.ColorSpace.Luma (+  Y(..), YA(..), Pixel(..), +  ToY(..), ToYA(..)+  ) where++import Prelude hiding (map)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend, mempty)++-- | Luma or brightness, that is usually denoted as @Y'@.+data Y = Y deriving (Eq, Enum, Typeable)++-- | Luma with Alpha channel.+data YA = YA+        | AlphaYA deriving (Eq, Enum, Typeable)+++class ColorSpace cs => ToY cs where++  toPixelY :: Pixel cs Double -> Pixel Y Double++  toImageY :: (Array arr cs Double, Array arr Y Double) =>+              Image arr cs Double+           -> Image arr Y Double+  toImageY = map toPixelY+  {-# INLINE toImageY #-}+  ++class (ToY (Opaque cs), Alpha cs) => ToYA cs where++  toPixelYA :: Pixel cs Double -> Pixel YA Double+  toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px))++  toImageYA :: (Array arr cs Double, Array arr YA Double) =>+               Image arr cs Double+            -> Image arr YA Double+  toImageYA = map toPixelYA+  {-# INLINE toImageYA #-}+++instance ColorSpace Y where+  type PixelElt Y e = e+  data Pixel Y e = PixelY !e deriving (Ord, Eq)++  fromChannel = PixelY+  {-# INLINE fromChannel #-}++  fromElt = PixelY+  {-# INLINE fromElt #-}++  toElt (PixelY y) = y+  {-# INLINE toElt #-}++  getPxCh (PixelY y) _ = y+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelY y) = PixelY (f Y y)+  {-# INLINE chOp #-}+ +  pxOp !f (PixelY y) = PixelY (f y)+  {-# INLINE pxOp #-}++  chApp (PixelY fy) (PixelY y) = PixelY (fy y)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelY y) = f y `mappend` mempty+  {-# INLINE pxFoldMap #-}+++instance ColorSpace YA where+  type PixelElt YA e = (e, e)+  data Pixel YA e = PixelYA !e !e deriving Eq++  fromChannel !e = PixelYA e e +  {-# INLINE fromChannel #-}++  fromElt !(g, a) = PixelYA g a+  {-# INLINE fromElt #-}++  toElt (PixelYA g a) = (g, a)+  {-# INLINE toElt  #-}++  getPxCh (PixelYA g _) YA      = g+  getPxCh (PixelYA _ a) AlphaYA = a+  {-# INLINE getPxCh  #-}+  +  chOp !f (PixelYA g a) = PixelYA (f YA g) (f AlphaYA a)+  {-# INLINE chOp #-}+  +  pxOp !f (PixelYA g a) = PixelYA (f g) (f a)+  {-# INLINE pxOp #-}++  chApp (PixelYA fy fa) (PixelYA y a) = PixelYA (fy y) (fa a)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelYA y a) = f y `mappend` f a+  {-# INLINE pxFoldMap #-}+  +instance Alpha YA where+  type Opaque YA = Y++  getAlpha (PixelYA _ a) = a+  {-# INLINE getAlpha  #-}+  +  addAlpha !a (PixelY g) = PixelYA g a+  {-# INLINE addAlpha #-}++  dropAlpha (PixelYA g _) = PixelY g+  {-# INLINE dropAlpha #-}+++instance Show Y where+  show Y = "Luma"+  ++instance Show YA where+  show YA  = "Luma"+  show AlphaYA = "Alpha"+  ++instance Show e => Show (Pixel Y e) where+  show (PixelY g) = "<Luma:("++show g++")>"+++instance Show e => Show (Pixel YA e) where+  show (PixelYA g a) = "<LumaA:("++show g++"|"++show a++")>"++
+ src/Graphics/Image/ColorSpace/RGB.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             TypeFamilies #-}+module Graphics.Image.ColorSpace.RGB (+  RGB(..), RGBA(..), Pixel(..), +  ToRGB(..), ToRGBA(..)+  ) where++import Prelude hiding (map)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend)+++data RGB = RedRGB+         | GreenRGB+         | BlueRGB deriving (Eq, Enum, Typeable)++data RGBA = RedRGBA+          | GreenRGBA+          | BlueRGBA+          | AlphaRGBA deriving (Eq, Enum, Typeable)+++class ColorSpace cs => ToRGB cs where++  toPixelRGB :: Pixel cs Double -> Pixel RGB Double++  toImageRGB :: (Array arr cs Double, Array arr RGB Double) =>+                Image arr cs Double+             -> Image arr RGB Double+  toImageRGB = map toPixelRGB+  {-# INLINE toImageRGB #-}+++class (ToRGB (Opaque cs), Alpha cs) => ToRGBA cs where++  toPixelRGBA :: Pixel cs Double -> Pixel RGBA Double+  toPixelRGBA px = addAlpha (getAlpha px) (toPixelRGB (dropAlpha px))++  toImageRGBA :: (Array arr cs Double, Array arr RGBA Double) =>+                Image arr cs Double+             -> Image arr RGBA Double+  toImageRGBA = map toPixelRGBA+  {-# INLINE toImageRGBA #-}++  +instance ColorSpace RGB where+  type PixelElt RGB e = (e, e, e)+  data Pixel RGB e = PixelRGB !e !e !e deriving Eq++  fromChannel !e = PixelRGB e e e+  {-# INLINE fromChannel #-}++  fromElt !(r, g, b) = PixelRGB r g b+  {-# INLINE fromElt #-}++  toElt (PixelRGB r g b) = (r, g, b)+  {-# INLINE toElt #-}++  getPxCh (PixelRGB r _ _) RedRGB   = r+  getPxCh (PixelRGB _ g _) GreenRGB = g+  getPxCh (PixelRGB _ _ b) BlueRGB  = b+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b)+  {-# INLINE chOp #-}++  pxOp !f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b)+  {-# INLINE pxOp #-}++  chApp (PixelRGB fr fg fb) (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelRGB r g b) = f r `mappend` f g `mappend` f b+  {-# INLINE pxFoldMap #-}+++instance ColorSpace RGBA where+  type PixelElt RGBA e = (e, e, e, e)+  data Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq++  fromChannel !e = PixelRGBA e e e e+  {-# INLINE fromChannel #-}++  fromElt (r, g, b, a) = PixelRGBA r g b a+  {-# INLINE fromElt #-}++  toElt (PixelRGBA r g b a) = (r, g, b, a)+  {-# INLINE toElt #-}++  getPxCh (PixelRGBA r _ _ _) RedRGBA   = r+  getPxCh (PixelRGBA _ g _ _) GreenRGBA = g+  getPxCh (PixelRGBA _ _ b _) BlueRGBA  = b+  getPxCh (PixelRGBA _ _ _ a) AlphaRGBA = a+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelRGBA r g b a) =+    PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a)+  {-# INLINE chOp #-}++  pxOp !f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a)+  {-# INLINE pxOp #-}++  chApp (PixelRGBA fr fg fb fa) (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelRGBA r g b a) = f r `mappend` f g `mappend` f b `mappend` f a+  {-# INLINE pxFoldMap #-}+++instance Alpha RGBA where+  type Opaque RGBA = RGB++  getAlpha (PixelRGBA _ _ _ a) = a+  {-# INLINE getAlpha #-}+  +  addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a+  {-# INLINE addAlpha #-}++  dropAlpha (PixelRGBA r g b _) = PixelRGB r g b+  {-# INLINE dropAlpha #-}+++instance Show RGB where+  show RedRGB   = "Red"+  show GreenRGB = "Green"+  show BlueRGB  = "Blue"+++instance Show RGBA where+  show RedRGBA   = "Red"+  show GreenRGBA = "Green"+  show BlueRGBA  = "Blue"+  show AlphaRGBA = "Alpha"++ +instance Show e => Show (Pixel RGB e) where+  show (PixelRGB r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"+++instance Show e => Show (Pixel RGBA e) where+  show (PixelRGBA r g b a) = "<RGBA:("++show r++"|"++show g++"|"++show b++"|"++show a++")>"+++
+ src/Graphics/Image/ColorSpace/YCbCr.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+             TypeFamilies #-}+module Graphics.Image.ColorSpace.YCbCr (+  YCbCr(..), YCbCrA(..), Pixel(..), +  ToYCbCr(..), ToYCbCrA(..)+  ) where++import Prelude hiding (map)+import Graphics.Image.Interface+import Data.Typeable (Typeable)+import Data.Monoid (mappend)++data YCbCr = LumaYCbCr+           | CBlueYCbCr+           | CRedYCbCr deriving (Eq, Enum, Typeable)+++data YCbCrA = LumaYCbCrA+            | CBlueYCbCrA+            | CRedYCbCrA+            | AlphaYCbCrA deriving (Eq, Enum, Typeable)+++class ColorSpace cs => ToYCbCr cs where++  toPixelYCbCr :: Pixel cs Double -> Pixel YCbCr Double++  toImageYCbCr :: (Array arr cs Double, Array arr YCbCr Double) =>+                  Image arr cs Double+               -> Image arr YCbCr Double+  toImageYCbCr = map toPixelYCbCr+  {-# INLINE toImageYCbCr #-}+++class (ToYCbCr (Opaque cs), Alpha cs) => ToYCbCrA cs where++  toPixelYCbCrA :: Pixel cs Double -> Pixel YCbCrA Double+  toPixelYCbCrA px = addAlpha (getAlpha px) (toPixelYCbCr (dropAlpha px))++  toImageYCbCrA :: (Array arr cs Double, Array arr YCbCrA Double) =>+                   Image arr cs Double+                -> Image arr YCbCrA Double+  toImageYCbCrA = map toPixelYCbCrA+  {-# INLINE toImageYCbCrA #-}++  +instance ColorSpace YCbCr where+  type PixelElt YCbCr e = (e, e, e)+  data Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq++  fromChannel !e = PixelYCbCr e e e+  {-# INLINE fromChannel #-}++  fromElt !(y, b, r) = PixelYCbCr y b r+  {-# INLINE fromElt #-}++  toElt (PixelYCbCr y b r) = (y, b, r)+  {-# INLINE toElt #-}++  getPxCh (PixelYCbCr y _ _) LumaYCbCr  = y+  getPxCh (PixelYCbCr _ b _) CBlueYCbCr = b+  getPxCh (PixelYCbCr _ _ r) CRedYCbCr  = r+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r)+  {-# INLINE chOp #-}++  pxOp !f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r)+  {-# INLINE pxOp #-}++  chApp (PixelYCbCr fy fb fr) (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelYCbCr y b r) = f y `mappend` f b `mappend` f r+  {-# INLINE pxFoldMap #-}+++instance ColorSpace YCbCrA where+  type PixelElt YCbCrA e = (e, e, e, e)+  data Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq++  fromChannel !e = PixelYCbCrA e e e e+  {-# INLINE fromChannel #-}++  fromElt (y, b, r, a) = PixelYCbCrA y b r a+  {-# INLINE fromElt #-}++  toElt (PixelYCbCrA y b r a) = (y, b, r, a)+  {-# INLINE toElt #-}++  getPxCh (PixelYCbCrA y _ _ _) LumaYCbCrA  = y+  getPxCh (PixelYCbCrA _ b _ _) CBlueYCbCrA = b+  getPxCh (PixelYCbCrA _ _ r _) CRedYCbCrA  = r+  getPxCh (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a+  {-# INLINE getPxCh #-}+  +  chOp !f (PixelYCbCrA y b r a) =+    PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a)+  {-# INLINE chOp #-}++  pxOp !f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a)+  {-# INLINE pxOp #-}++  chApp (PixelYCbCrA fy fb fr fa) (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a)+  {-# INLINE chApp #-}++  pxFoldMap f (PixelYCbCrA y b r a) = f y `mappend` f b `mappend` f r `mappend` f a+  {-# INLINE pxFoldMap #-}+++instance Alpha YCbCrA where+  type Opaque YCbCrA = YCbCr++  getAlpha (PixelYCbCrA _ _ _ a) = a+  {-# INLINE getAlpha #-}+  +  addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a+  {-# INLINE addAlpha #-}++  dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r+  {-# INLINE dropAlpha #-}+++instance Show YCbCr where+  show LumaYCbCr  = "Luma"+  show CBlueYCbCr = "Blue Chroma"+  show CRedYCbCr  = "Red Chroma"+++instance Show YCbCrA where+  show LumaYCbCrA  = "Luma"+  show CBlueYCbCrA = "Blue Chroma"+  show CRedYCbCrA  = "Red Chroma"+  show AlphaYCbCrA = "Alpha"++ +instance Show e => Show (Pixel YCbCr e) where+  show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>"+++instance Show e => Show (Pixel YCbCrA e) where+  show (PixelYCbCrA y b r a) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show a++")>"+++
+ src/Graphics/Image/IO.hs view
@@ -0,0 +1,313 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE BangPatterns, FlexibleContexts #-}+module Graphics.Image.IO (+  -- * Reading+  readImage, readImageExact,+  -- * Writing+  writeImage, writeImageExact,+  -- * Displaying+  displayImage, setDisplayProgram, +  --displayImageHistograms, displayHistograms, writeHistograms,+  -- * Supported Image Formats+  module Graphics.Image.IO.External+  +  -- $supported+  +  ) where++import Prelude as P hiding (readFile, writeFile)+import qualified Control.Monad as M (foldM)+import Control.Concurrent -- (forkIO, ThreadId)+import Data.Char (toLower)+import Data.IORef+import Data.ByteString (readFile)+--import Graphics.EasyPlot hiding (TerminalType(..))+--import qualified Graphics.EasyPlot as Plot (TerminalType(PNG))+import Graphics.Image.ColorSpace+import Graphics.Image.Interface+import Graphics.Image.IO.Base+import Graphics.Image.IO.External+--import HIP.Histogram+import qualified Data.ByteString.Lazy as BL (writeFile, hPut)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath (takeExtension)+import System.IO (Handle, hFlush)+import System.IO.Temp (withSystemTempFile)+import System.IO.Unsafe (unsafePerformIO)+import System.Process (spawnProcess, waitForProcess, showCommandForUser)+++guessFormat :: (ImageFormat f, Enum f) => FilePath -> Maybe f+guessFormat path =+  headMaybe . dropWhile (not . isFormat e) . enumFrom . toEnum $ 0+  where e = P.map toLower . takeExtension $ path+        headMaybe ls = if null ls then Nothing else Just $ head ls++-- | This function will try to guess an image format from file's extension,+-- then it will attempt to read it as such. It will fall back onto the rest of+-- the supported formats and will try to read them regarless of file's+-- extension. Whenever image cannot be decoded, 'Left' containing all errors for+-- each attempted format will be returned, and 'Right' containing an image+-- otherwise. Image will be read into a type signature specified 'ColorSpace'+-- ('Graphics.Image.ColorSpace.Y', 'Graphics.Image.ColorSpace.YA',+-- 'Graphics.Image.ColorSpace.RGB' and 'Graphics.Image.ColorSpace.RGBA' only)+-- with 'Double' precision, while doing all necessary conversions.+readImage :: Readable (Image arr cs Double) InputFormat =>+             FilePath+          -> IO (Either String (Image arr cs Double))+readImage path = do+  imgstr <- readFile path+  let maybeFormat = (guessFormat path :: Maybe InputFormat)+      formats = enumFrom . toEnum $ 0+      orderedFormats = maybe formats (\f -> f:(filter (/=f) formats)) maybeFormat+      reader (Left err) format = +        return $ either (Left . ((err++"\n")++)) Right (decode format imgstr)+      reader img         _     = return img+  M.foldM reader (Left "") orderedFormats++-- | This function allows for reading any supported image in the exact colorspace+-- and precision it is currently encoded in. For instance, frog image can be+-- read into it's 'Graphics.Image.ColorSpace.YCbCr' colorspace with+-- 'Graphics.Image.ColorSpace.Word8' precision and into any supported array+-- representation.+--+-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RP YCbCr Word8))+-- Right <Image RepaDelayed YCbCr: 200x320>+--+-- The drawback here is that colorspace and precision has to match exactly,+-- otherwise it will return an error:+--+-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RD RGB Word8))+-- Left "JuicyPixel decoding error: Input image is in YCbCr8 (Pixel YCbCr Word8), cannot convert it to RGB8 (Pixel RGB Word8) colorspace."+--+-- Attempt to read an image in a particular color space that is not supported by+-- the format, will result in a compile error. Refer to 'Readable' class for all+-- images that can be decoded.+readImageExact :: Readable img format =>+                  format+                  -- ^ A file format that an image should be read as. See+                   -- <#g:4 Supported Image Formats>+               -> FilePath -- ^ Location of an image.+               -> IO (Either String img)+readImageExact format path = fmap (decode format) (readFile path)+++-- | Just like 'readImage', this function will guess an output file format from the+-- extension and write to file any image that is in one of 'Y', 'YA', 'RGB' or+-- 'RGBA' 'ColorSpace's with 'Double' precision. While doing necessary+-- conversions the choice will be given to the most suited color space supported+-- by the format, for instance, in case of a 'PNG' format, an ('Image' @arr@+-- 'RGBA' 'Double') would be written as 'RGBA'16, hence preserving transparency+-- and using highest supported precision 'Word16'. At the same time, writing+-- that image in 'GIF' format would save it in @RGB8@, since 'Word8' is the+-- highest precision 'GIF' supports and it currently cannot be saved with+-- transparency.+writeImage :: (ManifestArray arr cs Double, Writable (Image arr cs Double) OutputFormat) =>+              FilePath            -- ^ Location where an image should be written.+           -> Image arr cs Double -- ^ An image to write. +           -> IO ()+writeImage path = BL.writeFile path . encode format [] where+  format = maybe (error ("Could not guess output format. Use 'writeImageExact' "+++                         "or supply a filename with supported format."))+           id (guessFormat path :: Maybe OutputFormat)++  +writeImageExact :: Writable img format =>+                   format+                   -- ^ A file format that an image should be saved in. See+                   -- <#g:4 Supported Image Formats>+                -> [SaveOption format] -- ^ A list of format specific options.+                -> FilePath -- ^ Location where an image should be written.+                -> img -- ^ An image to write. Can be a list of images in case+                       -- of formats supporting animation.+                -> IO ()+writeImageExact format opts path = BL.writeFile path . encode format opts+  ++-- | Sets the program to be use when displaying an image, where 'Bool'+-- specifies if current thread should block until the program is closed when+-- calling 'displayImage' function. GPicView @("gpicview", False)@ is set as a+-- default program with a nonblocking flag. Here are some examples:+--+-- >>> setDisplayProgram ("gpicview", True) -- use gpicview and block current thread.+-- >>> setDisplayProgram ("gimp", False) -- use gimp and don't block current thread.+-- >>> setDisplayProgram ("xv", False)+-- >>> setDisplayProgram ("display", False)+--+setDisplayProgram :: (String, Bool) -> IO ()+setDisplayProgram = writeIORef displayProgram +++displayProgram :: IORef (String, Bool)+displayProgram = unsafePerformIO . newIORef $ ("gpicview", False)+{-# NOINLINE displayProgram #-}+++{- | Makes a call to the current display program, which can be changed using+'setDisplayProgram'. An image is written as a @.tiff@ file into an operating+system's temporary directory and passed as an argument to the display+program. If a blocking flag was set to 'False' using 'setDisplayProgram', then+function will return immediately with ('Just' 'ThreadId'), otherwise it will+block current thread until external program is terminated, in which case+'Nothing' is returned. Temporary file is deleted, after a program displaying an+image is closed.++  >>> frog <- readImageRGB "images/frog.jpg"+  >>> displayImage frog+  Just ThreadId 505+  >>> setDisplayProgram ("gimp", True)+  >>> displayImage frog -- will only return after gimp is closed.+  Nothing++-}+displayImage :: (ManifestArray arr cs e, Writable (Image arr cs e) TIF) =>+                Image arr cs e -- ^ Image to be displayed+             -> IO (Maybe ThreadId)+displayImage img = do+  (program, block) <- readIORef displayProgram+  let displayAction = withSystemTempFile "tmp-img.tiff" (displayUsing img program)+  if block+    then displayAction >> return Nothing+    else forkIO displayAction >>= (return . Just)+++displayUsing :: (ManifestArray arr cs e, Writable (Image arr cs e) TIF) =>+                Image arr cs e -> String -> FilePath -> Handle -> IO ()+displayUsing img program path h = do+  BL.hPut h $ encode TIF [] img+  hFlush h+  ph <- spawnProcess program [path]+  e <- waitForProcess ph+  let printExit ExitSuccess = return ()+      printExit exitCode = do+        putStrLn $ showCommandForUser program [path]+        print exitCode+  printExit e++++{- $supported+Encoding and decoding of images is done using+<http://hackage.haskell.org/package/JuicyPixels JuicyPixels> and+<http://hackage.haskell.org/package/netpbm netpbm> packages.+   +List of image formats that are currently supported, and their exact+'ColorSpace's and precision for reading and writing:+  +* 'BMP':++    * __in__: ('Y' 'Word8'), ('RGB'  'Word8'), ('RGBA'  'Word8')+    * __out__: ('Y' 'Word8'), ('RGB'  'Word8'), ('RGBA'  'Word8')++* 'GIF':++    * __in__: ('RGB'  'Word8'), ('RGBA'  'Word8')+    * __out__: ('RGB'  'Word8')+    * Also supports reading and writing animated images, when used as @['GIF']@++* 'HDR':++    * __in__: ('RGB'  'Float')+    * __out__: ('RGB'  'Float')++* 'JPG':++    * __in__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB'  'Word8'), ('CMYK'  'Word8'),+    ('YCbCr', 'Word8')+    * __out__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB'  'Word8'), ('CMYK'  'Word8'),+    ('YCbCr', 'Word8')++* 'PNG':++    * __in__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),+    ('RGB'  'Word8'), ('RGB'  'Word16'), ('RGBA'  'Word8'), ('RGBA'  'Word16')+    * __out__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),+    ('RGB'  'Word8'), ('RGB'  'Word16'), ('RGBA'  'Word8'), ('RGBA'  'Word16')++* 'TGA':++    * __in__: ('Y' 'Word8'), ('RGB'  'Word8'), ('RGBA'  'Word8')+    * __out__: ('Y' 'Word8'), ('RGB'  'Word8'), ('RGBA'  'Word8')++* 'TIF':++    * __in__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),+    ('RGB'  'Word8'), ('RGB'  'Word16'), ('RGBA'  'Word8'), ('RGBA'  'Word16'),+    ('CMYK'  'Word8'), ('CMYK'  'Word16')+    * __out__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),+    ('RGB'  'Word8'), ('RGB'  'Word16'), ('RGBA'  'Word8'), ('RGBA'  'Word16')+    ('CMYK'  'Word8'), ('CMYK'  'Word16'), ('YCbCr'  'Word8')++* 'PBM':++    * __in__: ('Binary' 'Bit')+    * Also supports sequence of images in one file, when read as @['PBM']@++* 'PGM':++    * __in__: ('Y' 'Word8'), ('Y' 'Word16')+    * Also supports sequence of images in one file, when read as @['PGM']@++* 'PPM':++    * __in__: ('RGB'  'Word8'), ('RGB'  'Word16')+    * Also supports sequence of images in one file, when read as @['PPM']@++-}+++{-+displayImageHistograms :: (Strategy strat img (Channel px), AImage img px,+                           Enum (Channel px), RealFrac (Channel px)) =>+                          strat img (Channel px)+                       -> Int +                       -> img px+                       -> IO ()+displayImageHistograms strat steps img = displayHistograms $ getHistograms strat steps img+++-- | Displays a list of 'Histogram's supplied using an external program that can+-- be changed with 'setDisplayProgram'.+--+-- >>> centaurus <- readImageRGB "images/centaurus.jpg"+-- >>> cluster <- readImageRGB "images/cluster.jpg" +-- >>> displayHistograms ((getHistograms 255 centaurus)++(getHistograms 255 cluster))+--+-- <<images/centaurus_cluster_histogram.png>>+--+displayHistograms :: (Show a, Num a, Fractional a, Enum a) => [Histogram a] -> IO ()+displayHistograms hists = do+  program <- readIORef displayProgram+  withSystemTempDirectory "hip_" (displayHistogramsUsing hists program)+++displayHistogramsUsing :: (Show a, Num a, Fractional a, Enum a) =>+                          [Histogram a] -> String -> FilePath -> IO ()+displayHistogramsUsing hists program tmpDir = do+  let path = tmpDir </> "tmp-hist.png"+  wrote <- writeHistograms path hists+  if wrote+    then do ph <- runCommand (program ++ " " ++ path)+            e <- waitForProcess ph+            let printExit ExitSuccess = return ()+                printExit exitCode = print exitCode+            printExit e+    else print "Was unsuccessfull in using gnuplot."+++-- | Writes histograms into a PNG file image.+--+-- >>> centaurus <- readImageRGB "images/centaurus.jpg"+-- >>> cluster <- readImageRGB "images/cluster.jpg"+-- >>> let histograms = ((getHistograms 255 centaurus)++(getHistograms 255 cluster)) +-- >>> writeHistograms "images/centaurus_cluster_histogram.png" histograms+-- True+--+writeHistograms :: (Show a, Num a, Fractional a, Enum a) =>+                   FilePath -- ^ PNG image file name.+                -> [Histogram a] -- ^ List of histograms to be plotted.+                -> IO Bool -- ^ Returns 'True' in case of success.+writeHistograms path = plot (Plot.PNG path)+  +  +-}
+ src/Graphics/Image/IO/Base.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Graphics.Image.IO.Base (+  ImageFormat(..), Readable(..), Writable(..), Convertible(..)+  ) where++import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+++class Convertible a b where+  convert :: a -> b+++class ImageFormat format where+  data SaveOption format++  ext :: format -> String++  exts :: format -> [String]+  exts f = [ext f]++  isFormat :: String -> format -> Bool+  isFormat e f = e `elem` (exts f)+++class ImageFormat format => Readable img format where++  decode :: format -> B.ByteString -> Either String img+++class ImageFormat format => Writable img format where++  encode :: format -> [SaveOption format] -> img -> BL.ByteString+++
+ src/Graphics/Image/IO/External.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+             TypeFamilies, UndecidableInstances #-}+module Graphics.Image.IO.External (+  module Graphics.Image.IO.External.JuicyPixels,+  module Graphics.Image.IO.External.Netpbm,+  InputFormat, OutputFormat,+  Readable(..), Writable(..), ImageFormat(..),+  ) where++import Graphics.Image.Interface+import Graphics.Image.IO.Base+import Graphics.Image.IO.External.JuicyPixels+import Graphics.Image.IO.External.Netpbm+++-- | A collection of all image formats that can be read into HIP images with+-- 'Double' precision pixel channels.+data InputFormat = InputBMP+                 | InputGIF+                 | InputHDR+                 | InputJPG+                 | InputPNG+                 | InputTIF+                 | InputPNM+                 | InputTGA  deriving (Show, Enum, Eq)+++instance ImageFormat InputFormat where+  data SaveOption InputFormat++  ext InputBMP = ext BMP+  ext InputGIF = ext GIF+  ext InputHDR = ext HDR+  ext InputJPG = ext JPG+  ext InputPNG = ext PNG+  ext InputTGA = ext TGA+  ext InputTIF = ext TIF+  ext InputPNM = ext PPM++  exts InputBMP = exts BMP+  exts InputGIF = exts GIF+  exts InputHDR = exts HDR+  exts InputJPG = exts JPG+  exts InputPNG = exts PNG+  exts InputTGA = exts TGA+  exts InputTIF = exts TIF+  exts InputPNM = [ext PBM, ext PGM, ext PPM]+++instance (Readable (Image arr cs Double) BMP,+          Readable (Image arr cs Double) GIF,+          Readable (Image arr cs Double) HDR,+          Readable (Image arr cs Double) JPG,+          Readable (Image arr cs Double) PNG,+          Readable (Image arr cs Double) TGA,+          Readable (Image arr cs Double) TIF,+          Readable (Image arr cs Double) PPM) =>+         Readable (Image arr cs Double) InputFormat where+  decode InputBMP = decode BMP+  decode InputGIF = decode GIF+  decode InputHDR = decode HDR+  decode InputJPG = decode JPG+  decode InputPNG = decode PNG+  decode InputTIF = decode TIF+  decode InputPNM = decode PPM+  decode InputTGA = decode TGA++++-- | A collection of all image formats that can be written from HIP images with+-- 'Double' precision pixel channels.+data OutputFormat = OutputBMP+                  | OutputGIF+                  | OutputHDR+                  | OutputJPG+                  | OutputPNG+                  | OutputTIF+                  | OutputTGA  deriving (Show, Enum, Eq)+++instance ImageFormat OutputFormat where+  data SaveOption OutputFormat+  ext OutputBMP = ext BMP+  ext OutputGIF = ext GIF+  ext OutputHDR = ext HDR+  ext OutputJPG = ext JPG+  ext OutputPNG = ext PNG+  ext OutputTGA = ext TGA+  ext OutputTIF = ext TIF+++instance (Writable (Image arr cs Double) BMP,+          Writable (Image arr cs Double) GIF,+          Writable (Image arr cs Double) HDR,+          Writable (Image arr cs Double) JPG,+          Writable (Image arr cs Double) PNG,+          Writable (Image arr cs Double) TGA,+          Writable (Image arr cs Double) TIF) =>+         Writable (Image arr cs Double) OutputFormat where+  encode OutputBMP _ = encode BMP []+  encode OutputGIF _ = encode GIF []+  encode OutputHDR _ = encode HDR []+  encode OutputJPG _ = encode JPG []+  encode OutputPNG _ = encode PNG []+  encode OutputTGA _ = encode TGA []+  encode OutputTIF _ = encode TIF []
+ src/Graphics/Image/IO/External/JuicyPixels.hs view
@@ -0,0 +1,1077 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+             TypeFamilies, ViewPatterns #-}+module Graphics.Image.IO.External.JuicyPixels (+  BMP(..),+  GIF(..), JP.GifDelay, JP.GifLooping(..), JP.PaletteOptions(..), JP.PaletteCreationMethod(..),+  HDR(..), JPG(..), PNG(..), TGA(..), TIF(..)+  ) where++import GHC.Float+import Data.Either+import Data.Monoid (mempty)+import Graphics.Image.ColorSpace+import Graphics.Image.Interface hiding (map)+import Graphics.Image.IO.Base+import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import qualified Codec.Picture as JP+import qualified Codec.Picture.Jpg as JP+import qualified Codec.Picture.Types as JP+import qualified Codec.Picture.ColorQuant as JP+++data BMP = BMP -- ^ Bitmap image with @.bmp@ extension.++instance ImageFormat BMP where+  data SaveOption BMP++  ext _ = ".bmp"+++data GIF = GIF -- ^ Graphics Interchange Format image with @.gif@ extension.++instance ImageFormat GIF where+  data SaveOption GIF = GIFPalette JP.PaletteOptions+  +  ext _ = ".gif"++instance ImageFormat [GIF] where+  data SaveOption [GIF] = GIFsPalette JP.PaletteOptions+                        | GIFsLooping JP.GifLooping++  ext _ = ext GIF++data HDR = HDR -- ^ High-dynamic-range image with @.hdr@ extension.++instance ImageFormat HDR where+  data SaveOption HDR++  ext _ = ".hdr"++  exts _ = [".hdr", ".pic"]+++data JPG = JPG -- ^ Joint Photographic Experts Group image with @.jpg@ or+               -- @.jpeg@ extension.++instance ImageFormat JPG where+  data SaveOption JPG = JPGQuality Word8++  ext _ = ".jpg"++  exts _ = [".jpg", ".jpeg"]+++data PNG = PNG -- ^ Portable Network Graphics image with @.png@ extension.++instance ImageFormat PNG where+  data SaveOption PNG++  ext _ = ".png"+++data TGA = TGA -- ^ Truevision Graphics Adapter image with .tga extension.++instance ImageFormat TGA where+  data SaveOption TGA++  ext _ = ".tga"+++data TIF = TIF -- ^ Tagged Image File Format image with @.tif@ or @.tiff@+               -- extension.++instance ImageFormat TIF where+  data SaveOption TIF  ++  ext _ = ".tif"++  exts _ = [".tif", ".tiff"]+++--------------------------------------------------------------------------------+-- Converting to and from JuicyPixels ------------------------------------------+--------------------------------------------------------------------------------++-- Y -> Y (Double)++instance Convertible JP.Pixel8 (Pixel Y Double) where+  convert = toDouble . PixelY++instance Convertible JP.Pixel16 (Pixel Y Double) where+  convert = toDouble . PixelY++instance Convertible JP.PixelF (Pixel Y Double) where+  convert = toDouble . PixelY++instance Convertible JP.PixelYA8 (Pixel Y Double) where+  convert = convert . JP.dropTransparency++instance Convertible JP.PixelYA16 (Pixel Y Double) where+  convert = convert . JP.dropTransparency++instance Convertible JP.Pixel8 (Pixel YA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.Pixel16 (Pixel YA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelF (Pixel YA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelYA8 (Pixel YA Double) where+  convert (JP.PixelYA8 y a) = toDouble (PixelYA y a)++instance Convertible JP.PixelYA16 (Pixel YA Double) where+  convert (JP.PixelYA16 y a) = toDouble (PixelYA y a)+++-- Color -> Y (Double)++instance Convertible JP.PixelRGB8 (Pixel Y Double) where+  convert = toPixelY . (convert :: JP.PixelRGB8 -> Pixel RGB Double)++instance Convertible JP.PixelRGB16 (Pixel Y Double) where+  convert = toPixelY . (convert :: JP.PixelRGB16 -> Pixel RGB Double)++instance Convertible JP.PixelRGBA8 (Pixel Y Double) where+  convert = toPixelY . (convert :: JP.PixelRGBA8 -> Pixel RGB Double)++instance Convertible JP.PixelRGBA16 (Pixel Y Double) where+  convert = toPixelY . (convert :: JP.PixelRGBA16 -> Pixel RGB Double)++instance Convertible JP.PixelRGBF (Pixel Y Double) where+  convert = toPixelY . (convert :: JP.PixelRGBF -> Pixel RGB Double)++instance Convertible JP.PixelCMYK8 (Pixel Y Double) where+  convert = toPixelY . toDouble . (convert :: JP.PixelCMYK8 -> Pixel CMYK Word8)++instance Convertible JP.PixelCMYK16 (Pixel Y Double) where+  convert = toPixelY . toDouble . (convert :: JP.PixelCMYK16 -> Pixel CMYK Word16)++instance Convertible JP.PixelYCbCr8 (Pixel Y Double) where+  convert = convert . JP.computeLuma++-- Color -> YA (Double)  ++instance Convertible JP.PixelRGB8 (Pixel YA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelRGB16 (Pixel YA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelRGBF (Pixel YA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelCMYK8 (Pixel YA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelCMYK16 (Pixel YA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelYCbCr8 (Pixel YA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelRGBA8 (Pixel YA Double) where+  convert = toPixelYA . (convert :: JP.PixelRGBA8 -> Pixel RGBA Double)++instance Convertible JP.PixelRGBA16 (Pixel YA Double) where+  convert = toPixelYA . (convert :: JP.PixelRGBA16 -> Pixel RGBA Double)+  +  ++-- Y -> RGB (Double)++instance Convertible JP.Pixel8 (Pixel RGB Double) where+  convert = toDouble . fromChannel++instance Convertible JP.Pixel16 (Pixel RGB Double) where+  convert = toDouble . fromChannel++instance Convertible JP.PixelF (Pixel RGB Double) where+  convert = toDouble . fromChannel++instance Convertible JP.PixelYA8 (Pixel RGB Double) where+  convert = convert . JP.dropTransparency++instance Convertible JP.PixelYA16 (Pixel RGB Double) where+  convert = convert . JP.dropTransparency++-- Color -> RGB (Double)++instance Convertible JP.PixelRGB8 (Pixel RGB Double) where+  convert (JP.PixelRGB8 r g b) = toDouble $ PixelRGB r g b++instance Convertible JP.PixelRGB16 (Pixel RGB Double) where+  convert (JP.PixelRGB16 r g b) = toDouble $ PixelRGB r g b++instance Convertible JP.PixelRGBA8 (Pixel RGB Double) where+  convert = convert . JP.dropTransparency++instance Convertible JP.PixelRGBA16 (Pixel RGB Double) where+  convert = convert . JP.dropTransparency++instance Convertible JP.PixelRGBF (Pixel RGB Double) where+  convert (JP.PixelRGBF r g b) = +    PixelRGB (float2Double r) (float2Double g) (float2Double b)++instance Convertible JP.PixelYCbCr8 (Pixel RGB Double) where+  convert = convert . (JP.convertPixel :: JP.PixelYCbCr8 -> JP.PixelRGB8)++instance Convertible JP.PixelCMYK8 (Pixel RGB Double) where+  convert = convert . (JP.convertPixel :: JP.PixelCMYK8 -> JP.PixelRGB8)++instance Convertible JP.PixelCMYK16 (Pixel RGB Double) where+  convert = convert . (JP.convertPixel :: JP.PixelCMYK16 -> JP.PixelRGB16)++-- Y -> RGBA (Double)++instance Convertible JP.Pixel8 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.Pixel16 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelF (Pixel RGBA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelYA8 (Pixel RGBA Double) where+  convert = toPixelRGBA . (convert :: JP.PixelYA8 -> Pixel YA Double)++instance Convertible JP.PixelYA16 (Pixel RGBA Double) where+  convert = toPixelRGBA . (convert :: JP.PixelYA16 -> Pixel YA Double)++-- Color -> RGBA (Double)++instance Convertible JP.PixelRGB8 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelRGB16 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelRGBF (Pixel RGBA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelCMYK8 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelCMYK16 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert++instance Convertible JP.PixelYCbCr8 (Pixel RGBA Double) where+  convert = addAlpha 1 . convert+  +instance Convertible JP.PixelRGBA8 (Pixel RGBA Double) where+  convert (JP.PixelRGBA8 r g b a) = toDouble $ PixelRGBA r g b a+  +instance Convertible JP.PixelRGBA16 (Pixel RGBA Double) where+  convert (JP.PixelRGBA16 r g b a) = toDouble $ PixelRGBA r g b a+++---- to JuicyPixels -----++---- Exact precision conversions++instance Convertible JP.Pixel8 (Pixel Y Word8) where+  convert = PixelY+  +instance Convertible JP.Pixel16 (Pixel Y Word16) where+  convert = PixelY++instance Convertible JP.Pixel32 (Pixel Y Word32) where+  convert = PixelY++instance Convertible JP.PixelF (Pixel Y Float) where+  convert = PixelY++instance Convertible JP.PixelYA8 (Pixel YA Word8) where+  convert (JP.PixelYA8 g a) = PixelYA g a+  +instance Convertible JP.PixelYA16 (Pixel YA Word16) where+  convert (JP.PixelYA16 g a) = PixelYA g a++instance Convertible JP.PixelRGB8 (Pixel RGB Word8) where+  convert (JP.PixelRGB8 r g b) = PixelRGB r g b+  +instance Convertible JP.PixelRGB16 (Pixel RGB Word16) where+  convert (JP.PixelRGB16 r g b) = PixelRGB r g b++instance Convertible JP.PixelRGBF (Pixel RGB Float) where+  convert (JP.PixelRGBF r g b) = PixelRGB r g b++instance Convertible JP.PixelRGBA8 (Pixel RGBA Word8) where+  convert (JP.PixelRGBA8 r g b a) = PixelRGBA r g b a+  +instance Convertible JP.PixelRGBA16 (Pixel RGBA Word16) where+  convert (JP.PixelRGBA16 r g b a) = PixelRGBA r g b a++instance Convertible JP.PixelYCbCr8 (Pixel YCbCr Word8) where+  convert (JP.PixelYCbCr8 y cb cr) = PixelYCbCr y cb cr++instance Convertible JP.PixelCMYK8 (Pixel CMYK Word8) where+  convert (JP.PixelCMYK8 c m y k) = PixelCMYK c m y k++instance Convertible JP.PixelCMYK16 (Pixel CMYK Word16) where+  convert (JP.PixelCMYK16 c m y k) = PixelCMYK c m y k++++instance Convertible (Pixel Y Word8) JP.Pixel8 where+  convert (PixelY g) = g+  +instance Convertible (Pixel Y Word16) JP.Pixel16 where+  convert (PixelY g) = g++instance Convertible (Pixel Y Word32) JP.Pixel32 where+  convert (PixelY g) = g++instance Convertible (Pixel Y Float) JP.PixelF where+  convert (PixelY g) = g++instance Convertible (Pixel YA Word8) JP.PixelYA8 where+  convert (PixelYA g a) = JP.PixelYA8 g a+  +instance Convertible (Pixel YA Word16) JP.PixelYA16 where+  convert (PixelYA g a) = JP.PixelYA16 g a++instance Convertible (Pixel RGB Word8) JP.PixelRGB8 where+  convert (PixelRGB r g b) = JP.PixelRGB8 r g b+  +instance Convertible (Pixel RGB Word16) JP.PixelRGB16 where+  convert (PixelRGB r g b) = JP.PixelRGB16 r g b++instance Convertible (Pixel RGB Float) JP.PixelRGBF where+  convert (PixelRGB r g b) = JP.PixelRGBF r g b++instance Convertible (Pixel RGBA Word8) JP.PixelRGBA8 where+  convert (PixelRGBA r g b a) = JP.PixelRGBA8 r g b a+  +instance Convertible (Pixel RGBA Word16) JP.PixelRGBA16 where+  convert (PixelRGBA r g b a) = JP.PixelRGBA16 r g b a+++instance Convertible (Pixel YCbCr Word8) JP.PixelYCbCr8 where+  convert (PixelYCbCr y cb cr) = JP.PixelYCbCr8 y cb cr++instance Convertible (Pixel CMYK Word8) JP.PixelCMYK8 where+  convert (PixelCMYK c m y k) = JP.PixelCMYK8 c m y k++instance Convertible (Pixel CMYK Word16) JP.PixelCMYK16 where+  convert (PixelCMYK c m y k) = JP.PixelCMYK16 c m y k++++--------------------------------------------------------------------------------+-- Decoding images using JuicyPixels ------------------------------------------+--------------------------------------------------------------------------------+++-- BMP Format Reading++instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) BMP where+  decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeBitmap++instance Array arr Y Word8 => Readable (Image arr Y Word8) BMP where+  decode _ = jpImageY8ToImage . JP.decodeBitmap++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) BMP where+  decode _ = jpImageRGB8ToImage . JP.decodeBitmap++instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) BMP where+  decode _ = jpImageRGBA8ToImage . JP.decodeBitmap++instance Array arr Y Double => Readable (Image arr Y Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap++instance Array arr YA Double => Readable (Image arr YA Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap++instance Array arr RGB Double => Readable (Image arr RGB Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap++instance Array arr RGBA Double => Readable (Image arr RGBA Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap+++-- GIF Format Reading++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) GIF where+  decode _ = jpImageRGB8ToImage . JP.decodeGif++instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) GIF where+  decode _ = jpImageRGBA8ToImage . JP.decodeGif++instance Array arr Y Double => Readable (Image arr Y Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++instance Array arr YA Double => Readable (Image arr YA Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++instance Array arr RGB Double => Readable (Image arr RGB Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++instance Array arr RGBA Double => Readable (Image arr RGBA Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++-- List of GIF Format frames Reading++decodeGifs :: (Either String JP.DynamicImage -> Either String img)+           -> B.ByteString -> Either String [img]+decodeGifs decoder = either Left decodeLS . JP.decodeGifImages where+    decodeLS ls = if null errs then Right imgs else Left $ unlines errs where+      (errs, imgs) = partitionEithers $ map (decoder . Right) ls++instance Array arr RGB Word8 => Readable [Image arr RGB Word8] [GIF] where+  decode _ = decodeGifs jpImageRGB8ToImage++instance Array arr RGBA Word8 => Readable [Image arr RGBA Word8] [GIF] where+  decode _ = decodeGifs jpImageRGBA8ToImage++instance Array arr Y Double => Readable [Image arr Y Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage++instance Array arr YA Double => Readable [Image arr YA Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage++instance Array arr RGB Double => Readable [Image arr RGB Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage++instance Array arr RGBA Double => Readable [Image arr RGBA Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage+  +++-- HDR Format Reading++instance Array arr RGB Float => Readable (Image arr RGB Float) HDR where+  decode _ = jpImageRGBFToImage . JP.decodeHDR++instance Array arr Y Double => Readable (Image arr Y Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR++instance Array arr YA Double => Readable (Image arr YA Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR++instance Array arr RGB Double => Readable (Image arr RGB Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR++instance Array arr RGBA Double => Readable (Image arr RGBA Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR+++-- JPG Format Reading++instance Array arr Y Word8 => Readable (Image arr Y Word8) JPG where+  decode _ = jpImageY8ToImage . JP.decodeJpeg++instance Array arr YA Word8 => Readable (Image arr YA Word8) JPG where+  decode _ = jpImageYA8ToImage . JP.decodeJpeg++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) JPG where+  decode _ = jpImageRGB8ToImage . JP.decodeJpeg++instance Array arr CMYK Word8 => Readable (Image arr CMYK Word8) JPG where+  decode _ = jpImageCMYK8ToImage . JP.decodeJpeg++instance Array arr YCbCr Word8 => Readable (Image arr YCbCr Word8) JPG where+  decode _ = jpImageYCbCr8ToImage . JP.decodeJpeg++instance Array arr Y Double => Readable (Image arr Y Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg++instance Array arr YA Double => Readable (Image arr YA Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg++instance Array arr RGB Double => Readable (Image arr RGB Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg++instance Array arr RGBA Double => Readable (Image arr RGBA Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg+++-- PNG Format Reading++instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) PNG where+  decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodePng++instance Array arr Y Word8 => Readable (Image arr Y Word8) PNG where+  decode _ = jpImageY8ToImage . JP.decodePng++instance Array arr Y Word16 => Readable (Image arr Y Word16) PNG where+  decode _ = jpImageY16ToImage . JP.decodePng++instance Array arr YA Word8 => Readable (Image arr YA Word8) PNG where+  decode _ = jpImageYA8ToImage . JP.decodePng++instance Array arr YA Word16 => Readable (Image arr YA Word16) PNG where+  decode _ = jpImageYA16ToImage . JP.decodePng++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) PNG where+  decode _ = jpImageRGB8ToImage . JP.decodePng++instance Array arr RGB Word16 => Readable (Image arr RGB Word16) PNG where+  decode _ = jpImageRGB16ToImage . JP.decodePng++instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) PNG where+  decode _ = jpImageRGBA8ToImage . JP.decodePng++instance Array arr RGBA Word16 => Readable (Image arr RGBA Word16) PNG where+  decode _ = jpImageRGBA16ToImage . JP.decodePng++instance Array arr Y Double => Readable (Image arr Y Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng++instance Array arr YA Double => Readable (Image arr YA Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng++instance Array arr RGB Double => Readable (Image arr RGB Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng++instance Array arr RGBA Double => Readable (Image arr RGBA Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng+++-- TGA Format Reading++instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) TGA where+  decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeTga++instance Array arr Y Word8 => Readable (Image arr Y Word8) TGA where+  decode _ = jpImageY8ToImage . JP.decodeTga++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) TGA where+  decode _ = jpImageRGB8ToImage . JP.decodeTga++instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) TGA where+  decode _ = jpImageRGBA8ToImage . JP.decodeTga++instance Array arr Y Double => Readable (Image arr Y Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++instance Array arr YA Double => Readable (Image arr YA Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++instance Array arr RGB Double => Readable (Image arr RGB Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++instance Array arr RGBA Double => Readable (Image arr RGBA Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga+++-- TIF Format Reading++instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) TIF where+  decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeTiff++instance Array arr Y Word8 => Readable (Image arr Y Word8) TIF where+  decode _ = jpImageY8ToImage . JP.decodeTiff++instance Array arr Y Word16 => Readable (Image arr Y Word16) TIF where+  decode _ = jpImageY16ToImage . JP.decodeTiff++instance Array arr YA Word8 => Readable (Image arr YA Word8) TIF where+  decode _ = jpImageYA8ToImage . JP.decodeTiff++instance Array arr YA Word16 => Readable (Image arr YA Word16) TIF where+  decode _ = jpImageYA16ToImage . JP.decodeTiff++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) TIF where+  decode _ = jpImageRGB8ToImage . JP.decodeTiff++instance Array arr RGB Word16 => Readable (Image arr RGB Word16) TIF where+  decode _ = jpImageRGB16ToImage . JP.decodeTiff++instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) TIF where+  decode _ = jpImageRGBA8ToImage . JP.decodeTiff++instance Array arr RGBA Word16 => Readable (Image arr RGBA Word16) TIF where+  decode _ = jpImageRGBA16ToImage . JP.decodeTiff++instance Array arr CMYK Word8 => Readable (Image arr CMYK Word8) TIF where+  decode _ = jpImageCMYK8ToImage . JP.decodeTiff++instance Array arr CMYK Word16 => Readable (Image arr CMYK Word16) TIF where+  decode _ = jpImageCMYK16ToImage . JP.decodeTiff+++instance Array arr Y Double => Readable (Image arr Y Double) TIF where+  decode _ = jpDynamicImageToImage . JP.decodeTiff++instance Array arr YA Double => Readable (Image arr YA Double) TIF where+  decode _ = jpDynamicImageToImage . JP.decodeTiff++instance Array arr RGB Double => Readable (Image arr RGB Double) TIF where+  decode _ = jpDynamicImageToImage . JP.decodeTiff++instance Array arr RGBA Double => Readable (Image arr RGBA Double) TIF where+  decode _ = jpDynamicImageToImage . JP.decodeTiff++++-- General decoding and helper functions++jpImageToImage :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) =>+                  JP.Image jpx -> Image arr cs e+jpImageToImage jimg = make (JP.imageHeight jimg, JP.imageWidth jimg) getPx+  where getPx (y, x) = convert $ JP.pixelAt jimg x y+++jpImageY8ToImage :: Array arr Y Word8 =>+                    Either String JP.DynamicImage -> Either String (Image arr Y Word8)+jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImage jimg)+jpImageY8ToImage jimg = jpCSError "Y8 (Pixel Y Word8)" jimg+++jpImageY16ToImage :: Array arr Y Word16 =>+                     Either String JP.DynamicImage -> Either String (Image arr Y Word16)+jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImage jimg)+jpImageY16ToImage jimg = jpCSError "Y16 (Pixel Y Word16)" jimg++{- -- No JuicyPixels images are actually read in this type+jpImageYFToImage :: Array arr Y Float =>+                     Either String JP.DynamicImage -> Either String (Image arr Y Float)+jpImageYFToImage (Right (JP.ImageYF jimg)) = Right (jpImageToImage jimg)+jpImageYFToImage jimg = jpCSError "YF (Pixel Y Float)" jimg+-}++jpImageYA8ToImage :: Array arr YA Word8 =>+                    Either String JP.DynamicImage -> Either String (Image arr YA Word8)+jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImage jimg)+jpImageYA8ToImage jimg = jpCSError "YA8 (Pixel YA Word8)" jimg+++jpImageYA16ToImage :: Array arr YA Word16 =>+                     Either String JP.DynamicImage -> Either String (Image arr YA Word16)+jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImage jimg)+jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg+++jpImageRGB8ToImage :: Array arr RGB Word8 =>+                      Either String JP.DynamicImage -> Either String (Image arr RGB Word8)+jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImage jimg)+jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg+++jpImageRGB16ToImage :: Array arr RGB Word16 =>+                       Either String JP.DynamicImage -> Either String (Image arr RGB Word16)+jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImage jimg)+jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg+++jpImageRGBFToImage :: Array arr RGB Float =>+                       Either String JP.DynamicImage -> Either String (Image arr RGB Float)+jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImage jimg)+jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg+++jpImageRGBA8ToImage :: Array arr RGBA Word8 =>+                      Either String JP.DynamicImage -> Either String (Image arr RGBA Word8)+jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImage jimg)+jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg+++jpImageRGBA16ToImage :: Array arr RGBA Word16 =>+                       Either String JP.DynamicImage -> Either String (Image arr RGBA Word16)+jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImage jimg)+jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg+++jpImageYCbCr8ToImage :: Array arr YCbCr Word8 =>+                      Either String JP.DynamicImage -> Either String (Image arr YCbCr Word8)+jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImage jimg)+jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg+++jpImageCMYK8ToImage :: Array arr CMYK Word8 =>+                      Either String JP.DynamicImage -> Either String (Image arr CMYK Word8)+jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImage jimg)+jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg+++jpImageCMYK16ToImage :: Array arr CMYK Word16 =>+                      Either String JP.DynamicImage -> Either String (Image arr CMYK Word16)+jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImage jimg)+jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg+++jpDynamicImageToImage' :: (Convertible JP.PixelCMYK16 (Pixel cs e),+                          Convertible JP.PixelCMYK8 (Pixel cs e),+                          Convertible JP.PixelRGB16 (Pixel cs e),+                          Convertible JP.PixelRGB8 (Pixel cs e),+                          Convertible JP.PixelRGBA16 (Pixel cs e),+                          Convertible JP.PixelRGBA8 (Pixel cs e),+                          Convertible JP.PixelRGBF (Pixel cs e),+                          Convertible JP.PixelYA16 (Pixel cs e),+                          Convertible JP.PixelYA8 (Pixel cs e),+                          Convertible JP.PixelYCbCr8 (Pixel cs e),+                          Convertible JP.Pixel16 (Pixel cs e),+                          Convertible JP.Pixel8 (Pixel cs e),+                          Convertible JP.PixelF (Pixel cs e),+                          Array arr cs e) =>+                         JP.DynamicImage -> Image arr cs e+jpDynamicImageToImage' (JP.ImageY8 jimg)     = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageY16 jimg)    = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageYF jimg)     = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageYA8 jimg)    = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageYA16 jimg)   = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageRGB8 jimg)   = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageRGB16 jimg)  = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageRGBF jimg)   = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageRGBA8 jimg)  = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageRGBA16 jimg) = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageCMYK8 jimg)  = jpImageToImage jimg+jpDynamicImageToImage' (JP.ImageCMYK16 jimg) = jpImageToImage jimg+++jpDynamicImageToImage :: (Convertible JP.PixelCMYK16 (Pixel cs e),+                          Convertible JP.PixelCMYK8 (Pixel cs e),+                          Convertible JP.PixelRGB16 (Pixel cs e),+                          Convertible JP.PixelRGB8 (Pixel cs e),+                          Convertible JP.PixelRGBA16 (Pixel cs e),+                          Convertible JP.PixelRGBA8 (Pixel cs e),+                          Convertible JP.PixelRGBF (Pixel cs e),+                          Convertible JP.PixelYA16 (Pixel cs e),+                          Convertible JP.PixelYA8 (Pixel cs e),+                          Convertible JP.PixelYCbCr8 (Pixel cs e),+                          Convertible JP.Pixel16 (Pixel cs e),+                          Convertible JP.Pixel8 (Pixel cs e),+                          Convertible JP.PixelF (Pixel cs e), Array arr cs e) =>+                         Either String JP.DynamicImage -> Either String (Image arr cs e)+jpDynamicImageToImage = either jpError (Right . jpDynamicImageToImage')+++jpImageShowCS :: JP.DynamicImage -> String+jpImageShowCS (JP.ImageY8 _)     = "Y8 (Pixel Y Word8)"+jpImageShowCS (JP.ImageY16 _)    = "Y16 (Pixel Y Word16)"+jpImageShowCS (JP.ImageYF _)     = "YF (Pixel Y Float)"+jpImageShowCS (JP.ImageYA8 _)    = "YA8 (Pixel YA Word8)"+jpImageShowCS (JP.ImageYA16 _)   = "YA16 (Pixel YA Word16)"+jpImageShowCS (JP.ImageRGB8 _)   = "RGB8 (Pixel RGB Word8)"+jpImageShowCS (JP.ImageRGB16 _)  = "RGB16 (Pixel RGB Word16)"+jpImageShowCS (JP.ImageRGBF _)   = "RGBF (Pixel RGB Float)"+jpImageShowCS (JP.ImageRGBA8 _)  = "RGBA8 (Pixel RGBA Word8)"+jpImageShowCS (JP.ImageRGBA16 _) = "RGBA16 (Pixel RGBA Word16)"+jpImageShowCS (JP.ImageYCbCr8 _) = "YCbCr8 (Pixel YCbCr Word8)"+jpImageShowCS (JP.ImageCMYK8 _)  = "CMYK8 (Pixel CMYK Word8)"+jpImageShowCS (JP.ImageCMYK16 _) = "CMYK16 (Pixel CMYK Word16)"+++jpError :: String -> Either String a+jpError err = Left ("JuicyPixel decoding error: "++err)+++jpCSError :: String -> Either String JP.DynamicImage -> Either String a+jpCSError _  (Left err)   = jpError err+jpCSError cs (Right jimg) = jpError ("Input image is in "++(jpImageShowCS jimg)+++                                     ", cannot convert it to "++cs++" colorspace.")+++--------------------------------------------------------------------------------+-- Encoding images using JuicyPixels -------------------------------------------+--------------------------------------------------------------------------------++instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) ++instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) ++instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) ++instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                                 . fromPixelBinary)++instance ManifestArray arr Y Double => Writable (Image arr Y Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                                 . toWord8)++instance ManifestArray arr YA Double => Writable (Image arr YA Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                                 . toWord8 . dropAlpha)++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                                 . toWord8)++instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8)+                                                 . toWord8)++-- Writable GIF++encodeGIF :: ManifestArray arr cs e =>+             [SaveOption GIF] -> (Pixel cs e -> JP.PixelRGB8)+             -> Image arr cs e -> BL.ByteString+encodeGIF []                     !conv =+  either error id . uncurry JP.encodeGifImageWithPalette .+  JP.palettize JP.defaultPaletteOptions . imageToJPImage conv+encodeGIF (GIFPalette palOpts:_) !conv =+  either error id . uncurry JP.encodeGifImageWithPalette .+  JP.palettize palOpts . imageToJPImage conv+++instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) GIF where+  encode _ opts = encodeGIF opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8)+  +instance ManifestArray arr Y Double => Writable (Image arr Y Double) GIF where+  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                  . toWord8 . toPixelRGB)+    +instance ManifestArray arr YA Double => Writable (Image arr YA Double) GIF where+  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                  . toWord8 . toPixelRGB . dropAlpha)++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) GIF where+  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                  . toWord8)++instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) GIF where+  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                  . toWord8 . dropAlpha)+++encodeGIFs :: ManifestArray arr cs e =>+              [SaveOption [GIF]] -> (Pixel cs e -> JP.PixelRGB8)+           -> [(JP.GifDelay, Image arr cs e)] -> BL.ByteString+encodeGIFs !opts !conv =+  either error id . JP.encodeGifImages (getGIFsLoop opts) . map palletizeGif where+    getGIFsLoop []                   = JP.LoopingNever+    getGIFsLoop (GIFsLooping loop:_) = loop+    getGIFsLoop (_:xs)               = getGIFsLoop xs    +    getGIFsPal []                      = JP.defaultPaletteOptions+    getGIFsPal (GIFsPalette palOpts:_) = palOpts+    getGIFsPal (_:xs)                  = getGIFsPal xs+    palletizeGif !(d, img) = (p, d, jimg) where  +      !(jimg, p) = JP.palettize (getGIFsPal opts) $ imageToJPImage conv img+++instance ManifestArray arr RGB Word8 => Writable [(JP.GifDelay, Image arr RGB Word8)] [GIF] where+  encode _ opts = encodeGIFs opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8)++instance ManifestArray arr RGB Double => Writable [(JP.GifDelay, Image arr RGB Double)] [GIF] where+  encode _ opts = encodeGIFs opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                   . toWord8)++-- Writable HDR++instance ManifestArray arr RGB Float => Writable (Image arr RGB Float) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage (convert :: Pixel RGB Float -> JP.PixelRGBF) ++instance ManifestArray arr Y Double => Writable (Image arr Y Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)+                                              . toFloat . toPixelRGB)++instance ManifestArray arr YA Double => Writable (Image arr YA Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)+                                              . toFloat . toPixelRGB . dropAlpha)++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)+                                              . toFloat)++instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)+                                              . toFloat . dropAlpha)+ ++-- Writable JPG+++encodeJPG :: (JP.JpgEncodable px, ManifestArray arr cs e) =>+             [SaveOption JPG] -> (Pixel cs e -> px) -> Image arr cs e -> BL.ByteString+encodeJPG []               conv =+  JP.encodeDirectJpegAtQualityWithMetadata 100 mempty . imageToJPImage conv+encodeJPG (JPGQuality q:_) conv =+  JP.encodeDirectJpegAtQualityWithMetadata q mempty . imageToJPImage conv+++instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) JPG where+  encode _ opts = encodeJPG opts (convert :: Pixel Y Word8 -> JP.Pixel8)++instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) JPG where+  encode _ opts = encodeJPG opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) ++instance ManifestArray arr CMYK Word8 => Writable (Image arr CMYK Word8) JPG where+  encode _ opts = encodeJPG opts (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) +               +instance ManifestArray arr YCbCr Word8 => Writable (Image arr YCbCr Word8) JPG where+  encode _ opts = encodeJPG opts (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) ++instance ManifestArray arr Y Double => Writable (Image arr Y Double) JPG where+  encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                  . toWord8) ++instance ManifestArray arr YA Double => Writable (Image arr YA Double) JPG where+  encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                  . toWord8 . dropAlpha) ++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) JPG where+  encode _ opts = encodeJPG opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                  . toWord8) ++instance ManifestArray arr CMYK Double => Writable (Image arr CMYK Double) JPG where+  encode _ opts = encodeJPG opts ((convert :: Pixel CMYK Word8 -> JP.PixelCMYK8)+                                  . toWord8) ++instance ManifestArray arr YCbCr Double => Writable (Image arr YCbCr Double) JPG where+  encode _ opts = encodeJPG opts ((convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8)+                                  . toWord8) ++-- Writable PNG++instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) PNG where+  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) +                                              . fromPixelBinary)+  +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) ++instance ManifestArray arr Y Word16 => Writable (Image arr Y Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) ++instance ManifestArray arr YA Word8 => Writable (Image arr YA Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) ++instance ManifestArray arr YA Word16 => Writable (Image arr YA Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) ++instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) ++instance ManifestArray arr RGB Word16 => Writable (Image arr RGB Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) ++instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) ++instance ManifestArray arr RGBA Word16 => Writable (Image arr RGBA Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) +++instance ManifestArray arr Y Double => Writable (Image arr Y Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16)+                                              . toWord16)++instance ManifestArray arr YA Double => Writable (Image arr YA Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16)+                                              . toWord16)++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16)+                                              . toWord16)++instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16)+                                              . toWord16)++-- Writable TGA++instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                              . fromPixelBinary)+  +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) ++instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) ++instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) +++instance ManifestArray arr Y Double => Writable (Image arr Y Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                              . toWord8)++instance ManifestArray arr YA Double => Writable (Image arr YA Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                              . toWord8 . dropAlpha)++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)+                                              . toWord8)++instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8)+                                              . toWord8)++-- Writable TIF++instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) ++instance ManifestArray arr Y Word16 => Writable (Image arr Y Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) ++instance ManifestArray arr YA Word8 => Writable (Image arr YA Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) ++instance ManifestArray arr YA Word16 => Writable (Image arr YA Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) ++instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) ++instance ManifestArray arr RGB Word16 => Writable (Image arr RGB Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) ++instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) ++instance ManifestArray arr RGBA Word16 => Writable (Image arr RGBA Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) ++instance ManifestArray arr YCbCr Word8 => Writable (Image arr YCbCr Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8)+  +instance ManifestArray arr CMYK Word8 => Writable (Image arr CMYK Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) ++instance ManifestArray arr CMYK Word16 => Writable (Image arr CMYK Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word16 -> JP.PixelCMYK16) +++instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)+                                               . fromPixelBinary)+  +instance ManifestArray arr Y Double => Writable (Image arr Y Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16)+                                               . toWord16)++instance ManifestArray arr YA Double => Writable (Image arr YA Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16)+                                               . toWord16)++instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16)+                                               . toWord16)++instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16)+                                               . toWord16)++instance ManifestArray arr YCbCr Double => Writable (Image arr YCbCr Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8)+                                               . toWord8)++instance ManifestArray arr CMYK Double => Writable (Image arr CMYK Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel CMYK Word16 -> JP.PixelCMYK16)+                                               . toWord16)++++imageToJPImage :: (JP.Pixel a, ManifestArray arr cs e) =>+                  (Pixel cs e -> a) -> Image arr cs e -> JP.Image a+imageToJPImage !f img@(dims -> (m, n)) = JP.generateImage g n m+  where g !j !i = f (index img (i, j))+        {-# INLINE g #-}+{-# INLINE imageToJPImage #-}+++
+ src/Graphics/Image/IO/External/Netpbm.hs view
@@ -0,0 +1,286 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Graphics.Image.IO.External.Netpbm (+  PBM(..), PGM(..), PPM(..)+  ) where+++import Graphics.Image.ColorSpace+import Graphics.Image.Interface hiding (map)+import Graphics.Image.IO.Base+import Foreign.Storable (Storable)+import qualified Data.ByteString as B (ByteString)+import qualified Graphics.Netpbm as PNM+import qualified Data.Vector.Storable as VS ((!), Vector)+++data PBM = PBM -- ^ Netpbm: portable bitmap image with .pbm extension.++instance ImageFormat PBM where+  data SaveOption PBM++  ext _ = ".pbm"+++data PGM = PGM -- ^ Netpbm: portable graymap image with .pgm extension.++instance ImageFormat PGM where+  data SaveOption PGM++  ext _ = ".pgm"+++data PPM = PPM -- ^ Netpbm: portable pixmap image with .ppm extension.++instance ImageFormat PPM where+  data SaveOption PPM++  ext _ = ".ppm"+++instance ImageFormat [PBM] where+  data SaveOption [PBM]++  ext _ = ".pbm"+++instance ImageFormat [PGM] where+  data SaveOption [PGM]++  ext _ = ".pgm"+++instance ImageFormat [PPM] where+  data SaveOption [PPM]++  ext _ = ".ppm"+++--------------------------------------------------------------------------------+-- Converting to and from Netpbm -----------------------------------------------+--------------------------------------------------------------------------------++-- -> Y (Double)++instance Convertible PNM.PbmPixel (Pixel Y Double) where+  convert (PNM.PbmPixel bool) = PixelY $ if bool then 0 else 1+  +instance Convertible PNM.PgmPixel8 (Pixel Y Double) where+  convert (PNM.PgmPixel8 w8) = toDouble . PixelY $ w8++instance Convertible PNM.PgmPixel16 (Pixel Y Double) where+  convert (PNM.PgmPixel16 w16) = toDouble . PixelY $ w16++instance Convertible PNM.PpmPixelRGB8 (Pixel Y Double) where+  convert (PNM.PpmPixelRGB8 r g b) = toPixelY . toDouble $ PixelRGB r g b++instance Convertible PNM.PpmPixelRGB16 (Pixel Y Double) where+  convert (PNM.PpmPixelRGB16 r g b) = toPixelY . toDouble $ PixelRGB r g b++-- -> YA (Double)++instance Convertible PNM.PbmPixel (Pixel YA Double) where+  convert = addAlpha 1 . (convert :: PNM.PbmPixel -> Pixel Y Double)+  +instance Convertible PNM.PgmPixel8 (Pixel YA Double) where+  convert = addAlpha 1 . (convert :: PNM.PgmPixel8 -> Pixel Y Double)++instance Convertible PNM.PgmPixel16 (Pixel YA Double) where+  convert = addAlpha 1 . (convert :: PNM.PgmPixel16 -> Pixel Y Double)++instance Convertible PNM.PpmPixelRGB8 (Pixel YA Double) where+  convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB8 -> Pixel Y Double)++instance Convertible PNM.PpmPixelRGB16 (Pixel YA Double) where+  convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB16 -> Pixel Y Double)++-- -> RGB (Double)++instance Convertible PNM.PbmPixel (Pixel RGB Double) where+  convert = toPixelRGB . (convert :: PNM.PbmPixel -> Pixel Y Double)+  +instance Convertible PNM.PgmPixel8 (Pixel RGB Double) where+  convert = toPixelRGB . (convert :: PNM.PgmPixel8 -> Pixel Y Double)++instance Convertible PNM.PgmPixel16 (Pixel RGB Double) where+  convert = toPixelRGB . (convert :: PNM.PgmPixel16 -> Pixel Y Double)++instance Convertible PNM.PpmPixelRGB8 (Pixel RGB Double) where+  convert (PNM.PpmPixelRGB8 r g b) = toDouble $ PixelRGB r g b++instance Convertible PNM.PpmPixelRGB16 (Pixel RGB Double) where+  convert (PNM.PpmPixelRGB16 r g b) = toDouble $ PixelRGB r g b+++-- -> RGBA (Double)++instance Convertible PNM.PbmPixel (Pixel RGBA Double) where+  convert = addAlpha 1 . (convert :: PNM.PbmPixel -> Pixel RGB Double)+  +instance Convertible PNM.PgmPixel8 (Pixel RGBA Double) where+  convert = addAlpha 1 . (convert :: PNM.PgmPixel8 -> Pixel RGB Double)++instance Convertible PNM.PgmPixel16 (Pixel RGBA Double) where+  convert = addAlpha 1 . (convert :: PNM.PgmPixel16 -> Pixel RGB Double)++instance Convertible PNM.PpmPixelRGB8 (Pixel RGBA Double) where+  convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB8 -> Pixel RGB Double)++instance Convertible PNM.PpmPixelRGB16 (Pixel RGBA Double) where+  convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB16 -> Pixel RGB Double)+++---- Exact precision conversions+++instance Convertible PNM.PbmPixel (Pixel Binary Bit) where+  convert (PNM.PbmPixel bool) = fromBool bool+  +instance Convertible PNM.PgmPixel8 (Pixel Y Word8) where+  convert (PNM.PgmPixel8 w8) = PixelY w8++instance Convertible PNM.PgmPixel16 (Pixel Y Word16) where+  convert (PNM.PgmPixel16 w16) = PixelY w16++instance Convertible PNM.PpmPixelRGB8 (Pixel RGB Word8) where+  convert (PNM.PpmPixelRGB8 r g b) = PixelRGB r g b++instance Convertible PNM.PpmPixelRGB16 (Pixel RGB Word16) where+  convert (PNM.PpmPixelRGB16 r g b) = PixelRGB r g b+++--------------------------------------------------------------------------------+-- Decoding images using Netpbm ------------------------------------------------+--------------------------------------------------------------------------------+++-- BMP Format Reading (general)++instance Array arr Y Double => Readable (Image arr Y Double) PBM where+  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm++instance Array arr Y Double => Readable (Image arr Y Double) PGM where+  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm++instance Array arr Y Double => Readable (Image arr Y Double) PPM where+  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm++instance Array arr YA Double => Readable (Image arr YA Double) PPM where+  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm++instance Array arr RGB Double => Readable (Image arr RGB Double) PPM where+  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm++instance Array arr RGBA Double => Readable (Image arr RGBA Double) PPM where+  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm++-- BMP Format Reading (exact)++instance Array arr Binary Bit => Readable (Image arr Binary Bit) PBM where+  decode _ = either Left (ppmToImageUsing pnmDataPBMToImage . head) . decodePnm++instance Array arr Y Word8 => Readable (Image arr Y Word8) PGM where+  decode _ = either Left (ppmToImageUsing pnmDataPGM8ToImage . head) . decodePnm++instance Array arr Y Word16 => Readable (Image arr Y Word16) PGM where+  decode _ = either Left (ppmToImageUsing pnmDataPGM16ToImage . head) . decodePnm++instance Array arr RGB Word8 => Readable (Image arr RGB Word8) PPM where+  decode _ = either Left (ppmToImageUsing pnmDataPPM8ToImage . head) . decodePnm++instance Array arr RGB Word16 => Readable (Image arr RGB Word16) PPM where+  decode _ = either Left (ppmToImageUsing pnmDataPPM16ToImage . head) . decodePnm+++instance Array arr Binary Bit => Readable [Image arr Binary Bit] [PBM] where+  decode _ = pnmToImagesUsing pnmDataPBMToImage++instance Array arr Y Word8 => Readable [Image arr Y Word8] [PGM] where+  decode _ = pnmToImagesUsing pnmDataPGM8ToImage++instance Array arr Y Word16 => Readable [Image arr Y Word16] [PGM] where+  decode _ = pnmToImagesUsing pnmDataPGM16ToImage++instance Array arr RGB Word8 => Readable [Image arr RGB Word8] [PPM] where+  decode _ = pnmToImagesUsing pnmDataPPM8ToImage++instance Array arr RGB Word16 => Readable [Image arr RGB Word16] [PPM] where+  decode _ = pnmToImagesUsing pnmDataPPM16ToImage+++pnmToImagesUsing :: (Int -> Int -> PNM.PpmPixelData -> Either [Char] b)+                 -> B.ByteString -> Either String [b]+pnmToImagesUsing conv =+  either Left (Right . map (either error id . ppmToImageUsing conv)) . decodePnm+++getPx :: (Storable a, Convertible a b) => VS.Vector a -> Int -> (Int, Int) -> b+getPx v w (i, j) = convert (v VS.! (i * w + j))+++pnmDataToImage :: (Array arr cs e, Convertible PNM.PbmPixel px,+                   Convertible PNM.PgmPixel16 px, Convertible PNM.PgmPixel8 px,+                   Convertible PNM.PpmPixelRGB16 px, Convertible PNM.PpmPixelRGB8 px) =>+                  (px -> Pixel cs e) -> Int -> Int -> PNM.PpmPixelData -> Image arr cs e+pnmDataToImage conv w h (PNM.PbmPixelData v)      = make (h, w) (conv . getPx v w)+pnmDataToImage conv w h (PNM.PgmPixelData8 v)     = make (h, w) (conv . getPx v w)+pnmDataToImage conv w h (PNM.PgmPixelData16 v)    = make (h, w) (conv . getPx v w)+pnmDataToImage conv w h (PNM.PpmPixelDataRGB8 v)  = make (h, w) (conv . getPx v w)+pnmDataToImage conv w h (PNM.PpmPixelDataRGB16 v) = make (h, w) (conv . getPx v w)+++pnmDataPBMToImage :: (Array arr cs e, Convertible PNM.PbmPixel (Pixel cs e)) =>+                     Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e)+pnmDataPBMToImage w h (PNM.PbmPixelData v) = Right $ make (h, w) (getPx v w)+pnmDataPBMToImage _ _ d                    = pnmCSError "Binary (Pixel Binary Bit)" d++pnmDataPGM8ToImage :: (Array arr cs e, Convertible PNM.PgmPixel8 (Pixel cs e)) =>+                      Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e)+pnmDataPGM8ToImage w h (PNM.PgmPixelData8 v) = Right $ make (h, w) (getPx v w)+pnmDataPGM8ToImage _ _ d                     = pnmCSError "Y8 (Pixel Y Word8)" d++pnmDataPGM16ToImage :: (Array arr cs e, Convertible PNM.PgmPixel16 (Pixel cs e)) =>+                       Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e)+pnmDataPGM16ToImage w h (PNM.PgmPixelData16 v) = Right $ make (h, w) (getPx v w)+pnmDataPGM16ToImage _ _ d                      = pnmCSError "Y16 (Pixel Y Word16)" d++pnmDataPPM8ToImage :: (Array arr cs e, Convertible PNM.PpmPixelRGB8 (Pixel cs e)) =>+                      Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e)+pnmDataPPM8ToImage w h (PNM.PpmPixelDataRGB8 v) = Right $ make (h, w) (getPx v w)+pnmDataPPM8ToImage _ _ d                        = pnmCSError "RGB8 (Pixel RGB Word8)" d++pnmDataPPM16ToImage :: (Array arr cs e, Convertible PNM.PpmPixelRGB16 (Pixel cs e)) =>+                       Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e)+pnmDataPPM16ToImage w h (PNM.PpmPixelDataRGB16 v) = Right $ make (h, w) (getPx v w)+pnmDataPPM16ToImage _ _ d                         = pnmCSError "RGB16 (Pixel RGB Word16)" d+++ppmToImageUsing :: (Int -> Int -> PNM.PpmPixelData -> t) -> PNM.PPM -> t+ppmToImageUsing conv (PNM.PPM { PNM.ppmHeader = PNM.PPMHeader { PNM.ppmWidth  = w+                                                              , PNM.ppmHeight = h }+                              , PNM.ppmData   = ppmData }) = conv w h ppmData+                                                        ++decodePnm :: B.ByteString -> Either String [PNM.PPM]+decodePnm = pnmResultToImage . PNM.parsePPM where+  pnmResultToImage (Right ([], _))   = pnmError "Unknown"+  pnmResultToImage (Right (ppms, _)) = Right ppms+  pnmResultToImage (Left err)        = pnmError err+++++pnmError :: String -> Either String a+pnmError err = Left ("Netpbm decoding error: "++err)+++pnmCSError :: String -> PNM.PpmPixelData -> Either String a+pnmCSError cs ppmData = pnmError ("Input image is in "++(pnmShowData ppmData)+++                                  ", cannot convert it to "++cs++" colorspace.")++pnmShowData :: PNM.PpmPixelData -> String+pnmShowData (PNM.PbmPixelData _)      = "Binary (Pixel Binary Bit)"+pnmShowData (PNM.PgmPixelData8 _)     = "Y8 (Pixel Y Word8)"+pnmShowData (PNM.PgmPixelData16 _)    = "Y16 (Pixel Y Word16)"+pnmShowData (PNM.PpmPixelDataRGB8 _)  = "RGB8 (Pixel RGB Word8)"+pnmShowData (PNM.PpmPixelDataRGB16 _) = "RGB8 (Pixel RGB Word8)"
+ src/Graphics/Image/Interface.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,+             MultiParamTypeClasses, ScopedTypeVariables,+             TypeFamilies, UndecidableInstances, ViewPatterns #-}++module Graphics.Image.Interface (+  ColorSpace(..), Alpha(..), Elevator(..),+  Array(..), ManifestArray(..), SequentialArray(..), MutableArray(..), +  Exchangable(..),+  defaultIndex, maybeIndex, Border(..), borderIndex+  ) where++import Prelude hiding (and, map, zipWith, sum, product)+import GHC.Exts (Constraint)+import Data.Typeable (Typeable, showsTypeRep, typeOf)+import Data.Monoid (Monoid)+import Control.DeepSeq (NFData(rnf))+import Data.Word+import Data.Foldable (Foldable(foldMap))+import Control.Applicative+import Control.Monad.Primitive (PrimMonad (..))+++-- | This class has all included color spaces installed into it and is also+-- intended for implementing any other possible custom color spaces. Every+-- instance of this class automatically installs an associated 'Pixel' into+-- 'Num', 'Fractional', 'Floating', 'Functor', 'Applicative' and 'Foldable',+-- which in turn make it possible to be used by the rest of the library.+class (Eq cs, Enum cs, Show cs, Typeable cs) => ColorSpace cs where+  +  -- | Representation of a pixel, such that it can be an element of any+  -- Array. Which is usally a tuple of channels or a channel itself for single+  -- channel color spaces.+  type PixelElt cs e++  -- | A concrete Pixel representation for a particular color space.+  data Pixel cs e++  -- | Construt a pixel by replicating a same value among all of the channels.+  fromChannel :: e -> Pixel cs e++  -- | Convert a Pixel to a representation suitable for storage as an unboxed+  -- element, usually a tuple of channels.+  toElt :: Pixel cs e -> PixelElt cs e++  -- | Convert from an elemnt representation back to a Pixel.+  fromElt :: PixelElt cs e -> Pixel cs e++  -- | Retrieve Pixel's channel value+  getPxCh :: Pixel cs e -> cs -> e+  +  -- | Map a channel aware function over all Pixel's channels.+  chOp :: (cs -> e' -> e) -> Pixel cs e' -> Pixel cs e ++  -- | Map a function over all Pixel's channels.+  pxOp :: (e' -> e) -> Pixel cs e' -> Pixel cs e++  -- | Function application to a Pixel.+  chApp :: Pixel cs (e' -> e) -> Pixel cs e' -> Pixel cs e++  -- | A pixel eqiuvalent of 'foldMap'.+  pxFoldMap :: Monoid m => (e -> m) -> Pixel cs e -> m+  ++class (ColorSpace (Opaque cs), ColorSpace cs) => Alpha cs where+  -- | An opaque version of this color space.+  type Opaque cs++  -- | Get an alpha channel of a transparant pixel. +  getAlpha :: Pixel cs e -> e++  -- | Add an alpha channel of an opaque pixel.+  --+  -- @ addAlpha 0 (PixelHSI 1 2 3) == PixelHSIA 1 2 3 0 @+  addAlpha :: e -> Pixel (Opaque cs) e -> Pixel cs e+  +  -- | Convert a transparent pixel to an opaque one by dropping the alpha+  -- channel.+  --+  -- @ dropAlpha (PixelRGBA 1 2 3 4) == PixelRGB 1 2 3 @+  --+  dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e++++-- | A class with a set of convenient functions that allow for changing precision of+-- channels within pixels, while scaling the values to keep them in an appropriate range.+--+-- >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double+-- >>> toWord8 rgb+-- <RGB:(0|128|255)>+--+class Elevator e where++  toWord8 :: ColorSpace cs => Pixel cs e -> Pixel cs Word8++  toWord16 :: ColorSpace cs => Pixel cs e -> Pixel cs Word16++  toWord32 :: ColorSpace cs => Pixel cs e -> Pixel cs Word32++  toWord64 :: ColorSpace cs => Pixel cs e -> Pixel cs Word64++  toFloat :: ColorSpace cs => Pixel cs e -> Pixel cs Float++  toDouble :: ColorSpace cs => Pixel cs e -> Pixel cs Double++  fromDouble :: ColorSpace cs => Pixel cs Double -> Pixel cs e++  +class (Show arr, ColorSpace cs, Num (Pixel cs e), Num e, Typeable e, Elt arr cs e) =>+      Array arr cs e where+  +  type Elt arr cs e :: Constraint+  type Elt arr cs e = ()+  data Image arr cs e++  -- | Create an Image by supplying it's dimensions and a pixel genrating+  -- function.+  make :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.+            -> ((Int, Int) -> Pixel cs e)+               -- ^ A function that takes (@i@-th row, and @j@-th column) as an+               -- argument and returns a pixel for that location.+            -> Image arr cs e++  -- | Create a singleton image, required for various operations on images with+  -- a scalar.+  singleton :: Pixel cs e -> Image arr cs e++  -- | Get dimensions of an image.+  --+  -- >>> frog <- readImageRGB "images/frog.jpg"+  -- >>> frog+  -- <Image RepaDelayed RGB: 200x320>+  -- >>> dims frog+  -- (200,320)+  --+  dims :: Image arr cs e -> (Int, Int)++  -- | Map a function over a an image.+  map :: Array arr cs' e' =>+         (Pixel cs' e' -> Pixel cs e)+         -- ^ A function that takes a pixel of a source image and returns a pixel+         -- for the result image a the same location.+      -> Image arr cs' e' -- ^ Source image.+      -> Image arr cs  e  -- ^ Result image.++  -- | Map an index aware function over each pixel in an image.+  imap :: Array arr cs' e' =>+          ((Int, Int) -> Pixel cs' e' -> Pixel cs e)+        -- ^ A function that takes an index @(i, j)@, a pixel at that location+        -- and returns a new pixel at the same location for the result image.+       -> Image arr cs' e' -- ^ Source image.+       -> Image arr cs e   -- ^ Result image.++  -- | Zip two images with a function+  zipWith :: (Array arr cs1 e1, Array arr cs2 e2) =>+             (Pixel cs1 e1 -> Pixel cs2 e2 -> Pixel cs e)+          -> Image arr cs1 e1 -> Image arr cs2 e2 -> Image arr cs e++  -- | Zip two images with an index aware function+  izipWith :: (Array arr cs1 e1, Array arr cs2 e2) =>+              ((Int, Int) -> Pixel cs1 e1 -> Pixel cs2 e2 -> Pixel cs e)+           -> Image arr cs1 e1 -> Image arr cs2 e2 -> Image arr cs e++  -- | Traverse an image+  traverse :: Array arr cs' e' =>+              Image arr cs' e' -- ^ Source image.+           -> ((Int, Int) -> (Int, Int))+           -- ^ Function that takes dimensions of a source image and returns+           -- dimensions of a new image.+           -> (((Int, Int) -> Pixel cs' e') ->+               (Int, Int) -> Pixel cs e)+           -- ^ Function that receives a pixel getter (a source image index+           -- function), a location @(i, j)@ in a new image and returns a pixel+           -- for that location.+           -> Image arr cs e+  +  -- | Traverse two images.+  traverse2 :: (Array arr cs1 e1, Array arr cs2 e2) =>+               Image arr cs1 e1 -- ^ First source image.+            -> Image arr cs2 e2 -- ^ Second source image.+            -> ((Int, Int) -> (Int, Int) -> (Int, Int))+            -- ^ Function that produces dimensions for the new image.+            -> (((Int, Int) -> Pixel cs1 e1) ->+                ((Int, Int) -> Pixel cs2 e2) ->+                (Int, Int) -> Pixel cs e)+            -- ^ Function that produces pixels for the new image.+            -> Image arr cs e+  +  -- | Transpose an image+  transpose :: Image arr cs e -> Image arr cs e++  -- | Backwards permutation of an image. +  backpermute :: (Int, Int) -- ^ Dimensions of a result image.+              -> ((Int, Int) -> (Int, Int))+                 -- ^ Function that maps an index of a source image to an index+                 -- of a result image.+              -> Image arr cs e -- ^ Source image.+              -> Image arr cs e -- ^ Result image.++  -- | Construct an image from a nested rectangular shaped list of pixels.+  -- Length of an outer list will constitute @m@ rows, while the length of inner lists -+  -- @n@ columns. All of the inner lists must be the same length and greater than @0@.+  --+  -- >>> fromLists [[PixelY (fromIntegral (i*j) / 60000) | j <- [1..300]] | i <- [1..200]] :: Image VU Y Double+  -- <Image VectorUnboxed Luma: 200x300>+  --+  -- <<images/grad_fromLists.png>>+  --+  fromLists :: [[Pixel cs e]]+            -> Image arr cs e+++class Array arr cs e => ManifestArray arr cs e where++  -- | Get a pixel at @i@-th and @j@-th location.+  --+  -- >>> let grad_gray = computeS $ makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200)+  -- >>> index grad_gray (20, 30) == PixelY ((20*30) / (200*200))+  -- True+  --+  index :: Image arr cs e -> (Int, Int) -> Pixel cs e+  +  -- | Make sure that an image is fully evaluated.+  deepSeqImage :: Image arr cs e -> a -> a++  -- | Perform matrix multiplication on two images. Inner dimensions must agree.+  (|*|) :: Image arr cs e -> Image arr cs e -> Image arr cs e++  -- | Undirected reduction of an image.+  fold :: (Pixel cs e -> Pixel cs e -> Pixel cs e) -- ^ An associative folding function.+       -> Pixel cs e -- ^ Initial element, that is neutral with respect to the folding function.+       -> Image arr cs e -- ^ Source image.+       -> Pixel cs e++  -- | Pixelwise equality function of two images. Images are+  -- considered distinct if either images' dimensions or at least one pair of+  -- corresponding pixels are not the same. Used in defining an in instance for+  -- the 'Eq' typeclass.+  eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool+++class ManifestArray arr cs e => SequentialArray arr cs e where++  foldl :: (a -> Pixel cs e -> a) -> a -> Image arr cs e -> a++  foldr :: (Pixel cs e -> a -> a) -> a -> Image arr cs e -> a++  mapM :: (Array arr cs' e', Monad m) =>+          (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m (Image arr cs e)++  mapM_ :: (Array arr cs' e', Monad m) =>+           (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m ()++  foldM :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m a++  foldM_ :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m ()+++class ManifestArray arr cs e => MutableArray arr cs e where+  data MImage st arr cs e++  mdims :: MImage st arr cs e -> (Int, Int)++  thaw :: PrimMonad m => Image arr cs e -> m (MImage (PrimState m) arr cs e)++  freeze :: PrimMonad m => MImage (PrimState m) arr cs e -> m (Image arr cs e)++  new :: PrimMonad m => (Int, Int) -> m (MImage (PrimState m) arr cs e)++  read :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> m (Pixel cs e)++  write :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m ()++  swap :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m ()+++class Exchangable arr' arr where++  -- | Exchange the underlying array representation of an image.+  exchange :: (Array arr' cs e, Array arr cs e) =>+              arr -- ^ New representation of an image.+           -> Image arr' cs e -- ^ Source image.+           -> Image arr cs e+++-- | Changing to the same array representation as before is disabled and `changeTo`+-- will behave simply as an identitity function.+instance Exchangable arr arr where++  exchange _ = id+  {-# INLINE exchange #-}++++-- | Approach to be used near the border during transformations, which, besides a pixel+-- of interest, also use it's neighbors, consequently going out of bounds at the+-- edges of an image.+data Border px =+  Fill !px    -- ^ Fill in a constant pixel.+              --+              -- @+              --            outside |  Image  | outside+              -- ('Fill' 0) : 0 0 0 0 | 1 2 3 4 | 0 0 0 0+              -- @+              --+  | Wrap      -- ^ Wrap around from the opposite border of the image.+              --+              -- @+              --            outside |  Image  | outside+              -- 'Wrap' :     1 2 3 4 | 1 2 3 4 | 1 2 3 4+              -- @+              --+  | Edge      -- ^ Replicate the pixel at the edge.+              --+              -- @+              --            outside |  Image  | outside+              -- 'Edge' :     1 1 1 1 | 1 2 3 4 | 4 4 4 4+              -- @+              --+  | Reflect   -- ^ Mirror like reflection.+              --+              -- @+              --            outside |  Image  | outside+              -- 'Reflect' :  4 3 2 1 | 1 2 3 4 | 4 3 2 1+              -- @+              --+  | Continue  -- ^ Also mirror like reflection, but without repeating the edge pixel.+              --+              -- @+              --            outside |  Image  | outside+              -- 'Continue' : 1 4 3 2 | 1 2 3 4 | 3 2 1 4+              -- @+              --++-- | Border handling function. If @(i, j)@ location is within bounds, then supplied+-- lookup function will be used, otherwise it will be handled according to a+-- supplied border strategy.+borderIndex :: Border (Pixel cs e) -- ^ Border handling strategy.+            -> (Int, Int) -- ^ Image dimensions+            -> ((Int, Int) -> Pixel cs e) -- ^ Image's indexing function.+            -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup.+            -> Pixel cs e+borderIndex border !(m, n) !getPx !(i, j) =+  if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else getPxB border where+    getPxB (Fill px) = px+    getPxB Wrap      = getPx (i `mod` m, j `mod` n)+    getPxB Edge      = getPx (if i < 0 then 0 else if i >= m then m - 1 else i,+                              if j < 0 then 0 else if j >= n then n - 1 else j)+    getPxB Reflect   = getPx (if i < 0 then (abs i - 1) `mod` m else+                                if i >= m then (m - (i - m + 1)) `mod` m else i,+                              if j < 0 then (abs j - 1) `mod` n else+                                if j >= n then (n - (j - n + 1)) `mod` n else j)+    getPxB Continue  = getPx (if i < 0 then abs i `mod` m else+                                if i >= m then m - (i - m + 2) `mod` m else i,+                              if j < 0 then abs j `mod` n else+                                if j >= n then n - (j - n + 2) `mod` n else j)+    {-# INLINE getPxB #-}+{-# INLINE borderIndex #-}+++-- | Image indexing function that returns a default pixel if index is out of bounds.+defaultIndex :: ManifestArray arr cs e =>+                Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e+defaultIndex !px !img = borderIndex (Fill px) (dims img) (index img)+{-# INLINE defaultIndex #-}+++-- | Image indexing function that returns 'Nothing' if index is out of bounds,+-- 'Just' pixel otherwise.+maybeIndex :: ManifestArray arr cs e =>+              Image arr cs e -> (Int, Int) -> Maybe (Pixel cs e)+maybeIndex !img@(dims -> (m, n)) !(i, j) =+  if i >= 0 && j >= 0 && i < m && j < n then Just $ index img (i, j) else Nothing+{-# INLINE maybeIndex #-}++++instance ColorSpace cs => Functor (Pixel cs) where++  fmap = pxOp+  +instance ColorSpace cs => Applicative (Pixel cs) where++  pure = fromChannel++  (<*>) = chApp++instance ColorSpace cs => Foldable (Pixel cs) where++  foldMap = pxFoldMap+++instance (ColorSpace cs, Num e) => Num (Pixel cs e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  +  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  +  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  +  abs         = liftA abs+  {-# INLINE abs #-}+  +  signum      = liftA signum+  {-# INLINE signum #-}+  +  fromInteger = pure . fromInteger+  {-# INLINE fromInteger#-}+  ++instance (ColorSpace cs, Fractional e) => Fractional (Pixel cs e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  +  recip        = liftA recip+  {-# INLINE recip #-}++  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance (ColorSpace cs, Floating e) => Floating (Pixel cs e) where+  pi      = fromChannel pi+  {-# INLINE pi #-}++  exp     = liftA exp+  {-# INLINE exp #-}++  log     = liftA log+  {-# INLINE log #-}+  +  sin     = liftA sin+  {-# INLINE sin #-}+  +  cos     = liftA cos+  {-# INLINE cos #-}+  +  asin    = liftA asin+  {-# INLINE asin #-}+  +  atan    = liftA atan+  {-# INLINE atan #-}+  +  acos    = liftA acos+  {-# INLINE acos #-}+  +  sinh    = liftA sinh+  {-# INLINE sinh #-}+  +  cosh    = liftA cosh+  {-# INLINE cosh #-}+  +  asinh   = liftA asinh+  {-# INLINE asinh #-}+  +  atanh   = liftA atanh+  {-# INLINE atanh #-}+  +  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance (ManifestArray arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where+  (==) = eq+  {-# INLINE (==) #-}++  +instance Array arr cs e => Num (Image arr cs e) where+  (+)         = zipWith (+)+  {-# INLINE (+) #-}+  +  (-)         = zipWith (-)+  {-# INLINE (-) #-}+  +  (*)         = zipWith (*)+  {-# INLINE (*) #-}+  +  abs         = map abs+  {-# INLINE abs #-}+  +  signum      = map signum+  {-# INLINE signum #-}+  +  fromInteger = singleton . fromInteger+  {-# INLINE fromInteger#-}+++instance (Fractional (Pixel cs e), Fractional e, Array arr cs e) =>+         Fractional (Image arr cs e) where+  (/)          = zipWith (/)+  {-# INLINE (/) #-}+  +  fromRational = singleton . fromRational +  {-# INLINE fromRational #-}+++instance (Floating (Pixel cs e), Floating e, Array arr cs e) =>+         Floating (Image arr cs e) where+  pi    = singleton pi+  {-# INLINE pi #-}+  +  exp   = map exp+  {-# INLINE exp #-}+  +  log   = map log+  {-# INLINE log#-}+  +  sin   = map sin+  {-# INLINE sin #-}+  +  cos   = map cos+  {-# INLINE cos #-}+  +  asin  = map asin+  {-# INLINE asin #-}+  +  atan  = map atan+  {-# INLINE atan #-}+  +  acos  = map acos+  {-# INLINE acos #-}+  +  sinh  = map sinh+  {-# INLINE sinh #-}+  +  cosh  = map cosh+  {-# INLINE cosh #-}+  +  asinh = map asinh+  {-# INLINE asinh #-}+  +  atanh = map atanh+  {-# INLINE atanh #-}+  +  acosh = map acosh+  {-# INLINE acosh #-}  +++instance ManifestArray arr cs e => NFData (Image arr cs e) where+  rnf img = img `deepSeqImage` ()+  {-# INLINE rnf #-}++++instance Array arr cs e => Show (Image arr cs e) where+  show ((dims -> (m, n)) :: Image arr cs e) =+    "<Image "++show (undefined :: arr)++" "+++    ((showsTypeRep (typeOf (undefined :: cs))) " (")+++    ((showsTypeRep (typeOf (undefined :: e))) "): "++show m++"x"++show n++">")+++instance MutableArray arr cs e => Show (MImage st arr cs e) where+  show ((mdims -> (m, n)) :: MImage st arr cs e) =+    "<MutableImage "++show (undefined :: arr)++" "+++    ((showsTypeRep (typeOf (undefined :: cs))) " (")+++    ((showsTypeRep (typeOf (undefined :: e))) "): "++show m++"x"++show n++">")++
+ src/Graphics/Image/Interface/Repa.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts #-}+module Graphics.Image.Interface.Repa (+  -- * Construction+  makeImage,+  -- * IO+  readImageY, readImageYA, readImageRGB, readImageRGBA,+  -- * Computation+  computeS, computeP, delay,+  -- * Representation+  RD(..), RS(..), RP(..),+  ) where++import Graphics.Image.IO+import Graphics.Image.Interface+import Graphics.Image.Interface.Repa.Internal+import Graphics.Image.ColorSpace+++-- | Create a delayed representation of an image.+makeImage :: Array RD cs Double =>+             (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.+          -> ((Int, Int) -> Pixel cs Double)+             -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument+             -- and returns a pixel for that location.+          -> Image RD cs Double+makeImage = make+{-# INLINE makeImage #-}+++-- | Read image as luma (brightness).+readImageY :: FilePath -> IO (Image RD Y Double)+readImageY = fmap (either error id) . readImage+{-# INLINE readImageY #-}+++-- | Read image as luma with 'Alpha' channel.+readImageYA :: FilePath -> IO (Image RD YA Double)+readImageYA = fmap (either error id) . readImage+{-# INLINE readImageYA #-}+++-- | Read image in RGB colorspace.+readImageRGB :: FilePath -> IO (Image RD RGB Double)+readImageRGB = fmap (either error id) . readImage+{-# INLINE readImageRGB #-}+++-- | Read image in RGB colorspace with 'Alpha' channel.+readImageRGBA :: FilePath -> IO (Image RD RGBA Double)+readImageRGBA = fmap (either error id) . readImage+{-# INLINE readImageRGBA #-}+
+ src/Graphics/Image/Interface/Repa/Internal.hs view
@@ -0,0 +1,476 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns, ConstraintKinds, GADTs, FlexibleContexts, FlexibleInstances,+             MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies,+             UndecidableInstances, ViewPatterns #-}++module Graphics.Image.Interface.Repa.Internal (+  RD(..), RP(..), RS(..), computeP, computeS, delay+  ) where++import Prelude hiding (map, zipWith, foldl, foldr, mapM, mapM_, read)+import qualified Prelude as P (map, mapM_)+import Graphics.Image.Interface+import Graphics.Image.ColorSpace.Binary (Bit(..))+import Graphics.Image.Interface.Vector.Unboxed (VU(..), fromUnboxedVector, toUnboxedVector)+import Control.Monad (liftM)+import Data.Array.Repa.Repr.Unboxed (Unbox)+import qualified Data.Vector.Unboxed as V ((!))+import Data.Function (on)+import Data.Typeable (Typeable)+import Data.Array.Repa hiding (+  Array, map, zipWith, rank, index, traverse, (++), computeP, computeS, delay,+  traverse, traverse2, transpose, backpermute)+import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.Eval as R (Elt(..), suspendedComputeP)+++-- | Repa 'D'elayed Array representation, which allows for fusion of computation.+data RD = RD++-- | Repa 'U'nboxed Array representation, which is computed in parallel.+data RP = RP++-- | Repa 'U'nboxed Array representation, which is computed sequentially. +data RS = RS++instance Show RD where+  show _ = "RepaDelayed"++instance Show RP where+  show _ = "RepaParallel"+  +instance Show RS where+  show _ = "RepaSequential"++instance Elt RD cs e => Array RD cs e where+  type Elt RD cs e = (ColorSpace cs, Num e, Typeable e,+                      R.Elt e, Unbox e, +                      R.Elt (PixelElt cs e), Unbox (PixelElt cs e),+                      R.Elt (Pixel cs e), Unbox (Pixel cs e))+  data Image RD cs e where+    RScalar :: !(Pixel cs e)                  -> Image RD cs e+    RUImage :: !(R.Array U DIM2 (Pixel cs e)) -> Image RD cs e+    RDImage :: !(R.Array D DIM2 (Pixel cs e)) -> Image RD cs e++  dims (RScalar _                        ) = (1, 1)+  dims (RUImage (extent -> (Z :. m :. n))) = (m, n)+  dims (RDImage (extent -> (Z :. m :. n))) = (m, n)+  {-# INLINE dims #-}++  singleton = RScalar+  {-# INLINE singleton #-}++  make !(m, n) !f = RDImage $ fromFunction (Z :. m :. n) (f . shT2)+  {-# INLINE make #-}++  map f (RScalar px)        = RScalar (f px)+  map f (getDelayed -> arr) = RDImage (R.map f arr)+  {-# INLINE map #-}++  imap f (RScalar px)  = RScalar (f (0, 0) px)+  imap f (getDelayed -> arr) = RDImage (R.zipWith f (R.fromFunction (extent arr) shT2) arr)+  {-# INLINE imap #-}+    +  zipWith f (RScalar px1)        (RScalar px2)        = RScalar (f px1 px2)+  zipWith f (RScalar px1)        (getDelayed -> arr2) = RDImage (R.map (f   px1) arr2)+  zipWith f (getDelayed -> arr1) (RScalar px2)        = RDImage (R.map (`f` px2) arr1)+  zipWith f (getDelayed -> arr1) (getDelayed -> arr2) = RDImage (R.zipWith f arr1 arr2)+  {-# INLINE zipWith #-}++  izipWith f (RScalar px1)        (RScalar px2)        = RScalar (f (0, 0) px1 px2)+  izipWith f (RScalar px1)        !img2                = imap (flip f px1) img2+  izipWith f !img1                (RScalar px2)        = imap (\ !ix !px -> f ix px px2) img1+  izipWith f (getDelayed -> arr1) (getDelayed -> arr2) =+    RDImage (R.traverse2 arr1 arr2 const getNewPx) where+      getNewPx !getPx1 !getPx2 !sh = f (shT2 sh) (getPx1 sh) (getPx2 sh)+      {-# INLINE getNewPx #-}+  {-# INLINE izipWith #-}++  traverse (getDelayed -> arr) newDims newPx =+    RDImage $ R.traverse arr (tSh2 . newDims . shT2) newPixel where+    newPixel getPx = newPx (getPx . tSh2) . shT2+  {-# INLINE traverse #-}++  traverse2 (getDelayed -> arr1) (getDelayed -> arr2) newDims newPx =+    RDImage $ R.traverse2 arr1 arr2 (((.).(.)) tSh2 (newDims `on` shT2)) newPixel where+    newPixel getPx1 getPx2 = newPx (getPx1 . tSh2) (getPx2 . tSh2) . shT2+  {-# INLINE traverse2 #-}++  transpose (RDImage arr) = RDImage (R.transpose arr)+  transpose (RUImage arr) = RDImage (R.transpose arr)+  transpose img           = img+  {-# INLINE transpose #-}++  backpermute _ _ img@(RScalar _)                = img+  backpermute (tSh2 -> sh) g (getDelayed -> arr) =+    RDImage (R.backpermute sh (tSh2 . g . shT2) arr)+  {-# INLINE backpermute #-}++  fromLists !ls = if isSquare+                  then RUImage . R.fromListUnboxed (Z :. m :. n) . concat $ ls+                  else error "fromLists: Inner lists do not all have an equal length."+    where+      !(m, n) = (length ls, length $ head ls)+      !isSquare = (n > 0) && all (==n) (P.map length ls)+  {-# INLINE fromLists #-}+  +++instance Elt RS cs e => Array RS cs e where+  type Elt RS cs e = (ColorSpace cs, +                      R.Elt e, Unbox e, Num e, Typeable e,+                      R.Elt (PixelElt cs e), Unbox (PixelElt cs e),+                      R.Elt (Pixel cs e), Unbox (Pixel cs e))+  +  data Image RS cs e where+    RSImage :: !(Image RD cs e) -> Image RS cs e++  dims (RSImage img) = dims img+  {-# INLINE dims #-}++  make !ix !f = computeS $ (make ix f :: Image RD cs e)+  {-# INLINE make #-}++  singleton = RSImage . singleton+  {-# INLINE singleton #-}++  map !f (RSImage img) = computeS . map f $ img+  {-# INLINE map #-}++  imap !f (RSImage img) = computeS . imap f $ img+  {-# INLINE imap #-}++  zipWith !f (RSImage img1) (RSImage img2) = computeS . zipWith f img1 $ img2+  {-# INLINE zipWith #-}++  izipWith !f (RSImage img1) (RSImage img2) = computeS . izipWith f img1 $ img2+  {-# INLINE izipWith #-}++  traverse (RSImage img) newDims = computeS . traverse img newDims +  {-# INLINE traverse #-}++  traverse2 (RSImage img1) (RSImage img2) newDims = computeS . traverse2 img1 img2 newDims +  {-# INLINE traverse2 #-}++  transpose (RSImage img) = computeS . transpose $ img+  {-# INLINE transpose #-}+  +  backpermute !f !g (RSImage img) = computeS $ backpermute f g img+  {-# INLINE backpermute #-}++  fromLists = RSImage . fromLists+  {-# INLINE fromLists #-}++++instance Elt RP cs e => Array RP cs e where+  type Elt RP cs e = (ColorSpace cs, +                      R.Elt e, Unbox e, Num e, Typeable e,+                      R.Elt (PixelElt cs e), Unbox (PixelElt cs e),+                      R.Elt (Pixel cs e), Unbox (Pixel cs e))+  +  data Image RP cs e where+    RPImage :: !(Image RD cs e) -> Image RP cs e++  dims (RPImage img) = dims img+  {-# INLINE dims #-}++  make !ix = suspendedComputeP . make ix+  {-# INLINE make #-}++  singleton = RPImage . singleton+  {-# INLINE singleton #-}++  map !f (RPImage img) = suspendedComputeP . map f $ img+  {-# INLINE map #-}++  imap !f (RPImage img) = suspendedComputeP . imap f $ img+  {-# INLINE imap #-}++  zipWith !f (RPImage img1) (RPImage img2) = suspendedComputeP . zipWith f img1 $ img2+  {-# INLINE zipWith #-}++  izipWith !f (RPImage img1) (RPImage img2) = suspendedComputeP . izipWith f img1 $ img2+  {-# INLINE izipWith #-}++  traverse (RPImage img) newDims = suspendedComputeP . traverse img newDims +  {-# INLINE traverse #-}++  traverse2 (RPImage img1) (RPImage img2) newDims =+    suspendedComputeP . traverse2 img1 img2 newDims +  {-# INLINE traverse2 #-}++  transpose (RPImage img) = suspendedComputeP . transpose $ img+  {-# INLINE transpose #-}+  +  backpermute !f !g (RPImage img) = suspendedComputeP $ backpermute f g img+  {-# INLINE backpermute #-}++  fromLists = RPImage . fromLists+  {-# INLINE fromLists #-}+++  +instance Array RS cs e => ManifestArray RS cs e where++  index (RSImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j)+  index (RSImage (RScalar px))  (_, _) = px+  index _ _ = _error_compute+  {-# INLINE index #-}++  deepSeqImage (RSImage (RUImage arr)) = deepSeqArray arr+  deepSeqImage (RSImage (RScalar px))  = seq px+  deepSeqImage _ = _error_compute+  {-# INLINE deepSeqImage #-}++  (|*|) i1@(RSImage img1) i2@(RSImage img2) =+    i1 `deepSeqImage` i2 `deepSeqImage` computeS (mult img1 img2)+  {-# INLINE (|*|) #-}++  fold !f !px0 (RSImage (RUImage arr)) = R.foldAllS f px0 $ arr+  fold !f !px0 (RSImage (RScalar px))  = f px0 px+  fold _  _  _ = _error_compute+  {-# INLINE fold #-}++  eq (RSImage (RUImage arr1)) (RSImage (RUImage arr2)) = R.equalsS arr1 arr2+  eq _ _ = _error_compute+  {-# INLINE eq #-}+++instance Array RP cs e => ManifestArray RP cs e where++  index (RPImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j)+  index (RPImage (RScalar px))  (0, 0) = px+  index (RPImage (RScalar _))   (_, _) = error "Scalar Image can only be indexed at (0,0)."+  index _ _ = _error_compute+  {-# INLINE index #-}++  deepSeqImage (RPImage (RUImage arr)) = deepSeqArray arr+  deepSeqImage (RPImage (RScalar px))  = seq px+  deepSeqImage _ = _error_compute+  {-# INLINE deepSeqImage #-}++  (|*|) i1@(RPImage img1) i2@(RPImage img2) =+    i1 `deepSeqImage` i2 `deepSeqImage` suspendedComputeP (mult img1 img2)+  {-# INLINE (|*|) #-}++  fold !f !px0 (RPImage (RUImage arr)) = head . R.foldAllP f px0 $ arr+  fold !f !px0 (RPImage (RScalar px))  = f px0 px+  fold _  _  _ = _error_compute+  {-# INLINE fold #-}++  eq (RPImage (RUImage arr1)) (RPImage (RUImage arr2)) = head $ R.equalsP arr1 arr2+  eq _ _ = _error_compute+  {-# INLINE eq #-}++  +instance ManifestArray RS cs e => SequentialArray RS cs e where++  foldl !f !a = foldl f a . exchange VU+  {-# INLINE foldl #-}++  foldr !f !a = foldr f a . exchange VU+  {-# INLINE foldr #-}++  mapM !f img = liftM (exchange RS) (mapM f (exchange VU img))+  {-# INLINE mapM #-}++  mapM_ !f img = mapM_ f (exchange VU img)+  {-# INLINE mapM_ #-}++  foldM !f !a = foldM f a . exchange VU+  {-# INLINE foldM #-}++  foldM_ !f !a = foldM_ f a . exchange VU+  {-# INLINE foldM_ #-}+++instance ManifestArray RS cs e => MutableArray RS cs e where++  data MImage st RS cs e where+    MRSImage :: MImage st VU cs e -> MImage st RS cs e++  mdims (MRSImage (mdims -> sz)) = sz+  {-# INLINE mdims #-}++  thaw img = liftM MRSImage (thaw (exchange VU img))+  {-# INLINE thaw #-}++  freeze (MRSImage mimg) = liftM (exchange RS) (freeze mimg)+  {-# INLINE freeze #-}++  new sz = liftM MRSImage (new sz)+  {-# INLINE new #-}++  read (MRSImage mimg) = read mimg+  {-# INLINE read #-}+  +  write (MRSImage mimg) = write mimg+  {-# INLINE write #-}++  swap (MRSImage mimg) = swap mimg+  {-# INLINE swap #-}+++-- | O(1) - Delays manifest array.+instance Exchangable RS RD where++  exchange _ (RSImage img) = img+  {-# INLINE exchange #-}+++-- | O(1) - Delays manifest array.+instance Exchangable RP RD where+  +  exchange _ (RPImage img) = img+  {-# INLINE exchange #-}++-- | Computes delayed array sequentially.+instance Exchangable RD RS where    ++  exchange _ (RDImage arr) = RSImage . RUImage . R.computeS $ arr+  exchange _ img           = RSImage img+  {-# INLINE exchange #-}+++-- | O(1) - Changes computation strategy.+instance Exchangable RP RS where+  +  exchange _ (RPImage img) = RSImage img+  {-# INLINE exchange #-}+++-- | Computes delayed array in parallel.+instance Exchangable RD RP where+  +  exchange _ (RDImage arr) = RPImage . RUImage . R.suspendedComputeP $ arr+  exchange _ img           = RPImage img+  {-# INLINE exchange #-}+++-- | O(1) - Changes computation strategy.+instance Exchangable RS RP where+  +  exchange _ (RSImage img) = RPImage img+  {-# INLINE exchange #-}++-- | O(1) - Changes to Repa representation.+instance Exchangable VU RS where+  exchange _ img@(dims -> (1, 1)) = singleton (toUnboxedVector img V.! 0)+  exchange _ img = RSImage . RUImage . R.fromUnboxed (tSh2 $ dims img) . toUnboxedVector $ img+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Repa representation.+instance Exchangable VU RP where+  exchange _ img@(dims -> (1, 1)) = singleton (toUnboxedVector img V.! 0)+  exchange _ img = RPImage . RUImage . R.fromUnboxed (tSh2 $ dims img) . toUnboxedVector $ img+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Vector representation.+instance Exchangable RS VU where+  exchange _ img@(RSImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr)+  exchange _ (RSImage (RScalar px)) = singleton px+  exchange _ _                     = _error_compute+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Vector representation.+instance Exchangable RP VU where+  exchange _ img@(RPImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr)+  exchange _ (RPImage (RScalar px)) = singleton px+  exchange _ _                     = _error_compute+  {-# INLINE exchange #-}++-- | Computes an image in parallel and ensures that all elements are evaluated.+computeP :: (Array arr cs e, Array RP cs e, Exchangable arr RP) =>+            Image arr cs e -> Image RP cs e+computeP !img = head $ do+  img' <- return $ exchange RP img+  img' `deepSeqImage` return img'+{-# INLINE computeP #-}++-- | Computes an image sequentially and ensures that all elements are evaluated.+computeS :: (Array arr cs e, Array RS cs e, Exchangable arr RS) =>+            Image arr cs e -> Image RS cs e+computeS !img = head $ do+  img' <- return $ exchange RS img+  img' `deepSeqImage` return img'+{-# INLINE computeS #-}++-- | Delays an image, so further operations can be fused together.+delay :: (ManifestArray arr cs e, Array RD cs e, Exchangable arr RD) =>+         Image arr cs e -> Image RD cs e+delay = exchange RD+{-# INLINE delay #-}+++mult :: Array RD cs e => Image RD cs e -> Image RD cs e -> Image RD cs e+mult img1@(RUImage arr1) img2@(RUImage arr2) =+  if n1 /= m2 +  then error ("Inner dimensions of multiplied images must be the same, but received: "+++              show img1 ++" X "++ show img2)+  else RDImage . fromFunction (Z :. m1 :. n2) $ getPx where+    (Z :. m1 :. n1) = extent arr1+    (Z :. m2 :. n2) = extent arr2+    getPx (Z :. i :. j) =+      sumAllS (slice arr1 (Any :. (i :: Int) :. All) *^ slice arr2 (Any :. (j :: Int)))+    {-# INLINE getPx #-}+mult _ _ = _error_compute+{-# INLINE mult #-}+++shT2 :: DIM2 -> (Int, Int)+shT2 !(Z :. i :. j) = (i, j)+{-# INLINE shT2 #-}++tSh2 :: (Int, Int) -> DIM2+tSh2 !(i, j) = (Z :. i :. j) +{-# INLINE tSh2 #-}+++suspendedComputeP :: Array RD cs e =>+                     Image RD cs e -> Image RP cs e+suspendedComputeP (RDImage arr) = RPImage . RUImage . R.suspendedComputeP $ arr+suspendedComputeP !img          = RPImage img+{-# INLINE suspendedComputeP #-}+++getDelayed :: Array RD cs e => Image RD cs e -> R.Array D DIM2 (Pixel cs e)+getDelayed (RUImage arr) = R.delay arr+getDelayed (RDImage arr) = arr+getDelayed _             = error "Scalar image is not an array."+{-# INLINE getDelayed #-}++  +_error_compute :: t+_error_compute = error "Image should be computed at ths point. Please report this error"+                         +_error_scalar_op :: t+_error_scalar_op =+  error "This operation is not allowed on scalar images."+++instance R.Elt Bit where+  touch (Bit w) = R.touch w+  {-# INLINE touch #-}+  +  zero     = 0+  {-# INLINE zero #-}+  +  one      = 1+  {-# INLINE one #-}+++instance (ColorSpace cs, R.Elt e, Num e) => R.Elt (Pixel cs e) where+  touch !px = P.mapM_ (R.touch . getPxCh px) (enumFrom (toEnum 0)) +  {-# INLINE touch #-}+  +  zero     = 0+  {-# INLINE zero #-}+  +  one      = 1+  {-# INLINE one #-}++
+ src/Graphics/Image/Interface/Vector.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleContexts #-}+module Graphics.Image.Interface.Vector (+  -- * Construction+  makeImage, fromUnboxedVector, toUnboxedVector,+  -- * IO+  readImageY, readImageYA, readImageRGB, readImageRGBA,+  -- * Representation+  VU(..), +  ) where++import Graphics.Image.IO+import Graphics.Image.Interface+import Graphics.Image.Interface.Vector.Unboxed+import Graphics.Image.ColorSpace+++-- | Create an image with 'VU' (Vector Unboxed) representation and pixels of 'Double'+-- precision. Note, that for 'Double' precision pixels it is essential to keep values+-- normalized in the @[0, 1]@ range in order for an image to be written to file+-- properly.+--+-- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY (fromIntegral i)/200 * (fromIntegral j)/200)+--+-- Because all 'Pixel's and 'Image's are installed into 'Num', above is equivalent to:+--+-- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200)+-- >>> writeImage "images/grad_gray.png" grad_gray+--+-- Creating color images is just as easy.+--+-- >>> let grad_color = makeImage (200, 200) (\(i, j) -> PixelRGB (fromIntegral i) (fromIntegral j) (fromIntegral (i + j))) / 400+-- >>> writeImage "images/grad_color.png" grad_color+--+-- <<images/grad_gray.png>> <<images/grad_color.png>>+--+makeImage :: Array VU cs Double =>+             (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.+          -> ((Int, Int) -> Pixel cs Double)+             -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument+             -- and returns a pixel for that location.+          -> Image VU cs Double+makeImage = make+{-# INLINE makeImage #-}+++-- | Read luma (brightness) of an image.+readImageY :: FilePath -> IO (Image VU Y Double)+readImageY = fmap (either error id) . readImage+{-# INLINE readImageY #-}+++-- | Read image as luma with 'Alpha' channel.+readImageYA :: FilePath -> IO (Image VU YA Double)+readImageYA = fmap (either error id) . readImage+{-# INLINE readImageYA #-}+++-- | Read image in RGB colorspace.+readImageRGB :: FilePath -> IO (Image VU RGB Double)+readImageRGB = fmap (either error id) . readImage+{-# INLINE readImageRGB #-}+++-- | Read image in RGB colorspace with 'Alpha' channel.+readImageRGBA :: FilePath -> IO (Image VU RGBA Double)+readImageRGBA = fmap (either error id) . readImage+{-# INLINE readImageRGBA #-}+
+ src/Graphics/Image/Interface/Vector/Unboxed.hs view
@@ -0,0 +1,244 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, FlexibleInstances,+             GADTs, MultiParamTypeClasses, TemplateHaskell, TypeFamilies,+             UndecidableInstances, ViewPatterns #-}+module Graphics.Image.Interface.Vector.Unboxed (+  VU(..), Image(..), fromUnboxedVector, toUnboxedVector, fromIx, toIx+  ) where++import Prelude hiding (map, zipWith)+import qualified Prelude as P (map)+import Control.DeepSeq (deepseq)+import Control.Monad (liftM)+import Data.Word (Word8)+import Data.Typeable (Typeable)+import Data.Vector.Unboxed (Vector, Unbox)+import Data.Vector.Unboxed.Deriving+import qualified Data.Vector.Unboxed as V+import qualified Data.Vector.Unboxed.Mutable as MV+import Graphics.Image.Interface+import Graphics.Image.ColorSpace.Binary (Bit(..))+++-- | Unboxed 'Vector' representation.+data VU = VU+++instance Show VU where+  show _ = "VectorUnboxed"+++instance Elt VU cs e => Array VU cs e where+  type Elt VU cs e = (ColorSpace cs, Num e, Unbox e, Typeable e, +                      Unbox (PixelElt cs e), Unbox (Pixel cs e))+  data Image VU cs e where+    VScalar :: !(Pixel cs e)                          -> Image VU cs e+    VUImage :: !Int -> !Int -> !(Vector (Pixel cs e)) -> Image VU cs e+  +  make !(m, n) !f = VUImage m n $ V.generate (m * n) (f . toIx n)+  {-# INLINE make #-}++  singleton = VScalar+  {-# INLINE singleton #-}+  +  dims (VUImage m n _) = (m, n)+  dims _               = (1, 1)+  {-# INLINE dims #-}+  +  map !f (VScalar px)    = VScalar (f px)+  map !f (VUImage m n v) = VUImage m n (V.map f v)+  {-# INLINE map #-}++  imap !f (VScalar px)    = VScalar (f (0, 0) px)+  imap !f (VUImage m n v) = VUImage m n (V.imap (\ !k !px -> f (toIx n k) px) v)+  {-# INLINE imap #-}+  +  zipWith !f (VScalar px1) (VScalar px2)    = VScalar (f px1 px2)+  zipWith !f (VScalar px1) (VUImage m n v2) = VUImage m n (V.map (f px1) v2)+  zipWith !f (VUImage m n v1) (VScalar px2) = VUImage m n (V.map (`f` px2) v1)+  zipWith !f img1@(VUImage m1 n1 v1) img2@(VUImage m2 n2 v2) =+    if m1 /= m2 || n1 /= n2+    then error ("zipWith: Images must be of the same dimensions, received: "+++                show img1++" and "++show img2++".")+    else VUImage m1 n1 (V.zipWith f v1 v2)+  {-# INLINE zipWith #-}++  izipWith !f (VScalar px1) (VScalar px2)    = VScalar (f (0, 0) px1 px2)+  izipWith !f (VScalar px1) (VUImage m n v2) =+    VUImage m n (V.imap (\ !k !px2 -> f (toIx n k) px1 px2) v2)+  izipWith !f (VUImage m n v1) (VScalar px2) =+    VUImage m n (V.imap (\ !k !px1 -> f (toIx n k) px1 px2) v1)+  izipWith !f img1@(VUImage m1 n1 v1) img2@(VUImage m2 n2 v2) =+    if m1 /= m2 || n1 /= n2+    then error ("izipWith: Images must be of the same dimensions, received: "+++                show img1++" and "++show img2++".")+    else VUImage m1 n1 (V.izipWith (\ !k !px1 !px2 -> f (toIx n1 k) px1 px2) v1 v2)+  {-# INLINE izipWith #-}++  traverse !img !getNewDims !getNewPx = make (getNewDims $ dims img) (getNewPx (index img))+  {-# INLINE traverse #-}++  traverse2 !img1 !img2 !getNewDims !getNewPx =+    make (getNewDims (dims img1) (dims img2)) (getNewPx (index img1) (index img2))+  {-# INLINE traverse2 #-}++  transpose !img@(dims -> (m, n)) = make (n, m) getPx where+    getPx !(i, j) = index img (j, i)+    {-# INLINE getPx #-}+  {-# INLINE transpose #-}++  backpermute !(m, n) !f (VUImage _ n' v) =+    VUImage m n $ V.backpermute v $ V.generate (m*n) (fromIx n' . f . toIx n)+  backpermute !sz      _ (VScalar px)     =+    if sz == (1, 1) then VScalar px else make sz (const px)+  {-# INLINE backpermute #-}+  +  fromLists !ls = if isSquare+                  then VUImage m n . V.fromList . concat $ ls+                  else error "fromLists: Inner lists are of different lengths."+    where+      !(m, n) = (length ls, length $ head ls)+      !isSquare = (n > 0) && all (==n) (P.map length ls)+  {-# INLINE fromLists #-}+++instance Array VU cs e => ManifestArray VU cs e where++  index (VUImage _ n v) !ix = v V.! fromIx n ix+  index (VScalar px)      _ = px+  {-# INLINE index #-}++  deepSeqImage (VUImage m n v) = m `seq` n `seq` deepseq v+  deepSeqImage (VScalar px)    = seq px+  {-# INLINE deepSeqImage #-}+  +  fold !f !px0 (VUImage _ _ v) = V.foldl' f px0 v+  fold !f !px0 (VScalar px)    = f px0 px+  {-# INLINE fold #-}++  (|*|) img1@(VUImage m1 n1 v1) !img2@(VUImage {}) =+    if n1 /= m2 +    then error ("Inner dimensions of multiplying images must be the same, but received: "+++                show img1 ++" X "++ show img2)+    else+      make (m1, n2) getPx where+        VUImage n2 m2 v2 = transpose img2+        getPx !(i, j) = V.sum $ V.zipWith (*) (V.slice (i*n1) n1 v1) (V.slice (j*m2) m2 v2)+        {-# INLINE getPx #-}+  (|*|) (VScalar px1) (VScalar px2) = VScalar (px1 * px2)+  (|*|) _ _ = error "Scalar Images cannot be multiplied."+  {-# INLINE (|*|) #-}++  eq (VUImage m1 n1 v1) (VUImage m2 n2 v2) =+    m1 == m2 && n1 == n2 && V.all id (V.zipWith (==) v1 v2)+  eq (VScalar px1)           (VScalar px2) = px1 == px2+  eq _                       _             = False+  {-# INLINE eq #-}+++instance ManifestArray VU cs e => SequentialArray VU cs e where++  foldl !f !a (VUImage _ _ v) = V.foldl' f a v+  foldl !f !a (VScalar px)    = f a px+  {-# INLINE foldl #-}++  foldr !f !a (VUImage _ _ v) = V.foldr' f a v+  foldr !f !a (VScalar px)    = f px a+  {-# INLINE foldr #-}++  mapM !f (VUImage m n v) = liftM (VUImage m n) (V.mapM f v)+  mapM !f (VScalar px)    = liftM VScalar (f px)+  {-# INLINE mapM #-}++  mapM_ !f (VUImage _ _ v) = V.mapM_ f v+  mapM_ !f (VScalar px)    = (f px) >> return ()+  {-# INLINE mapM_ #-}++  foldM !f !a (VUImage _ _ v) = V.foldM' f a v+  foldM !f !a (VScalar px)    = f a px+  {-# INLINE foldM #-}++  foldM_ !f !a (VUImage _ _ v) = V.foldM'_ f a v+  foldM_ !f !a (VScalar px)    = f a px >> return ()+  {-# INLINE foldM_ #-}+++instance ManifestArray VU cs e => MutableArray VU cs e where++  data MImage st VU cs e where+    MVImage :: !Int -> !Int -> MV.MVector st (Pixel cs e) -> MImage st VU cs e+    MVScalar :: MV.MVector st (Pixel cs e) -> MImage st VU cs e++  mdims (MVImage m n _) = (m, n)+  mdims (MVScalar _)    = (1, 1)+  {-# INLINE mdims #-}++  thaw (VUImage m n v) = liftM (MVImage m n) (V.thaw v)+  thaw (VScalar px)    = liftM MVScalar (V.thaw (V.singleton px))+  {-# INLINE thaw #-}++  freeze (MVImage m n mv) = liftM (VUImage m n) (V.freeze mv)+  freeze (MVScalar mv)    = liftM (VScalar . (V.! 0)) (V.freeze mv)+  {-# INLINE freeze #-}++  new (m, n) = liftM (MVImage m n) (MV.new (m*n))+  {-# INLINE new #-}++  read (MVImage _ n mv) ix = MV.read mv (fromIx n ix)+  read (MVScalar mv)    _  = MV.read mv 0+  {-# INLINE read #-}++  write (MVImage _ n mv) ix = MV.write mv (fromIx n ix)+  write (MVScalar mv)    _  = MV.write mv 0+  {-# INLINE write #-}++  swap (MVImage _ n mv) ix1 ix2 = MV.swap mv (fromIx n ix1) (fromIx n ix2)+  swap _                _   _   = return ()+  {-# INLINE swap #-}+++-- | Convert an image to a flattened Unboxed 'Vector'. It is a __O(1)__ opeartion.+--+-- >>> toUnboxedVector $ makeImage (3, 2) (\(i, j) -> PixelY $ fromIntegral (i+j))+-- fromList [<Luma:(0.0)>,<Luma:(1.0)>,<Luma:(1.0)>,<Luma:(2.0)>,<Luma:(2.0)>,<Luma:(3.0)>]+--+toUnboxedVector :: Array VU cs e => Image VU cs e -> Vector (Pixel cs e)+toUnboxedVector (VUImage _ _ v) = v+toUnboxedVector (VScalar px) = V.singleton px+++-- | Construct a two dimensional image with @m@ rows and @n@ columns from a flat+-- Unboxed 'Vector' of length @k@. It is a __O(1)__ opeartion. Make sure that @m * n = k@.+--+-- >>> fromUnboxedVector (200, 300) $ generate 60000 (\i -> PixelY $ fromIntegral i / 60000)+-- <Image VectorUnboxed Luma: 200x300>+--+-- <<images/grad_fromVector.png>>+-- +fromUnboxedVector :: Array VU cs e => (Int, Int) -> Vector (Pixel cs e) -> Image VU cs e+fromUnboxedVector (m, n) v+  | m * n == V.length v = VUImage m n v+  | otherwise = error "fromUnboxedVector: m * n doesn't equal the length of a Vector."+++fromIx :: Int -> (Int, Int) -> Int+fromIx !n !(i, j) = i * n + j+{-# INLINE fromIx #-}+++toIx :: Int -> Int -> (Int, Int)+toIx !n !k = (k `div` n, k `mod` n)+{-# INLINE toIx #-}+++derivingUnbox "Bit"+    [t| Bit -> Word8 |]+    [| \(Bit w) -> w |]+    [| Bit           |]++  +derivingUnbox "Pixel"+    [t| (ColorSpace cs, Unbox (PixelElt cs e)) => (Pixel cs e) -> (PixelElt cs e) |]+    [| toElt                                                                      |]+    [| fromElt                                                                    |]+
+ src/Graphics/Image/Processing.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}+module Graphics.Image.Processing (+  -- * Geometric+  module Graphics.Image.Processing.Geometric,+  -- * Interpolation+  module Graphics.Image.Processing.Interpolation,+  -- * Convolution+  module Graphics.Image.Processing.Convolution,+  -- * Tools+  Border(..), pixelGrid+  ) where++import Data.Word (Word8)+import Graphics.Image.Interface+import Graphics.Image.Processing.Convolution+import Graphics.Image.Processing.Geometric+import Graphics.Image.Processing.Interpolation++++-- | This function magnifies an image by a positive factor and draws a grid+-- around the original pixels. It is here simply as useful inspection tool.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_eye_grid.png" $ pixelGrid 10 $ crop (51, 112) (20, 20) frog+--+-- <<images/frog.jpg>> <<images/frog_eye_grid.png>>+--+pixelGrid :: (Array arr cs e, Elevator e) =>+             Word8          -- ^ Magnification factor.+          -> Image arr cs e -- ^ Source image.+          -> Image arr cs e+pixelGrid !(succ . fromIntegral -> k) !img = traverse img getNewDims getNewPx where+  getNewDims !(m, n) = (1 + m*k, 1 + n*k)+  {-# INLINE getNewDims #-}+  getNewPx !getPx !(i, j) = if i `mod` k == 0 || j `mod` k == 0+                            then fromDouble $ fromChannel 0.5+                            else getPx ((i - 1) `div` k, (j - 1) `div` k)+  {-# INLINE getNewPx #-}+{-# INLINE pixelGrid #-}+
+ src/Graphics/Image/Processing/Binary.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, FunctionalDependencies,+             MultiParamTypeClasses #-}+module Graphics.Image.Processing.Binary (+  -- * Construction+  toImageBinaryUsing, toImageBinaryUsing2,+  thresholdWith, compareWith,+  -- * Bitwise operations+  (.&&.), (.||.), invert,+  -- * Thresholding+  Thresholding(..),+  -- * Binary Morphology+  -- $morphology+  erode, dialate, open, close+  ) where++import Prelude hiding (map, zipWith)+import Graphics.Image.Interface+import Graphics.Image.ColorSpace+import Graphics.Image.Processing.Convolution++import qualified Data.Foldable as F++infix  4  .==., ./=., .<., .<=., .>=., .>.+infixr 3  .&&.+infixr 2  .||.+++-- | 'Thresholding' contains a convenient set of functions for binary image+-- construction, which is done by comparing either a single pixel with every+-- pixel in an image or two same size images pointwise.+class Array arr Binary Bit => Thresholding a b arr | a b -> arr where+  (.==.) :: (Eq (Pixel cs e), Array arr cs e)  => a cs e -> b cs e -> Image arr Binary Bit+  (./=.) :: (Eq (Pixel cs e), Array arr cs e)  => a cs e -> b cs e -> Image arr Binary Bit+  (.<.)  :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit+  (.<=.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit+  (.>.)  :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit+  (.>=.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit++++instance Array arr Binary Bit => Thresholding (Image arr) (Image arr) arr where+  (.==.) = toImageBinaryUsing2 (==)+  {-# INLINE (.==.) #-}+  +  (./=.) = toImageBinaryUsing2 (/=)+  {-# INLINE (./=.) #-}+  +  (.<.)  = toImageBinaryUsing2 (<)+  {-# INLINE (.<.) #-}+  +  (.<=.) = toImageBinaryUsing2 (<=)+  {-# INLINE (.<=.) #-}+  +  (.>.)  = toImageBinaryUsing2 (>)+  {-# INLINE (.>.) #-}+  +  (.>=.) = toImageBinaryUsing2 (>=)+  {-# INLINE (.>=.) #-}+  ++instance Array arr Binary Bit => Thresholding Pixel (Image arr) arr where+  (.==.) !px = toImageBinaryUsing (==px)+  {-# INLINE (.==.) #-}+  +  (./=.) !px = toImageBinaryUsing (/=px)+  {-# INLINE (./=.) #-}+  +  (.<.)  !px = toImageBinaryUsing (< px)+  {-# INLINE (.<.) #-}+  +  (.<=.) !px = toImageBinaryUsing (<=px)+  {-# INLINE (.<=.) #-}+  +  (.>.)  !px = toImageBinaryUsing (> px)+  {-# INLINE (.>.) #-}+  +  (.>=.) !px = toImageBinaryUsing (>=px)+  {-# INLINE (.>=.) #-}+  ++instance Array arr Binary Bit => Thresholding (Image arr) Pixel arr where+  (.==.) !img !px = toImageBinaryUsing (==px) img+  {-# INLINE (.==.) #-}+  +  (./=.) !img !px = toImageBinaryUsing (/=px) img+  {-# INLINE (./=.) #-}+  +  (.<.)  !img !px = toImageBinaryUsing (< px) img+  {-# INLINE (.<.) #-}+  +  (.<=.) !img !px = toImageBinaryUsing (<=px) img+  {-# INLINE (.<=.) #-}+  +  (.>.)  !img !px = toImageBinaryUsing (> px) img+  {-# INLINE (.>.) #-}+  +  (.>=.) !img !px = toImageBinaryUsing (>=px) img+  {-# INLINE (.>=.) #-}+++-- | Pixel wise @AND@ operator on binary images. +(.&&.) :: Array arr Binary Bit =>+          Image arr Binary Bit -> Image arr Binary Bit -> Image arr Binary Bit+(.&&.) = zipWith (*)+{-# INLINE (.&&.) #-}++-- | Pixel wise @OR@ operator on binary images.+(.||.) :: Array arr Binary Bit =>+          Image arr Binary Bit -> Image arr Binary Bit -> Image arr Binary Bit+(.||.) = zipWith (+)+{-# INLINE (.||.) #-}+++-- | Complement each pixel in the image+invert :: Array arr Binary Bit => Image arr Binary Bit -> Image arr Binary Bit+invert = map complement+{-# INLINE invert #-}+++-- | Construct a binary image using a predicate from a source image.+toImageBinaryUsing :: (Array arr cs e, Array arr Binary Bit) =>+                      (Pixel cs e -> Bool) -- ^ Predicate+                   -> Image arr cs e -- ^ Source image.+                   -> Image arr Binary Bit+toImageBinaryUsing !f = map (fromBool . f)+{-# INLINE toImageBinaryUsing #-}+++-- | Construct a binary image using a predicate from two source images.+toImageBinaryUsing2 :: (Array arr cs e, Array arr Binary Bit) =>+                       (Pixel cs e -> Pixel cs e -> Bool) -- ^ Predicate+                    -> Image arr cs e -- ^ First source image.+                    -> Image arr cs e -- ^ Second source image.+                    -> Image arr Binary Bit+toImageBinaryUsing2 !f =  zipWith (((.).(.)) fromBool f)+{-# INLINE toImageBinaryUsing2 #-}+++-- | Threshold a source image with an applicative pixel.+--+-- >>> yield <- readImageRGB "images/yield.jpg"+-- >>> writeImageExact PNG [] "images/yield_bin.png" $ thresholdWith (PixelRGB (>0.55) (<0.6) (<0.5)) yield+--+-- <<images/yield.jpg>> <<images/yield_bin.png>>+--+thresholdWith :: (Array arr cs e, Array arr Binary Bit) =>+                 Pixel cs (e -> Bool)+                 -- ^ Pixel containing a thresholding function per channel.+              -> Image arr cs e -- ^ Source image.+              -> Image arr Binary Bit+thresholdWith !f = map (fromBool . F.and . (f <*>))+{-# INLINE thresholdWith #-}+++-- | Compare two images with an applicative pixel. Works just like+-- 'thresholdWith', but on two images.+compareWith :: (Array arr cs e1, Array arr cs e2, Array arr Binary Bit) =>+               Pixel cs (e1 -> e2 -> Bool)+               -- ^ Pixel containing a comparing function per channel.+            -> Image arr cs e1 -- ^ First image.+            -> Image arr cs e2 -- ^ second image.+            -> Image arr Binary Bit+compareWith !f = zipWith (\ !px1 !px2 -> fromBool . F.and $ (f <*> px1 <*> px2))+{-# INLINE compareWith #-}+++{- $morphology In order to demonstrate how morphological operations work, a+/binary source image/ = __B__ constructed here together with a /structuring element/ =+__S__ will be used in examples that follow.++@+figure :: Image VU Binary Bit+figure = fromLists [[0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],+                    [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],+                    [0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0],+                    [0,0,0,0,0,0,1,1,0,0,0,0,0,1,1,1,0],+                    [0,0,0,0,0,0,0,1,0,0,0,0,1,1,0,0,0],+                    [0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0],+                    [0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0],+                    [0,0,0,0,1,1,1,1,1,1,1,0,0,0,0,0,0],+                    [0,0,0,0,1,1,1,1,1,1,1,0,0,0,0,0,0],+                    [0,0,0,0,0,0,1,1,1,1,1,0,0,0,0,0,0],+                    [0,0,0,0,0,0,1,1,1,1,0,0,0,1,0,0,0],+                    [0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,0,0],+                    [0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0],+                    [0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0],+                    [0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0],+                    [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],+                    [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]]+struct :: Image VU Binary Bit+struct = fromLists [[0,1],[1,1],[0,1]]+@+-}+++-- | Erosion is defined as: __{E = B ⊖ S = {m,n|Sₘₙ⊆B}__+--+-- >>> writeImageExact PNG [] "images/figure_erode.png" $ pixelGrid 10 $ fromImageBinary $ erode struct figure+--+-- <<images/figure.png>> eroded with <<images/struct.png>> is <<images/figure_erode.png>>+--+erode :: ManifestArray arr Binary Bit =>+         Image arr Binary Bit -- ^ Structuring element.+      -> Image arr Binary Bit -- ^ Binary source image.+      -> Image arr Binary Bit+erode !struc !img = invert $ convolve (Fill on) struc (invert img)+{-# INLINE erode #-}+++-- | Dialation is defined as: __{D = B ⊕ S = {m,n|Sₘₙ∩B≠∅}__+--+-- >>> writeImageExact PNG [] "images/figure_dialate.png" $ pixelGrid 10 $ fromImageBinary $ dialate struct figure+--+-- <<images/figure.png>> dialated with <<images/struct.png>> is <<images/figure_dialate.png>>+--+dialate :: ManifestArray arr Binary Bit =>+           Image arr Binary Bit -- ^ Structuring element.+        -> Image arr Binary Bit -- ^ Binary source image.+        -> Image arr Binary Bit+dialate !struc !img = convolve (Fill off) struc img+{-# INLINE dialate #-}+++-- | Opening is defined as: __{B ○ S = (B ⊖ S) ⊕ S}__+--+-- >>> writeImageExact PNG [] "images/figure_open.png" $ pixelGrid 10 $ fromImageBinary $ open struct figure+--+-- <<images/figure.png>> opened with <<images/struct.png>> is <<images/figure_open.png>>+--+open :: ManifestArray arr Binary Bit =>+        Image arr Binary Bit -- ^ Structuring element.+     -> Image arr Binary Bit -- ^ Binary source image.+     -> Image arr Binary Bit+open struc = dialate struc . erode struc+{-# INLINE open #-}+++-- | Closing is defined as: __{B ● S = (B ⊕ S) ⊖ S}__+--+-- >>> writeImageExact PNG [] "images/figure_close.png" $ pixelGrid 10 $ fromImageBinary $ close struct figure+--+-- <<images/figure.png>> closed with <<images/struct.png>> is <<images/figure_close.png>>+--+close :: ManifestArray arr Binary Bit =>+         Image arr Binary Bit -- ^ Structuring element.+      -> Image arr Binary Bit -- ^ Binary source image.+      -> Image arr Binary Bit+close struc = erode struc . dialate struc+{-# INLINE close #-}++
+ src/Graphics/Image/Processing/Complex.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, ViewPatterns #-}+module Graphics.Image.Processing.Complex (+  -- * Rectangular form+  (!+!), realPart', imagPart',+  -- * Polar form+  mkPolar', cis', polar', magnitude', phase',+  -- * Conjugate+  conjugate',+  -- * Processing+  makeFilter, applyFilter,+  -- ** Fourier Transform+  fft, ifft+  ) where++import Prelude hiding (map, zipWith)+--import qualified Data.Complex as C+import Graphics.Image.Interface+import Graphics.Image.ColorSpace.Complex+import Graphics.Image.Processing.Complex.Fourier+++infix 6 !+!++-- | Constrcut a complex image from two images containing real and imaginary parts.+--+-- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @+--+(!+!) :: (Array arr cs e, Array arr cs (Complex e)) =>+         Image arr cs e -> Image arr cs e -> Image arr cs (Complex e)+(!+!) = zipWith (+:)+{-# INLINE (!+!) #-}++-- | Extracts the real part of a complex image.+realPart' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+             Image arr cs (Complex e) -> Image arr cs e+realPart' = map realPart+{-# INLINE realPart' #-}++-- | Extracts the imaginary part of a complex image.+imagPart' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+             Image arr cs (Complex e) -> Image arr cs e+imagPart' = map imagPart+{-# INLINE imagPart' #-}++-- | Form a complex image from polar components of magnitude and phase.+mkPolar' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+            Image arr cs e -> Image arr cs e -> Image arr cs (Complex e)+mkPolar' = zipWith mkPolar+{-# INLINE mkPolar' #-}++-- | @'cis'' t@ is a complex image with magnitude 1 and phase t (modulo @2*'pi'@).+cis' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+        Image arr cs e -> Image arr cs (Complex e)+cis' = map cis+{-# INLINE cis' #-}++-- | The function @'polar''@ takes a complex image and returns a (magnitude, phase)+-- pair of images in canonical form: the magnitude is nonnegative, and the phase+-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.+polar' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+          Image arr cs (Complex e) -> (Image arr cs e, Image arr cs e)+polar' !zImg = (magnitude' zImg, phase' zImg)+{-# INLINE polar' #-}++-- | The nonnegative magnitude of a complex image.+magnitude' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+              Image arr cs (Complex e) -> Image arr cs e+magnitude' = map magnitude+{-# INLINE magnitude' #-}++-- | The phase of a complex image, in the range @(-'pi', 'pi']@. If the+-- magnitude is zero, then so is the phase.+phase' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+          Image arr cs (Complex e) -> Image arr cs e+phase' = map phase+{-# INLINE phase' #-}++-- | The conjugate of a complex image.+conjugate' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) =>+              Image arr cs (Complex e) -> Image arr cs (Complex e)+conjugate' = map conjugate+{-# INLINE conjugate' #-}+++-- | Make a filter by using a function that works around a regular @(x, y)@+-- coordinate system.+makeFilter :: (ManifestArray arr cs e, RealFloat e) =>+              (Int, Int)+              -- ^ Dimensions of the filter. Both @m@ and @n@ have to be powers+              -- of @2@, i.e. @m == 2^k@, where @k@ is some integer.+           -> ((Int, Int) -> Pixel cs e) -> Image arr cs e+makeFilter !(m, n) !getPx +  | isPowerOfTwo m && isPowerOfTwo n = make (m, n) getPx'+  | otherwise = error " "+  where getPx' (i, j) = getPx (if i < (m `div` 2) then i else i - m,+                               if j < (n `div` 2) then j else j - n)+        {-# INLINE getPx' #-}+{-# INLINE makeFilter #-}+++-- | Apply a filter to an image created by 'makeFilter'.+applyFilter :: (ManifestArray arr cs e, ManifestArray arr cs (Complex e), RealFloat e) =>+               Image arr cs e -- ^ Source image.+            -> Image arr cs e -- ^ Filter.+            -> Image arr cs e+applyFilter img filt = realPart' . ifft $ ((fft (img !+! 0)) * (filt !+! filt))+{-# INLINE applyFilter #-}++{-+gaussianBandpass :: (ManifestArray arr cs e, RealFloat e) =>+                    Int -> e -> e -> Image arr cs e+gaussianBandpass n center variance = makeFilter (n, n) bandpass where+  gaussian (x, y) = fromChannel $ exp (-(x^(2 :: Int) + y^(2 :: Int)) / (2*variance))+  bandpass (fromIntegral -> y, fromIntegral -> x) = gaussian (x', y')+    where (x' :+ y') = C.mkPolar (mag - center) ph+          (mag, ph) = C.polar (x :+ y)+-}          ++{-+idealBandpass :: (ManifestArray arr cs e, RealFloat e) =>+                 Int -> e -> e -> Image arr cs e+idealBandpass n width center = makeFilter (n, n) bandpass where+  bandpass (fromIntegral -> r, fromIntegral -> c)+    | center <= mag && mag <= (width + center) = 1+    | otherwise = 0+    where mag = C.magnitude (r :+ c)+-}
+ src/Graphics/Image/Processing/Complex/Fourier.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts #-}+module Graphics.Image.Processing.Complex.Fourier (+  fft, ifft, isPowerOfTwo+  ) where++import Prelude hiding (map)+import Data.Bits ((.&.))+import Graphics.Image.Interface+import Graphics.Image.ColorSpace.Complex+import Graphics.Image.Processing.Geometric (leftToRight)+++data Mode = Forward+          | Inverse++-- | Fast Fourier Transform+fft :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) =>+       Image arr cs (Complex e)+    -> Image arr cs (Complex e)+fft = fft2d Forward+{-# INLINE fft #-}+++-- | Inverse Fast Fourier Transform+ifft :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) =>+        Image arr cs (Complex e)+     -> Image arr cs (Complex e)+ifft = fft2d Inverse+{-# INLINE ifft #-}+++signOfMode :: Num a => Mode -> a+signOfMode Forward = -1+signOfMode Inverse = 1+{-# INLINE signOfMode #-}+++-- | Check if `Int` is a power of two.+isPowerOfTwo :: Int -> Bool+isPowerOfTwo n = n /= 0 && (n .&. (n-1)) == 0+{-# INLINE isPowerOfTwo #-}+++-- | Compute the DFT of a matrix. Array dimensions must be powers of two else `error`.+fft2d :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) =>+         Mode+      -> Image arr cs (Complex e)+      -> Image arr cs (Complex e)+fft2d mode img =+  let !(m, n) = dims img+      !sign   = signOfMode mode+      !scale  = fromIntegral (m * n) +  in if not (isPowerOfTwo m && isPowerOfTwo n)+     then error $ unlines+          [ "fft"+          , "  Array dimensions must be powers of two,"+          , "  but the provided image is " ++ show img ++ "." ]+     else case mode of+       Forward -> fftGeneral sign $ fftGeneral sign img+       Inverse -> map (/ scale) $ fftGeneral sign $ fftGeneral sign img+{-# INLINE fft2d #-}+++fftGeneral :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) =>+              Pixel cs e+           -> Image arr cs (Complex e)+           -> Image arr cs (Complex e)+fftGeneral !sign !img = transpose $ go n 0 1 where+  !(m, n) = dims img+  go !len !offset !stride+    | len == 2 = make (m, 2) swivel+    | otherwise = combine len +                  (go (len `div` 2) offset            (stride * 2))+                  (go (len `div` 2) (offset + stride) (stride * 2))+    where+      swivel (m', j) = case j of+        0 -> index img (m', offset) + index img (m', offset + stride)+        1 -> index img (m', offset) - index img (m', offset + stride)+        _ -> error "FFT: Image must have exactly 2 columns. Please, report this bug."+      combine !len' evens odds =  +        let odds' = traverse odds id+                    (\getPx (i, j) -> twiddle sign j len' * getPx (i, j)) +        in leftToRight (evens + odds') (evens - odds')+++-- Compute a twiddle factor.+twiddle :: (ColorSpace cs, Floating e) =>+           Pixel cs e+	-> Int 			-- index+	-> Int 			-- length+	-> Pixel cs (Complex e)+twiddle sign k n = cos alpha +: sign * sin alpha where+  !alpha = 2 * pi * fromIntegral k / fromIntegral n+{-# INLINE twiddle #-}
+ src/Graphics/Image/Processing/Convolution.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE BangPatterns #-}+module Graphics.Image.Processing.Convolution (+  convolve, convolveRows, convolveCols,+  --convolve', convolveRows', convolveCols',+  ) where++import Prelude hiding (map)+import qualified Prelude as P (map)+import Graphics.Image.Interface+import Graphics.Image.Processing.Geometric++++convolve'' :: ManifestArray arr cs e =>+              Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e+convolve'' !border !kernel !img =+  img `deepSeqImage` kernel `deepSeqImage` traverse2 kernel img (const . const sz) stencil+  where+    !(krnM, krnN)     = dims kernel+    !krnM2            = krnM `div` 2+    !krnN2            = krnN `div` 2+    !sz               = dims img+    getPxB !getPx !ix = borderIndex border sz getPx ix+    {-# INLINE getPxB #-}+    stencil !getKrnPx !getImgPx !(i, j) = integrate 0 0 0 where+      !ikrnM = i - krnM2+      !jkrnN = j - krnN2+      integrate !ki !kj !acc+        | kj == krnN            = integrate (ki+1) 0 acc+        | kj == 0 && ki == krnM = acc+        | otherwise             = let !krnPx = getKrnPx (ki, kj)+                                      !imgPx = getPxB getImgPx (ki + ikrnM, kj + jkrnN)+                                  in integrate ki (kj + 1) (acc + krnPx * imgPx)+      {-# INLINE integrate #-}+    {-# INLINE stencil #-}+{-# INLINE convolve'' #-}++-- | Convolution of an image using a kernel. Border resolution technique is required.+convolve  :: ManifestArray arr cs e =>+             Border (Pixel cs e)   -- ^ Approach to be used near the borders.+          -> Image arr cs e -- ^ Kernel image.+          -> Image arr cs e -- ^ Source image.+          -> Image arr cs e+convolve !out = convolve'' out . rotate180+{-# INLINE convolve #-}++{-+-- | Strict version of convolution that operates on manifest array representations.+convolve'  :: ManifestArray arr cs e =>+             Border (Pixel cs e)   -- ^ Approach to be used near the borders.+          -> Image arr cs e -- ^ Kernel image.+          -> Image arr cs e -- ^ Source image.+          -> Image arr cs e+convolve' !out = convolve'' out . rotate180+{-# INLINE convolve' #-}+-}+{-+-- | Convolve image's rows with a vector kernel represented by a list of pixels.+convolveRows :: Array arr cs e =>+                Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e+convolveRows !out = convolve out . fromLists . (:[]) . reverse+{-# INLINE convolveRows #-}+++-- | Convolve image's columns with a vector kernel represented by a list of pixels.+convolveCols :: Array arr cs e =>+                Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e+convolveCols !out = convolve out . fromLists . P.map (:[]) . reverse+{-# INLINE convolveCols #-}+-}++-- | Convolve image's rows with a vector kernel represented by a list of pixels.+convolveRows :: ManifestArray arr cs e =>+                Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e+convolveRows !out = convolve out . fromLists . (:[]) . reverse+{-# INLINE convolveRows #-}+++-- | Convolve image's columns with a vector kernel represented by a list of pixels.+convolveCols :: ManifestArray arr cs e =>+                Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e+convolveCols !out = convolve out . fromLists . P.map (:[]) . reverse+{-# INLINE convolveCols #-}+
+ src/Graphics/Image/Processing/Geometric.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}+module Graphics.Image.Processing.Geometric (+  -- ** Sampling+  downsampleRows, downsampleCols, downsample, +  upsampleRows, upsampleCols, upsample, +  -- ** Concatenation+  leftToRight, topToBottom,+  -- ** Canvas+  crop,+  -- ** Flipping+  flipV, flipH,+  -- ** Rotation+  rotate90, rotate180, rotate270,+  -- ** Scaling+  resize, scale                                          +  ) where++import Graphics.Image.Interface+import Graphics.Image.Processing.Interpolation++++downsampleF :: Array arr cs e => Int -> Int -> Image arr cs e -> Image arr cs e+downsampleF !fm !fn !img = traverse img+                           (\ !(m, n) -> (m `div` fm, n `div` fn))+                           (\ !getPx !(i, j) -> getPx (i*fm, j*fn))+{-# INLINE downsampleF #-}+++upsampleF :: Array arr cs e => Int -> Int -> Image arr cs e -> Image arr cs e+upsampleF !fm !fn !img = traverse img +                         (\ !(m, n) -> (m*fm, n*fn))+                         (\ !getPx !(i, j) ->+                           if i `mod` fm == 0 && j `mod` fn == 0+                           then getPx (i `div` fm, j `div` fn)+                           else fromChannel 0)+{-# INLINE upsampleF #-}+++-- | Downsample an image by discarding every odd row.+downsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e+downsampleRows = downsampleF 2 1+{-# INLINE downsampleRows #-}+++-- | Downsample an image by discarding every odd column.+downsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e+downsampleCols = downsampleF 1 2+{-# INLINE downsampleCols #-}+++-- | Downsample an image by discarding every odd row and column.+downsample :: Array arr cs e => Image arr cs e -> Image arr cs e+downsample = downsampleF 2 2+{-# INLINE downsample #-}+++-- | Upsample an image by inserting a row of back pixels after each row of a+-- source image.+upsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e+upsampleRows = upsampleF 2 1+{-# INLINE upsampleRows #-}+++-- | Upsample an image by inserting a column of back pixels after each column of a+-- source image.+upsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e+upsampleCols = upsampleF 1 2+{-# INLINE upsampleCols #-}+++-- | Upsample an image by inserting a row and a column of back pixels after each+-- row and a column of a source image.+upsample :: Array arr cs e => Image arr cs e -> Image arr cs e+upsample = upsampleF 2 2+{-# INLINE upsample #-}+++-- | Concatenate two images together into one. Both input images must have the+-- same number of rows.+leftToRight :: Array arr cs e => Image arr cs e -> Image arr cs e -> Image arr cs e+leftToRight !img1@(dims -> (_, n1)) !img2 = traverse2 img1 img2 newDims newPx where+  newDims !(m1, _) !(m2, n2)+    | m1 == m2  = (m1, n1 + n2)+    | otherwise = error ("Images must agree in numer of rows, but received: " +                         ++ show img1 ++ " and " ++ show img2)+  {-# INLINE newDims #-}+  newPx !getPx1 !getPx2 !(i, j) = if j < n1 then getPx1 (i, j) else getPx2 (i, j-n1)+  {-# INLINE newPx #-}+{-# INLINE leftToRight #-}+++-- | Concatenate two images together into one. Both input images must have the+-- same number of columns.+topToBottom :: Array arr cs e => Image arr cs e -> Image arr cs e -> Image arr cs e+topToBottom !img1@(dims -> (m1, _)) !img2 = traverse2 img1 img2 newDims newPx where+  newDims !(_, n1) !(m2, n2)+    | n1 == n2  = (m1 + m2, n1)+    | otherwise = error ("Images must agree in numer of columns, but received: "+                         ++ show img1 ++ " and " ++ show img2)+  {-# INLINE newDims #-}+  newPx !getPx1 !getPx2 !(i, j) = if i < m1 then getPx1 (i, j) else getPx2 (i-m1, j)+  {-# INLINE newPx #-}+{-# INLINE topToBottom #-}++-- | Crop an image, i.e. retrieves a sub-image image with @m@ rows and @n@+-- columns. Make sure @(m + i, n + j)@ is not greater than dimensions of a+-- source image.+crop :: Array arr cs e =>+        (Int, Int)     -- ^ @(i, j)@ starting index from within a source image.+     -> (Int, Int)     -- ^ @(m, n)@ dimensions of a new image.+     -> Image arr cs e -- ^ Source image.+     -> Image arr cs e              +crop !(i, j) sz = backpermute sz (\ !(i', j') -> (i' + i, j' + j))+{-# INLINE crop #-}+++flipUsing :: Array arr cs e =>+             ((Int, Int) -> (Int, Int) -> (Int, Int)) -> Image arr cs e -> Image arr cs e+flipUsing getNewIndex !img@(dims -> d) = backpermute d (getNewIndex d) img+{-# INLINE flipUsing #-}+++-- | Flip an image vertically.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_flipV.jpg" (computeS $ flipV frog) +--+-- <<images/frog.jpg>> <<images/frog_flipV.jpg>>+--+flipV :: Array arr cs e => Image arr cs e -> Image arr cs e+flipV = flipUsing (\ (m, _) !(i, j) -> (m - 1 - i, j))+{-# INLINE flipV #-}+++-- | Flip an image horizontally.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_flipH.jpg" (flipH frog) +--+-- <<images/frog.jpg>> <<images/frog_flipH.jpg>>+--+flipH :: Array arr cs e => Image arr cs e -> Image arr cs e+flipH = flipUsing (\ (_, n) !(i, j) -> (i, n - 1 - j))+{-# INLINE flipH #-}+++-- | Rotate an image clockwise by 90°.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_rotate90.jpg" (rotate90 frog) +--+-- <<images/frog.jpg>> <<images/frog_rotate90.jpg>>+--+rotate90 :: Array arr cs e => Image arr cs e -> Image arr cs e+rotate90 = transpose . flipV+{-# INLINE rotate90 #-}+++-- | Rotate an image by 180°.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_rotate180.jpg" (rotate180 frog) +--+-- <<images/frog.jpg>> <<images/frog_rotate180.jpg>>+--+rotate180 :: Array arr cs e => Image arr cs e -> Image arr cs e+rotate180 = flipUsing (\ !(m, n) !(i, j) -> (m - 1 - i, n - 1 - j))+{-# INLINE rotate180 #-}+++-- | Rotate an image clockwise by 270°.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_rotate270.jpg" (rotate270 frog) +--+-- <<images/frog.jpg>> <<images/frog_rotate270.jpg>>+--+rotate270 :: Array arr cs e => Image arr cs e -> Image arr cs e+rotate270 = transpose . flipH+{-# INLINE rotate270 #-}+++-- | Resize an image using an interpolation method.+--+-- >>> frog <- readImageRGB "images/frog.jpg"+-- >>> writeImage "images/frog_resize.jpg" (resize (Bilinear Edge) (100, 640) frog)+--+-- <<images/frog_resize.jpg>>+--+resize :: (Interpolation method, Array arr cs e, Elevator e) =>+          method (Pixel cs e) -- ^ Interpolation method to be used during scaling.+       -> (Int, Int)     -- ^ Dimensions of a result image.+       -> Image arr cs e -- ^ Source image.+       -> Image arr cs e -- ^ Reuslt image.+resize !method !sz'@(m', n') !img = traverse img (const sz') getNewPx where+  !sz@(m, n) = dims img+  !(fM, fN) = (fromIntegral m' / fromIntegral m, fromIntegral n' / fromIntegral n)+  getNewPx !getPx !(i, j) =+    interpolate method sz getPx ((fromIntegral i + 0.5) / fM - 0.5, (fromIntegral j + 0.5) / fN - 0.5)+  {-# INLINE getNewPx #-}+{-# INLINE resize #-}+++-- | Scale an image. Same as resize, except scaling factors are supplied+-- instead of new dimensions.+--+-- @ scale ('Bilinear' 'Edge') (0.5, 2) frog == resize ('Bilinear' 'Edge') (100, 640) frog @+--+scale :: (Interpolation method, Array arr cs e, Elevator e) =>+         method (Pixel cs e) -- ^ Interpolation method to be used during scaling.+      -> (Double, Double) -- ^ Positive scaling factors.+      -> Image arr cs e -- ^ Source image.+      -> Image arr cs e+scale !method !(fM, fN) !img@(dims -> (m, n)) =+  if fM <= 0 || fN <= 0+  then error "scale: scaling factor must be greater than 0."+  else resize method (round (fM * fromIntegral m), round (fN * fromIntegral n)) img+{-# INLINE scale #-}
+ src/Graphics/Image/Processing/Interpolation.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}+module Graphics.Image.Processing.Interpolation (+  Interpolation(..), Nearest(..), Bilinear(..)+  ) where++import Graphics.Image.Interface+++class Interpolation method where+  interpolate :: (Elevator e, Num e, ColorSpace cs) =>+                 method (Pixel cs e) -- ^ Interpolation method+              -> (Int, Int)          -- ^ Image dimensions @m@ rows and @n@ columns.+              -> ((Int, Int) -> Pixel cs e)+                 -- ^ Lookup function that returns a pixel at @i@th and @j@th+                 -- location.+              -> (Double, Double) -- ^ real values of @i@ and @j@ index+              -> Pixel cs e+++-- | Nearest Neighbor interpolation method.+data Nearest px = Nearest+++-- | Bilinear interpolation method.+data Bilinear px = Bilinear (Border px)+++instance Interpolation Nearest where+  interpolate _ !(m, n) !getPx !(round -> i, round -> j) =+    if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else 0+++instance Interpolation Bilinear where+  interpolate (Bilinear border) !sz !getPx !(i, j) = fi0 + jPx*(fi1-fi0) where+    getPx' = borderIndex border sz getPx+    !(i0, j0) = (floor i, floor j)+    !(i1, j1) = (i0 + 1, j0 + 1)+    !iPx = fromDouble $ fromChannel (i - fromIntegral i0)+    !jPx = fromDouble $ fromChannel (j - fromIntegral j0)+    !f00 = getPx' (i0, j0)+    !f10 = getPx' (i1, j0)+    !f01 = getPx' (i0, j1) +    !f11 = getPx' (i1, j1) +    !fi0 = f00 + iPx*(f10-f00)+    !fi1 = f01 + iPx*(f11-f01)+  {-# INLINE interpolate #-}