hip 1.5.2.0 → 1.5.3.0

raw patch · 47 files changed

+3620/−2971 lines, 47 filesdep ~basedep ~vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−6
• benchmarks/Canny.hs +0/−100
• benchmarks/Convolution.hs +108/−0
• benchmarks/Histogram.hs +28/−0
• hip.cabal +18/−8
• src/Graphics/Image.hs +9/−8
• src/Graphics/Image/ColorSpace.hs +108/−54
• src/Graphics/Image/ColorSpace/Binary.hs +99/−128
• src/Graphics/Image/ColorSpace/CMYK.hs +29/−21
• src/Graphics/Image/ColorSpace/HSI.hs +26/−18
• src/Graphics/Image/ColorSpace/RGB.hs +1/−1
• src/Graphics/Image/ColorSpace/X.hs +39/−18
• src/Graphics/Image/ColorSpace/Y.hs +28/−22
• src/Graphics/Image/ColorSpace/YCbCr.hs +26/−18
• src/Graphics/Image/IO.hs +7/−7
• src/Graphics/Image/IO/Base.hs +41/−24
• src/Graphics/Image/IO/Formats.hs +57/−44
• src/Graphics/Image/IO/Formats/JuicyPixels.hs +1034/−0
• src/Graphics/Image/IO/Formats/JuicyPixels/Common.hs +0/−112
• src/Graphics/Image/IO/Formats/JuicyPixels/Readable.hs +0/−568
• src/Graphics/Image/IO/Formats/JuicyPixels/Writable.hs +0/−305
• src/Graphics/Image/IO/Formats/Netpbm.hs +47/−73
• src/Graphics/Image/IO/Histogram.hs +82/−38
• src/Graphics/Image/Interface.hs +98/−101
• src/Graphics/Image/Interface/Elevator.hs +11/−9
• src/Graphics/Image/Interface/Repa.hs +2/−3
• src/Graphics/Image/Interface/Repa/Generic.hs +388/−412
• src/Graphics/Image/Interface/Repa/Helpers.hs +0/−39
• src/Graphics/Image/Interface/Repa/Storable.hs +75/−110
• src/Graphics/Image/Interface/Repa/Unboxed.hs +74/−82
• src/Graphics/Image/Interface/Vector/Generic.hs +438/−225
• src/Graphics/Image/Interface/Vector/Storable.hs +62/−63
• src/Graphics/Image/Interface/Vector/Unboxed.hs +63/−64
• src/Graphics/Image/Processing.hs +3/−0
• src/Graphics/Image/Processing/Binary.hs +188/−93
• src/Graphics/Image/Processing/Complex.hs +0/−29
• src/Graphics/Image/Processing/Complex/Fourier.hs +71/−52
• src/Graphics/Image/Processing/Convolution.hs +43/−39
• src/Graphics/Image/Processing/Filter.hs +141/−0
• src/Graphics/Image/Processing/Geometric.hs +23/−20
• src/Graphics/Image/Processing/Interpolation.hs +3/−3
• src/Graphics/Image/Utils.hs +52/−0
• tests/Graphics/Image/ColorSpaceSpec.hs +55/−20
• tests/Graphics/Image/Interface/VectorSpec.hs +12/−6
• tests/Graphics/Image/InterfaceSpec.hs +2/−17
• tests/Graphics/Image/Processing/BinarySpec.hs +9/−9
• tests/Graphics/Image/ProcessingSpec.hs +6/−2

@@ -1,10 +1,18 @@ 1.5.2.0 ======= +* Fixed FFT performace issue+* Reduced JuicyPixels module compile time and introduced conversion functions.+* Created `Filter` and implemented few filters: `gaussianBlur`+* Indroduced `Seq` format wrapper for sequence of images (eg. animated GIFs)++1.5.2.0+=======+ * Fixed `Storable` instance for some Pixel types. * Fixed reading/writing animated GIFs. Added a detailed example to documentation.-* Improved encodeing/decoding of images.-* Improved coversion between `ColorSpace`s. +* Improved encoding/decoding of images.+* Improved coversion between `ColorSpace`s.  1.5.1.0 =======@@ -21,10 +29,12 @@  * Refactored `Gray` color space to be `X`, in order to reflect it's generality * Renamed few core functions:+   * `mapPx` -> `liftPx`,   * `zipWithPx` -> `liftPx2`,   * `broadcastC` -> `promote`,   * `singleton` -> `scalar`.+ * `upsample`/`downsample` functions are now a lot more general.  @@ -52,7 +62,7 @@   * Renaming `RS` and `RP` Repa representations into `RSU` and `RPU`.   * Addition `VS` Storable Vector representationas well as `RSS` and `RPS`     Storable Repa representations.-    + 1.3.0.0 ======= @@ -84,8 +94,8 @@   * OS default image viewer is used for displaying images with ability to use a custom one.   * Histogram plotting is done using diagrams instead of cairo backend,     significantly simplifying installation-     + 1.0.2.0 ======= @@ -110,5 +120,3 @@  * Made it compatible with GHC >= 7.4 (#1) * Added histogram plotting using Charts--

@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}-module Main where--import Prelude as P-import Criterion.Main-import Graphics.Image as I-import Graphics.Image.Interface as I-import Graphics.Image.Interface.Repa--import Data.Array.Repa as R-import Data.Array.Repa.Eval as R-import Data.Array.Repa.Repr.Unboxed as R-import Data.Array.Repa.Stencil as R-import Data.Array.Repa.Stencil.Dim2 as R-import Data.Array.Repa.Algorithms.Convolve as R--- import Graphics.Image.Interface.Vector--sobelGx :: I.Array arr cs e => Image arr cs e -> Image arr cs e-sobelGx =-  convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]])--sobelGy :: I.Array arr cs e => Image arr cs e -> Image arr cs e-sobelGy =-  convolve Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]])--sobelGxSep :: I.Array arr cs e => Image arr cs e -> Image arr cs e-sobelGxSep =-  convolveCols Edge [1, 2, 1] . convolveRows Edge [1, 0, -1]--sobelGySep :: I.Array arr cs e => Image arr cs e -> Image arr cs e-sobelGySep =-  convolveCols Edge [1, 0, -1] . convolveRows Edge [1, 2, 1]---sobelGxRAlg :: (Unbox e, Num e, Monad m) => R.Array U DIM2 e -> m (R.Array U DIM2 e)-sobelGxRAlg =-  convolveOutP outClamp (R.fromListUnboxed (Z :. 3 :. 3) [-1, 0, 1, -2, 0, 2, -1, 0, 1])--sobelGxR-  :: (Source r e, Num e) => R.Array r DIM2 e-     -> R.Array PC5 DIM2 e-sobelGxR = mapStencil2 BoundClamp stencil -  where stencil = makeStencil2 3 3-                  (\ix -> case ix of-                      Z :. -1 :. -1  -> Just (-1)-                      Z :.  0 :. -1  -> Just (-2)-                      Z :.  1 :. -1  -> Just (-1)-                      Z :. -1 :.  1  -> Just 1-                      Z :.  0 :.  1  -> Just 2-                      Z :.  1 :.  1  -> Just 1-                      _              -> Nothing)--sobelGyR-  :: (Source r e, Num e) => R.Array r DIM2 e-     -> R.Array PC5 DIM2 e-sobelGyR = mapStencil2 BoundClamp stencil -  where stencil = makeStencil2 3 3-                  (\ix -> case ix of-                      Z :.  1 :. -1  -> Just (-1)-                      Z :.  1 :.  0  -> Just (-2)-                      Z :.  1 :.  1  -> Just (-1)-                      Z :. -1 :. -1  -> Just 1-                      Z :. -1 :.  0  -> Just 2-                      Z :. -1 :.  1  -> Just 1-                      _              -> Nothing)--force-  :: (Load r1 sh e, Unbox e, Monad m)-  => R.Array r1 sh e -> m (R.Array U sh e)-force arr = do-    forcedArr <- computeUnboxedP arr-    forcedArr `deepSeqArray` return forcedArr----main :: IO ()-main = do-  -- img' <- readImageRGB RPU "images/frog.jpg"-  -- let !imgU = compute img'-  let _foo = GIFALooping-  let !imgU = compute $ makeImage (1024, 768)-              (\(i, j) -> fromIntegral ((min i j) `div` (1 + max i j )))-              :: Image RPU Y Word8-  let sobelU = sobelGx imgU-  let sobelSepU = sobelGxSep imgU-  let !imgR = toRepaArray imgU-  let sobelR = sobelGxR imgR-  let sobelRAlg = sobelGxRAlg imgR-  defaultMain-    [ bgroup-        "Sobel"-        [-          bench "naive U" $ whnf compute sobelU-        , bench "separated U" $ whnf compute sobelSepU-        , bench "repa U Agorithms" $ whnfIO sobelRAlg-        , bench "repa U Stencil" $ whnfIO (force sobelR)-        ]-    ]-

@@ -0,0 +1,108 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+module Main where++import           Control.Monad+import           Criterion.Main+import           Data.Array.Repa                     as R+import           Data.Array.Repa.Algorithms.Convolve as R+import           Data.Array.Repa.Eval                as R+import           Data.Array.Repa.Repr.Unboxed        as R+import           Data.Array.Repa.Stencil             as R+import           Data.Array.Repa.Stencil.Dim2        as R++import           Graphics.Image                      as I+import           Graphics.Image.Interface            as I+import           Graphics.Image.Interface.Repa+import           Prelude                             as P++-- | Convolution+sobelGx :: (I.Array arr X e, I.Array arr cs e) => Image arr cs e -> Image arr cs e+sobelGx =+  convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]])+++-- | Same convolution by separable+sobelGxSep :: (I.Array arr X e, I.Array arr cs e) => Image arr cs e -> Image arr cs e+sobelGxSep =+  convolveCols Edge [1, 2, 1] . convolveRows Edge [1, 0, -1]+++-- | Repa algorithms convolution implementation+sobelGxRAlg :: (Unbox e, Num e, Monad m) => R.Array U DIM2 e -> m (R.Array U DIM2 e)+sobelGxRAlg =+  convolveOutP outClamp (R.fromListUnboxed (Z :. 3 :. 3) [-1, 0, 1, -2, 0, 2, -1, 0, 1])++-- | Repa algorithms convolution implementation - separable+sobelGxRAlgSep :: (Unbox e, Num e, Monad m) => R.Array U DIM2 e -> m (R.Array U DIM2 e)+sobelGxRAlgSep =+  convolveOutP+    outClamp+    (R.fromListUnboxed (Z :. 1 :. 3) [1, 0, -1]) >=>+  convolveOutP+    outClamp+    (R.fromListUnboxed (Z :. 3 :. 1) [1, 2, 1])+++-- |  Repa stencil base convolution+sobelGxR+  :: (Source r e, Num e) => R.Array r DIM2 e+     -> R.Array PC5 DIM2 e+sobelGxR = mapStencil2 BoundClamp stencil+  where stencil = makeStencil2 3 3+                  (\ix -> case ix of+                      Z :. -1 :. -1 -> Just (-1)+                      Z :.  0 :. -1 -> Just (-2)+                      Z :.  1 :. -1 -> Just (-1)+                      Z :. -1 :.  1 -> Just 1+                      Z :.  0 :.  1 -> Just 2+                      Z :.  1 :.  1 -> Just 1+                      _             -> Nothing)++forceP+  :: (Load r1 sh e, Unbox e, Monad m)+  => R.Array r1 sh e -> m (R.Array U sh e)+forceP !arr = do+    forcedArr <- computeUnboxedP arr+    forcedArr `deepSeqArray` return forcedArr++forceS+  :: (Load r1 sh e, Unbox e, Monad m)+  => R.Array r1 sh e -> m (R.Array U sh e)+forceS !arr = do+    forcedArr <- return $ computeS arr+    forcedArr `deepSeqArray` return forcedArr++++main :: IO ()+main = do+  let !imgU = compute $ makeImage (1600, 1600)+              (\(i, j) -> fromIntegral ((min i j) `div` (1 + max i j )))+              :: Image RPU Y Double+  let !imgU' =+        compute $+        makeImage+          (1600, 1600)+          (\(i, j) -> fromIntegral ((min i j) `div` (1 + max i j))) :: Image VU Y Double+  let !sobelFSep = applyFilter (sobelFilter Horizontal Edge) imgU+  let !sobelFSep' = applyFilter (sobelFilter Horizontal Edge)+  let !imgR = toRepaArray imgU+  let sobelR = sobelGxR imgR+  let sobelRAlgSep = sobelGxRAlgSep imgR+  defaultMain+    [ bgroup+        -- "Gaussian"+        -- [ bench "Native VU" $ whnf (applyFilter gb) imgU'+        -- ]+        "Sobel"+        [+        --   bench "naive U" $ whnf compute sobelU+          bench "repa R Stencil" $ whnfIO (forceP sobelR)+        , bench "Filter R" $ whnf compute sobelFSep+        , bench "Filter VU" $ whnf sobelFSep' imgU'+        , bench "repa R Agorithms Separated" $ whnfIO sobelRAlgSep+        ]+    ]

@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+module Main where++import Prelude as P+import Criterion.Main+import Graphics.Image as I+import Graphics.Image.Interface as I+++++main :: IO ()+main = do+  let toX (PixelY y) = PixelX y+  let !imgY =+        compute $+        makeImage+          (1024, 768)+          (\(i, j) -> fromIntegral ((min i j) `div` (1 + max i j))) :: Image VU Y Double+  defaultMain+    [ bgroup+        "Histogram"+        [ bench "Compute All" $ nf (hBins . head . getHistograms) imgY+        , bench "Compute Direct " $ nf (hBins . getHistogram . I.map toX) imgY+        , bench "Equalize" $ nf equalizeHistogram imgY+        ]+    ]

@@ -1,5 +1,5 @@ Name:              hip-Version:           1.5.2.0+Version:           1.5.3.0 License:           BSD3 License-File:      LICENSE Author:            Alexey Kuleshevich@@ -66,6 +66,7 @@                  , Graphics.Image.Processing                  , Graphics.Image.Processing.Binary                  , Graphics.Image.Processing.Complex+                 , Graphics.Image.Processing.Filter                  , Graphics.Image.Types   Other-Modules:   Graphics.Image.ColorSpace.Binary                  , Graphics.Image.ColorSpace.CMYK@@ -76,15 +77,12 @@                  , Graphics.Image.ColorSpace.Y                  , Graphics.Image.ColorSpace.YCbCr                  , Graphics.Image.IO.Base-                 , Graphics.Image.IO.Formats.JuicyPixels.Common-                 , Graphics.Image.IO.Formats.JuicyPixels.Readable-                 , Graphics.Image.IO.Formats.JuicyPixels.Writable+                 , Graphics.Image.IO.Formats.JuicyPixels                  , Graphics.Image.IO.Formats.Netpbm                  , Graphics.Image.Interface.Elevator                  , Graphics.Image.Interface.Repa.Generic                  , Graphics.Image.Interface.Repa.Storable                  , Graphics.Image.Interface.Repa.Unboxed-                 , Graphics.Image.Interface.Repa.Helpers                  , Graphics.Image.Interface.Vector.Generic                  , Graphics.Image.Interface.Vector.Storable                  , Graphics.Image.Interface.Vector.Unboxed@@ -93,6 +91,7 @@                  , Graphics.Image.Processing.Complex.Fourier                  , Graphics.Image.Processing.Geometric                  , Graphics.Image.Processing.Interpolation+                 , Graphics.Image.Utils   GHC-Options:     -Wall   if os(windows)     CPP-Options:      -DOS_Win32@@ -126,17 +125,28 @@ benchmark convolution   type:                exitcode-stdio-1.0   hs-source-dirs:      benchmarks-  main-is:             Canny.hs-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2+  main-is:             Convolution.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N6 -O2   build-depends:       base                      , criterion                      , deepseq                      , repa                      , repa-algorithms                      , hip+                     , vector   default-language:    Haskell2010 -                       +benchmark histogram+  type:                exitcode-stdio-1.0+  hs-source-dirs:      benchmarks+  main-is:             Histogram.hs+  ghc-options:         -threaded -O2+  build-depends:       base+                     , criterion+                     , hip+  default-language:    Haskell2010++ Source-Repository head   Type:     git   Location: https://github.com/lehins/hip.git

@@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module      : Graphics.Image--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -98,9 +98,10 @@   -- ** Geometric   I.traverse, traverse2,   transpose, backpermute,-  (|*|), +  (|*|),   -- * Reduction   fold, sum, product, maximum, minimum, normalize, eqTol,+  -- * Manifest Image   -- * Representations   exchange,   module IP@@ -139,13 +140,13 @@ -- -- <<images/grad_gray.png>> <<images/grad_color.png>> ---makeImageR :: Array arr cs Double =>+makeImageR :: Array arr cs e =>               arr -- ^ Underlying image representation.            -> (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.-           -> ((Int, Int) -> Pixel cs Double)+           -> ((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 Double+           -> Image arr cs e makeImageR _ = I.makeImage {-# INLINE makeImageR #-} @@ -238,7 +239,7 @@ -- | Check weather two images are equal within a tolerance. Useful for comparing -- images with `Float` or `Double` precision. eqTol-  :: (Array arr Binary Bit, Array arr cs e, Ord e) =>+  :: (Array arr X Bit, Array arr cs e, Ord e) =>      e -> Image arr cs e -> Image arr cs e -> Bool eqTol !tol !img1 = IP.and . toImageBinaryUsing2 (eqTolPx tol) img1 {-# INLINE eqTol #-}@@ -272,9 +273,9 @@ --     * __'Pixel' 'YCbCr' e  = PixelYCbCr y cb cr__    - Luma, blue-difference and red-difference chromas. --     * __'Pixel' 'YCbCrA' e = PixelYCbCrA y cb cr a__ - YCbCr with alpha. --       ---------------------------------------------------------------------------------------------     * __'Pixel' 'Binary' 'Bit'     = 'on' | 'off'__ - Bi-tonal.+--     * __'Pixel' 'X' 'Bit'          = 'on' | 'off'__ - Bi-tonal. --     * __'Pixel' cs ('Complex' e) = ('Pixel' cs e) '+:' ('Pixel' cs e)__ - Complex pixels with any color space.---     * __'Pixel' 'X' e         = PixelX g__ - Used for separating channels from other color spaces.+--     * __'Pixel' 'X' e         = PixelX g__ - Used to represent binary images as well as any other single channel colorspace, for instance to separate channels from other color spaces into standalone images. -- @ -- -- Every 'Pixel' is an instance of 'Functor', 'Applicative', 'F.Foldable' and

@@ -1,12 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ViewPatterns          #-} #if __GLASGOW_HASKELL__ >= 800   {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif@@ -21,9 +21,9 @@ module Graphics.Image.ColorSpace (   -- * Pixels   -- ** Family of Pixels-  -- | Pixel is a type family for all available color spaces. Below will be-  -- listed all class instances pixels are installed in, as well as all pixel-  -- constructors.+  -- | Pixel is a type family for all available color spaces. Below is the+  -- listed of all class instances, that pixels are installed in, as well as all+  -- pixel constructors.   --   -- >>> :t (PixelY 0) -- Black pixel in Luma   -- (PixelY 0) :: Num e => Pixel Y e@@ -78,11 +78,12 @@   -- >>> (on + on) - on   -- <Binary:(0)>   ---  on, off, isOn, isOff, one, zero, fromBool, complement,   toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary,+  module Graphics.Image.ColorSpace.Binary,   -- ** Complex   module Graphics.Image.ColorSpace.Complex,   -- ** X+  squashWith, squashWith2,   toPixelsX, fromPixelsX,   toImagesX, fromImagesX,   -- * ColorSpace@@ -103,44 +104,57 @@   -- ** YCbCr   YCbCr(..), YCbCrA(..),   ToYCbCr, ToYCbCrA,-  -- ** Binary-  Binary(..), Bit,    -- ** X   X(..),-  -- * Useful re-exports+  -- * Precision+  -- ** Image+  toWord8I,+  toWord16I,+  toWord32I,+  toFloatI,+  toDoubleI,+  -- ** Pixel+  toWord8Px,+  -- ** Componenet   Word8, Word16, Word32, Word64   ) where -import Data.Word-import Graphics.Image.Interface as I-import Graphics.Image.ColorSpace.Binary-import Graphics.Image.ColorSpace.RGB-import Graphics.Image.ColorSpace.HSI-import Graphics.Image.ColorSpace.CMYK-import Graphics.Image.ColorSpace.X-import Graphics.Image.ColorSpace.Y-import Graphics.Image.ColorSpace.YCbCr-import Graphics.Image.ColorSpace.Complex+import           Data.Word+import           Graphics.Image.ColorSpace.Binary+import           Graphics.Image.ColorSpace.CMYK+import           Graphics.Image.ColorSpace.Complex+import           Graphics.Image.ColorSpace.HSI+import           Graphics.Image.ColorSpace.RGB+import           Graphics.Image.ColorSpace.X+import           Graphics.Image.ColorSpace.Y+import           Graphics.Image.ColorSpace.YCbCr+import           Graphics.Image.Interface          as I+import           Graphics.Image.Interface.Elevator  --- Binary:+-- -- Binary: --- | Convert to a `Binary` image.-toImageBinary :: (Array arr cs e, Array arr Binary Bit) =>-                 Image arr cs e-              -> Image arr Binary Bit-toImageBinary = I.map toPixelBinary-{-# INLINE toImageBinary #-}+-- | Convert to a `Binary` pixel.+toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel X Bit+toPixelBinary px = if px == 0 then on else off + -- | Convert a Binary pixel to Luma pixel-fromPixelBinary :: Pixel Binary Bit -> Pixel Y Word8+fromPixelBinary :: Pixel X Bit -> Pixel Y Word8 fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound {-# INLINE fromPixelBinary #-} +-- | Convert to a `Binary` image.+toImageBinary :: (Array arr cs e, Array arr X Bit) =>+                 Image arr cs e+              -> Image arr X Bit+toImageBinary = I.map toPixelBinary+{-# INLINE toImageBinary #-} + -- | Convert a Binary image to Luma image-fromImageBinary :: (Array arr Binary Bit, Array arr Y Word8) =>-                   Image arr Binary Bit+fromImageBinary :: (Array arr X Bit, Array arr Y Word8) =>+                   Image arr X Bit                 -> Image arr Y Word8 fromImageBinary = I.map fromPixelBinary {-# INLINE fromImageBinary #-}@@ -150,7 +164,7 @@ -- pixels with `Float` or `Double` precision. eqTolPx :: (ColorSpace cs e, Ord e) =>            e -> Pixel cs e -> Pixel cs e -> Bool-eqTolPx !tol = foldlPx2 comp True +eqTolPx !tol = foldlPx2 comp True   where comp !acc !e1 !e2 = acc && max e1 e2 - min e1 e2 <= tol         {-# INLINE comp #-} {-# INLINE eqTolPx #-}@@ -175,10 +189,6 @@   toPixelY (PixelX y) = PixelY $ toDouble y   {-# INLINE toPixelY #-} -instance ToY Binary Bit where-  toPixelY (PixelBinary b) = PixelY $ toDouble b-  {-# INLINE toPixelY #-}- instance Elevator e => ToY Y e where   toPixelY (PixelY y) = PixelY $ toDouble y   {-# INLINE toPixelY #-}@@ -238,13 +248,14 @@ toImageYA = I.map toPixelYA {-# INLINE toImageYA #-} -                                -instance ToY Y e => ToYA Y e -instance ToYA Binary Bit where-  toPixelYA(PixelBinary b) = PixelYA (toDouble b) 1+instance ToYA X Bit where+  toPixelYA (PixelX y) = PixelYA (toDouble y) 1   {-# INLINE toPixelYA #-} ++instance ToY Y e => ToYA Y e+ instance Elevator e => ToYA YA e where   toPixelYA = fmap toDouble   {-# INLINE toPixelYA #-}@@ -290,8 +301,8 @@ {-# INLINE toImageRGB #-}  -instance ToRGB Binary Bit where-  toPixelRGB (PixelBinary b) = pure $ toDouble b+instance ToRGB X Bit where+  toPixelRGB (PixelX b) = pure $ toDouble b   {-# INLINE toPixelRGB #-}  instance Elevator e => ToRGB Y e where@@ -343,9 +354,9 @@  instance Elevator e => ToRGB YCbCr e where   toPixelRGB (fmap toDouble -> 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)+    !r = clamp01 (y                      +   1.402*(cr - 0.5))+    !g = clamp01 (y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5))+    !b = clamp01 (y +   1.772*(cb - 0.5))   {-# INLINE toPixelRGB #-}  instance Elevator e => ToRGB YCbCrA e where@@ -382,7 +393,7 @@ {-# INLINE toImageRGBA #-}  -instance ToRGBA Binary Bit+instance ToRGBA X Bit  instance ToRGB Y e => ToRGBA Y e @@ -430,7 +441,7 @@ toImageHSI = I.map toPixelHSI {-# INLINE toImageHSI #-} -  + instance Elevator e => ToHSI Y e where   toPixelHSI (PixelY y) = PixelHSI 0 0 $ toDouble y   {-# INLINE toPixelHSI #-}@@ -667,9 +678,9 @@  instance Elevator e => ToYCbCr RGB e where   toPixelYCbCr (fmap toDouble -> 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+    !y  = clamp01 (         0.299*r +    0.587*g +    0.114*b)+    !cb = clamp01 (0.5 - 0.168736*r - 0.331264*g +      0.5*b)+    !cr = clamp01 (0.5 +      0.5*r - 0.418688*g - 0.081312*b)   {-# INLINE toPixelYCbCr #-}  instance Elevator e => ToYCbCr RGBA e where@@ -719,8 +730,8 @@ toImageYCbCrA = I.map toPixelYCbCrA {-# INLINE toImageYCbCrA #-} -  + instance ToYCbCr Y e => ToYCbCrA Y e  instance Elevator e => ToYCbCrA YA e where@@ -752,4 +763,47 @@   toPixelYCbCrA = fmap toDouble   {-# INLINE toPixelYCbCrA #-} ++-- | Change image precision to `Word8`.+toWord8I :: (Functor (Pixel cs), Array arr cs e, Array arr cs Word8)+         => Image arr cs e -> Image arr cs Word8+toWord8I = I.map (fmap toWord8)+{-# INLINABLE toWord8I #-}++{-+{-# SPECIALIZE toWord8I :: (Array arr Y Double, Array arr Y Word8) => Image arr Y Double -> Image arr Y Word8 #-}+{-# SPECIALIZE toWord8I :: (Array arr YA Double, Array arr YA Word8) => Image arr YA Double -> Image arr YA Word8 #-}+{-# SPECIALIZE toWord8I :: (Array arr RGB Double, Array arr RGB Word8) => Image arr RGB Double -> Image arr RGB Word8 #-}+{-# SPECIALIZE toWord8I :: (Array arr RGBA Double, Array arr RGBA Word8) => Image arr RGBA Double -> Image arr RGBA Word8 #-}+-}+-- | Change image precision to `Word16`.+toWord16I :: (Functor (Pixel cs), Array arr cs e, Array arr cs Word16)+         => Image arr cs e -> Image arr cs Word16+toWord16I = I.map (fmap toWord16)+{-# INLINABLE toWord16I #-}++-- | Change image precision to `Word32`.+toWord32I :: (Functor (Pixel cs), Array arr cs e, Array arr cs Word32)+         => Image arr cs e -> Image arr cs Word32+toWord32I = I.map (fmap toWord32)+{-# INLINABLE toWord32I #-}++-- | Change image precision to `Float`.+toFloatI :: (Functor (Pixel cs), Array arr cs e, Array arr cs Float)+         => Image arr cs e -> Image arr cs Float+toFloatI = I.map (fmap toFloat)+{-# INLINABLE toFloatI #-}++-- | Change image precision to `Double`.+toDoubleI :: (Functor (Pixel cs), Array arr cs e, Array arr cs Double)+         => Image arr cs e -> Image arr cs Double+toDoubleI = I.map (fmap toDouble)+{-# INLINABLE toDoubleI #-}++++-- | Change pixel precision to `Word8`.+toWord8Px :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word8+toWord8Px = fmap toWord8+{-# INLINABLE toWord8Px #-} 

@@ -1,131 +1,130 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.ColorSpace.Binary--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Graphics.Image.ColorSpace.Binary (-  Binary(..), Bit(..), Pixel(..), on, off, isOn, isOff, fromBool, zero, one,-  toPixelBinary,-  module Data.Bits+  Bit(..), on, off, isOn, isOff, fromBool, zero, one, bit2bool, bool2bit, toNum, fromNum   ) where -import Prelude hiding (map)-import Control.Monad-import Data.Bits-import Data.Word (Word8)-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import qualified Data.Vector.Generic            as V-import qualified Data.Vector.Generic.Mutable    as M-import qualified Data.Vector.Unboxed            as U-import Graphics.Image.Interface----- | Binary Color Space, also known as bi-tonal.-data Binary = Binary deriving (Eq, Enum, Bounded, Show, Typeable)+import           Control.Monad+import           Data.Bits+import           Data.Typeable               (Typeable)+import qualified Data.Vector.Generic         as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed         as U+import           Data.Word                   (Word8)+import           Foreign.Ptr+import           Foreign.Storable+import           Graphics.Image.ColorSpace.X+import           Graphics.Image.Interface+import           Prelude                     hiding (map)  --- | Under the hood, Binary pixels are represented as 'Word8', but can only take--- values of @0@ or @1@.+-- | Under the hood, binary pixels are represented as `Word8`, but can only take+-- values of @0@ or @1@. Use `zero`\/`one` to construct a bit and `on`\/`off` to+-- construct a binary pixel. newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable) -newtype instance Pixel Binary Bit = PixelBinary Bit deriving (Ord, Eq) ---- | Convert to a `Binary` pixel.-toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel Binary Bit-toPixelBinary px = if px == 0 then on else off---instance Show (Pixel Binary Bit) where-  show (PixelBinary (Bit 0)) = "<Binary:(0)>"-  show _                     = "<Binary:(1)>"+instance Show Bit where+  show (Bit 0) = "0"+  show _       = "1"   instance Bits Bit where-  (.&.) = (*)+  (Bit 0) .&. _       = Bit 0+  (Bit 1) .&. (Bit 1) = Bit 1+  _       .&. (Bit 0) = Bit 0+  _       .&. _       = Bit 1   {-# INLINE (.&.) #-}--  (.|.) = (+)+  (Bit 1) .|. _       = Bit 1+  (Bit 0) .|. (Bit 0) = Bit 0+  _       .|. _       = Bit 1   {-# INLINE (.|.) #-}-   (Bit 0) `xor` (Bit 0) = Bit 0   (Bit 1) `xor` (Bit 1) = Bit 0   _       `xor` _       = Bit 1   {-# INLINE xor #-}-   complement (Bit 0) = Bit 1   complement       _ = Bit 0-+  {-# INLINE complement #-}   shift !b 0 = b   shift  _ _ = Bit 0-  +  {-# INLINE shift #-}   rotate !b _ = b-+  {-# INLINE rotate #-}   zeroBits = Bit 0-+  {-# INLINE zeroBits #-}   bit 0 = Bit 1   bit _ = Bit 0-+  {-# INLINE bit #-}   testBit (Bit 1) 0 = True   testBit _       _ = False-+  {-# INLINE testBit #-}   bitSizeMaybe _ = Just 1-+  {-# INLINE bitSizeMaybe #-}   bitSize _ = 1-+  {-# INLINE bitSize #-}   isSigned _ = False-+  {-# INLINE isSigned #-}   popCount (Bit 0) = 0   popCount _       = 1-+  {-# INLINE popCount #-}  -instance Bits (Pixel Binary Bit) where+instance Bits (Pixel X Bit) where   (.&.) = liftPx2 (.&.)   {-# INLINE (.&.) #-}-   (.|.) = liftPx2 (.|.)   {-# INLINE (.|.) #-}-   xor = liftPx2 xor   {-# INLINE xor #-}-   complement = liftPx complement-+  {-# INLINE complement #-}   shift !b !n = liftPx (`shift` n) b-  +  {-# INLINE shift #-}   rotate !b !n = liftPx (`rotate` n) b-+  {-# INLINE rotate #-}   zeroBits = promote zeroBits-+  {-# INLINE zeroBits #-}   bit = promote . bit--  testBit (PixelBinary (Bit 1)) 0 = True-  testBit _                     _ = False-+  {-# INLINE bit #-}+  testBit (PixelX (Bit 1)) 0 = True+  testBit _                _ = False+  {-# INLINE testBit #-}   bitSizeMaybe _ = Just 1-+  {-# INLINE bitSizeMaybe #-}   bitSize _ = 1-+  {-# INLINE bitSize #-}   isSigned _ = False+  {-# INLINE isSigned #-}+  popCount (PixelX (Bit 0)) = 0+  popCount _                = 1+  {-# INLINE popCount #-} -  popCount (PixelBinary (Bit 0)) = 0-  popCount _                     = 1+toNum :: Num a => Bit -> a+toNum (Bit 0) = 0+toNum _       = 1+{-# INLINE toNum #-} +fromNum :: (Eq a, Num a) => a -> Bit+fromNum 0 = zero+fromNum _ = one+{-# INLINE fromNum #-} + zero :: Bit zero = Bit 0 {-# INLINE zero #-}@@ -134,69 +133,54 @@ one = Bit 1 {-# INLINE one #-} +bool2bit :: Bool -> Bit+bool2bit False = zero+bool2bit True = one+{-# INLINE bool2bit #-}++bit2bool :: Bit -> Bool+bit2bool (Bit 0) = False+bit2bool _       = True+{-# INLINE bit2bool #-}+ -- | Represents value 'True' or @1@ in binary. Often also called a foreground -- pixel of an object.-on :: Pixel Binary Bit-on = PixelBinary one+on :: Pixel X Bit+on = PixelX one {-# INLINE on #-}   -- | Represents value 'False' or @0@ in binary. Often also called a background -- pixel.-off :: Pixel Binary Bit-off = PixelBinary zero+off :: Pixel X Bit+off = PixelX zero {-# INLINE off #-}  --- | Convert a 'Bool' to a 'PixelBin' pixel.+-- | Convert a 'Bool' to a binary pixel. -- -- >>> isOn (fromBool True) -- True ---fromBool :: Bool -> Pixel Binary Bit+fromBool :: Bool -> Pixel X 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+isOn :: Pixel X Bit -> Bool+isOn (PixelX (Bit 0)) = False+isOn _                = True {-# INLINE isOn #-}   -- | Test if Pixel's value is 'off'.-isOff :: Pixel Binary Bit -> Bool+isOff :: Pixel X Bit -> Bool isOff = not . isOn {-# INLINE isOff #-}  --instance ColorSpace Binary Bit where-  type Components Binary Bit = Bit--  promote = PixelBinary-  {-# INLINE promote #-}-  fromComponents = PixelBinary-  {-# INLINE fromComponents #-}-  toComponents (PixelBinary b) = b-  {-# INLINE toComponents #-}-  getPxC (PixelBinary b) _ = b-  {-# INLINE getPxC #-}-  setPxC (PixelBinary _) _ b = PixelBinary b-  {-# INLINE setPxC #-}  -  mapPxC f (PixelBinary b) = PixelBinary (f Binary b)-  {-# INLINE mapPxC #-}-  liftPx f (PixelBinary b) = PixelBinary (f b)-  {-# INLINE liftPx #-}-  liftPx2 f (PixelBinary b1) (PixelBinary b2) = PixelBinary (f b1 b2)-  {-# INLINE liftPx2 #-}-  foldrPx f z (PixelBinary b) = f b z-  {-# INLINE foldrPx #-}-  foldlPx2 f !z (PixelBinary b1) (PixelBinary b2) = f z b1 b2-  {-# INLINE foldlPx2 #-}- -- | Values: @0@ and @1@ instance Elevator Bit where   toWord8 (Bit 0) = 0@@ -221,22 +205,19 @@   fromDouble _ = Bit 1   {-# INLINE fromDouble #-} -    instance Num Bit where-  (Bit 0) + (Bit 0) = Bit 0-  _       + _       = Bit 1+  (+) = (.|.)   {-# INLINE (+) #-}   -- 0 - 0 = 0   -- 0 - 1 = 0   -- 1 - 0 = 1   -- 1 - 1 = 0-  _ - (Bit 1) = Bit 0-  _ - _       = Bit 1+  (Bit 0) - (Bit 0) = Bit 0+  _       - (Bit 0) = Bit 1+  _       - _       = Bit 0   {-# INLINE (-) #-}-  _       * (Bit 0) = Bit 0-  (Bit 0) * _       = Bit 0-  _       * _       = Bit 1+  (*) = (.&.)   {-# INLINE (*) #-}   abs         = id   {-# INLINE abs #-}@@ -250,28 +231,18 @@ instance Storable Bit where    sizeOf _ = sizeOf (undefined :: Word8)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: Word8)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     b <- peek q     return (Bit b)-  poke p (Bit b) = do-    q <- return $ castPtr p-    poke q b---instance Storable (Pixel Binary Bit) where--  sizeOf _ = sizeOf (undefined :: Bit)-  alignment _ = alignment (undefined :: Bit)-  peek p = do-    q <- return $ castPtr p-    b <- peek q-    return (PixelBinary b)-  poke p (PixelBinary b) = do+  {-# INLINE peek #-}+  poke !p (Bit b) = do     q <- return $ castPtr p     poke q b-+  {-# INLINE poke #-}   -- | Unboxing of a `Bit`.

@@ -1,10 +1,10 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.ColorSpace.CMYK -- Copyright   : (c) Alexey Kuleshevich 2017@@ -17,13 +17,13 @@   CMYK(..), CMYKA(..), Pixel(..)   ) where -import Prelude hiding (map)-import Control.Applicative-import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.Image.Interface+import           Control.Applicative+import           Data.Foldable+import           Data.Typeable            (Typeable)+import           Foreign.Ptr+import           Foreign.Storable+import           Graphics.Image.Interface+import           Prelude                  hiding (map)  ------------ --- CMYK ---@@ -45,7 +45,7 @@  instance Elevator e => ColorSpace CMYK e where   type Components CMYK e = (e, e, e, e)-  +   fromComponents !(c, m, y, k) = PixelCMYK c m y k   {-# INLINE fromComponents #-}   toComponents (PixelCMYK c m y k) = (c, m, y, k)@@ -97,20 +97,24 @@ instance Storable e => Storable (Pixel CMYK e) where    sizeOf _ = 4 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     c <- peek q     m <- peekElemOff q 1     y <- peekElemOff q 2     k <- peekElemOff q 3     return (PixelCMYK c m y k)-  poke p (PixelCMYK c m y k) = do+  {-# INLINE peek #-}+  poke !p (PixelCMYK c m y k) = do     q <- return $ castPtr p     poke q c     pokeElemOff q 1 m     pokeElemOff q 2 y     pokeElemOff q 3 k+  {-# INLINE poke #-}  ------------- --- CMYKA ---@@ -121,7 +125,7 @@            | MagCMYKA   -- ^ Magenta            | YelCMYKA   -- ^ Yellow            | KeyCMYKA   -- ^ Key (Black)-           | AlphaCMYKA -- ^ Alpha +           | AlphaCMYKA -- ^ Alpha            deriving (Eq, Enum, Show, Bounded, Typeable)  @@ -135,7 +139,7 @@  instance Elevator e => ColorSpace CMYKA e where   type Components CMYKA e = (e, e, e, e, e)-  +   fromComponents !(c, m, y, k, a) = PixelCMYKA c m y k a   {-# INLINE fromComponents #-}   toComponents (PixelCMYKA c m y k a) = (c, m, y, k, a)@@ -173,7 +177,7 @@    getAlpha (PixelCMYKA _ _ _ _ a) = a   {-# INLINE getAlpha #-}-  +   addAlpha !a (PixelCMYK c m y k) = PixelCMYKA c m y k a   {-# INLINE addAlpha #-} @@ -202,8 +206,10 @@ instance Storable e => Storable (Pixel CMYKA e) where    sizeOf _ = 5 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     c <- peek q     m <- peekElemOff q 1@@ -211,10 +217,12 @@     k <- peekElemOff q 3     a <- peekElemOff q 4     return (PixelCMYKA c m y k a)-  poke p (PixelCMYKA c m y k a) = do+  {-# INLINE peek #-}+  poke !p (PixelCMYKA c m y k a) = do     q <- return $ castPtr p     poke q c     pokeElemOff q 1 m     pokeElemOff q 2 y     pokeElemOff q 3 k     pokeElemOff q 4 a+  {-# INLINE poke #-}

@@ -1,10 +1,10 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.ColorSpace.HSI -- Copyright   : (c) Alexey Kuleshevich 2017@@ -17,13 +17,13 @@   HSI(..), HSIA(..), Pixel(..)   ) where -import Prelude hiding (map)-import Control.Applicative-import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.Image.Interface+import           Control.Applicative+import           Data.Foldable+import           Data.Typeable            (Typeable)+import           Foreign.Ptr+import           Foreign.Storable+import           Graphics.Image.Interface+import           Prelude                  hiding (map)  ----------- --- HSI ---@@ -31,7 +31,7 @@  -- | Hue, Saturation and Intensity color space. data HSI = HueHSI -- ^ Hue-         | SatHSI -- ^ Saturation +         | SatHSI -- ^ Saturation          | IntHSI -- ^ Intensity          deriving (Eq, Enum, Show, Bounded, Typeable) @@ -92,18 +92,22 @@ instance Storable e => Storable (Pixel HSI e) where    sizeOf _ = 3 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     r <- peek q     g <- peekElemOff q 1     b <- peekElemOff q 2     return (PixelHSI r g b)-  poke p (PixelHSI r g b) = do+  {-# INLINE peek #-}+  poke !p (PixelHSI r g b) = do     q <- return $ castPtr p     poke q r     pokeElemOff q 1 g     pokeElemOff q 2 b+  {-# INLINE poke #-}  ------------ --- HSIA ---@@ -187,17 +191,21 @@  instance Storable e => Storable (Pixel HSIA e) where   sizeOf _ = 4 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     h <- peek q     s <- peekElemOff q 1     i <- peekElemOff q 2     a <- peekElemOff q 3     return (PixelHSIA h s i a)-  poke p (PixelHSIA h s i a) = do+  {-# INLINE peek #-}+  poke !p (PixelHSIA h s i a) = do     q <- return $ castPtr p     poke q h     pokeElemOff q 1 s     pokeElemOff q 2 i     pokeElemOff q 3 a+  {-# INLINE poke #-}

@@ -180,7 +180,7 @@   foldr f !z (PixelRGBA r g b a) = f r (f g (f b (f a z)))   {-# INLINE foldr #-} - + instance Storable e => Storable (Pixel RGBA e) where   sizeOf _ = 4 * sizeOf (undefined :: e)   alignment _ = alignment (undefined :: e)

@@ -1,10 +1,10 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.ColorSpace.X -- Copyright   : (c) Alexey Kuleshevich 2017@@ -16,16 +16,18 @@ module Graphics.Image.ColorSpace.X (   X(..), Pixel(..),   toPixelsX, toImagesX,-  fromPixelsX, fromImagesX+  fromPixelsX, fromImagesX,+  squashWith, squashWith2   ) where -import Prelude as P-import Control.Applicative-import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.Image.Interface as I+import           Control.Applicative+import           Data.Foldable+import           Data.Typeable            (Typeable)+import           Foreign.Ptr+import           Foreign.Storable+import           Graphics.Image.Interface as I+import           Prelude                  as P+import           Graphics.Image.Utils ((.:!))  -- ^ This is a single channel colorspace, that is designed to separate Gray -- level values from other types of colorspace, hence it is not convertible to@@ -35,7 +37,7 @@ data X = X deriving (Eq, Enum, Bounded, Show, Typeable)  -newtype instance Pixel X e = PixelX e deriving (Ord, Eq)+newtype instance Pixel X e = PixelX { getX :: e } deriving (Ord, Eq)   instance Show e => Show (Pixel X e) where@@ -96,14 +98,18 @@ instance Storable e => Storable (Pixel X e) where    sizeOf _ = sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     g <- peek q     return (PixelX g)-  poke p (PixelX g) = do+  {-# INLINE peek #-}+  poke !p (PixelX g) = do     q <- return $ castPtr p     poke q g+  {-# INLINE poke #-}   -- | Separate a Pixel into a list of components with 'X' pixels containing every@@ -129,6 +135,21 @@   f !px (c, PixelX x) = setPxC px c x  ++-- | Apply a left fold to each of the pixels in the image.+squashWith :: (Array arr cs e, Array arr X b) =>+              (b -> e -> b) -> b -> Image arr cs e -> Image arr X b+squashWith f !a = I.map (PixelX . foldlPx f a) where+{-# INLINE squashWith #-}+++-- | Combination of zipWith and simultanious left fold on two pixels at the same time.+squashWith2 :: (Array arr cs e, Array arr X b) =>+               (b -> e -> e -> b) -> b -> Image arr cs e -> Image arr cs e -> Image arr X b+squashWith2 f !a = I.zipWith (PixelX .:! foldlPx2 f a) where+{-# INLINE squashWith2 #-}++ -- | Separate an image into a list of images with 'X' pixels containing every -- channel from the source image. --@@ -167,7 +188,7 @@ fromImagesX = fromXs 0 where   updateCh !ch !px (PixelX e) = setPxC px ch e   {-# INLINE updateCh #-}-  fromXs img []      = img+  fromXs img []          = img   fromXs img ((c, i):xs) = fromXs (I.zipWith (updateCh c) img i) xs   {-# INLINE fromXs #-} {-# INLINE fromImagesX #-}

@@ -1,10 +1,10 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.ColorSpace.Y -- Copyright   : (c) Alexey Kuleshevich 2017@@ -17,13 +17,13 @@   Y(..), YA(..), Pixel(..)   ) where -import Prelude hiding (map)-import Control.Applicative-import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.Image.Interface+import           Control.Applicative+import           Data.Foldable+import           Data.Typeable            (Typeable)+import           Foreign.Ptr+import           Foreign.Storable+import           Graphics.Image.Interface+import           Prelude                  hiding (map)  --------- --- Y ---@@ -92,14 +92,16 @@ instance Storable e => Storable (Pixel Y e) where    sizeOf _ = sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do-    q <- return $ castPtr p+  {-# INLINE alignment #-}+  peek !p = do+    let !q = castPtr p     y <- peek q     return (PixelY y)-  poke p (PixelY y) = do-    q <- return $ castPtr p-    poke q y+  {-# INLINE peek #-}+  poke !p (PixelY y) = let !q = castPtr p in poke q y+  {-# INLINE poke #-}   @@ -145,7 +147,7 @@   foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2   {-# INLINE foldlPx2 #-} -  + instance Elevator e => AlphaSpace YA e where   type Opaque YA = Y @@ -156,7 +158,7 @@   dropAlpha (PixelYA y _) = PixelY y   {-# INLINE dropAlpha #-} -  + instance Functor (Pixel YA) where   fmap f (PixelYA y a) = PixelYA (f y) (f a)   {-# INLINE fmap #-}@@ -177,14 +179,18 @@ instance Storable e => Storable (Pixel YA e) where    sizeOf _ = 2 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     y <- peekElemOff q 0     a <- peekElemOff q 1     return (PixelYA y a)-  poke p (PixelYA y a) = do+  {-# INLINE peek #-}+  poke !p (PixelYA y a) = do     q <- return $ castPtr p     pokeElemOff q 0 y     pokeElemOff q 1 a+  {-# INLINE poke #-} 

@@ -1,10 +1,10 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.ColorSpace.YCbCr -- Copyright   : (c) Alexey Kuleshevich 2017@@ -17,13 +17,13 @@   YCbCr(..), YCbCrA(..), Pixel(..)   ) where -import Prelude hiding (map)-import Control.Applicative-import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.Image.Interface+import           Control.Applicative+import           Data.Foldable+import           Data.Typeable            (Typeable)+import           Foreign.Ptr+import           Foreign.Storable+import           Graphics.Image.Interface+import           Prelude                  hiding (map)  ------------- --- YCbCr ---@@ -38,7 +38,7 @@  data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq -  + instance Show e => Show (Pixel YCbCr e) where   show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>" @@ -93,18 +93,22 @@ instance Storable e => Storable (Pixel YCbCr e) where    sizeOf _ = 3 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     y <- peek q     b <- peekElemOff q 1     r <- peekElemOff q 2     return (PixelYCbCr y b r)-  poke p (PixelYCbCr y b r) = do+  {-# INLINE poke #-}+  poke !p (PixelYCbCr y b r) = do     q <- return $ castPtr p     pokeElemOff q 0 y     pokeElemOff q 1 b     pokeElemOff q 2 r+  {-# INLINE peek #-}   --------------@@ -190,19 +194,23 @@ instance Storable e => Storable (Pixel YCbCrA e) where    sizeOf _ = 4 * sizeOf (undefined :: e)+  {-# INLINE sizeOf #-}   alignment _ = alignment (undefined :: e)-  peek p = do+  {-# INLINE alignment #-}+  peek !p = do     q <- return $ castPtr p     y <- peekElemOff q 0     b <- peekElemOff q 1     r <- peekElemOff q 2     a <- peekElemOff q 3     return (PixelYCbCrA y b r a)-  poke p (PixelYCbCrA y b r a) = do+  {-# INLINE peek #-}+  poke !p (PixelYCbCrA y b r a) = do     q <- return $ castPtr p     poke q y     pokeElemOff q 1 b     pokeElemOff q 2 r     pokeElemOff q 3 a+  {-# INLINE poke #-}  

@@ -29,7 +29,7 @@   gimpViewer,   -- * Supported Image Formats   module Graphics.Image.IO.Formats-  +   -- $supported    -- * Hands on examples@@ -64,7 +64,7 @@ data ExternalViewer =   ExternalViewer FilePath [String] Int     -- ^ Any custom viewer, which can be specified:-    -- +    --     -- * @FilePath@ - to the actual viewer executable.     -- * @[String]@ - command line arguments that will be passed to the executable.     -- * @Int@ - position index in the above list where `FilePath` to an image should be@@ -99,7 +99,7 @@       formats = enumFrom . toEnum $ 0       orderedFormats = maybe formats (\f -> f:P.filter (/=f) formats) maybeFormat       reader :: Either String (Image VS cs e) -> InputFormat -> IO (Either String (Image VS cs e))-      reader (Left err) format = +      reader (Left err) format =         return $ either (Left . ((err++"\n")++)) Right (decode format imgstr)       reader img         _     = return img   imgE <- M.foldM reader (Left "") orderedFormats@@ -161,7 +161,7 @@ writeImage :: (Array VS cs e, Array arr cs e,                Writable (Image VS cs e) OutputFormat) =>               FilePath            -- ^ Location where an image should be written.-           -> Image arr cs e -- ^ An image to write. +           -> Image arr cs e -- ^ An image to write.            -> IO () writeImage path = BL.writeFile path . encode format [] . exchange VS where   format = fromMaybe (error ("Could not guess output format. Use 'writeImageExact' "++@@ -183,8 +183,8 @@                        -- of formats supporting animation.                 -> IO () writeImageExact format opts path = BL.writeFile path . encode format opts-   + -- | An image is written as a @.tiff@ file into an operating system's temporary -- directory and passed as an argument to the external viewer program. displayImageUsing :: (Array VS cs e, Array arr cs e,@@ -271,11 +271,11 @@ 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 without an implicit conversion:-  + * 'BMP':      * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8')

@@ -1,7 +1,9 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.IO.Base -- Copyright   : (c) Alexey Kuleshevich 2016@@ -11,35 +13,37 @@ -- Portability : non-portable -- module Graphics.Image.IO.Base (-  ImageFormat(..), Readable(..), Writable(..), Convertible(..),+  ImageFormat(..), Readable(..), Writable(..), Convertible(..), Seq(..), ComplexWritable   ) where -import qualified Data.ByteString as B (ByteString)-import qualified Data.ByteString.Lazy as BL (ByteString)--import Graphics.Image.ColorSpace+import qualified Data.ByteString                     as B (ByteString)+import qualified Data.ByteString.Lazy                as BL (ByteString)+import           Graphics.Image.ColorSpace+import           Graphics.Image.Interface            as I+import           Graphics.Image.Processing.Complex   (imagPartI, realPartI)+import           Graphics.Image.Processing.Geometric (leftToRight)  -- | Used during converting pixels between libraries.-class Convertible a b where-  convert :: a -> b+class Convertible cs e where+  convert :: (ToYA cs' e', ToRGBA cs' e', Array arr cs' e', Array arr cs e) =>+    Image arr cs' e' -> Image arr cs e ---  Y (Double) -instance ToY cs e => Convertible (Pixel cs e) (Pixel Y Double) where-  convert = toPixelY--instance ToYA cs e => Convertible (Pixel cs e) (Pixel YA Double) where-  convert = toPixelYA+instance Convertible Y Double where+  convert = toImageY --- RGB -> RGB (Double)+instance Convertible YA Double where+  convert = toImageYA -instance ToRGB cs e => Convertible (Pixel cs e) (Pixel RGB Double) where-  convert = toPixelRGB+instance Convertible RGB Double where+  convert = toImageRGB -instance ToRGBA cs e => Convertible (Pixel cs e) (Pixel RGBA Double) where-  convert = toPixelRGBA+instance Convertible RGBA Double where+  convert = toImageRGBA  +-- | Special wrapper for formats that support encoding/decoding sequence of images.+newtype Seq f = Seq f  -- | Image file format. Helps in guessing image format using a file extension, -- as well as supplying format specific options during saving an image.@@ -50,11 +54,13 @@   -- | Default file extension for this image format.   ext :: format -> String -  -- | Known extensions for this image format.+  -- | Known file extensions for this image format, if more than one is commonly+  -- used, eg. ".jpeg", ".jpg".   exts :: format -> [String]   exts f = [ext f] -  -- | Returns `True` if a file extension (ex. @".png"@) corresponds to this format.+  -- | Checks if a file extension+  -- corresponds to the format, eg. @isFormat ".png" PNG == True@   isFormat :: String -> format -> Bool   isFormat e f = e `elem` exts f @@ -69,5 +75,16 @@ -- | Image formats that can be written to file. class ImageFormat format => Writable img format where -  -- | Encode an image to `BL.ByteString`.+  -- | Encode an image into `BL.ByteString`.   encode :: format -> [SaveOption format] -> img -> BL.ByteString++-- | Constraint type synonym for encoding a Complex image.+type ComplexWritable format arr cs e = ( Array arr cs e, Array arr cs (Complex e)+                                       , RealFloat e, Applicative (Pixel cs)+                                       , Writable (Image arr cs e) format )+++-- | Writing Complex images: places real part on the left side of imaginary part.+instance ComplexWritable format arr cs e => Writable (Image arr cs (Complex e)) format where+  encode format opts !imgC =+    encode format opts (leftToRight (realPartI imgC) (imagPartI imgC))

@@ -1,9 +1,10 @@+{-# LANGUAGE ConstraintKinds       #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-} -- | -- Module      : Graphics.Image.IO.Formats -- Copyright   : (c) Alexey Kuleshevich 2017@@ -12,25 +13,31 @@ -- Stability   : experimental -- Portability : non-portable ---module Graphics.Image.IO.Formats (-  module Graphics.Image.IO.Formats.JuicyPixels.Common,-  module Graphics.Image.IO.Formats.Netpbm,-  InputFormat(..), OutputFormat(..),-  Readable(..), Writable(..), ImageFormat(..),-  Convertible(..)+module Graphics.Image.IO.Formats+  ( module Graphics.Image.IO.Formats.JuicyPixels+  , module Graphics.Image.IO.Formats.Netpbm+    -- * General+  , ImageFormat(..)+  , InputFormat(..)+  , OutputFormat(..)+  , Readable(..)+  , Writable(..)+  , Convertible(..)+  , Seq(..)+  , AllReadable+  , AllWritable+  , ComplexWritable   ) where -import Graphics.Image.ColorSpace-import Graphics.Image.Interface-import Graphics.Image.Processing-import Graphics.Image.Processing.Complex-import Graphics.Image.IO.Base-import Graphics.Image.IO.Formats.JuicyPixels.Common-import Graphics.Image.IO.Formats.JuicyPixels.Readable()-import Graphics.Image.IO.Formats.JuicyPixels.Writable()-import Graphics.Image.IO.Formats.Netpbm +import           Graphics.Image.Interface+import           Graphics.Image.IO.Base+import           Graphics.Image.IO.Formats.JuicyPixels+import           Graphics.Image.IO.Formats.Netpbm +++ -- | A collection of all image formats that can be read into HIP images. data InputFormat = InputBMP                  | InputGIF@@ -64,15 +71,18 @@   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+-- | Constraint type synonym for all readable formats.+type AllReadable arr cs = ( 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 )+++instance AllReadable arr cs => Readable (Image arr cs Double) InputFormat where   decode InputBMP = decode BMP   decode InputGIF = decode GIF   decode InputHDR = decode HDR@@ -105,15 +115,26 @@   ext OutputTGA = ext TGA   ext OutputTIF = ext TIF +  exts OutputBMP = exts BMP+  exts OutputGIF = exts GIF+  exts OutputHDR = exts HDR+  exts OutputJPG = exts JPG+  exts OutputPNG = exts PNG+  exts OutputTGA = exts TGA+  exts OutputTIF = exts 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++-- | Constraint type synonym for all writable formats.+type AllWritable arr cs = ( 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 )+++instance AllWritable arr cs => Writable (Image arr cs Double) OutputFormat where   encode OutputBMP _ = encode BMP []   encode OutputGIF _ = encode GIF []   encode OutputHDR _ = encode HDR []@@ -121,11 +142,3 @@   encode OutputPNG _ = encode PNG []   encode OutputTGA _ = encode TGA []   encode OutputTIF _ = encode TIF []---instance (Array arr cs e, Array arr cs (Complex e),-          RealFloat e, Applicative (Pixel cs),-          Writable (Image arr cs e) format) =>-         Writable (Image arr cs (Complex e)) format where-  encode format opts imgC =-    encode format opts (leftToRight (realPartI imgC) (imagPartI imgC))

@@ -0,0 +1,1034 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeSynonymInstances  #-}+-- |+-- Module      : Graphics.Image.IO.Formats.JuicyPixels+-- Copyright   : (c) Alexey Kuleshevich 2017+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Graphics.Image.IO.Formats.JuicyPixels+  ( -- * JuicyPixels formats+    SaveOption(..)+    -- ** BMP+  , BMP(..)+    -- ** GIF+  , GIF(..)+  , GIFA(..)+  , JP.GifDelay+  , JP.GifLooping(..)+  , JP.PaletteOptions(..)+  , JP.PaletteCreationMethod(..)+  -- ** HDR+  , HDR(..)+  -- ** JPG+  , JPG(..)+  -- ** PNG+  , PNG(..)+  -- ** TGA+  , TGA(..)+  -- ** TIF+  , TIF(..)+  -- * JuciyPixels conversion+  -- ** To JuicyPixels+  -- O(1) Conversion to JuicyPixels images+  , toJPImageY8+  , toJPImageYA8+  , toJPImageY16+  , toJPImageYA16+  , toJPImageYF+  , toJPImageRGB8+  , toJPImageRGBA8+  , toJPImageRGB16+  , toJPImageRGBA16+  , toJPImageRGBF+  , toJPImageYCbCr8+  , toJPImageCMYK8+  , toJPImageCMYK16+  -- ** From JuicyPixels+  -- O(1) Conversion from JuicyPixels images+  , fromJPImageY8+  , fromJPImageYA8+  , fromJPImageY16+  , fromJPImageYA16+  , fromJPImageYF+  , fromJPImageRGB8+  , fromJPImageRGBA8+  , fromJPImageRGB16+  , fromJPImageRGBA16+  , fromJPImageRGBF+  , fromJPImageYCbCr8+  , fromJPImageCMYK8+  , fromJPImageCMYK16+  ) where++import           Prelude                         as P++import qualified Codec.Picture                   as JP+import qualified Codec.Picture.ColorQuant        as JP+import qualified Codec.Picture.Gif               as JP+import qualified Codec.Picture.Jpg               as JP+import           Control.Monad                   ((<=<))+import qualified Data.ByteString                 as B (ByteString)+import qualified Data.ByteString.Lazy            as BL (ByteString)+import qualified Data.Monoid                     as M (mempty)+import qualified Data.Vector.Storable            as V+import           Graphics.Image.ColorSpace+import           Graphics.Image.Interface        as I+import           Graphics.Image.Interface.Vector (VS)+import           Graphics.Image.IO.Base+++++-- Encoding++imageToJPImageUnsafe+  :: (JP.Pixel a, Array VS cs (JP.PixelBaseComponent a))+  => Image VS cs (JP.PixelBaseComponent a)+  -> JP.Image a+imageToJPImageUnsafe img = JP.Image n m $ V.unsafeCast $ toVector img where+  (m, n) = dims img+{-# INLINE imageToJPImageUnsafe #-}++toJPImageY8 :: Image VS Y Word8 -> JP.Image JP.Pixel8+toJPImageY8 = imageToJPImageUnsafe+{-# INLINE toJPImageY8 #-}++toJPImageY16 :: Image VS Y Word16 -> JP.Image JP.Pixel16+toJPImageY16 = imageToJPImageUnsafe+{-# INLINE toJPImageY16 #-}++toJPImageYA8 :: Image VS YA Word8 -> JP.Image JP.PixelYA8+toJPImageYA8 = imageToJPImageUnsafe+{-# INLINE toJPImageYA8 #-}++toJPImageYA16 :: Image VS YA Word16 -> JP.Image JP.PixelYA16+toJPImageYA16 = imageToJPImageUnsafe+{-# INLINE toJPImageYA16 #-}++toJPImageYF :: Image VS Y Float -> JP.Image JP.PixelF+toJPImageYF = imageToJPImageUnsafe+{-# INLINE toJPImageYF #-}++toJPImageRGB8 :: Image VS RGB Word8 -> JP.Image JP.PixelRGB8+toJPImageRGB8 = imageToJPImageUnsafe+{-# INLINE toJPImageRGB8 #-}++toJPImageRGBA8 :: Image VS RGBA Word8 -> JP.Image JP.PixelRGBA8+toJPImageRGBA8 = imageToJPImageUnsafe+{-# INLINE toJPImageRGBA8 #-}++toJPImageRGB16 :: Image VS RGB Word16 -> JP.Image JP.PixelRGB16+toJPImageRGB16 = imageToJPImageUnsafe+{-# INLINE toJPImageRGB16 #-}++toJPImageRGBA16 :: Image VS RGBA Word16 -> JP.Image JP.PixelRGBA16+toJPImageRGBA16 = imageToJPImageUnsafe+{-# INLINE toJPImageRGBA16 #-}++toJPImageRGBF :: Image VS RGB Float -> JP.Image JP.PixelRGBF+toJPImageRGBF = imageToJPImageUnsafe+{-# INLINE toJPImageRGBF #-}++toJPImageYCbCr8 :: Image VS YCbCr Word8 -> JP.Image JP.PixelYCbCr8+toJPImageYCbCr8 = imageToJPImageUnsafe+{-# INLINE toJPImageYCbCr8 #-}++toJPImageCMYK8 :: Image VS CMYK Word8 -> JP.Image JP.PixelCMYK8+toJPImageCMYK8 = imageToJPImageUnsafe+{-# INLINE toJPImageCMYK8 #-}++toJPImageCMYK16 :: Image VS CMYK Word16 -> JP.Image JP.PixelCMYK16+toJPImageCMYK16 = imageToJPImageUnsafe+{-# INLINE toJPImageCMYK16 #-}+++++-- General decoding and helper functions+++jpImageToImageUnsafe :: (Array VS cs e, JP.Pixel jpx) =>+                        JP.Image jpx -> Image VS cs e+jpImageToImageUnsafe (JP.Image n m !v) = fromVector (m, n) $ V.unsafeCast v+{-# INLINE jpImageToImageUnsafe #-}+++fromJPImageY8 :: JP.Image JP.Pixel8 -> Image VS Y Word8+fromJPImageY8 = jpImageToImageUnsafe+{-# INLINE fromJPImageY8 #-}++fromJPImageY16 :: JP.Image JP.Pixel16 -> Image VS Y Word16+fromJPImageY16 = jpImageToImageUnsafe+{-# INLINE fromJPImageY16 #-}++fromJPImageYA8 :: JP.Image JP.PixelYA8 -> Image VS YA Word8+fromJPImageYA8 = jpImageToImageUnsafe+{-# INLINE fromJPImageYA8 #-}++fromJPImageYA16 :: JP.Image JP.PixelYA16 -> Image VS YA Word16+fromJPImageYA16 = jpImageToImageUnsafe+{-# INLINE fromJPImageYA16 #-}++fromJPImageRGB8 :: JP.Image JP.PixelRGB8 -> Image VS RGB Word8+fromJPImageRGB8 = jpImageToImageUnsafe+{-# INLINE fromJPImageRGB8 #-}++fromJPImageYF :: JP.Image JP.PixelF -> Image VS Y Float+fromJPImageYF = jpImageToImageUnsafe+{-# INLINE fromJPImageYF #-}++fromJPImageRGBA8 :: JP.Image JP.PixelRGBA8 -> Image VS RGBA Word8+fromJPImageRGBA8 = jpImageToImageUnsafe+{-# INLINE fromJPImageRGBA8 #-}++fromJPImageRGB16 :: JP.Image JP.PixelRGB16 -> Image VS RGB Word16+fromJPImageRGB16 = jpImageToImageUnsafe+{-# INLINE fromJPImageRGB16 #-}++fromJPImageRGBA16 :: JP.Image JP.PixelRGBA16 -> Image VS RGBA Word16+fromJPImageRGBA16 = jpImageToImageUnsafe+{-# INLINE fromJPImageRGBA16 #-}++fromJPImageRGBF :: JP.Image JP.PixelRGBF -> Image VS RGB Float+fromJPImageRGBF = jpImageToImageUnsafe+{-# INLINE fromJPImageRGBF #-}++fromJPImageYCbCr8 :: JP.Image JP.PixelYCbCr8 -> Image VS YCbCr Word8+fromJPImageYCbCr8 = jpImageToImageUnsafe+{-# INLINE fromJPImageYCbCr8 #-}++fromJPImageCMYK8 :: JP.Image JP.PixelCMYK8 -> Image VS CMYK Word8+fromJPImageCMYK8 = jpImageToImageUnsafe+{-# INLINE fromJPImageCMYK8 #-}++fromJPImageCMYK16 :: JP.Image JP.PixelCMYK16 -> Image VS CMYK Word16+fromJPImageCMYK16 = jpImageToImageUnsafe+{-# INLINE fromJPImageCMYK16 #-}+++jpImageY8ToImage :: JP.DynamicImage -> Either String (Image VS Y Word8)+jpImageY8ToImage (JP.ImageY8 jimg) = Right (fromJPImageY8 jimg)+jpImageY8ToImage jimg              = jpCSError "Y8 (Pixel Y Word8)" jimg+{-# INLINE jpImageY8ToImage #-}++jpImageY16ToImage :: JP.DynamicImage -> Either String (Image VS Y Word16)+jpImageY16ToImage (JP.ImageY16 jimg) = Right (fromJPImageY16 jimg)+jpImageY16ToImage jimg               = jpCSError "Y16 (Pixel Y Word16)" jimg+{-# INLINE jpImageY16ToImage #-}++jpImageYA8ToImage :: JP.DynamicImage -> Either String (Image VS YA Word8)+jpImageYA8ToImage (JP.ImageYA8 jimg) = Right (fromJPImageYA8 jimg)+jpImageYA8ToImage jimg               = jpCSError "YA8 (Pixel YA Word8)" jimg+{-# INLINE jpImageYA8ToImage #-}++jpImageYA16ToImage :: JP.DynamicImage -> Either String (Image VS YA Word16)+jpImageYA16ToImage (JP.ImageYA16 jimg) = Right (fromJPImageYA16 jimg)+jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg+{-# INLINE jpImageYA16ToImage #-}++jpImageRGB8ToImage :: JP.DynamicImage -> Either String (Image VS RGB Word8)+jpImageRGB8ToImage (JP.ImageRGB8 jimg) = Right (fromJPImageRGB8 jimg)+jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg+{-# INLINE jpImageRGB8ToImage #-}++jpImageRGB16ToImage :: JP.DynamicImage -> Either String (Image VS RGB Word16)+jpImageRGB16ToImage (JP.ImageRGB16 jimg) = Right (fromJPImageRGB16 jimg)+jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg+{-# INLINE jpImageRGB16ToImage #-}++jpImageRGBFToImage :: JP.DynamicImage -> Either String (Image VS RGB Float)+jpImageRGBFToImage (JP.ImageRGBF jimg) = Right (fromJPImageRGBF jimg)+jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg+{-# INLINE jpImageRGBFToImage #-}++jpImageRGBA8ToImage :: JP.DynamicImage -> Either String (Image VS RGBA Word8)+jpImageRGBA8ToImage (JP.ImageRGBA8 jimg) = Right (fromJPImageRGBA8 jimg)+jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg+{-# INLINE jpImageRGBA8ToImage #-}++jpImageRGBA16ToImage :: JP.DynamicImage -> Either String (Image VS RGBA Word16)+jpImageRGBA16ToImage (JP.ImageRGBA16 jimg) = Right (fromJPImageRGBA16 jimg)+jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg+{-# INLINE jpImageRGBA16ToImage #-}++jpImageYCbCr8ToImage :: JP.DynamicImage -> Either String (Image VS YCbCr Word8)+jpImageYCbCr8ToImage (JP.ImageYCbCr8 jimg) = Right (fromJPImageYCbCr8 jimg)+jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg+{-# INLINE jpImageYCbCr8ToImage #-}++jpImageCMYK8ToImage :: JP.DynamicImage -> Either String (Image VS CMYK Word8)+jpImageCMYK8ToImage (JP.ImageCMYK8 jimg) = Right (fromJPImageCMYK8 jimg)+jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg+{-# INLINE jpImageCMYK8ToImage #-}++jpImageCMYK16ToImage :: JP.DynamicImage -> Either String (Image VS CMYK Word16)+jpImageCMYK16ToImage (JP.ImageCMYK16 jimg) = Right (fromJPImageCMYK16 jimg)+jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg+{-# INLINE jpImageCMYK16ToImage #-}+++jpDynamicImageToImage+  :: (Convertible cs e, ColorSpace cs e, V.Storable (Pixel cs e)) =>+     JP.DynamicImage -> Image VS cs e+jpDynamicImageToImage (JP.ImageY8 jimg)     = convert $ fromJPImageY8 jimg+jpDynamicImageToImage (JP.ImageYA8 jimg)    = convert $ fromJPImageYA8 jimg+jpDynamicImageToImage (JP.ImageY16 jimg)    = convert $ fromJPImageY16 jimg+jpDynamicImageToImage (JP.ImageYA16 jimg)   = convert $ fromJPImageYA16 jimg+jpDynamicImageToImage (JP.ImageYF jimg)     = convert $ fromJPImageYF jimg+jpDynamicImageToImage (JP.ImageRGB8 jimg)   = convert $ fromJPImageRGB8 jimg+jpDynamicImageToImage (JP.ImageRGBA8 jimg)  = convert $ fromJPImageRGBA8 jimg+jpDynamicImageToImage (JP.ImageRGB16 jimg)  = convert $ fromJPImageRGB16 jimg+jpDynamicImageToImage (JP.ImageRGBA16 jimg) = convert $ fromJPImageRGBA16 jimg+jpDynamicImageToImage (JP.ImageRGBF jimg)   = convert $ fromJPImageRGBF jimg+jpDynamicImageToImage (JP.ImageYCbCr8 jimg) = convert $ fromJPImageYCbCr8 jimg+jpDynamicImageToImage (JP.ImageCMYK8 jimg)  = convert $ fromJPImageCMYK8 jimg+jpDynamicImageToImage (JP.ImageCMYK16 jimg) = convert $ fromJPImageCMYK16 jimg+{-# INLINE 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 -> JP.DynamicImage -> Either String a+jpCSError cs jimg =+  jpError $+  "Input image is in " +++  jpImageShowCS jimg ++ ", cannot convert it to " ++ cs ++ " colorspace."++++-- | Bitmap image with @.bmp@ extension.+data BMP = BMP deriving Show++instance ImageFormat BMP where+  data SaveOption BMP++  ext _ = ".bmp"+++--------------------------------------------------------------------------------+-- Decoding BMP Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS X Bit) BMP where+  decode _ = fmap toImageBinary . jpImageY8ToImage <=< JP.decodeBitmap++instance Readable (Image VS Y Word8) BMP where+  decode _ = jpImageY8ToImage <=< JP.decodeBitmap++instance Readable (Image VS RGB Word8) BMP where+  decode _ = jpImageRGB8ToImage <=< JP.decodeBitmap++instance Readable (Image VS RGBA Word8) BMP where+  decode _ = jpImageRGBA8ToImage <=< JP.decodeBitmap+++instance Readable (Image VS Y Double) BMP where+  decode _ = fmap jpDynamicImageToImage . JP.decodeBitmap++instance Readable (Image VS YA Double) BMP where+  decode _ = fmap jpDynamicImageToImage . JP.decodeBitmap++instance Readable (Image VS RGB Double) BMP where+  decode _ = fmap jpDynamicImageToImage . JP.decodeBitmap++instance Readable (Image VS RGBA Double) BMP where+  decode _ = fmap jpDynamicImageToImage . JP.decodeBitmap+++--------------------------------------------------------------------------------+-- Encoding BMP Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Writable (Image VS Y Word8) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageY8++instance Writable (Image VS RGB Word8) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageRGB8++instance Writable (Image VS RGBA Word8) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageRGBA8++instance Writable (Image VS X Bit) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageY8 . fromImageBinary+++instance Writable (Image VS Y Double) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageY8 . toWord8I++instance Writable (Image VS YA Double) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageY8 . toWord8I . toImageY++instance Writable (Image VS RGB Double) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageRGB8 . toWord8I++instance Writable (Image VS RGBA Double) BMP where+  encode _ _ = JP.encodeBitmap . toJPImageRGBA8 . toWord8I++++-- | Graphics Interchange Format image with @.gif@ extension.+data GIF = GIF deriving Show++instance ImageFormat GIF where+  data SaveOption GIF = GIFPalette JP.PaletteOptions++  ext _ = ".gif"+++-- | Graphics Interchange Format animated image with @.gif@ extension.+data GIFA = GIFA deriving Show+{-# DEPRECATED GIFA "use (`Seq` `GIF`) instead" #-}+++instance ImageFormat GIFA where+  data SaveOption GIFA = GIFAPalette JP.PaletteOptions+                       | GIFALooping JP.GifLooping++  ext _ = ext GIF++++instance ImageFormat (Seq GIF) where+  data SaveOption (Seq GIF) = GIFSeqPalette JP.PaletteOptions+                            | GIFSeqLooping JP.GifLooping+  ext _ = ext GIF++++--------------------------------------------------------------------------------+-- Decoding GIF Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS RGB Word8) GIF where+  decode _ = jpImageRGB8ToImage <=< JP.decodeGif++instance Readable (Image VS RGBA Word8) GIF where+  decode _ = jpImageRGBA8ToImage <=< JP.decodeGif+++instance Readable (Image VS Y Double) GIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeGif++instance Readable (Image VS YA Double) GIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeGif++instance Readable (Image VS RGB Double) GIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeGif++instance Readable (Image VS RGBA Double) GIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeGif+++-- Animated GIF Format frames reading into a list++decodeGifs :: (JP.DynamicImage -> Either String img)+           -> B.ByteString -> Either String [img]+decodeGifs decoder bs = do+  imgs <- JP.decodeGifImages bs+  sequence $ fmap decoder imgs+++decodeGifsDelays :: (JP.DynamicImage -> Either String img)+                 -> B.ByteString -> Either String [(JP.GifDelay, img)]+decodeGifsDelays decoder bs = do+  imgs <- JP.decodeGifImages bs+  delays <- JP.getDelaysGifImages bs+  gifs <- sequence $ fmap decoder imgs+  return $ zip delays gifs++++instance Readable [Image VS RGB Word8] GIFA where+  decode _ = decodeGifs jpImageRGB8ToImage++instance Readable [Image VS RGBA Word8] GIFA where+  decode _ = decodeGifs jpImageRGBA8ToImage++instance Readable [(JP.GifDelay, Image VS RGB Word8)] GIFA where+  decode _ = decodeGifsDelays jpImageRGB8ToImage++instance Readable [(JP.GifDelay, Image VS RGBA Word8)] GIFA where+  decode _ = decodeGifsDelays jpImageRGBA8ToImage++++instance Readable [Image VS Y Double] GIFA where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++instance Readable [Image VS YA Double] GIFA where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++instance Readable [Image VS RGB Double] GIFA where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++instance Readable [Image VS RGBA Double] GIFA where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)+++instance Readable [Image VS RGB Word8] (Seq GIF) where+  decode _ = decodeGifs jpImageRGB8ToImage++instance Readable [Image VS RGBA Word8] (Seq GIF) where+  decode _ = decodeGifs jpImageRGBA8ToImage++instance Readable [(JP.GifDelay, Image VS RGB Word8)] (Seq GIF) where+  decode _ = decodeGifsDelays jpImageRGB8ToImage++instance Readable [(JP.GifDelay, Image VS RGBA Word8)] (Seq GIF) where+  decode _ = decodeGifsDelays jpImageRGBA8ToImage++++instance Readable [Image VS Y Double] (Seq GIF) where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++instance Readable [Image VS YA Double] (Seq GIF) where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++instance Readable [Image VS RGB Double] (Seq GIF) where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++instance Readable [Image VS RGBA Double] (Seq GIF) where+  decode _ = decodeGifs (Right . jpDynamicImageToImage)++++--------------------------------------------------------------------------------+-- Encoding GIF Format ---------------------------------------------------------+--------------------------------------------------------------------------------++encodeGIF :: [SaveOption GIF]+          -> Image VS RGB Word8+          -> BL.ByteString+encodeGIF []                     =+  either error id . uncurry JP.encodeGifImageWithPalette .+  JP.palettize JP.defaultPaletteOptions . toJPImageRGB8+encodeGIF (GIFPalette palOpts:_) =+  either error id . uncurry JP.encodeGifImageWithPalette .+  JP.palettize palOpts . toJPImageRGB8+{-# INLINE encodeGIF #-}++instance Writable (Image VS RGB Word8) GIF where+  encode _ = encodeGIF++instance Writable (Image VS Y Double) GIF where+  encode _ _ = JP.encodeGifImage . toJPImageY8 . toWord8I++instance Writable (Image VS YA Double) GIF where+  encode f opts = encode f opts . toImageY++instance Writable (Image VS RGB Double) GIF where+  encode _ opts = encodeGIF opts . toWord8I++instance Writable (Image VS RGBA Double) GIF where+  encode f opts = encode f opts . toImageRGB+++encodeGIFA :: [SaveOption GIFA]+           -> [(JP.GifDelay, Image VS RGB Word8)] -> BL.ByteString+encodeGIFA !opts =+  either error id . JP.encodeGifImages (getGIFALoop opts) . P.map palletizeGif where+    getGIFALoop []                = JP.LoopingNever+    getGIFALoop (GIFALooping l:_) = l+    getGIFALoop (_:xs)            = getGIFALoop xs+    getGIFAPal []                      = JP.defaultPaletteOptions+    getGIFAPal (GIFAPalette palOpts:_) = palOpts+    getGIFAPal (_:xs)                  = getGIFAPal xs+    palletizeGif !(d, img) = (p, d, jimg) where+      !(jimg, p) = JP.palettize (getGIFAPal opts) $ toJPImageRGB8 img+++instance Writable [(JP.GifDelay, Image VS RGB Word8)] GIFA where+  encode _ opts = encodeGIFA opts++instance Writable [(JP.GifDelay, Image VS RGB Double)] GIFA where+  encode _ opts = encodeGIFA opts . fmap (\ !(d, i) -> (d, toWord8I i))+++encodeGIFSeq :: [SaveOption (Seq GIF)]+           -> [(JP.GifDelay, Image VS RGB Word8)] -> BL.ByteString+encodeGIFSeq !opts =+  either error id . JP.encodeGifImages (getGIFSeqLoop opts) . P.map palletizeGif where+    getGIFSeqLoop []                  = JP.LoopingNever+    getGIFSeqLoop (GIFSeqLooping l:_) = l+    getGIFSeqLoop (_:xs)              = getGIFSeqLoop xs+    getGIFSeqPal []                        = JP.defaultPaletteOptions+    getGIFSeqPal (GIFSeqPalette palOpts:_) = palOpts+    getGIFSeqPal (_:xs)                    = getGIFSeqPal xs+    palletizeGif !(d, img) = (p, d, jimg) where+      !(jimg, p) = JP.palettize (getGIFSeqPal opts) $ toJPImageRGB8 img+    {-# INLINE palletizeGif #-}+{-# INLINE encodeGIFSeq #-}++instance Writable [(JP.GifDelay, Image VS RGB Word8)] (Seq GIF) where+  encode _ opts = encodeGIFSeq opts++instance Writable [(JP.GifDelay, Image VS RGB Double)] (Seq GIF) where+  encode _ opts = encodeGIFSeq opts . fmap (fmap toWord8I)+++++++-- | High-dynamic-range image with @.hdr@ or @.pic@ extension.+data HDR = HDR deriving Show++instance ImageFormat HDR where+  data SaveOption HDR++  ext _ = ".hdr"++  exts _ = [".hdr", ".pic"]+++--------------------------------------------------------------------------------+-- Decoding HDR Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS RGB Float) HDR where+  decode _ = jpImageRGBFToImage <=< JP.decodeHDR+++instance Readable (Image VS Y Double) HDR where+  decode _ = fmap jpDynamicImageToImage . JP.decodeHDR++instance Readable (Image VS YA Double) HDR where+  decode _ = fmap jpDynamicImageToImage . JP.decodeHDR++instance Readable (Image VS RGB Double) HDR where+  decode _ = fmap jpDynamicImageToImage . JP.decodeHDR++instance Readable (Image VS RGBA Double) HDR where+  decode _ = fmap jpDynamicImageToImage . JP.decodeHDR+++--------------------------------------------------------------------------------+-- Encoding HDR Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Writable (Image VS RGB Float) HDR where+  encode _ _ = JP.encodeHDR . toJPImageRGBF++instance Writable (Image VS Y Double) HDR where+  encode _ _ = JP.encodeHDR . toJPImageRGBF . toFloatI . toImageRGB++instance Writable (Image VS YA Double) HDR where+  encode _ _ = JP.encodeHDR . toJPImageRGBF . toFloatI . toImageRGB++instance Writable (Image VS RGB Double) HDR where+  encode _ _ = JP.encodeHDR . toJPImageRGBF . toFloatI++instance Writable (Image VS RGBA Double) HDR where+  encode _ _ = JP.encodeHDR . toJPImageRGBF . toFloatI . toImageRGB+++-- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension.+data JPG = JPG deriving Show++instance ImageFormat JPG where+  data SaveOption JPG = JPGQuality Word8++  ext _ = ".jpg"++  exts _ = [".jpg", ".jpeg"]+++--------------------------------------------------------------------------------+-- Decoding JPG Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS Y Word8) JPG where+  decode _ = jpImageY8ToImage <=< JP.decodeJpeg++instance Readable (Image VS YA Word8) JPG where+  decode _ = jpImageYA8ToImage <=< JP.decodeJpeg++instance Readable (Image VS RGB Word8) JPG where+  decode _ = jpImageRGB8ToImage <=< JP.decodeJpeg++instance Readable (Image VS CMYK Word8) JPG where+  decode _ = jpImageCMYK8ToImage <=< JP.decodeJpeg++instance Readable (Image VS YCbCr Word8) JPG where+  decode _ = jpImageYCbCr8ToImage <=< JP.decodeJpeg+++instance Readable (Image VS Y Double) JPG where+  decode _ = fmap jpDynamicImageToImage . JP.decodeJpeg++instance Readable (Image VS YA Double) JPG where+  decode _ = fmap jpDynamicImageToImage . JP.decodeJpeg++instance Readable (Image VS RGB Double) JPG where+  decode _ = fmap jpDynamicImageToImage . JP.decodeJpeg++instance Readable (Image VS RGBA Double) JPG where+  decode _ = fmap jpDynamicImageToImage . JP.decodeJpeg+++--------------------------------------------------------------------------------+-- Encoding JPG Format ---------------------------------------------------------+--------------------------------------------------------------------------------++encodeJPG+  :: JP.JpgEncodable px+  => [SaveOption JPG] -> JP.Image px -> BL.ByteString+encodeJPG []               =+  JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty+encodeJPG (JPGQuality q:_) =+  JP.encodeDirectJpegAtQualityWithMetadata q M.mempty+{-# INLINE encodeJPG #-}++instance Writable (Image VS Y Word8) JPG where+  encode _ opts = encodeJPG opts . toJPImageY8++instance Writable (Image VS RGB Word8) JPG where+  encode _ opts = encodeJPG opts . toJPImageRGB8++instance Writable (Image VS CMYK Word8) JPG where+  encode _ opts = encodeJPG opts . toJPImageCMYK8++instance Writable (Image VS YCbCr Word8) JPG where+  encode _ opts = encodeJPG opts . toJPImageYCbCr8++-- | Image is converted `YCbCr` color space prior to encoding.+instance Writable (Image VS Y Double) JPG where+  encode _ opts = encodeJPG opts . toJPImageYCbCr8 . toWord8I . toImageYCbCr++-- | Image is converted `YCbCr` color space prior to encoding.+instance Writable (Image VS YA Double) JPG where+  encode _ opts = encodeJPG opts . toJPImageYCbCr8 . toWord8I . toImageYCbCr++-- | Image is converted `YCbCr` color space prior to encoding.+instance Writable (Image VS RGB Double) JPG where+  encode _ opts = encodeJPG opts . toJPImageYCbCr8 . toWord8I . toImageYCbCr++-- | Image is converted `YCbCr` color space prior to encoding.+instance Writable (Image VS RGBA Double) JPG where+  encode _ opts = encodeJPG opts . toJPImageYCbCr8 . toWord8I . toImageYCbCr+++++-- | Portable Network Graphics image with @.png@ extension.+data PNG = PNG deriving Show++instance ImageFormat PNG where+  data SaveOption PNG++  ext _ = ".png"++++--------------------------------------------------------------------------------+-- Decoding PNG Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS X Bit) PNG where+  decode _ = fmap toImageBinary . jpImageY8ToImage <=< JP.decodePng++instance Readable (Image VS Y Word8) PNG where+  decode _ = jpImageY8ToImage <=< JP.decodePng++instance Readable (Image VS Y Word16) PNG where+  decode _ = jpImageY16ToImage <=< JP.decodePng++instance Readable (Image VS YA Word8) PNG where+  decode _ = jpImageYA8ToImage <=< JP.decodePng++instance Readable (Image VS YA Word16) PNG where+  decode _ = jpImageYA16ToImage <=< JP.decodePng++instance Readable (Image VS RGB Word8) PNG where+  decode _ = jpImageRGB8ToImage <=< JP.decodePng++instance Readable (Image VS RGB Word16) PNG where+  decode _ = jpImageRGB16ToImage <=< JP.decodePng++instance Readable (Image VS RGBA Word8) PNG where+  decode _ = jpImageRGBA8ToImage <=< JP.decodePng++instance Readable (Image VS RGBA Word16) PNG where+  decode _ = jpImageRGBA16ToImage <=< JP.decodePng+++instance Readable (Image VS Y Double) PNG where+  decode _ = fmap jpDynamicImageToImage . JP.decodePng++instance Readable (Image VS YA Double) PNG where+  decode _ = fmap jpDynamicImageToImage . JP.decodePng++instance Readable (Image VS RGB Double) PNG where+  decode _ = fmap jpDynamicImageToImage . JP.decodePng++instance Readable (Image VS RGBA Double) PNG where+  decode _ = fmap jpDynamicImageToImage . JP.decodePng+++--------------------------------------------------------------------------------+-- Encoding PNG Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Writable (Image VS X Bit) PNG where+  encode _ _ = JP.encodePng . toJPImageY8 . fromImageBinary++instance Writable (Image VS Y Word8) PNG where+  encode _ _ = JP.encodePng . toJPImageY8++instance Writable (Image VS Y Word16) PNG where+  encode _ _ = JP.encodePng . toJPImageY16++instance Writable (Image VS YA Word8) PNG where+  encode _ _ = JP.encodePng . toJPImageYA8++instance Writable (Image VS YA Word16) PNG where+  encode _ _ = JP.encodePng . toJPImageYA16++instance Writable (Image VS RGB Word8) PNG where+  encode _ _ = JP.encodePng . toJPImageRGB8++instance Writable (Image VS RGB Word16) PNG where+  encode _ _ = JP.encodePng . toJPImageRGB16++instance Writable (Image VS RGBA Word8) PNG where+  encode _ _ = JP.encodePng . toJPImageRGBA8++instance Writable (Image VS RGBA Word16) PNG where+  encode _ _ = JP.encodePng . toJPImageRGBA16+++instance Writable (Image VS Y Double) PNG where+  encode _ _ = JP.encodePng . toJPImageY16 . toWord16I++instance Writable (Image VS YA Double) PNG where+  encode _ _ = JP.encodePng . toJPImageYA16 . toWord16I++instance Writable (Image VS RGB Double) PNG where+  encode _ _ = JP.encodePng . toJPImageRGB16 . toWord16I++instance Writable (Image VS RGBA Double) PNG where+  encode _ _ = JP.encodePng . toJPImageRGBA16 . toWord16I+++++++-- | Truevision Graphics Adapter image with .tga extension.+data TGA = TGA++instance ImageFormat TGA where+  data SaveOption TGA++  ext _ = ".tga"+++--------------------------------------------------------------------------------+-- Decoding TGA Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS X Bit) TGA where+  decode _ = fmap toImageBinary . jpImageY8ToImage <=< JP.decodeTga++instance Readable (Image VS Y Word8) TGA where+  decode _ = jpImageY8ToImage <=< JP.decodeTga++instance Readable (Image VS RGB Word8) TGA where+  decode _ = jpImageRGB8ToImage <=< JP.decodeTga++instance Readable (Image VS RGBA Word8) TGA where+  decode _ = jpImageRGBA8ToImage <=< JP.decodeTga+++instance Readable (Image VS Y Double) TGA where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTga++instance Readable (Image VS YA Double) TGA where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTga++instance Readable (Image VS RGB Double) TGA where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTga++instance Readable (Image VS RGBA Double) TGA where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTga+++--------------------------------------------------------------------------------+-- Encoding TGA Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Writable (Image VS X Bit) TGA where+  encode _ _ = JP.encodeTga . toJPImageY8 . fromImageBinary++instance Writable (Image VS Y Word8) TGA where+  encode _ _ = JP.encodeTga . toJPImageY8++instance Writable (Image VS RGB Word8) TGA where+  encode _ _ = JP.encodeTga . toJPImageRGB8++instance Writable (Image VS RGBA Word8) TGA where+  encode _ _ = JP.encodeTga . toJPImageRGBA8+++instance Writable (Image VS Y Double) TGA where+  encode _ _ = JP.encodeTga . toJPImageY8 . toWord8I++instance Writable (Image VS YA Double) TGA where+  encode _ _ = JP.encodeTga . toJPImageY8 . toWord8I . toImageY++instance Writable (Image VS RGB Double) TGA where+  encode _ _ = JP.encodeTga . toJPImageRGB8 . toWord8I++instance Writable (Image VS RGBA Double) TGA where+  encode _ _ = JP.encodeTga . toJPImageRGBA8 . toWord8I++++-- | Tagged Image File Format image with @.tif@ or @.tiff@ extension.+data TIF = TIF deriving Show++instance ImageFormat TIF where+  data SaveOption TIF++  ext _ = ".tif"++  exts _ = [".tif", ".tiff"]+++--------------------------------------------------------------------------------+-- Decoding TIF Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Readable (Image VS X Bit) TIF where+  decode _ = fmap toImageBinary . jpImageY8ToImage <=< JP.decodeTiff++instance Readable (Image VS Y Word8) TIF where+  decode _ = jpImageY8ToImage <=< JP.decodeTiff++instance Readable (Image VS Y Word16) TIF where+  decode _ = jpImageY16ToImage <=< JP.decodeTiff++instance Readable (Image VS YA Word8) TIF where+  decode _ = jpImageYA8ToImage <=< JP.decodeTiff++instance Readable (Image VS YA Word16) TIF where+  decode _ = jpImageYA16ToImage <=< JP.decodeTiff++instance Readable (Image VS RGB Word8) TIF where+  decode _ = jpImageRGB8ToImage <=< JP.decodeTiff++instance Readable (Image VS RGB Word16) TIF where+  decode _ = jpImageRGB16ToImage <=< JP.decodeTiff++instance Readable (Image VS RGBA Word8) TIF where+  decode _ = jpImageRGBA8ToImage <=< JP.decodeTiff++instance Readable (Image VS RGBA Word16) TIF where+  decode _ = jpImageRGBA16ToImage <=< JP.decodeTiff++instance Readable (Image VS CMYK Word8) TIF where+  decode _ = jpImageCMYK8ToImage <=< JP.decodeTiff++instance Readable (Image VS CMYK Word16) TIF where+  decode _ = jpImageCMYK16ToImage <=< JP.decodeTiff+++instance Readable (Image VS Y Double) TIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTiff++instance Readable (Image VS YA Double) TIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTiff++instance Readable (Image VS RGB Double) TIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTiff++instance Readable (Image VS RGBA Double) TIF where+  decode _ = fmap jpDynamicImageToImage . JP.decodeTiff+++--------------------------------------------------------------------------------+-- Encoding TIF Format ---------------------------------------------------------+--------------------------------------------------------------------------------++instance Writable (Image VS Y Word8) TIF where+  encode _ _ = JP.encodeTiff . toJPImageY8++instance Writable (Image VS Y Word16) TIF where+  encode _ _ = JP.encodeTiff . toJPImageY16++instance Writable (Image VS YA Word8) TIF where+  encode _ _ = JP.encodeTiff . toJPImageYA8++instance Writable (Image VS YA Word16) TIF where+  encode _ _ = JP.encodeTiff . toJPImageYA16++instance Writable (Image VS RGB Word8) TIF where+  encode _ _ = JP.encodeTiff . toJPImageRGB8++instance Writable (Image VS RGB Word16) TIF where+  encode _ _ = JP.encodeTiff . toJPImageRGB16++instance Writable (Image VS RGBA Word8) TIF where+  encode _ _ = JP.encodeTiff . toJPImageRGBA8++instance Writable (Image VS RGBA Word16) TIF where+  encode _ _ = JP.encodeTiff . toJPImageRGBA16++instance Writable (Image VS YCbCr Word8) TIF where+  encode _ _ = JP.encodeTiff . toJPImageYCbCr8++instance Writable (Image VS CMYK Word8) TIF where+  encode _ _ = JP.encodeTiff . toJPImageCMYK8++instance Writable (Image VS CMYK Word16) TIF where+  encode _ _ = JP.encodeTiff . toJPImageCMYK16+++instance Writable (Image VS X Bit) TIF where+  encode _ _ = JP.encodeTiff . toJPImageY8 . fromImageBinary++instance Writable (Image VS Y Double) TIF where+  encode _ _ = JP.encodeTiff . toJPImageY16 . toWord16I++instance Writable (Image VS YA Double) TIF where+  encode _ _ = JP.encodeTiff . toJPImageYA16 . toWord16I++instance Writable (Image VS RGB Double) TIF where+  encode _ _ = JP.encodeTiff . toJPImageRGB16 . toWord16I++instance Writable (Image VS RGBA Double) TIF where+  encode _ _ = JP.encodeTiff . toJPImageRGBA16 . toWord16I++instance Writable (Image VS YCbCr Double) TIF where+  encode _ _ = JP.encodeTiff . toJPImageYCbCr8 . toWord8I++instance Writable (Image VS CMYK Double) TIF where+  encode _ _ = JP.encodeTiff . toJPImageCMYK16 . toWord16I++

@@ -1,112 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--- |--- Module      : Graphics.Image.IO.Formats.JuicyPixels.Common--- Copyright   : (c) Alexey Kuleshevich 2017--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.Image.IO.Formats.JuicyPixels.Common (-  BMP(..),-  GIF(..), GIFA(..),-  JP.GifDelay, JP.GifLooping(..), JP.PaletteOptions(..), JP.PaletteCreationMethod(..),-  HDR(..),-  JPG(..),-  PNG(..),-  TGA(..),-  TIF(..),-  SaveOption(..),-  ) where--import Graphics.Image.ColorSpace-import Graphics.Image.IO.Base-import qualified Codec.Picture as JP-------- | Bitmap image with @.bmp@ extension.-data BMP = BMP--instance ImageFormat BMP where-  data SaveOption BMP--  ext _ = ".bmp"----- | Graphics Interchange Format image with @.gif@ extension.-data GIF = GIF--instance ImageFormat GIF where-  data SaveOption GIF = GIFPalette JP.PaletteOptions-  -  ext _ = ".gif"---  -- | Graphics Interchange Format animated image with @.gif@ extension.-data GIFA = GIFA--instance ImageFormat GIFA where-  data SaveOption GIFA = GIFAPalette JP.PaletteOptions-                       | GIFALooping JP.GifLooping-  -  ext _ = ext GIF---- | High-dynamic-range image with @.hdr@ or @.pic@ extension.-data HDR = HDR--instance ImageFormat HDR where-  data SaveOption HDR--  ext _ = ".hdr"--  exts _ = [".hdr", ".pic"]----- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension.-data JPG = JPG--instance ImageFormat JPG where-  data SaveOption JPG = JPGQuality Word8--  ext _ = ".jpg"--  exts _ = [".jpg", ".jpeg"]----- | Portable Network Graphics image with @.png@ extension.-data PNG = PNG--instance ImageFormat PNG where-  data SaveOption PNG--  ext _ = ".png"----- | Truevision Graphics Adapter image with .tga extension.-data TGA = TGA--instance ImageFormat TGA where-  data SaveOption TGA--  ext _ = ".tga"----- | Tagged Image File Format image with @.tif@ or @.tiff@ extension.-data TIF = TIF--instance ImageFormat TIF where-  data SaveOption TIF  --  ext _ = ".tif"--  exts _ = [".tif", ".tiff"]

@@ -1,568 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--- |--- Module      : Graphics.Image.IO.Formats.JuicyPixels.Readable--- Copyright   : (c) Alexey Kuleshevich 2017--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.Image.IO.Formats.JuicyPixels.Readable () where--import Prelude as P--import Graphics.Image.ColorSpace-import Graphics.Image.Interface as I-import Graphics.Image.Interface.Vector-import Graphics.Image.IO.Base-import Graphics.Image.IO.Formats.JuicyPixels.Common-import qualified Data.ByteString as B  -- (ByteString)-import qualified Codec.Picture as JP-import qualified Codec.Picture.Types as JP-import qualified Codec.Picture.Gif as JP-import qualified Data.Vector.Storable as V-------------------------------------------------------------------------------------- Converting to and from JuicyPixels --------------------------------------------------------------------------------------------------------------------------------- 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 y) = y-  -instance Convertible (Pixel Y Word16) JP.Pixel16 where-  convert (PixelY y) = y--instance Convertible (Pixel Y Word32) JP.Pixel32 where-  convert (PixelY y) = y--instance Convertible (Pixel Y Float) JP.PixelF where-  convert (PixelY y) = y--instance Convertible (Pixel YA Word8) JP.PixelYA8 where-  convert (PixelYA y a) = JP.PixelYA8 y a-  -instance Convertible (Pixel YA Word16) JP.PixelYA16 where-  convert (PixelYA y a) = JP.PixelYA16 y 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 Readable (Image VS Binary Bit) BMP where-  decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeBitmap--instance Readable (Image VS Y Word8) BMP where-  decode _ = jpImageY8ToImage . JP.decodeBitmap--instance Readable (Image VS RGB Word8) BMP where-  decode _ = jpImageRGB8ToImage . JP.decodeBitmap--instance Readable (Image VS RGBA Word8) BMP where-  decode _ = jpImageRGBA8ToImage . JP.decodeBitmap------ GIF Format Reading--instance Readable (Image VS RGB Word8) GIF where-  decode _ = jpImageRGB8ToImage . JP.decodeGif--instance Readable (Image VS RGBA Word8) GIF where-  decode _ = jpImageRGBA8ToImage . JP.decodeGif----- Animated GIF Format frames reading into a list--decodeGifs :: (Either String JP.DynamicImage -> Either String img)-           -> B.ByteString -> Either String [img]-decodeGifs decoder bs = do-  imgs <- JP.decodeGifImages bs-  sequence $ fmap (decoder . Right) imgs---decodeGifsDelays :: (Either String JP.DynamicImage -> Either String img)-                 -> B.ByteString -> Either String [(GifDelay, img)]-decodeGifsDelays decoder bs = do-  imgs <- JP.decodeGifImages bs-  delays <- JP.getDelaysGifImages bs-  gifs <- sequence $ fmap (decoder . Right) imgs-  return $ zip delays gifs----instance Readable [Image VS RGB Word8] GIFA where-  decode _ = decodeGifs jpImageRGB8ToImage--instance Readable [Image VS RGBA Word8] GIFA where-  decode _ = decodeGifs jpImageRGBA8ToImage--instance Readable [(GifDelay, Image VS RGB Word8)] GIFA where-  decode _ = decodeGifsDelays jpImageRGB8ToImage--instance Readable [(GifDelay, Image VS RGBA Word8)] GIFA where-  decode _ = decodeGifsDelays jpImageRGBA8ToImage----- HDR Format Reading--instance Readable (Image VS RGB Float) HDR where-  decode _ = jpImageRGBFToImage . JP.decodeHDR----- JPG Format Reading--instance Readable (Image VS Y Word8) JPG where-  decode _ = jpImageY8ToImage . JP.decodeJpeg--instance Readable (Image VS YA Word8) JPG where-  decode _ = jpImageYA8ToImage . JP.decodeJpeg--instance Readable (Image VS RGB Word8) JPG where-  decode _ = jpImageRGB8ToImage . JP.decodeJpeg--instance Readable (Image VS CMYK Word8) JPG where-  decode _ = jpImageCMYK8ToImage . JP.decodeJpeg--instance Readable (Image VS YCbCr Word8) JPG where-  decode _ = jpImageYCbCr8ToImage . JP.decodeJpeg----- PNG Format Reading--instance Readable (Image VS Binary Bit) PNG where-  decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodePng--instance Readable (Image VS Y Word8) PNG where-  decode _ = jpImageY8ToImage . JP.decodePng--instance Readable (Image VS Y Word16) PNG where-  decode _ = jpImageY16ToImage . JP.decodePng--instance Readable (Image VS YA Word8) PNG where-  decode _ = jpImageYA8ToImage . JP.decodePng--instance Readable (Image VS YA Word16) PNG where-  decode _ = jpImageYA16ToImage . JP.decodePng--instance Readable (Image VS RGB Word8) PNG where-  decode _ = jpImageRGB8ToImage . JP.decodePng--instance Readable (Image VS RGB Word16) PNG where-  decode _ = jpImageRGB16ToImage . JP.decodePng--instance Readable (Image VS RGBA Word8) PNG where-  decode _ = jpImageRGBA8ToImage . JP.decodePng--instance Readable (Image VS RGBA Word16) PNG where-  decode _ = jpImageRGBA16ToImage . JP.decodePng----- TGA Format Reading--instance Readable (Image VS Binary Bit) TGA where-  decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTga--instance Readable (Image VS Y Word8) TGA where-  decode _ = jpImageY8ToImage . JP.decodeTga--instance Readable (Image VS RGB Word8) TGA where-  decode _ = jpImageRGB8ToImage . JP.decodeTga--instance Readable (Image VS RGBA Word8) TGA where-  decode _ = jpImageRGBA8ToImage . JP.decodeTga----- TIF Format Reading--instance Readable (Image VS Binary Bit) TIF where-  decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTiff--instance Readable (Image VS Y Word8) TIF where-  decode _ = jpImageY8ToImage . JP.decodeTiff--instance Readable (Image VS Y Word16) TIF where-  decode _ = jpImageY16ToImage . JP.decodeTiff--instance Readable (Image VS YA Word8) TIF where-  decode _ = jpImageYA8ToImage . JP.decodeTiff--instance Readable (Image VS YA Word16) TIF where-  decode _ = jpImageYA16ToImage . JP.decodeTiff--instance Readable (Image VS RGB Word8) TIF where-  decode _ = jpImageRGB8ToImage . JP.decodeTiff--instance Readable (Image VS RGB Word16) TIF where-  decode _ = jpImageRGB16ToImage . JP.decodeTiff--instance Readable (Image VS RGBA Word8) TIF where-  decode _ = jpImageRGBA8ToImage . JP.decodeTiff--instance Readable (Image VS RGBA Word16) TIF where-  decode _ = jpImageRGBA16ToImage . JP.decodeTiff--instance Readable (Image VS CMYK Word8) TIF where-  decode _ = jpImageCMYK8ToImage . JP.decodeTiff--instance Readable (Image VS CMYK Word16) TIF where-  decode _ = jpImageCMYK16ToImage . JP.decodeTiff----- To Double precision safe conversion--instance Readable (Image VS Y Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap--instance Readable (Image VS YA Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap--instance Readable (Image VS RGB Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap--instance Readable (Image VS RGBA Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap---instance Readable (Image VS Y Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif--instance Readable (Image VS YA Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif--instance Readable (Image VS RGB Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif--instance Readable (Image VS RGBA Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif---instance Readable [Image VS Y Double] GIFA where-  decode _ = decodeGifs jpDynamicImageToImage--instance Readable [Image VS YA Double] GIFA where-  decode _ = decodeGifs jpDynamicImageToImage--instance Readable [Image VS RGB Double] GIFA where-  decode _ = decodeGifs jpDynamicImageToImage--instance Readable [Image VS RGBA Double] GIFA where-  decode _ = decodeGifs jpDynamicImageToImage---instance Readable (Image VS Y Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR--instance Readable (Image VS YA Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR--instance Readable (Image VS RGB Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR--instance Readable (Image VS RGBA Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR---instance Readable (Image VS Y Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg--instance Readable (Image VS YA Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg--instance Readable (Image VS RGB Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg--instance Readable (Image VS RGBA Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg---instance Readable (Image VS Y Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng--instance Readable (Image VS YA Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng--instance Readable (Image VS RGB Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng--instance Readable (Image VS RGBA Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng---instance Readable (Image VS Y Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga--instance Readable (Image VS YA Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga--instance Readable (Image VS RGB Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga--instance Readable (Image VS RGBA Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga---instance Readable (Image VS Y Double) TIF where-  decode _ = jpDynamicImageToImage . JP.decodeTiff--instance Readable (Image VS YA Double) TIF where-  decode _ = jpDynamicImageToImage . JP.decodeTiff--instance Readable (Image VS RGB Double) TIF where-  decode _ = jpDynamicImageToImage . JP.decodeTiff--instance Readable (Image VS RGBA Double) TIF where-  decode _ = jpDynamicImageToImage . JP.decodeTiff------ General decoding and helper functions--jpImageToImageUnsafe :: (Array VS cs e, JP.Pixel jpx) =>-                        JP.Image jpx -> Image VS cs e-jpImageToImageUnsafe (JP.Image n m !v) = fromVector (m, n) $ V.unsafeCast v------ jpImageToImageSafe :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) =>---                       JP.Image jpx -> Image arr cs e--- jpImageToImageSafe !jimg = makeImage (JP.imageHeight jimg, JP.imageWidth jimg) getPx---   where getPx !(y, x) = convert $ JP.pixelAt jimg x y---jpImageY8ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word8)-jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageY8ToImage jimg = jpCSError "Y8 (Pixel Y Word8)" jimg---jpImageY16ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word16)-jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageY16ToImage jimg = jpCSError "Y16 (Pixel Y Word16)" jimg--{- -- No JuicyPixels images are actually read in this type-jpImageYFToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Float)-jpImageYFToImage (Right (JP.ImageYF jimg)) = Right (jpImageToImage jimg)-jpImageYFToImage jimg = jpCSError "YF (Pixel Y Float)" jimg--}--jpImageYA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word8)-jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageYA8ToImage jimg = jpCSError "YA8 (Pixel YA Word8)" jimg---jpImageYA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word16)-jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg---jpImageRGB8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word8)-jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg---jpImageRGB16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word16)-jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg---jpImageRGBFToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Float)-jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg---jpImageRGBA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word8)-jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg---jpImageRGBA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word16)-jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg---jpImageYCbCr8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YCbCr Word8)-jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg---jpImageCMYK8ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word8)-jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg---jpImageCMYK16ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word16)-jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImageUnsafe jimg)-jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg---jpDynamicImageToImage' :: (Convertible (Pixel Y Word8) (Pixel cs e),-                           Convertible (Pixel YA Word8) (Pixel cs e),-                           Convertible (Pixel Y Word16) (Pixel cs e),-                           Convertible (Pixel YA Word16) (Pixel cs e),-                           Convertible (Pixel Y Float) (Pixel cs e),-                           Convertible (Pixel RGB Word8) (Pixel cs e),-                           Convertible (Pixel RGBA Word8) (Pixel cs e),-                           Convertible (Pixel RGB Word16) (Pixel cs e),-                           Convertible (Pixel RGBA Word16) (Pixel cs e),-                           Convertible (Pixel RGB Float) (Pixel cs e),-                           Convertible (Pixel YCbCr Word8) (Pixel cs e),-                           Convertible (Pixel CMYK Word8) (Pixel cs e),-                           Convertible (Pixel CMYK Word16) (Pixel cs e),-                           Array VS cs e) =>-                          JP.DynamicImage -> Image VS cs e-jpDynamicImageToImage' (JP.ImageY8 jimg)     =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS Y Word8)-jpDynamicImageToImage' (JP.ImageYA8 jimg)    =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS YA Word8)-jpDynamicImageToImage' (JP.ImageY16 jimg)    =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS Y Word16)-jpDynamicImageToImage' (JP.ImageYA16 jimg)   =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS YA Word16)-jpDynamicImageToImage' (JP.ImageYF jimg)     =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS Y Float)-jpDynamicImageToImage' (JP.ImageRGB8 jimg)   =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGB Word8)-jpDynamicImageToImage' (JP.ImageRGBA8 jimg)  =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGBA Word8)-jpDynamicImageToImage' (JP.ImageRGB16 jimg)  =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGB Word16)-jpDynamicImageToImage' (JP.ImageRGBA16 jimg) =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGBA Word16)-jpDynamicImageToImage' (JP.ImageRGBF jimg)   =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGB Float)-jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS YCbCr Word8)-jpDynamicImageToImage' (JP.ImageCMYK8 jimg)  =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS CMYK Word8)-jpDynamicImageToImage' (JP.ImageCMYK16 jimg) =-  I.map convert $ (jpImageToImageUnsafe jimg :: Image VS CMYK Word16)---jpDynamicImageToImage :: (Convertible (Pixel Y Word8) (Pixel cs e),-                          Convertible (Pixel YA Word8) (Pixel cs e),-                          Convertible (Pixel Y Word16) (Pixel cs e),-                          Convertible (Pixel YA Word16) (Pixel cs e),-                          Convertible (Pixel Y Float) (Pixel cs e),-                          Convertible (Pixel RGB Word8) (Pixel cs e),-                          Convertible (Pixel RGBA Word8) (Pixel cs e),-                          Convertible (Pixel RGB Word16) (Pixel cs e),-                          Convertible (Pixel RGBA Word16) (Pixel cs e),-                          Convertible (Pixel RGB Float) (Pixel cs e),-                          Convertible (Pixel YCbCr Word8) (Pixel cs e),-                          Convertible (Pixel CMYK Word8) (Pixel cs e),-                          Convertible (Pixel CMYK Word16) (Pixel cs e),-                          Array VS cs e) =>-                         Either String JP.DynamicImage -> Either String (Image VS 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."

@@ -1,305 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--- |--- Module      : Graphics.Image.IO.Formats.JuicyPixels.Writable--- Copyright   : (c) Alexey Kuleshevich 2017--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.Image.IO.Formats.JuicyPixels.Writable () where--import Prelude as P-import qualified Data.Monoid as M (mempty)-import Graphics.Image.ColorSpace-import Graphics.Image.Interface as I-import Graphics.Image.Interface.Vector-import Graphics.Image.IO.Base-import Graphics.Image.IO.Formats.JuicyPixels.Common-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.ColorQuant as JP-import qualified Data.Vector.Storable as V------------------------------------------------------------------------------------- Encoding images using JuicyPixels ------------------------------------------------------------------------------------------------------------------------------instance Writable (Image VS Y Word8) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) id--instance Writable (Image VS RGB Word8) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) id--instance Writable (Image VS RGBA Word8) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) id--instance Writable (Image VS Binary Bit) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary--instance Writable (Image VS Y Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8)--instance Writable (Image VS YA Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8)-                                                ((fmap toWord8) . dropAlpha)--instance Writable (Image VS RGB Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8)--instance Writable (Image VS RGBA Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8)---- Writable GIF--encodeGIF :: (Array VS cs' e, Array VS cs Word8) =>-             [SaveOption GIF] -> (Pixel cs' e -> Pixel cs Word8)-             -> Image VS cs' e -> BL.ByteString-encodeGIF []                     !conv =-  either error id . uncurry JP.encodeGifImageWithPalette .-  JP.palettize JP.defaultPaletteOptions . imageToJPImage (undefined :: JP.PixelRGB8) conv-encodeGIF (GIFPalette palOpts:_) !conv =-  either error id . uncurry JP.encodeGifImageWithPalette .-  JP.palettize palOpts . imageToJPImage (undefined :: JP.PixelRGB8) conv---instance Writable (Image VS RGB Word8) GIF where-  encode _ opts = encodeGIF opts id-  -instance Writable (Image VS Y Double) GIF where-  encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB)-    -instance Writable (Image VS YA Double) GIF where-  encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB . dropAlpha)--instance Writable (Image VS RGB Double) GIF where-  encode _ opts = encodeGIF opts (fmap toWord8)--instance Writable (Image VS RGBA Double) GIF where-  encode _ opts = encodeGIF opts ((fmap toWord8) . dropAlpha)---encodeGIFA :: (Array VS cs' e, Array VS cs Word8) =>-              [SaveOption GIFA] -> (Pixel cs' e -> Pixel cs Word8)-           -> [(JP.GifDelay, Image VS cs' e)] -> BL.ByteString-encodeGIFA !opts !conv =-  either error id . JP.encodeGifImages (getGIFALoop opts) . P.map palletizeGif where-    getGIFALoop []                   = JP.LoopingNever-    getGIFALoop (GIFALooping loop:_) = loop-    getGIFALoop (_:xs)               = getGIFALoop xs    -    getGIFAPal []                      = JP.defaultPaletteOptions-    getGIFAPal (GIFAPalette palOpts:_) = palOpts-    getGIFAPal (_:xs)                  = getGIFAPal xs-    palletizeGif !(d, img) = (p, d, jimg) where  -      !(jimg, p) = JP.palettize (getGIFAPal opts) $-                   imageToJPImage (undefined :: JP.PixelRGB8) conv img---instance Writable [(JP.GifDelay, Image VS RGB Word8)] GIFA where-  encode _ opts = encodeGIFA opts id--instance Writable [(JP.GifDelay, Image VS RGB Double)] GIFA where-  encode _ opts = encodeGIFA opts (fmap toWord8)---- Writable HDR--instance Writable (Image VS RGB Float) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) id--instance Writable (Image VS Y Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF)-                                             (fmap toFloat . toPixelRGB)--instance Writable (Image VS YA Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF)-                                             (fmap toFloat . toPixelRGB . dropAlpha)--instance Writable (Image VS RGB Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) (fmap toFloat)--instance Writable (Image VS RGBA Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF)-                                             (fmap toFloat . dropAlpha)- ---- Writable JPG---encodeJPG-  :: (JP.JpgEncodable px, Array VS cs' e, Array VS cs (JP.PixelBaseComponent px)) =>-     [SaveOption JPG]-     -> px-     -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent px))-     -> Image VS cs' e-     -> BL.ByteString-encodeJPG []               t conv =-  JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage t conv-encodeJPG (JPGQuality q:_) t conv =-  JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage t conv---instance Writable (Image VS Y Word8) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) id--instance Writable (Image VS RGB Word8) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) id--instance Writable (Image VS CMYK Word8) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.PixelCMYK8) id-               -instance Writable (Image VS YCbCr Word8) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.PixelYCbCr8) id--instance Writable (Image VS Y Double) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) (fmap toWord8)--instance Writable (Image VS YA Double) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha) --instance Writable (Image VS RGB Double) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) (fmap toWord8)--instance Writable (Image VS RGBA Double) JPG where-  encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) ((fmap toWord8) . dropAlpha) ----- Writable PNG--instance Writable (Image VS Binary Bit) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary-  -instance Writable (Image VS Y Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) id--instance Writable (Image VS Y Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) id--instance Writable (Image VS YA Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA8) id--instance Writable (Image VS YA Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) id--instance Writable (Image VS RGB Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB8) id--instance Writable (Image VS RGB Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) id--instance Writable (Image VS RGBA Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA8) id--instance Writable (Image VS RGBA Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) id---instance Writable (Image VS Y Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16)--instance Writable (Image VS YA Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16)--instance Writable (Image VS RGB Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16)--instance Writable (Image VS RGBA Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16)---- Writable TGA--instance Writable (Image VS Binary Bit) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary-  -instance Writable (Image VS Y Word8) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) id--instance Writable (Image VS RGB Word8) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) id--instance Writable (Image VS RGBA Word8) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) id---instance Writable (Image VS Y Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8)--instance Writable (Image VS YA Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha)--instance Writable (Image VS RGB Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8)--instance Writable (Image VS RGBA Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8)---- Writable TIF--instance Writable (Image VS Y Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) id--instance Writable (Image VS Y Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) id--instance Writable (Image VS YA Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA8) id--instance Writable (Image VS YA Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) id--instance Writable (Image VS RGB Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB8) id--instance Writable (Image VS RGB Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) id--instance Writable (Image VS RGBA Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA8) id--instance Writable (Image VS RGBA Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) id--instance Writable (Image VS YCbCr Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) id-  -instance Writable (Image VS CMYK Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK8) id--instance Writable (Image VS CMYK Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) id---instance Writable (Image VS Binary Bit) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary-  -instance Writable (Image VS Y Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16)--instance Writable (Image VS YA Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16)--instance Writable (Image VS RGB Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16)--instance Writable (Image VS RGBA Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16)--instance Writable (Image VS YCbCr Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) (fmap toWord8)--instance Writable (Image VS CMYK Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) (fmap toWord16)----imageToJPImage :: (JP.Pixel a, Array VS cs' e, Array VS cs (JP.PixelBaseComponent a)) =>-                  a -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent a)) -> Image VS cs' e -> JP.Image a-imageToJPImage _ f !img = JP.Image n m $ V.unsafeCast $ toVector $ I.map f img where-  !(m, n) = dims img

@@ -1,32 +1,37 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.IO.Formats.Netpbm--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable ---module Graphics.Image.IO.Formats.Netpbm (-  PBM(..), PGM(..), PPM(..)+module Graphics.Image.IO.Formats.Netpbm+  ( -- * Netpbm formats+    -- ** PBM+    PBM(..)+    -- ** PGM+  , PGM(..)+    -- ** PPM+  , PPM(..)   ) where -import Graphics.Image.ColorSpace-import Graphics.Image.Interface as I-import Graphics.Image.Interface.Vector-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 V+import qualified Data.ByteString                 as B (ByteString)+import qualified Data.Vector.Storable            as V+import           Foreign.Storable                (Storable)+import           Graphics.Image.ColorSpace+import           Graphics.Image.Interface        as I+import           Graphics.Image.Interface.Vector (VS)+import           Graphics.Image.IO.Base+import qualified Graphics.Netpbm                 as PNM   -- | Netpbm: portable bitmap image with @.pbm@ extension.-data PBM = PBM+data PBM = PBM deriving Show  instance ImageFormat PBM where   data SaveOption PBM@@ -35,7 +40,7 @@   -- | Netpbm: portable graymap image with @.pgm@ extension.-data PGM = PGM+data PGM = PGM deriving Show  instance ImageFormat PGM where   data SaveOption PGM@@ -44,7 +49,7 @@   -- | Netpbm: portable pixmap image with @.ppm@ extension.-data PPM = PPM+data PPM = PPM deriving Show  instance ImageFormat PPM where   data SaveOption PPM@@ -52,55 +57,29 @@   ext _ = ".ppm"  -instance ImageFormat [PBM] where-  data SaveOption [PBM]+instance ImageFormat (Seq PBM) where+  data SaveOption (Seq PBM)    ext _ = ".pbm"  -instance ImageFormat [PGM] where-  data SaveOption [PGM]+instance ImageFormat (Seq PGM) where+  data SaveOption (Seq PGM)    ext _ = ".pgm"  -instance ImageFormat [PPM] where-  data SaveOption [PPM]+instance ImageFormat (Seq PPM) where+  data SaveOption (Seq PPM)    ext _ = ".ppm"   ----------------------------------------------------------------------------------- Converting to and from Netpbm --------------------------------------------------------------------------------------------------------------------------------------- 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 ------------------------------------------------ --------------------------------------------------------------------------------  --- BPM Format Reading (general)- instance Readable (Image VS Y Double) PBM where   decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm @@ -119,9 +98,8 @@ instance Readable (Image VS RGBA Double) PPM where   decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm --- BPM Format Reading (exact) -instance Readable (Image VS Binary Bit) PBM where+instance Readable (Image VS X Bit) PBM where   decode _ = either Left (ppmToImageUsing pnmDataPBMToImage . head) . decodePnm  instance Readable (Image VS Y Word8) PGM where@@ -137,19 +115,19 @@   decode _ = either Left (ppmToImageUsing pnmDataPPM16ToImage . head) . decodePnm  -instance Readable [Image VS Binary Bit] [PBM] where+instance Readable [Image VS X Bit] (Seq PBM) where   decode _ = pnmToImagesUsing pnmDataPBMToImage -instance Readable [Image VS Y Word8] [PGM] where+instance Readable [Image VS Y Word8] (Seq PGM) where   decode _ = pnmToImagesUsing pnmDataPGM8ToImage -instance Readable [Image VS Y Word16] [PGM] where+instance Readable [Image VS Y Word16] (Seq PGM) where   decode _ = pnmToImagesUsing pnmDataPGM16ToImage -instance Readable [Image VS RGB Word8] [PPM] where+instance Readable [Image VS RGB Word8] (Seq PPM) where   decode _ = pnmToImagesUsing pnmDataPPM8ToImage -instance Readable [Image VS RGB Word16] [PPM] where+instance Readable [Image VS RGB Word16] (Seq PPM) where   decode _ = pnmToImagesUsing pnmDataPPM16ToImage  @@ -159,23 +137,19 @@   fmap (fmap (either error id . ppmToImageUsing conv)) . decodePnm  -pnmDataToImage :: (Convertible (Pixel Binary Bit) (Pixel cs e),-                   Convertible (Pixel Y Word8) (Pixel cs e),-                   Convertible (Pixel Y Word16) (Pixel cs e),-                   Convertible (Pixel RGB Word8) (Pixel cs e),-                   Convertible (Pixel RGB Word16) (Pixel cs e),-                   Array VS cs e) =>-                  Int -> Int -> PNM.PpmPixelData -> Image VS cs e+pnmDataToImage+  :: (Convertible cs e, ColorSpace cs e, V.Storable (Pixel cs e)) =>+     Int -> Int -> PNM.PpmPixelData -> Image VS cs e pnmDataToImage w h (PNM.PbmPixelData v)      =-  I.map convert (makeImageUnsafe (h, w) v :: Image VS Binary Bit)+  convert (makeImageUnsafe (h, w) v :: Image VS X Bit) pnmDataToImage w h (PNM.PgmPixelData8 v)     =-  I.map convert (makeImageUnsafe (h, w) v :: Image VS Y Word8)+  convert (makeImageUnsafe (h, w) v :: Image VS Y Word8) pnmDataToImage w h (PNM.PgmPixelData16 v)    =-  I.map convert (makeImageUnsafe (h, w) v :: Image VS Y Word16)+  convert (makeImageUnsafe (h, w) v :: Image VS Y Word16) pnmDataToImage w h (PNM.PpmPixelDataRGB8 v)  =-  I.map convert (makeImageUnsafe (h, w) v :: Image VS RGB Word8)+  convert (makeImageUnsafe (h, w) v :: Image VS RGB Word8) pnmDataToImage w h (PNM.PpmPixelDataRGB16 v) =-  I.map convert (makeImageUnsafe (h, w) v :: Image VS RGB Word16)+  convert (makeImageUnsafe (h, w) v :: Image VS RGB Word16)   makeImageUnsafe@@ -184,9 +158,9 @@ makeImageUnsafe sz = fromVector sz . V.unsafeCast  -pnmDataPBMToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS Binary Bit)+pnmDataPBMToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS X Bit) pnmDataPBMToImage w h (PNM.PbmPixelData v) = Right $ makeImageUnsafe (h, w) v-pnmDataPBMToImage _ _ d                    = pnmCSError "Binary (Pixel Binary Bit)" d+pnmDataPBMToImage _ _ d                    = pnmCSError "Binary (Pixel X Bit)" d  pnmDataPGM8ToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS Y Word8) pnmDataPGM8ToImage w h (PNM.PgmPixelData8 v) = Right $ makeImageUnsafe (h, w) v@@ -209,8 +183,8 @@ 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"@@ -229,7 +203,7 @@   pnmShowData ppmData ++ ", cannot convert it to " ++ cs ++ " colorspace."  pnmShowData :: PNM.PpmPixelData -> String-pnmShowData (PNM.PbmPixelData _)      = "Binary (Pixel Binary Bit)"+pnmShowData (PNM.PbmPixelData _)      = "Binary (Pixel X Bit)" pnmShowData (PNM.PgmPixelData8 _)     = "Y8 (Pixel Y Word8)" pnmShowData (PNM.PgmPixelData16 _)    = "Y16 (Pixel Y Word16)" pnmShowData (PNM.PpmPixelDataRGB8 _)  = "RGB8 (Pixel RGB Word8)"

@@ -1,10 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Image.IO.Histogram--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -12,30 +12,31 @@ -- module Graphics.Image.IO.Histogram (   Histogram(..), Histograms, ChannelColour(..), getHistograms, getHistogram,+  equalizeHistogram, cdf,   displayHistograms, writeHistograms   ) where -import Prelude as P -import Control.Concurrent (forkIO)-import Control.Monad (void)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C-import qualified Data.Vector.Unboxed as V-import System.Directory (getTemporaryDirectory)-import System.FilePath ((</>))-import System.IO.Temp (createTempDirectory)+import           Control.Concurrent                        (forkIO)+import           Control.Monad                             (void)+import qualified Data.Colour                               as C+import qualified Data.Colour.Names                         as C+import qualified Data.Vector.Unboxed                       as V+import           Prelude                                   as P+import           System.Directory                          (getTemporaryDirectory)+import           System.FilePath                           ((</>))+import           System.IO.Temp                            (createTempDirectory) -import Graphics.Image.Interface as I-import Graphics.Image.IO-import Graphics.Image.ColorSpace-import Graphics.Rendering.Chart.Easy-import Graphics.Rendering.Chart.Backend.Diagrams+import           Graphics.Image.ColorSpace+import           Graphics.Image.Interface                  as I+import           Graphics.Image.IO+import           Graphics.Rendering.Chart.Backend.Diagrams+import           Graphics.Rendering.Chart.Easy  #if MIN_VERSION_vector(0,11,0)-import Data.Vector.Unboxed.Mutable (modify)+import           Data.Vector.Unboxed.Mutable               (modify) #else-import Control.Monad.Primitive (PrimMonad (..))-import qualified Data.Vector.Unboxed.Mutable as MV+import           Control.Monad.Primitive                   (PrimMonad (..))+import qualified Data.Vector.Unboxed.Mutable               as MV  modify :: (PrimMonad m, V.Unbox a) => MV.MVector (PrimState m) a -> (a -> a) -> Int -> m () modify v f idx = do@@ -45,16 +46,16 @@   class ChannelColour cs where- +   -- | Get a pure colour representation of a channel.   csColour :: cs -> C.AlphaColour Double   -- | A single channel histogram of an image.-data Histogram = Histogram { hBins :: V.Vector Int+data Histogram = Histogram { hBins   :: V.Vector Int                              -- ^ Vector containing pixel counts. Index of a                              -- vector serves as an original pixel value.-                           , hName :: String+                           , hName   :: String                              -- ^ Name of the channel that will be displayed in                              -- the legend.                            , hColour :: C.AlphaColour Double@@ -64,28 +65,71 @@ -- data type with fields like title, width, heigth, etc. type Histograms = [Histogram] + -- | Create a histogram per channel with 256 bins each.-getHistograms :: forall arr cs e . (ChannelColour cs, MArray arr X e, Array arr X e, +getHistograms :: forall arr cs e . (ChannelColour cs, MArray arr X e, Array arr X e,                                     MArray arr cs e, Array arr cs e) =>                  Image arr cs e               -> Histograms getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toImagesX-  where setCh cs h = h { hName = show cs-                       , hColour = csColour cs }+  where setCh !cs !h = h { hName = show cs+                         , hColour = csColour cs }+        {-# INLINE setCh #-}+{-# INLINE getHistograms #-}  -- | Generate a histogram with 256 bins for a single channel Gray image. getHistogram :: MArray arr X e =>                 Image arr X e              -> Histogram-getHistogram img = Histogram { hBins = V.modify countBins $-                                       V.replicate-                                       (1 + fromIntegral (maxBound :: Word8)) (0 :: Int)-                             , hName = show X-                             , hColour = csColour X } where-  incBin v (PixelX g) = modify v (+1) $ fromIntegral (toWord8 g)-  countBins v = I.mapM_ (incBin v) img-  +getHistogram !img = Histogram { hBins = V.modify countBins $+                                        V.replicate+                                        (1 + fromIntegral (maxBound :: Word8)) (0 :: Int)+                              , hName = show X+                              , hColour = csColour X }+  where+    incBin !v (PixelX x) = modify v (+1) $ fromIntegral (toWord8 x)+    {-# INLINE incBin #-}+    countBins !v = I.mapM_ (incBin v) img+    {-# INLINE countBins #-}+{-# INLINE getHistogram #-} ++-- | Discrete cumulative distribution function.+cdf :: MArray arr X e => Image arr X e -> V.Vector Double+cdf !img = V.unfoldr gen (0, 0)+  where+    !p = 1 / fromIntegral (m * n)+    !(m, n) = dims img+    !histogram = hBins $ getHistogram img+    !l = V.length histogram+    gen !(acc, k)+      | k == l = Nothing+      | otherwise =+        let !acc' = acc + fromIntegral (V.unsafeIndex histogram k)+        in Just (acc' * p, (acc', k + 1))+    {-# INLINE gen #-}+{-# INLINE cdf #-}+++-- | Converts an image to Luma and performs histogram equalization.+equalizeHistogram+  :: ( ToY cs e+     , Array arr cs e+     , Array arr Y Double+     , Array arr X Word8+     , MArray arr X Word8+     )+  => Image arr cs e -> Image arr Y Double+equalizeHistogram !img = I.map f imgX where+  !imgX = I.map (toX . toPixelY) img+  !cdfImg = cdf imgX+  toX (PixelY y) = PixelX $ toWord8 y+  {-# INLINE toX #-}+  f (PixelX x) = PixelY (V.unsafeIndex cdfImg (fromIntegral x))+  {-# INLINE f #-}+{-# INLINE equalizeHistogram #-}++ -- | Write histograms into a PNG image file. -- -- >>> frog <- readImageRGB VU "images/frog.jpg"@@ -157,9 +201,9 @@   csColour IntHSI = C.opaque C.darkblue  instance ChannelColour HSIA where-  csColour HueHSIA = C.opaque C.purple-  csColour SatHSIA = C.opaque C.orange-  csColour IntHSIA = C.opaque C.darkblue+  csColour HueHSIA   = C.opaque C.purple+  csColour SatHSIA   = C.opaque C.orange+  csColour IntHSIA   = C.opaque C.darkblue   csColour AlphaHSIA = C.opaque C.gray  

@@ -1,17 +1,18 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns            #-}+{-# LANGUAGE CPP                     #-}+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE Rank2Types              #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE ViewPatterns            #-} #if __GLASGOW_HASKELL__ >= 800     {-# OPTIONS_GHC -Wno-redundant-constraints #-}-    {-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE UndecidableSuperClasses #-} #endif-{-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Image.Interface -- Copyright   : (c) Alexey Kuleshevich 2017@@ -21,10 +22,17 @@ -- Portability : non-portable -- module Graphics.Image.Interface (+  -- * Pixel and ColorSpace   Pixel, ColorSpace(..), AlphaSpace(..), Elevator(..),-  BaseArray(..), Array(..), MArray(..),+  -- * Array and Image+  BaseArray(..), Array(..),+  -- * MArray and MImage+  MArray(..), createImage,+  -- * Exchanging Representation   exchange,-  defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex,+  -- * Indexing+  index, defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex,+  -- * Tools   fromIx, toIx, checkDims #if !MIN_VERSION_base(4,8,0)   , module Control.Applicative@@ -32,29 +40,33 @@ #endif   ) where -import Prelude hiding (and, map, zipWith, sum, product)+import           Prelude                           hiding (and, map, product,+                                                    sum, zipWith) #if !MIN_VERSION_base(4,8,0)-import Control.Applicative+import           Control.Applicative #endif-import Control.Monad.Primitive (PrimMonad (..))-import Data.Maybe (fromMaybe)-import Data.Foldable-import GHC.Exts (Constraint)-import Data.Typeable (Typeable, showsTypeRep, typeOf)-import Control.DeepSeq (NFData(rnf), deepseq)-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Unboxed as VU+import           Control.DeepSeq                   (NFData (rnf), deepseq)+import           Control.Monad.Primitive           (PrimMonad (..))+import           Control.Monad.ST+import           Data.Foldable+import           Data.Maybe                        (fromMaybe)+import           Data.Proxy                        (Proxy (..))+import           Data.Typeable                     (Typeable, showsTypeRep,+                                                    typeRep)+import qualified Data.Vector.Generic               as VG+import qualified Data.Vector.Unboxed               as VU+import           GHC.Exts                          (Constraint) -import Graphics.Image.Interface.Elevator+import           Graphics.Image.Interface.Elevator  -- | A Pixel family with a color space and a precision of elements. data family Pixel cs e :: *  -class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs, Elevator e,-      Eq (Pixel cs e), VU.Unbox (Components cs e))+class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs,+      Eq (Pixel cs e), VU.Unbox (Components cs e), Elevator e)       => ColorSpace cs e where-  +   type Components cs e    -- | Convert a Pixel to a representation suitable for storage as an unboxed@@ -69,12 +81,12 @@    -- | Retrieve Pixel's component value   getPxC :: Pixel cs e -> cs -> e-  +   -- | Set Pixel's component value   setPxC :: Pixel cs e -> cs -> e -> Pixel cs e-  +   -- | Map a channel aware function over all Pixel's components.-  mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e +  mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e    -- | Map a function over all Pixel's componenets.   liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e@@ -82,6 +94,7 @@   -- | Zip two Pixels with a function.   liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e +  -- | Left fold on two pixels a the same time.   foldlPx2 :: (b -> e -> e -> b) -> b -> Pixel cs e -> Pixel cs e -> b    -- | Right fold over all Pixel's components.@@ -105,21 +118,21 @@   toListPx !px = foldr' f [] (enumFrom (toEnum 0))     where f !cs !ls = getPxC px cs:ls -   + -- | A color space that supports transparency. class (ColorSpace (Opaque cs) e, ColorSpace cs e) => AlphaSpace cs e where   -- | A corresponding opaque version of this color space.   type Opaque cs -  -- | Get an alpha channel of a transparant pixel. +  -- | Get an alpha channel of a transparant pixel.   getAlpha :: Pixel cs e -> e    -- | Add an alpha channel to 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.   --@@ -164,7 +177,8 @@             -> Image arr cs e    makeImageWindowed :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.-                    -> ((Int, Int), (Int, Int))+                    -> (Int, Int) -- ^ Starting index+                    -> (Int, Int) -- ^ Size of the window                     -> ((Int, Int) -> Pixel cs e)                        -- ^ Function that generates inner pixels.                     -> ((Int, Int) -> Pixel cs e)@@ -217,7 +231,7 @@            -- 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.@@ -229,11 +243,11 @@                 (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. +  -- | 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@@ -256,7 +270,7 @@   -- | 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. +  -- | 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.@@ -274,14 +288,14 @@   -- 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+  eq :: Image arr cs e -> Image arr cs e -> Bool    -- | `Array` class does not enforce an image to be represented as concrete   -- array of pixels in memory, but if at any time it is desired for the image   -- to be brought to a computed state, this function can be used.   compute :: Image arr cs e -> Image arr cs e -  -- | Each array has a sibling `Manifest` array representation, which +  -- | Each array has a sibling `Manifest` array representation, which   toManifest :: Image arr cs e -> Image (Manifest arr) cs e    -- | Convert an image to a flattened 'Vector'. For all current representations@@ -300,26 +314,17 @@   -- <Image Vector Luma: 200x300>   --   -- <<images/grad_fromVector.png>>-  -- +  --   fromVector :: (Int, Int) -> Vector arr (Pixel cs e) -> Image arr cs e -       + -- | Array representation that is actually has real data stored in memory, hence -- allowing for image indexing, forcing pixels into computed state etc. class BaseArray arr cs e => MArray arr cs e  where   data MImage s arr cs e-  ++  -- | Get a pixel at @(i, j)@ location without any bounds checks.   unsafeIndex :: Image arr cs e -> (Int, Int) -> Pixel cs e-  -  -- | Get a pixel at @i@-th and @j@-th location.-  ---  -- >>> let grad_gray = 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-  index !img !ix = borderIndex (error $ show img ++ " - Index out of bounds: " ++ show ix) img ix-  {-# INLINE index #-}    -- | Make sure that an image is fully evaluated.   deepSeqImage :: Image arr cs e -> a -> a@@ -380,6 +385,13 @@           MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m ()  +-- | Run a stateful monadic computation that generates an image.+createImage+  :: MArray arr cs e+  => (forall s. ST s (MImage s arr cs e)) -> Image arr cs e+createImage create = runST (create >>= freeze)++ -- | Exchange the underlying array representation of an image. exchange :: (Array arr' cs e, Array arr cs e) =>             arr -- ^ New representation of an image.@@ -387,12 +399,12 @@          -> Image arr cs e exchange _ img@(dims -> (1, 1)) = scalar $ index00 img exchange _ img = fromVector (dims img) $ VG.convert $ toVector img-{-# INLINE[0] exchange #-}+{-# INLINE exchange #-}  -{-# RULES-"exchange/id" forall arr. exchange arr = id- #-}+--{-# RULES+--"exchange/id" forall arr. exchange arr = id+-- #-}   -- | Approach to be used near the borders during various transformations.@@ -446,7 +458,7 @@                    -> ((Int, Int) -> px) -- ^ Image's indexing function.                    -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup.                    -> px-handleBorderIndex border !(m, n) getPx !(i, j) =+handleBorderIndex ~border !(m, n) getPx !(i, j) =   if north || east || south || west   then case border of     Fill px  -> px@@ -470,6 +482,17 @@ {-# INLINE handleBorderIndex #-}  +-- | Get a pixel at @i@-th and @j@-th location.+--+-- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200)+-- >>> index grad_gray (20, 30) == PixelY ((20*30) / (200*200))+-- True+--+index :: MArray arr cs e => Image arr cs e -> (Int, Int) -> Pixel cs e+index !img !ix = borderIndex (error $ show img ++ " - Index out of bounds: " ++ show ix) img ix+{-# INLINE index #-}++ -- | Image indexing function that returns a default pixel if index is out of bounds. defaultIndex :: MArray arr cs e =>                 Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e@@ -481,7 +504,7 @@ -- out of bounds pixels. borderIndex :: MArray arr cs e =>                Border (Pixel cs e) -> Image arr cs e -> (Int, Int) -> Pixel cs e-borderIndex atBorder !img = handleBorderIndex atBorder (dims img) (unsafeIndex img)+borderIndex ~atBorder !img = handleBorderIndex atBorder (dims img) (unsafeIndex img) {-# INLINE borderIndex #-}  @@ -490,7 +513,7 @@ maybeIndex :: MArray 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+  if i >= 0 && j >= 0 && i < m && j < n then Just $ unsafeIndex img (i, j) else Nothing {-# INLINE maybeIndex #-}  @@ -511,17 +534,16 @@ toIx !n !k = divMod k n {-# INLINE toIx #-} - checkDims :: String -> (Int, Int) -> (Int, Int)-checkDims err !ds@(m, n)-  | m <= 0 || n <= 0 = +checkDims err !sz@(m, n)+  | m <= 0 || n <= 0 =     error $-    show err ++ ": Image dimensions are expected to be positive: " ++ show ds-  | otherwise = ds+    show err ++ ": dimensions are expected to be positive: " ++ show sz+  | otherwise = sz {-# INLINE checkDims #-}  -instance (ColorSpace cs e, Num e) => Num (Pixel cs e) where+instance ColorSpace cs e => Num (Pixel cs e) where   (+)         = liftPx2 (+)   {-# INLINE (+) #-}   (-)         = liftPx2 (-)@@ -534,8 +556,8 @@   {-# INLINE signum #-}   fromInteger = promote . fromInteger   {-# INLINE fromInteger #-}-   + instance (ColorSpace cs e, Fractional e) => Fractional (Pixel cs e) where   (/)          = liftPx2 (/)   {-# INLINE (/) #-}@@ -573,52 +595,40 @@   acosh   = liftPx acosh   {-# INLINE acosh #-} - instance (ColorSpace cs e, Bounded e) => Bounded (Pixel cs e) where   maxBound = promote maxBound   {-# INLINE maxBound #-}-     minBound = promote minBound   {-# INLINE minBound #-} - instance (Foldable (Pixel cs), NFData e) => NFData (Pixel cs e) where    rnf = foldr' deepseq ()   {-# INLINE rnf #-} --instance (Array arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where+instance Array arr 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 = scalar . fromInteger   {-# INLINE fromInteger #-} - instance (Fractional (Pixel cs e), Array arr cs e) =>          Fractional (Image arr cs e) where   (/)          = zipWith (/)   {-# INLINE (/) #-}-  -  fromRational = scalar . fromRational +  fromRational = scalar . fromRational   {-# INLINE fromRational #-}  @@ -626,42 +636,30 @@          Floating (Image arr cs e) where   pi    = scalar 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 #-}  +  {-# INLINE acosh #-}   instance MArray arr cs e => NFData (Image arr cs e) where@@ -669,14 +667,13 @@   {-# INLINE rnf #-}  - instance BaseArray arr cs e =>          Show (Image arr cs e) where   show (dims -> (m, n)) =     "<Image " ++-    showsTypeRep (typeOf (undefined :: arr)) " " ++-    showsTypeRep (typeOf (undefined :: cs)) " (" ++-    showsTypeRep (typeOf (undefined :: e)) "): " +++    showsTypeRep (typeRep (Proxy :: Proxy arr)) " " +++    showsTypeRep (typeRep (Proxy :: Proxy cs)) " (" +++    showsTypeRep (typeRep (Proxy :: Proxy e)) "): " ++      show m ++ "x" ++ show n ++ ">"  @@ -684,7 +681,7 @@          Show (MImage st arr cs e) where   show (mdims -> (m, n)) =     "<MutableImage " ++-    showsTypeRep (typeOf (undefined :: arr)) " " ++-    showsTypeRep (typeOf (undefined :: cs)) " (" ++-    showsTypeRep (typeOf (undefined :: e)) "): " +++    showsTypeRep (typeRep (Proxy :: Proxy arr)) " " +++    showsTypeRep (typeRep (Proxy :: Proxy cs)) " (" +++    showsTypeRep (typeRep (Proxy :: Proxy e)) "): " ++      show m ++ "x" ++ show n ++ ">"

@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 800   {-# OPTIONS_GHC -Wno-redundant-constraints #-}@@ -15,14 +15,15 @@ -- module Graphics.Image.Interface.Elevator (   Elevator(..)+  , clamp01   ) where -import qualified Data.Complex as C-import Data.Int-import Data.Word-import GHC.Float-import Data.Typeable-import Data.Vector.Unboxed (Unbox)+import qualified Data.Complex        as C+import           Data.Int+import           Data.Typeable+import           Data.Vector.Unboxed (Unbox)+import           Data.Word+import           GHC.Float   -- | A class with a set of convenient functions that allow for changing precision of@@ -61,7 +62,7 @@ -- | Lower the precision dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div`-                                                   fromIntegral (maxBound :: b)) +                                                   fromIntegral (maxBound :: b)) {-# INLINE dropDown #-}  -- | Increase the precision@@ -77,6 +78,7 @@ -- | Convert to integral streaching it's value up to a maximum value. stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e)+{-# INLINE stretch #-}   -- | Clamp a value to @[0, 1]@ range.

@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- |@@ -30,12 +29,12 @@  -- | Create a sequential unboxed image from a 2D Repa delayed array. fromRepaArrayS :: R.Source r (Pixel cs e) => R.Array r DIM2 (Pixel cs e) -> Image RSU cs e-fromRepaArrayS = SUImage . SDImage . R.delay+fromRepaArrayS = SUImage . fromRepaArrayR   -- | Create a parallel unboxed image from a 2D Repa delayed array. fromRepaArrayP :: R.Source r (Pixel cs e) => R.Array r DIM2 (Pixel cs e) -> Image RPU cs e-fromRepaArrayP = PUImage . PDImage . R.delay+fromRepaArrayP = PUImage . fromRepaArrayR   -- | Convert into Repa Unboxed array from an image.

@@ -1,14 +1,13 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 800     {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}@@ -21,498 +20,475 @@ -- Stability   : experimental -- Portability : non-portable ---module Graphics.Image.Interface.Repa.Generic where+module Graphics.Image.Interface.Repa.Generic+  ( RImage+  , Strategy(..)+  , computeR+  , makeImageR+  , dimsR+  , scalarR+  , index00R+  , makeImageWindowedR+  , mapR+  , imapR+  , eqR+  , zipWithR+  , izipWithR+  , unsafeTraverseR+  , traverseR+  , unsafeTraverse2R+  , traverse2R+  , transposeR+  , backpermuteR+  , fromListsR+  , foldR+  , foldIxR+  , toVectorUnboxedR+  , fromVectorUnboxedR+  , toVectorStorableR+  , fromVectorStorableR+  , fromRepaArrayR+  , multR+  , ix2sh+  , sh2ix+  )where -import Prelude as P-import Data.Array.Repa.Index-import qualified Data.Array.Repa as R-import qualified Data.Array.Repa.Eval as R-import qualified Data.Vector.Generic as VG-import Data.Typeable (Typeable)+import           Data.Array.Repa                     as R+import           Data.Array.Repa.Eval                as R (Elt (..), Target,+                                                           fromList,+                                                           suspendedComputeP)+import           Data.Array.Repa.Operators.Traversal as R+import           Data.Array.Repa.Repr.ForeignPtr+import           Data.Array.Repa.Repr.Partitioned    (P, Range (..))+import           Data.Array.Repa.Repr.Unboxed        (Unbox)+import           Data.Array.Repa.Repr.Undefined      (X)+import           Data.Complex                        as C+import           Data.Maybe                          (listToMaybe)+import qualified Data.Vector.Storable                as VS+import qualified Data.Vector.Unboxed                 as VU+import           Graphics.Image.ColorSpace.Binary    (Bit (..))+import           Graphics.Image.Interface            (ColorSpace (..), Pixel,+                                                      checkDims, toIx)+import           Prelude                             as P -import Graphics.Image.ColorSpace.Binary (Bit(..))-import Graphics.Image.Interface as I-import qualified Graphics.Image.Interface.Vector.Unboxed as IVU-import Graphics.Image.Interface.Repa.Helpers+data Strategy+  = Parallel+  | Sequential +data RImage r p = RTImage !(R.Array r R.DIM2 p)+                | RDImage !(R.Array R.D R.DIM2 p) -type family Repr arr :: *+sh2ix :: DIM2 -> (Int, Int)+sh2ix (Z :. i :. j) = (i, j)+{-# INLINE sh2ix #-} +ix2sh :: (Int, Int) -> DIM2+ix2sh !(i, j) = Z :. i :. j+{-# INLINE ix2sh #-} --- | Repa Array representation, which is computed in parallel.-data RP r = RP r deriving Typeable+errorR :: String -> String -> a+errorR fName errMsg =+  error $ "Graphics.Image.Interface.Repa.Generic." P.++ fName P.++ ": " P.++ errMsg --- | Repa Array representation, which is computed sequentially. -data RS r = RS r deriving Typeable+checkDimsR :: String -> (Int, Int) -> DIM2+checkDimsR fName = ix2sh . checkDims ("Graphics.Image.Interface.Repa.Generic." P.++ fName)+{-# INLINE checkDimsR #-} -instance Show r => Show (RP r) where-  show (RP r) = "RepaParallel " ++ show r-  -instance Show r => Show (RS r) where-  show (RS r) = "RepaSequential " ++ show r +dimsR :: Source r p => RImage r p -> (Int, Int)+dimsR (RTImage arr) = sh2ix $ R.extent arr+dimsR (RDImage arr) = sh2ix $ R.extent arr+{-# INLINE dimsR #-} --------------------------- Sequential Arrays --------------------------+makeImageR :: (Int, Int) -> ((Int, Int) -> px) -> RImage t px+makeImageR sz f =+  RDImage $ R.fromFunction (checkDimsR "makeImageR" sz) (f . sh2ix)+{-# INLINE makeImageR #-} -instance SuperClass (RS r) cs e => BaseArray (RS r) cs e where-  type SuperClass (RS r) cs e =-    (Typeable r, ColorSpace cs e, R.Elt (Pixel cs e), R.Elt e, -     R.Target (Repr r) (Pixel cs e), R.Source (Repr r) (Pixel cs e),-     BaseArray r cs e)-  -  data Image (RS r) cs e = SScalar !(Pixel cs e)-                         | STImage !(R.Array (Repr r) R.DIM2 (Pixel cs e))-                         | SDImage !(R.Array R.D R.DIM2 (Pixel cs e))-                       -  dims (SScalar _                          ) = (1, 1)-  dims (STImage (R.extent -> (Z :. m :. n))) = (m, n)-  dims (SDImage (R.extent -> (Z :. m :. n))) = (m, n)-  {-# INLINE dims #-}+makeImageWindowedR+  :: (Int, Int)+  -> (Int, Int)+  -> (Int, Int)+  -> ((Int, Int) -> p)+  -> ((Int, Int) -> p)+  -> RImage r p+makeImageWindowedR !sz !wIx !wSz getWindowPx getBorderPx =+  RDImage $ R.delay $ makeWindowed sh wIx wSz wArr bArr+  where+    wArr = R.fromFunction sh (getWindowPx . sh2ix)+    bArr = R.fromFunction sh (getBorderPx . sh2ix)+    !sh = checkDimsR "makeImageWindowedR" sz+{-# INLINE makeImageWindowedR #-} +makeWindowed+  :: (Source r1 p, Source r2 p)+  => DIM2 -- ^ Extent of array.+  -> (Int, Int) -- ^ Window starting index+  -> (Int, Int) -- ^ Window size.+  -> Array r1 DIM2 p -- ^ Array for internal elements.+  -> Array r2 DIM2 p -- ^ Array for border elements.+  -> Array (P r1 (P r2 (P r2 (P r2 (P r2 X))))) DIM2 p+makeWindowed sh@(Z :. m :. n) !(it, jt) !(wm, wn) arrWindow arrBorder =+  let inInternal (Z :. i :. j) = i >= it && i < ib && j >= jt && j < jb+      {-# INLINE inInternal #-}+      inBorder = not . inInternal+      {-# INLINE inBorder #-}+      !(ib, jb) = (wm + it, wn + jt)+  in APart sh (Range (Z :. it :. jt) (Z :. wm       :. wn      ) inInternal) arrWindow $+     APart sh (Range (Z :. 0  :. 0 ) (Z :. it       :. n       ) inBorder  ) arrBorder $+     APart sh (Range (Z :. it :. 0 ) (Z :. wm       :. jt      ) inBorder  ) arrBorder $+     APart sh (Range (Z :. it :. jb) (Z :. wm       :. (n - jb)) inBorder  ) arrBorder $+     APart sh (Range (Z :. ib :. 0 ) (Z :. (m - ib) :. n       ) inBorder  ) arrBorder $+     AUndefined sh+{-# INLINE makeWindowed #-} -instance (VG.Vector (Vector r) (Pixel cs e),-          MArray (Manifest r) cs e, BaseArray (RS r) cs e) => Array (RS r) cs e where+fromRepaArrayR :: (Source r1 p) => R.Array r1 DIM2 p -> RImage r p+fromRepaArrayR = RDImage . R.delay+{-# INLINE fromRepaArrayR #-} -  type Manifest (RS r) = Manifest r-  -  type Vector (RS r) = Vector r-  -  makeImage !(checkDims "RS.makeImage" -> (m, n)) f =-    SDImage $ R.fromFunction (Z :. m :. n) (f . sh2ix)-  {-# INLINE makeImage #-}-  -  makeImageWindowed !(checkDims "RS.makeImage" -> (m, n)) !window getWindowPx getBorderPx  =-    SDImage $ R.delay $ makeWindowed (Z :. m :. n) window-    (R.fromFunction (Z :. m :. n) (getWindowPx . sh2ix))-     (R.fromFunction (Z :. m :. n) (getBorderPx . sh2ix))-    -  scalar = SScalar-  {-# INLINE scalar #-} -  index00 (SScalar px)  = px-  index00 (STImage arr) = R.index arr (Z :. 0 :. 0)-  index00 (SDImage arr) = R.index arr (Z :. 0 :. 0)-  {-# INLINE index00 #-}+scalarR :: p -> RImage t p+scalarR = RDImage . fromFunction (Z :. 1 :. 1) . const+{-# INLINE scalarR #-} -  map f (SScalar px)  = SScalar (f px)-  map f (STImage arr) = SDImage (R.map f arr)-  map f (SDImage arr) = SDImage (R.map f arr)-  {-# INLINE map #-}+index00R :: Source r e => RImage r e -> e+index00R (RTImage arr) = R.index arr (Z :. 0 :. 0)+index00R (RDImage arr) = R.index arr (Z :. 0 :. 0)+{-# INLINE index00R #-} -  imap f (SScalar px)  = SScalar (f (0, 0) px)-  imap f (STImage arr) = SDImage (imapR f arr)-  imap f (SDImage arr) = SDImage (imapR f arr)-  {-# INLINE imap #-}+mapR :: Source r1 a => (a -> p) -> RImage r1 a -> RImage r p+mapR f (RTImage arr) = RDImage (R.map f arr)+mapR f (RDImage arr) = RDImage (R.map f arr)+{-# INLINE mapR #-} -  zipWith f (SScalar px1) (SScalar px2) = SScalar (f px1 px2)-  zipWith f (SScalar px1) !img2         = I.map (f px1) img2-  zipWith f !img1         (SScalar px2) = I.map (`f` px2) img1-  zipWith f !img1         !img2         =-    SDImage (R.zipWith f (getDelayedS img1) (getDelayedS img2))-  {-# INLINE zipWith #-} -  izipWith f (SScalar px1) (SScalar px2) = SScalar (f (0, 0) px1 px2)-  izipWith f (SScalar px1) !img2         = imap (`f` px1) img2-  izipWith f !img1         (SScalar px2) = imap (\ !ix !px -> f ix px px2) img1-  izipWith f !img1         !img2         =-    SDImage (izipWithR f (getDelayedS img1) (getDelayedS img2))-  {-# INLINE izipWith #-}-  -  traverse !img getNewDims getNewPx =-    SDImage (traverseR (getDelayedS img) getNewDims getNewPx)-  {-# INLINE traverse #-}+imapR :: Source r2 b =>+         ((Int, Int) -> b -> p) -> RImage r2 b -> RImage r p+imapR f (RTImage arr) = RDImage (imapArr (f . sh2ix) arr)+imapR f (RDImage arr) = RDImage (imapArr (f . sh2ix) arr)+{-# INLINE imapR #-} -  traverse2 !img1 !img2 getNewDims getNewPx =-    SDImage (traverse2R (getDelayedS img1) (getDelayedS img2) getNewDims getNewPx)-  {-# INLINE traverse2 #-} -  transpose (SDImage arr) = SDImage (R.transpose arr)-  transpose (STImage arr) = SDImage (R.transpose arr)-  transpose !img          = img-  {-# INLINE transpose #-}+imapArr :: R.Source r2 b =>+           (DIM2 -> b -> c) -> R.Array r2 DIM2 b -> R.Array R.D DIM2 c+imapArr f !arr = R.traverse arr id (\ getPx !sh -> f sh (getPx sh))+{-# INLINE imapArr #-} -  backpermute !newDims g !img = SDImage (backpermuteR (getDelayedS img) newDims g)-  {-# INLINE backpermute #-} -  fromLists = STImage . fromListsRepa-  {-# INLINE fromLists #-}+getDelayed :: Source r e => RImage r e -> Array D DIM2 e+getDelayed (RTImage arr) = delay arr+getDelayed (RDImage arr) = arr+{-# INLINE getDelayed #-} -  fold f !px0 (SDImage arr) = R.foldAllS f px0 arr-  fold f !px0 (STImage arr) = R.foldAllS f px0 arr-  fold f !px0 (SScalar px)  = f px px0-  {-# INLINE fold #-}+zipWithR+  :: (Source r2 t, Source r1 e) =>+     (t -> e -> c) -> RImage r2 t -> RImage r1 e -> RImage r c+zipWithR f !img1 !img2 = zipWithArr f (getDelayed img1) (getDelayed img2)+{-# INLINE zipWithR #-} -  foldIx f !px0 (SDImage arr) = foldIxS f px0 arr-  foldIx f !px0 (STImage arr) = foldIxS f px0 arr-  foldIx f !px0 (SScalar px)  = f px0 (0, 0) px-  {-# INLINE foldIx #-}+zipWithArr+  :: (Source r1 a, Source r2 b)+  => (a -> b -> c) -> Array r1 DIM2 a -> Array r2 DIM2 b -> RImage r c+zipWithArr f arr1 arr2 =+  RDImage $+  case (extent arr1, extent arr2) of+    (Z :. 1 :. 1, _) -> R.map (f (unsafeIndex arr1 (Z :. 0 :. 0))) arr2+    (_, Z :. 1 :. 1) -> R.map (`f` (unsafeIndex arr2 (Z :. 0 :. 0))) arr1+    _                -> R.zipWith f arr1 arr2+{-# INLINE zipWithArr #-} -  eq (SScalar px1) (SScalar px2) = px1 == px2-  eq !img1 !img2 = R.equalsS (getDelayedS img1) (getDelayedS img2)-  {-# INLINE eq #-}+izipWithR+  :: (Source r2 a, Source r1 b) =>+     ((Int, Int) -> a -> b -> c)+     -> RImage r2 a -> RImage r1 b -> RImage r c+izipWithR f !img1 !img2 = izipWithArr f (getDelayed img1) (getDelayed img2)+{-# INLINE izipWithR #-} -  compute !img@(SScalar _) = img-  compute !img@(STImage _) = img-  compute (SDImage arr)    = STImage (R.computeS arr)-  {-# INLINE compute #-}+izipWithArr+  :: (Source r1 a, Source r2 b)+  => ((Int, Int) -> a -> b -> c)+  -> Array r1 DIM2 a+  -> Array r2 DIM2 b+  -> RImage r c+izipWithArr f arr1 arr2 =+  RDImage $+  case (extent arr1, extent arr2) of+    (Z :. 1 :. 1, _) ->+      imapArr (\ !sh -> f (sh2ix sh) (unsafeIndex arr1 (Z :. 0 :. 0))) arr2+    (_, Z :. 1 :. 1) ->+      imapArr+        (\ !sh !px1 -> f (sh2ix sh) px1 (unsafeIndex arr2 (Z :. 0 :. 0))) arr1+    (Z :. m1 :. n1, Z :. m2 :. n2) -> traverse2 arr1 arr2 getNewDims getNewPx+      where getNewDims _ _ = Z :. min m1 m2 :. min n1 n2+            {-# INLINE getNewDims #-}+            getNewPx getPx1 getPx2 !sh = f (sh2ix sh) (getPx1 sh) (getPx2 sh)+            {-# INLINE getNewPx #-}+{-# INLINE izipWithArr #-} -  (|*|) img1@(STImage arr1) img2@(STImage arr2) =-     SDImage (multR (show img1 ++ " X " ++ show img2) arr1 arr2)-  (|*|) img1@(SDImage _) !img2            = compute img1 |*| img2-  (|*|) !img1            img2@(SDImage _) = img1 |*| compute img2-  (|*|) (SScalar px1)    !img2            = STImage (scalarR px1) |*| img2-  (|*|) !img1            (SScalar px2)    = img1 |*| STImage (scalarR px2)-  {-# INLINE (|*|) #-} -  toManifest _ = error $ "RS.toManifest: Cannot convert generic Repa " ++-                         "representation to a generic Vector representation."-  {-# INLINE toManifest #-}+traverseR+  :: Source r1 c+  => RImage r1 c+  -> ((Int, Int) -> (Int, Int))+  -> (((Int, Int) -> c) -> (Int, Int) -> p)+  -> RImage r p+traverseR img getNewDims getNewPx =+  RDImage $+  R.traverse+    (getDelayed img)+    (checkDimsR "traverseR" . getNewDims . sh2ix)+    (\ getPx -> getNewPx (getPx . ix2sh) . sh2ix)+{-# INLINE traverseR #-} -  toVector _ = error $ "RS.toVector: Cannot convert generic Repa " ++-                        "representation to a generic Vector."-  {-# INLINE toVector #-}+unsafeTraverseR+  :: Source r1 c+  => RImage r1 c+  -> ((Int, Int) -> (Int, Int))+  -> (((Int, Int) -> c) -> (Int, Int) -> p)+  -> RImage r p+unsafeTraverseR img getNewDims getNewPx =+  RDImage $+  R.unsafeTraverse+    (getDelayed img)+    (checkDimsR "traverseR" . getNewDims . sh2ix)+    (\ getPx -> getNewPx (getPx . ix2sh) . sh2ix)+{-# INLINE unsafeTraverseR #-} -  fromVector _ = error $ "RS.fromVector: Cannot convert to generic Repa " ++-                        "from a generic Vector."-  {-# INLINE fromVector #-} ------------------------- Parallel Arrays ------------------------+traverse2R+  :: (Source r1 a, Source r2 b)+  => RImage r1 a+  -> RImage r2 b+  -> ((Int, Int) -> (Int, Int) -> (Int, Int))+  -> (((Int, Int) -> a) -> ((Int, Int) -> b) -> (Int, Int) -> c)+  -> RImage r c+traverse2R img1 img2 getNewDims getNewPx =+  RDImage $+  R.traverse2+    (getDelayed img1)+    (getDelayed img2)+    (\ !sh1 !sh2 -> checkDimsR "traverse2R" (getNewDims (sh2ix sh1) (sh2ix sh2)))+    (\getPx1 getPx2 -> getNewPx (getPx1 . ix2sh) (getPx2 . ix2sh) . sh2ix)+{-# INLINE traverse2R #-} +unsafeTraverse2R+  :: (Source r1 a, Source r2 b)+  => RImage r1 a+  -> RImage r2 b+  -> ((Int, Int) -> (Int, Int) -> (Int, Int))+  -> (((Int, Int) -> a) -> ((Int, Int) -> b) -> (Int, Int) -> c)+  -> RImage r c+unsafeTraverse2R img1 img2 getNewDims getNewPx =+  RDImage $+  R.unsafeTraverse2+    (getDelayed img1)+    (getDelayed img2)+    (\ !sh1 !sh2 -> checkDimsR "traverse2R" (getNewDims (sh2ix sh1) (sh2ix sh2)))+    (\getPx1 getPx2 -> getNewPx (getPx1 . ix2sh) (getPx2 . ix2sh) . sh2ix)+{-# INLINE unsafeTraverse2R #-}  -instance SuperClass (RP r) cs e => BaseArray (RP r) cs e where-  type SuperClass (RP r) cs e = (-    Typeable r, ColorSpace cs e,-    R.Target (Repr r) (Pixel cs e), R.Source (Repr r) (Pixel cs e),-    BaseArray r cs e,-    R.Elt e, R.Elt (Pixel cs e))-  -  data Image (RP r) cs e = PScalar !(Pixel cs e)-                         | PTImage !(R.Array (Repr r) R.DIM2 (Pixel cs e))-                         | PDImage !(R.Array R.D R.DIM2 (Pixel cs e))-                       -  dims (PScalar _                          ) = (1, 1)-  dims (PTImage (R.extent -> (Z :. m :. n))) = (m, n)-  dims (PDImage (R.extent -> (Z :. m :. n))) = (m, n)-  {-# INLINE dims #-}+transposeR :: Source r1 p => RImage r1 p -> RImage r p+transposeR (RDImage arr) = RDImage (R.transpose arr)+transposeR (RTImage arr) = RDImage (R.transpose arr)+{-# INLINE transposeR #-}  -instance (VG.Vector (Vector r) (Pixel cs e),-          MArray (Manifest r) cs e, BaseArray (RP r) cs e) => Array (RP r) cs e where+backpermuteR+  :: R.Source r e+  => (Int, Int) -> ((Int, Int) -> (Int, Int)) -> RImage r e -> RImage r e+backpermuteR !newDims g !img =+  RDImage $ R.backpermute+    (ix2sh (checkDims "backpermuteR" newDims))+    (ix2sh . g . sh2ix)+    (getDelayed img)+{-# INLINE backpermuteR #-} -  type Manifest (RP r) = Manifest r -  type Vector (RP r) = Vector r -  makeImage !(checkDims "RP.makeImage" -> (m, n)) f =-    PDImage $ R.fromFunction (Z :. m :. n) (f . sh2ix)-  {-# INLINE makeImage #-}-  -  makeImageWindowed !(checkDims "RP.makeImage" -> (m, n)) !window getWindowPx getBorderPx  =-    PDImage $ R.delay $ makeWindowed (Z :. m :. n) window-    (R.fromFunction (Z :. m :. n) (getWindowPx . sh2ix))-     (R.fromFunction (Z :. m :. n) (getBorderPx . sh2ix))-    -  scalar = PScalar-  {-# INLINE scalar #-} -  index00 (PScalar px)  = px-  index00 (PTImage arr) = R.index arr (Z :. 0 :. 0)-  index00 (PDImage arr) = R.index arr (Z :. 0 :. 0)-  {-# INLINE index00 #-}+fromListsR :: Target r p => [[p]] -> RImage r p+fromListsR ls =+  if all (== n) (P.map length ls)+    then RTImage $ R.fromList (Z :. m :. n) . concat $ ls+    else error "fromListsRepa: Inner lists do not all have an equal length."+  where+    !(m, n) = checkDims "fromListsRepa" (length ls, maybe 0 length $ listToMaybe ls)+{-# INLINE fromListsR #-} -  map f (PScalar px)  = PScalar (f px)-  map f (PTImage arr) = PDImage (R.map f arr)-  map f (PDImage arr) = PDImage (R.map f arr)-  {-# INLINE map #-} -  imap f (PScalar px)  = PScalar (f (0, 0) px)-  imap f (PTImage arr) = PDImage (imapR f arr)-  imap f (PDImage arr) = PDImage (imapR f arr)-  {-# INLINE imap #-} -  zipWith f (PScalar px1) (PScalar px2) = PScalar (f px1 px2)-  zipWith f (PScalar px1) !img2         = I.map (f px1) img2-  zipWith f !img1         (PScalar px2) = I.map (`f` px2) img1-  zipWith f !img1         !img2         =-    PDImage (R.zipWith f (getDelayedP img1) (getDelayedP img2))-  {-# INLINE zipWith #-}+multR :: (Num p, Elt p, Unbox p, Source r2 p, Source r1 p, Source r p, Target r p,+           Target r2 p, Target r1 p) =>+         Strategy -> RImage r2 p -> RImage r1 p -> RImage r p+multR strategy (RTImage arr1) (RTImage arr2) =+  if n1 /= m2+    then errorR "multR" $+         "Inner dimensions of multiplied images must be the same, but received: " P.+++         show (m1, n1) P.+++         " X " P.+++         show (m2, n2)+    else computeR strategy $ RDImage $ fromFunction (Z :. m1 :. n2) getPx+  where+    (Z :. m1 :. n1) = R.extent arr1+    (Z :. m2 :. n2) = R.extent arr2+    getPx (Z :. i :. j) =+      R.sumAllS+        (R.slice arr1 (R.Any :. (i :: Int) :. R.All) R.*^+         R.slice arr2 (R.Any :. (j :: Int)))+    {-# INLINE getPx #-}+multR strategy img1 img2 =+  multR strategy (computeR strategy img1) (computeR strategy img2)+{-# INLINE multR #-} -  izipWith f (PScalar px1) (PScalar px2) = PScalar (f (0, 0) px1 px2)-  izipWith f (PScalar px1) !img2         = imap (`f` px1) img2-  izipWith f !img1         (PScalar px2) = imap (\ !ix !px -> f ix px px2) img1-  izipWith f !img1         !img2         =-    PDImage (izipWithR f (getDelayedP img1) (getDelayedP img2))-  {-# INLINE izipWith #-}-  -  traverse !img getNewDims getNewPx =-    PDImage (traverseR (getDelayedP img) getNewDims getNewPx)-  {-# INLINE traverse #-} -  traverse2 !img1 !img2 getNewDims getNewPx =-    PDImage (traverse2R (getDelayedP img1) (getDelayedP img2) getNewDims getNewPx)-  {-# INLINE traverse2 #-}+computeR :: (Target r p, Source r p) => Strategy -> RImage r p -> RImage r p+computeR Parallel (RDImage arr) = arrManifest `deepSeqArray` RTImage arrManifest+  where arrManifest = suspendedComputeP arr+computeR Sequential (RDImage arr) = RTImage $ computeS arr+computeR _ img = img+{-# INLINE computeR #-} -  transpose (PDImage arr) = PDImage (R.transpose arr)-  transpose (PTImage arr) = PDImage (R.transpose arr)-  transpose !img          = img-  {-# INLINE transpose #-} -  backpermute !newDims g !img = PDImage (backpermuteR (getDelayedP img) newDims g)-  {-# INLINE backpermute #-}+foldR :: (Source r p, Target r p, Elt p, Unbox p)+       => Strategy -> (p -> p -> p) -> p -> RImage r p -> p+foldR Parallel f !px0 !img =+  let RTImage arr = computeR Parallel img+  in case foldAllP f px0 arr of+       Just e  -> e+       Nothing -> errorR "foldPR" "impossible happened."+foldR Sequential f !px0 img =+  let RTImage arr = computeR Sequential img+  in foldAllS f px0 arr+{-# INLINE foldR #-} -  fromLists = PTImage . fromListsRepa-  {-# INLINE fromLists #-} -  fold f !px0 (PScalar px) = f px0 px-  fold f !px0 img =-    case R.foldAllP f px0 (getDelayedP img) of-      Just e  -> e-      Nothing -> error $ "RP.fold: impossible happened."-  {-# INLINE fold #-}+addIxArr+  :: Source r2 b =>+     Array r2 DIM2 b -> Array R.D DIM2 (Int, b)+addIxArr !arr = R.zipWith (,) arrIx arr+  where+    !sh = extent arr+    !arrIx = R.fromFunction (R.extent arr) (toIndex sh)+{-# INLINE addIxArr #-} -  foldIx f !px0 (PScalar px) = f px0 (0, 0) px-  foldIx f !px0 img =-    case foldIxPUnboxed f px0 (getDelayedP img) of-      Just e  -> e-      Nothing -> error $ "RP.foldIx: impossible happened."-  {-# INLINE foldIx #-} +foldIxR :: (Source r b, Elt b, Unbox b) =>+           Strategy -> (b -> (Int, Int) -> b -> b) -> b -> RImage r b -> b+foldIxR strategy f !acc' !img =+  case strategy of+    Parallel ->+      case foldAllP accumWithIx (-1, acc') arr of+        Just (_, acc) -> acc+        Nothing       -> error $ "foldIxPR: impossible happened."+    Sequential -> snd $ R.foldAllS accumWithIx (-1, acc') arr+  where+    (Z :. _ :. n) = extent arr+    !arr = addIxArr (getDelayed img)+    accumWithIx !(-1, acc) !(k, px) = (-1, f acc (toIx n k) px)+    accumWithIx !(k, px) (-1, acc) = (-1, f acc (toIx n k) px)+    accumWithIx (acc1Ix, _) (acc2Ix, _) =+      errorR "accumWithx" $+      "Impossible happened. Received: " P.++ show acc1Ix P.++ " " P.+++      show acc2Ix+    {-# INLINE accumWithIx #-}+{-# INLINE foldIxR #-} -  eq (PScalar px1) (PScalar px2) = px1 == px2-  eq !img1 !img2 =-    case R.equalsP (getDelayedP img1) (getDelayedP img2) of-      Just e  -> e-      Nothing -> error $ "RP.eq: impossible happened."-  {-# INLINE eq #-} -  compute !img@(PScalar _) = img-  compute !img@(PTImage _) = img-  compute (PDImage arr)    = arrManifest `R.deepSeqArray` PTImage arrManifest-     where arrManifest = R.suspendedComputeP arr-  {-# INLINE compute #-}+eqR :: (Eq a, Source r1 a, Source r a) =>+        Strategy -> RImage r1 a -> RImage r a -> Bool+eqR strategy !img1 !img2 =+  case strategy of+    Parallel ->+      let eqArr = R.zipWith (==) (getDelayed img1) (getDelayed img2)+      in dimsR img1 == dimsR img2 && mCompute "eqR" (foldAllP (&&) True eqArr)+    Sequential -> R.equalsS (getDelayed img1) (getDelayed img2)+{-# INLINE eqR #-} -  (|*|) img1@(PTImage arr1) img2@(PTImage arr2) =-     PDImage (multR (show img1 ++ " X " ++ show img2) arr1 arr2)-  (|*|) img1@(PDImage _) !img2            = compute img1 |*| img2-  (|*|) !img1            img2@(PDImage _) = img1 |*| compute img2-  (|*|) (PScalar px1)    !img2            = PTImage (scalarR px1) |*| img2-  (|*|) !img1            (PScalar px2)    = img1 |*| PTImage (scalarR px2)-  {-# INLINE (|*|) #-}+mCompute :: String -> Maybe t -> t+mCompute _ (Just res)  = res+mCompute fName Nothing = errorR fName "impossible happened"+{-# INLINE mCompute #-} -  toManifest _ = error $ "RP.toManifest: Cannot convert generic Repa " ++-                         "representation to a generic Vector."-  {-# INLINE toManifest #-} -  toVector _ = error $ "RP.toVector: Cannot convert generic Repa " ++-                        "representation to a generic Vector."-  {-# INLINE toVector #-} -  fromVector _ = error $ "RP.fromVector: Cannot convert to generic Repa " ++-                        "from a generic Vector."-  {-# INLINE fromVector #-}+fromVectorUnboxedR :: Unbox e => (Int, Int) -> VU.Vector e -> RImage U e+fromVectorUnboxedR !sz = RTImage . fromUnboxed (ix2sh sz)+{-# INLINE fromVectorUnboxedR #-} -  -------------------------- Helper functions ------------------------- -sh2ix :: DIM2 -> (Int, Int)-sh2ix (Z :. i :. j) = (i, j)-{-# INLINE sh2ix #-}+toVectorR :: (Target r2 e, Source r2 e) =>+             (R.Array r2 DIM2 e -> t) -> Strategy -> RImage r2 e -> t+toVectorR toVector Parallel (RDImage arr) =+ toVector $ mCompute "toVectorR" (computeP arr)+toVectorR toVector Sequential (RDImage arr) = toVector $ computeS arr+toVectorR toVector _ (RTImage arr) = toVector arr+{-# INLINE toVectorR #-} -ix2sh :: (Int, Int) -> DIM2-ix2sh !(i, j) = Z :. i :. j -{-# INLINE ix2sh #-} +toVectorUnboxedR :: Unbox e => Strategy -> RImage U e -> VU.Vector e+toVectorUnboxedR = toVectorR toUnboxed+{-# INLINE toVectorUnboxedR #-} -toRS :: Image (RP r) cs e -> Image (RS r) cs e-toRS (PScalar px)  = SScalar px-toRS (PDImage img) = SDImage img-toRS (PTImage img) = STImage img+toVectorStorableR :: VS.Storable e => Strategy -> RImage F e -> VS.Vector e+toVectorStorableR = toVectorR toStorableR+{-# INLINE toVectorStorableR #-} -toRP :: Image (RS r) cs e -> Image (RP r) cs e-toRP (SScalar px)  = PScalar px-toRP (SDImage img) = PDImage img-toRP (STImage img) = PTImage img  -imapR-  :: R.Source r2 b =>-     ((Int, Int) -> b -> c) -> R.Array r2 DIM2 b -> R.Array R.D DIM2 c-imapR f !arr = R.zipWith f (R.fromFunction (R.extent arr) sh2ix) arr----- | Combine two arrays, element-wise, with index aware operator. If the extent of--- the two array arguments differ, then the resulting array's extent is their--- intersection.-izipWithR-  :: (R.Source r2 t1, R.Source r1 t)-  => ((Int, Int) -> t -> t1 -> c)-  -> R.Array r1 DIM2 t-  -> R.Array r2 DIM2 t1-  -> R.Array R.D DIM2 c-izipWithR f !arr1 !arr2 =-  (R.traverse2 arr1 arr2 getNewDims getNewPx) where-    getNewPx !getPx1 !getPx2 !sh = f (sh2ix sh) (getPx1 sh) (getPx2 sh)-    getNewDims (Z :. m1 :. n1) (Z :. m2 :. n2) = Z :. min m1 m2 :. min n1 n2-    {-# INLINE getNewPx #-}-{-# INLINE izipWithR #-}---traverseR-  :: R.Source r c-  => R.Array r DIM2 c-  -> ((Int, Int) -> (Int, Int))-  -> (((Int, Int) -> c) -> (Int, Int) -> b)-  -> R.Array R.D DIM2 b-traverseR !arr getNewDims getNewPx =-  R.traverse arr (ix2sh . checkDims "traverseR" . getNewDims . sh2ix) getNewE+toStorableR :: VS.Storable a => Array F DIM2 a -> VS.Vector a+toStorableR arr = VS.unsafeFromForeignPtr0 (toForeignPtr arr) (m * n)   where-    getNewE getPx = getNewPx (getPx . ix2sh) . sh2ix-    {-# INLINE getNewE #-}-{-# INLINE traverseR #-}----traverse2R-  :: (R.Source r2 c1, R.Source r1 c)-  => R.Array r1 DIM2 c-  -> R.Array r2 DIM2 c1-  -> ((Int, Int) -> (Int, Int) -> (Int, Int))-  -> (((Int, Int) -> c) -> ((Int, Int) -> c1) -> (Int, Int) -> c2)-  -> R.Array R.D DIM2 c2-traverse2R !arr1 !arr2 getNewDims getNewPx =-  R.traverse2 arr1 arr2 getNewSh getNewE-  where getNewE getPx1 getPx2 = getNewPx (getPx1 . ix2sh) (getPx2 . ix2sh) . sh2ix-        {-# INLINE getNewE #-}-        getNewSh !sh1 !sh2 =-          ix2sh . checkDims "traverse2R" $ getNewDims (sh2ix sh1) (sh2ix sh2)-        {-# INLINE getNewSh #-}-{-# INLINE traverse2R #-}--backpermuteR-  :: R.Source r e-  => R.Array r DIM2 e-  -> (Int, Int)-  -> ((Int, Int) -> (Int, Int))-  -> R.Array R.D DIM2 e-backpermuteR !arr newDims g =-  R.backpermute-    (ix2sh (checkDims "backpermuteR" newDims))-    (ix2sh . g . sh2ix)-    arr-{-# INLINE backpermuteR #-}+    (Z :. m :. n) = R.extent arr+{-# INLINE toStorableR #-}  -fromListsRepa :: (R.Target r e) => [[e]] -> R.Array r DIM2 e-fromListsRepa ls =-  if all (== n) (P.map length ls)-    then R.fromList (Z :. m :. n) . concat $ ls-    else error "fromListsRepa: Inner lists do not all have an equal length."+fromVectorStorableR+  :: VS.Storable px+  => (Int, Int) -> VS.Vector px -> RImage F px+fromVectorStorableR !(m, n) !v+  | sz == sz' = RTImage $ fromForeignPtr (ix2sh (m, n)) fp+  | otherwise =+    errorR "fromVectorStorableR" $+    "(impossible) Vector size mismatch: " P.++ show sz P.++ " vs " P.++ show sz'   where-    !(m, n) = checkDims "fromListsRepa" (length ls, length $ head ls)-{-# INLINE fromListsRepa #-}+    !(fp, sz) = VS.unsafeToForeignPtr0 v+    !sz' = m * n+{-# INLINE fromVectorStorableR #-}   -multR-  :: (ColorSpace cs e, Num (Pixel cs e), R.Elt (Pixel cs e),-      R.Target r (Pixel cs e), R.Source r (Pixel cs e))-  => String -> R.Array r DIM2 (Pixel cs e) -> R.Array r DIM2 (Pixel cs e) -> R.Array R.D DIM2 (Pixel cs e)-multR errMsg !arr1 !arr2 =-  if n1 /= m2-    then error $-         "Inner dimensions of multiplied images must be the same, but received: " ++ errMsg-    else R.fromFunction (Z :. m1 :. n2) $ getPx-  where-    (Z :. m1 :. n1) = R.extent arr1-    (Z :. m2 :. n2) = R.extent arr2-    getPx (Z :. i :. j) =-      R.sumAllS-        (R.slice arr1 (R.Any :. (i :: Int) :. R.All) R.*^-         R.slice arr2 (R.Any :. (j :: Int)))-    {-# INLINE getPx #-}-{-# INLINE multR #-} +instance (Num e, R.Elt e) => Elt (C.Complex e) where+  touch (r :+ i) = R.touch r >> R.touch i+  {-# INLINE touch #-} -scalarR :: (IVU.Unbox a, R.Target r a) => a -> R.Array r DIM2 a-scalarR !px = R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px+  zero     = 0 :+ 0+  {-# INLINE zero #-} +  one      = 1 :+ 0+  {-# INLINE one #-} -getDelayedS :: Array (RS r) cs e => Image (RS r) cs e -> R.Array R.D DIM2 (Pixel cs e)-getDelayedS (STImage arr) = R.delay arr-getDelayedS (SDImage arr) = arr-getDelayedS (SScalar px)  = R.fromFunction (Z :. 1 :. 1) (const px)-{-# INLINE getDelayedS #-} -getDelayedP :: Array (RP r) cs e => Image (RP r) cs e -> R.Array R.D DIM2 (Pixel cs e)-getDelayedP (PTImage arr) = R.delay arr-getDelayedP (PDImage arr) = arr-getDelayedP (PScalar px)  = R.fromFunction (Z :. 1 :. 1) (const px)-{-# INLINE getDelayedP #-} --instance R.Elt Bit where+instance Elt Bit where   touch (Bit w) = R.touch w   {-# INLINE touch #-}-  +   zero     = 0   {-# INLINE zero #-}-  +   one      = 1   {-# INLINE one #-}  -instance (ColorSpace cs e, R.Elt e, Num (Pixel cs e)) => R.Elt (Pixel cs e) where-  touch !px = P.mapM_ (R.touch . getPxC px) (enumFrom (toEnum 0)) +instance (ColorSpace cs e, Elt e, Num (Pixel cs e)) => Elt (Pixel cs e) where+  touch = foldlPx (\ a !e -> a >> touch e) (return ())   {-# INLINE touch #-}-  +   zero     = 0   {-# INLINE zero #-}-  +   one      = 1   {-# INLINE one #-}---addIxArr-  :: R.Source r2 b =>-     R.Array r2 DIM2 b -> R.Array R.D DIM2 ((Int, Int), b)-addIxArr !arr = R.zipWith (,) arrIx arr-  where-    !arrIx = R.fromFunction (R.extent arr) sh2ix-{-# INLINE addIxArr #-}---foldIxS-  :: (R.Elt b, IVU.Unbox b, R.Source r2 b) =>-     (b -> (Int, Int) -> b -> b) -> b -> R.Array r2 DIM2 b -> b-foldIxS f !acc !arr = snd $ R.foldAllS g ((-1, 0), acc) arr'-  where-    !arr' = addIxArr arr-    g (accIx@(-1, _), acc') !(ix, px) = (accIx, f acc' ix px)-    g !(ix, px) (accIx@(-1, _), acc') = (accIx, f acc' ix px)-    g (acc1Ix, _) (acc2Ix, _) =-      error $ "foldIxS: Impossible happened. Received: " ++ show acc1Ix ++ " " ++ show acc2Ix-    {-# INLINE g #-}-{-# INLINE foldIxS #-}---foldIxPUnboxed-  :: (R.Source r2 b, IVU.Unbox b, R.Elt b, Functor m, Monad m)-  => (b -> (Int, Int) -> b -> b) -> b -> R.Array r2 DIM2 b -> m b-foldIxPUnboxed f !acc !arr = snd <$> R.foldAllP g ((-1, 0), acc) arr'-  where-    !arr' = addIxArr arr-    g (accIx@(-1, _), acc') !(ix, px) = (accIx, f acc' ix px)-    g !(ix, px) (accIx@(-1, _), acc') = (accIx, f acc' ix px)-    g (acc1Ix, _) (acc2Ix, _) =-      error $ "foldIxPUnboxed: Impossible happened. Received: " ++ show acc1Ix ++ " " ++ show acc2Ix-    {-# INLINE g #-}-{-# INLINE foldIxPUnboxed #-}-

@@ -1,39 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-module Graphics.Image.Interface.Repa.Helpers where--import Data.Array.Repa-import Data.Array.Repa.Repr.Partitioned-import Data.Array.Repa.Repr.Undefined---- | Make a 2D windowed array from two others, one to produce the elements in---   the internal region, and one to produce elements in the border region. The---   two arrays must have the same extent.----makeWindowed-        :: (Source r1 a, Source r2 a)-        => DIM2                 -- ^ Extent of array.-        -> ((Int, Int), (Int, Int))  -- ^ Window points.-        -> Array r1 DIM2 a      -- ^ Array for internal elements.-        -> Array r2 DIM2 a      -- ^ Array for border elements.-        -> Array (P r1 (P r2 (P r2 (P r2 (P r2 X))))) DIM2 a-makeWindowed sh@(_ :. m :. n) !((it, jt), (ib, jb)) arrWindow arrBorder =-  checkDims `seq`-  let inInternal (Z :. i :. j) = i >= it && i < ib && j >= jt && j < jb-      {-# INLINE inInternal #-}-      inBorder = not . inInternal-      {-# INLINE inBorder #-}-  in APart sh (Range (Z :. it :. jt) (Z :. (ib - it) :. (jb - jt)) inInternal) arrWindow $-     APart sh (Range (Z :. 0 :.  0 ) (Z :. it        :. n        ) inBorder  ) arrBorder $-     APart sh (Range (Z :. it :. 0 ) (Z :. (ib - it) :. jt       ) inBorder  ) arrBorder $-     APart sh (Range (Z :. it :. jb) (Z :. (ib - it) :. (n - jb) ) inBorder  ) arrBorder $-     APart sh (Range (Z :. ib :. 0 ) (Z :. (m - ib)  :. n        ) inBorder  ) arrBorder $-     AUndefined sh-  where-    checkDims =-      if extent arrWindow == extent arrBorder-        then ()-        else error-               "makeWindowed: internal and border arrays have different extents"-    {-# NOINLINE checkDims #-}-{-# INLINE makeWindowed #-}

@@ -1,13 +1,12 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-} -- | -- Module      : Graphics.Image.Interface.Repa.Storable -- Copyright   : (c) Alexey Kuleshevich 2017@@ -20,23 +19,20 @@   RSS(..), RPS(..), Image(..)   ) where -import Prelude as P-import Data.Array.Repa.Index-import qualified Data.Array.Repa as R -import qualified Data.Array.Repa.Eval as R-import qualified Data.Array.Repa.Repr.ForeignPtr as R-import qualified Data.Vector.Storable as VS-import Foreign.Storable-import Data.Typeable (Typeable)--import Graphics.Image.Interface as I-import Graphics.Image.Interface.Repa.Generic+import qualified Data.Array.Repa.Eval                     as R+import qualified Data.Array.Repa.Repr.ForeignPtr          as R+import           Data.Typeable                            (Typeable)+import           Data.Vector.Unboxed                      (Unbox)+import           Foreign.Storable+import           Graphics.Image.Interface                 as I+import           Graphics.Image.Interface.Repa.Generic import qualified Graphics.Image.Interface.Vector.Storable as IVS+import           Prelude                                  as P    --- | Repa Array representation backed by Storable Vector, which is computed sequentially. +-- | Repa Array representation backed by Storable Vector, which is computed sequentially. data RSS = RSS deriving Typeable  -- | Repa Array representation backed by Storable Vector, which is computed in parallel.@@ -47,20 +43,17 @@  instance Show RPS where   show _ = "RepaParallelStorable"-   -type instance Repr IVS.VS = R.F - instance SuperClass RSS cs e => BaseArray RSS cs e where   type SuperClass RSS cs e =-    (ColorSpace cs e,+    (ColorSpace cs e, Unbox (Pixel cs e),      Storable e, Storable (Pixel cs e),      R.Elt e, R.Elt (Pixel cs e))-  -  newtype Image RSS cs e = SSImage (Image (RS IVS.VS) cs e)-                       -  dims (SSImage img) = dims img++  newtype Image RSS cs e = SSImage (RImage R.F (Pixel cs e))++  dims (SSImage img) = dimsR img   {-# INLINE dims #-}  @@ -69,82 +62,80 @@   type Manifest RSS = IVS.VS    type Vector RSS = Vector IVS.VS-  -  makeImage !sz f = SSImage (makeImage sz f)++  makeImage !sz f = SSImage (makeImageR sz f)   {-# INLINE makeImage #-}- -  makeImageWindowed !sz !w f = SSImage . makeImageWindowed sz w f++  makeImageWindowed !sz !wIx !wSz f = SSImage . makeImageWindowedR sz wIx wSz f   {-# INLINE makeImageWindowed #-}- -  scalar = SSImage . I.scalar++  scalar = SSImage . scalarR   {-# INLINE scalar #-} -  index00 (SSImage img) = index00 img+  index00 (SSImage img) = index00R img   {-# INLINE index00 #-} -  map f (SSImage img) = SSImage (I.map f img)+  map f (SSImage img) = SSImage (mapR f img)   {-# INLINE map #-} -  imap f (SSImage img) = SSImage (I.imap f img)+  imap f (SSImage img) = SSImage (imapR f img)   {-# INLINE imap #-} -  zipWith f (SSImage img1) (SSImage img2) = SSImage (I.zipWith f img1 img2)+  zipWith f (SSImage img1) (SSImage img2) = SSImage (zipWithR f img1 img2)   {-# INLINE zipWith #-} -  izipWith f (SSImage img1) (SSImage img2) = SSImage (I.izipWith f img1 img2)+  izipWith f (SSImage img1) (SSImage img2) = SSImage (izipWithR f img1 img2)   {-# INLINE izipWith #-} -  traverse (SSImage img) f g = SSImage (I.traverse img f g)+  traverse (SSImage img) f g = SSImage (traverseR img f g)   {-# INLINE traverse #-} -  traverse2 (SSImage img1) (SSImage img2) f g = SSImage (I.traverse2 img1 img2 f g)+  traverse2 (SSImage img1) (SSImage img2) f g = SSImage (traverse2R img1 img2 f g)   {-# INLINE traverse2 #-} -  transpose (SSImage img) = SSImage (I.transpose img)+  transpose (SSImage img) = SSImage (transposeR img)   {-# INLINE transpose #-} -  backpermute !sz g (SSImage img) = SSImage (I.backpermute sz g img)+  backpermute !sz g (SSImage img) = SSImage (backpermuteR sz g img)   {-# INLINE backpermute #-} -  fromLists = SSImage . fromLists+  fromLists = SSImage . fromListsR   {-# INLINE fromLists #-} -  fold f !px0 (SSImage img) = fold f px0 img+  fold f !px0 (SSImage img) = foldR Sequential f px0 img   {-# INLINE fold #-} -  foldIx f !px0 (SSImage img) = foldIx f px0 img+  foldIx f !px0 (SSImage img) = foldIxR Sequential f px0 img   {-# INLINE foldIx #-} -  eq (SSImage img1) (SSImage img2) = img1 == img2+  eq (SSImage img1) (SSImage img2) = eqR Sequential img1 img2   {-# INLINE eq #-} -  compute (SSImage img) = SSImage (compute img)+  compute (SSImage img) = SSImage (computeR Sequential img)   {-# INLINE compute #-} -  (|*|) (SSImage img1) (SSImage img2) = SSImage (img1 |*| img2)+  (|*|) (SSImage img1) (SSImage img2) = SSImage (multR Sequential img1 img2)   {-# INLINE (|*|) #-} -  toManifest (SSImage (SScalar px)) = I.scalar px-  toManifest (SSImage (STImage arr)) = fromRepaArrayStorable arr-  toManifest !img = toManifest (compute img)+  toManifest (SSImage img) = fromVector (dimsR img) $ toVectorStorableR Sequential img   {-# INLINE toManifest #-} -  toVector = I.toVector . toManifest+  toVector (SSImage img) = toVectorStorableR Sequential img   {-# INLINE toVector #-} -  fromVector !sz = SSImage . STImage . fromVectorStorable sz+  fromVector !sz = SSImage . fromVectorStorableR sz   {-# INLINE fromVector #-}   instance SuperClass RPS cs e => BaseArray RPS cs e where   type SuperClass RPS cs e =     (ColorSpace cs e,-     Storable e, Storable (Pixel cs e),+     Storable e, Storable (Pixel cs e), Unbox (Pixel cs e),      R.Elt e, R.Elt (Pixel cs e))-  -  newtype Image RPS cs e = PSImage (Image (RP IVS.VS) cs e)-                       -  dims (PSImage img) = dims img++  newtype Image RPS cs e = PSImage (RImage R.F (Pixel cs e))++  dims (PSImage img) = dimsR img   {-# INLINE dims #-}  @@ -153,92 +144,66 @@   type Manifest RPS = IVS.VS    type Vector RPS = Vector IVS.VS-  -  makeImage !sz f = PSImage (makeImage sz f)++  makeImage !sz f = PSImage (makeImageR sz f)   {-# INLINE makeImage #-}- -  makeImageWindowed !sz !w f = PSImage . makeImageWindowed sz w f++  makeImageWindowed !sz !wIx !wSz f = PSImage . makeImageWindowedR sz wIx wSz f   {-# INLINE makeImageWindowed #-}- -  scalar = PSImage . scalar++  scalar = PSImage . scalarR   {-# INLINE scalar #-} -  index00 (PSImage img) = index00 img+  index00 (PSImage img) = index00R img   {-# INLINE index00 #-} -  map f (PSImage img) = PSImage (I.map f img)+  map f (PSImage img) = PSImage (mapR f img)   {-# INLINE map #-} -  imap f (PSImage img) = PSImage (I.imap f img)+  imap f (PSImage img) = PSImage (imapR f img)   {-# INLINE imap #-} -  zipWith f (PSImage img1) (PSImage img2) = PSImage (I.zipWith f img1 img2)+  zipWith f (PSImage img1) (PSImage img2) = PSImage (zipWithR f img1 img2)   {-# INLINE zipWith #-} -  izipWith f (PSImage img1) (PSImage img2) = PSImage (I.izipWith f img1 img2)+  izipWith f (PSImage img1) (PSImage img2) = PSImage (izipWithR f img1 img2)   {-# INLINE izipWith #-} -  traverse (PSImage img) f g = PSImage (I.traverse img f g)+  traverse (PSImage img) f g = PSImage (traverseR img f g)   {-# INLINE traverse #-} -  traverse2 (PSImage img1) (PSImage img2) f g = PSImage (I.traverse2 img1 img2 f g)+  traverse2 (PSImage img1) (PSImage img2) f g = PSImage (traverse2R img1 img2 f g)   {-# INLINE traverse2 #-} -  transpose (PSImage img) = PSImage (I.transpose img)+  transpose (PSImage img) = PSImage (transposeR img)   {-# INLINE transpose #-} -  backpermute !sz g (PSImage img) = PSImage (backpermute sz g img)+  backpermute !sz g (PSImage img) = PSImage (backpermuteR sz g img)   {-# INLINE backpermute #-} -  fromLists = PSImage . fromLists+  fromLists = PSImage . fromListsR   {-# INLINE fromLists #-} -  fold f !px0 (PSImage img) = I.fold f px0 img+  fold f !px0 (PSImage img) = foldR Parallel f px0 img   {-# INLINE fold #-} -  foldIx f !px0 (PSImage img) = I.foldIx f px0 img+  foldIx f !px0 (PSImage img) = foldIxR Parallel f px0 img   {-# INLINE foldIx #-} -  eq (PSImage img1) (PSImage img2) = img1 == img2+  eq (PSImage img1) (PSImage img2) = eqR Parallel img1 img2   {-# INLINE eq #-} -  compute (PSImage img) = PSImage (compute img)+  compute (PSImage img) = PSImage (computeR Parallel img)   {-# INLINE compute #-} -  (|*|) (PSImage img1) (PSImage img2) = PSImage (img1 |*| img2)+  (|*|) (PSImage img1) (PSImage img2) = PSImage (multR Parallel img1 img2)   {-# INLINE (|*|) #-} -  toManifest (PSImage (PScalar px))  = scalar px-  toManifest (PSImage (PTImage arr)) = fromRepaArrayStorable arr-  toManifest !img = toManifest (compute img)+  toManifest (PSImage img) = fromVector (dimsR img) $ toVectorStorableR Parallel img   {-# INLINE toManifest #-} -  toVector = I.toVector . toManifest+  toVector (PSImage img) = toVectorStorableR Parallel img   {-# INLINE toVector #-} -  fromVector !sz = PSImage . PTImage . fromVectorStorable sz+  fromVector !sz = PSImage . fromVectorStorableR sz   {-# INLINE fromVector #-}---fromRepaArrayStorable-  :: forall cs e.-     Array IVS.VS cs e-  => R.Array R.F DIM2 (Pixel cs e) -> Image IVS.VS cs e-fromRepaArrayStorable !arr =-  fromVector (sh2ix (R.extent arr)) $-  VS.unsafeFromForeignPtr0 (R.toForeignPtr arr) (m * n)-  where-    (Z :. m :. n) = R.extent arr---fromVectorStorable-  :: forall cs e.-     Storable (Pixel cs e)-  => (Int, Int) -> VS.Vector (Pixel cs e) -> R.Array R.F DIM2 (Pixel cs e)-fromVectorStorable !(m, n) !v-  | sz == sz' = R.fromForeignPtr (ix2sh (m, n)) fp-  | otherwise = error $ "fromVectorStorable: (impossible) Vector size mismatch: " ++-                show sz ++ " vs " ++ show sz'-  where-    !(fp, sz) = VS.unsafeToForeignPtr0 v-    !sz' = m * n

@@ -1,13 +1,12 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-} -- | -- Module      : Graphics.Image.Interface.Repa.Unboxed -- Copyright   : (c) Alexey Kuleshevich 2017@@ -20,17 +19,17 @@   RSU(..), RPU(..), Image(..)   ) where -import Prelude as P-import qualified Data.Array.Repa as R -import qualified Data.Array.Repa.Eval as R-import Data.Typeable (Typeable)+import qualified Data.Array.Repa                         as R+import qualified Data.Array.Repa.Eval                    as R+import           Data.Typeable                           (Typeable)+import           Prelude                                 as P -import Graphics.Image.Interface as I-import Graphics.Image.Interface.Repa.Generic+import           Graphics.Image.Interface                as I+import           Graphics.Image.Interface.Repa.Generic import qualified Graphics.Image.Interface.Vector.Unboxed as IVU  --- | Repa Array representation backed by Unboxed Vector, which is computed sequentially. +-- | Repa Array representation backed by Unboxed Vector, which is computed sequentially. data RSU = RSU deriving Typeable  -- | Repa Array representation backed by Unboxed Vector, which is computed in parallel.@@ -41,19 +40,16 @@  instance Show RPU where   show _ = "RepaParallelUnboxed"-   -type instance Repr IVU.VU = R.U - instance SuperClass RSU cs e => BaseArray RSU cs e where   type SuperClass RSU cs e =     (ColorSpace cs e,      R.Elt e, R.Elt (Pixel cs e))-  -  newtype Image RSU cs e = SUImage (Image (RS IVU.VU) cs e)-                       -  dims (SUImage img) = dims img++  newtype Image RSU cs e = SUImage (RImage R.U (Pixel cs e))++  dims (SUImage img) = dimsR img   {-# INLINE dims #-}  @@ -62,152 +58,148 @@   type Manifest RSU = IVU.VU    type Vector RSU = Vector IVU.VU-  -  makeImage !sz f = SUImage (makeImage sz f)++  makeImage !sz f = SUImage (makeImageR sz f)   {-# INLINE makeImage #-}- -  makeImageWindowed !sz !w f = SUImage . makeImageWindowed sz w f++  makeImageWindowed !sz !wIx !wSz f = SUImage . makeImageWindowedR sz wIx wSz f   {-# INLINE makeImageWindowed #-}- -  scalar = SUImage . scalar++  scalar = SUImage . scalarR   {-# INLINE scalar #-} -  index00 (SUImage img) = index00 img+  index00 (SUImage img) = index00R img   {-# INLINE index00 #-} -  map f (SUImage img) = SUImage (I.map f img)+  map f (SUImage img) = SUImage (mapR f img)   {-# INLINE map #-} -  imap f (SUImage img) = SUImage (I.imap f img)+  imap f (SUImage img) = SUImage (imapR f img)   {-# INLINE imap #-} -  zipWith f (SUImage img1) (SUImage img2) = SUImage (I.zipWith f img1 img2)+  zipWith f (SUImage img1) (SUImage img2) = SUImage (zipWithR f img1 img2)   {-# INLINE zipWith #-} -  izipWith f (SUImage img1) (SUImage img2) = SUImage (I.izipWith f img1 img2)+  izipWith f (SUImage img1) (SUImage img2) = SUImage (izipWithR f img1 img2)   {-# INLINE izipWith #-} -  traverse (SUImage img) f g = SUImage (I.traverse img f g)+  traverse (SUImage img) f g = SUImage (traverseR img f g)   {-# INLINE traverse #-} -  traverse2 (SUImage img1) (SUImage img2) f g = SUImage (I.traverse2 img1 img2 f g)+  traverse2 (SUImage img1) (SUImage img2) f g = SUImage (traverse2R img1 img2 f g)   {-# INLINE traverse2 #-} -  transpose (SUImage img) = SUImage (I.transpose img)+  transpose (SUImage img) = SUImage (transposeR img)   {-# INLINE transpose #-} -  backpermute !sz g (SUImage img) = SUImage (backpermute sz g img)+  backpermute !sz g (SUImage img) = SUImage (backpermuteR sz g img)   {-# INLINE backpermute #-} -  fromLists = SUImage . fromLists+  fromLists = SUImage . fromListsR   {-# INLINE fromLists #-} -  fold f !px0 (SUImage img) = fold f px0 img+  fold f !px0 (SUImage img) = foldR Sequential f px0 img   {-# INLINE fold #-} -  foldIx f !px0 (SUImage img) = foldIx f px0 img+  foldIx f !px0 (SUImage img) = foldIxR Sequential f px0 img   {-# INLINE foldIx #-} -  eq (SUImage img1) (SUImage img2) = img1 == img2+  eq (SUImage img1) (SUImage img2) = eqR Sequential img1 img2   {-# INLINE eq #-} -  compute (SUImage img) = SUImage (compute img)+  compute (SUImage img) = SUImage (computeR Sequential img)   {-# INLINE compute #-} -  (|*|) (SUImage img1) (SUImage img2) = SUImage (img1 |*| img2)+  (|*|) (SUImage img1) (SUImage img2) = SUImage (multR Sequential img1 img2)   {-# INLINE (|*|) #-} -  toManifest (SUImage (SScalar px)) = scalar px-  toManifest (SUImage (STImage arr)) =-    fromVector (sh2ix (R.extent arr)) (R.toUnboxed arr)-  toManifest !img = toManifest (compute img)+  toManifest (SUImage img) = fromVector (dimsR img) (toVectorUnboxedR Sequential img)   {-# INLINE toManifest #-} -  toVector = I.toVector . toManifest+  toVector (SUImage img) = toVectorUnboxedR Sequential img   {-# INLINE toVector #-} -  fromVector sz = SUImage . STImage . R.fromUnboxed (ix2sh sz)+  fromVector !sz = SUImage . fromVectorUnboxedR sz   {-# INLINE fromVector #-}  + instance SuperClass RPU cs e => BaseArray RPU cs e where   type SuperClass RPU cs e =     (ColorSpace cs e, R.Elt e, R.Elt (Pixel cs e))-  -  newtype Image RPU cs e = PUImage (Image (RP IVU.VU) cs e)-                       -  dims (PUImage img) = dims img++  newtype Image RPU cs e = PUImage (RImage R.U (Pixel cs e))++  dims (PUImage img) = dimsR img   {-# INLINE dims #-}   instance BaseArray RPU cs e => Array RPU cs e where    type Manifest RPU = IVU.VU-  +   type Vector RPU = Vector IVU.VU-  -  makeImage !sz f = PUImage (makeImage sz f)++  makeImage !sz f = PUImage (makeImageR sz f)   {-# INLINE makeImage #-}- -  makeImageWindowed !sz !w f = PUImage . makeImageWindowed sz w f++  makeImageWindowed !sz !wIx !wSz f = PUImage . makeImageWindowedR sz wIx wSz f   {-# INLINE makeImageWindowed #-}- -  scalar = PUImage . scalar++  scalar = PUImage . scalarR   {-# INLINE scalar #-} -  index00 (PUImage img) = index00 img+  index00 (PUImage img) = index00R img   {-# INLINE index00 #-} -  map f (PUImage img) = PUImage (I.map f img)+  map f (PUImage img) = PUImage (mapR f img)   {-# INLINE map #-} -  imap f (PUImage img) = PUImage (I.imap f img)+  imap f (PUImage img) = PUImage (imapR f img)   {-# INLINE imap #-} -  zipWith f (PUImage img1) (PUImage img2) = PUImage (I.zipWith f img1 img2)+  zipWith f (PUImage img1) (PUImage img2) = PUImage (zipWithR f img1 img2)   {-# INLINE zipWith #-} -  izipWith f (PUImage img1) (PUImage img2) = PUImage (I.izipWith f img1 img2)+  izipWith f (PUImage img1) (PUImage img2) = PUImage (izipWithR f img1 img2)   {-# INLINE izipWith #-} -  traverse (PUImage img) f g = PUImage (I.traverse img f g)+  traverse (PUImage img) f g = PUImage (traverseR img f g)   {-# INLINE traverse #-} -  traverse2 (PUImage img1) (PUImage img2) f g = PUImage (I.traverse2 img1 img2 f g)+  traverse2 (PUImage img1) (PUImage img2) f g = PUImage (traverse2R img1 img2 f g)   {-# INLINE traverse2 #-} -  transpose (PUImage img) = PUImage (I.transpose img)+  transpose (PUImage img) = PUImage (transposeR img)   {-# INLINE transpose #-} -  backpermute !sz g (PUImage img) = PUImage (backpermute sz g img)+  backpermute !sz g (PUImage img) = PUImage (backpermuteR sz g img)   {-# INLINE backpermute #-} -  fromLists = PUImage . fromLists+  fromLists = PUImage . fromListsR   {-# INLINE fromLists #-} -  fold f !px0 (PUImage img) = I.fold f px0 img+  fold f !px0 (PUImage img) = foldR Parallel f px0 img   {-# INLINE fold #-} -  foldIx f !px0 (PUImage img) = I.foldIx f px0 img+  foldIx f !px0 (PUImage img) = foldIxR Parallel f px0 img   {-# INLINE foldIx #-} -  eq (PUImage img1) (PUImage img2) = img1 == img2+  eq (PUImage img1) (PUImage img2) = eqR Parallel img1 img2   {-# INLINE eq #-} -  compute (PUImage img) = PUImage (compute img)+  compute (PUImage img) = PUImage (computeR Parallel img)   {-# INLINE compute #-} -  (|*|) (PUImage img1) (PUImage img2) = PUImage (img1 |*| img2)+  (|*|) (PUImage img1) (PUImage img2) = PUImage (multR Parallel img1 img2)   {-# INLINE (|*|) #-} -  toManifest (PUImage (PScalar px)) = scalar px-  toManifest (PUImage (PTImage arr)) =-    fromVector (sh2ix (R.extent arr)) (R.toUnboxed arr)-  toManifest !img = toManifest (compute img)++  toManifest (PUImage img) = fromVector (dimsR img) (toVectorUnboxedR Parallel img)   {-# INLINE toManifest #-} -  toVector = I.toVector . toManifest+  toVector (PUImage img) = toVectorUnboxedR Parallel img   {-# INLINE toVector #-} -  fromVector sz = PUImage . PTImage . R.fromUnboxed (ix2sh sz)+  fromVector !sz = PUImage . fromVectorUnboxedR sz   {-# INLINE fromVector #-}

@@ -1,15 +1,11 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} -- | -- Module      : Graphics.Image.Interface.Vector.Generic -- Copyright   : (c) Alexey Kuleshevich 2017@@ -18,265 +14,482 @@ -- Stability   : experimental -- Portability : non-portable ---module Graphics.Image.Interface.Vector.Generic (-  G(..), Image(..), fromVector-  ) where+module Graphics.Image.Interface.Vector.Generic+  ( VGImage+  , MVGImage+  , makeImageVG+  , dimsVG+  , scalarVG+  , index00VG+  , makeImageWindowedVG+  , mapVG+  , imapVG+  , zipWithVG+  , izipWithVG+  , unsafeTraverseVG+  , traverseVG+  , unsafeTraverse2VG+  , traverse2VG+  , transposeVG+  , unsafeBackpermuteVG+  , backpermuteVG+  , fromListsVG+  , foldlVG+  , foldrVG+  , ifoldlVG+  , toVectorVG+  , fromVectorVG+  , multVG+  , unsafeIndexVG+  , makeImageMVG+  , mapMVG+  , mapM_VG+  , foldMVG+  , foldM_VG+  , mdimsVG+  , thawVG+  , freezeVG+  , newVG+  , readVG+  , writeVG+  , swapVG+  )+where -import Prelude hiding (map, zipWith)-import qualified Prelude as P (map)-import Control.DeepSeq (NFData, deepseq)-import Control.Monad-import Control.Monad.ST+import           Control.DeepSeq             (NFData (rnf))+import           Control.Monad               (when)+import           Control.Monad.Primitive     (PrimMonad, PrimState)+import           Control.Monad.ST            (ST)+import           Prelude                     hiding (map, zipWith) #if !MIN_VERSION_base(4,8,0)-import Data.Functor+import           Data.Functor #endif-import Data.Primitive.MutVar-import Data.Typeable (Typeable)-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector.Generic as VG+import           Data.Maybe                  (listToMaybe)+import qualified Data.Vector.Generic         as VG import qualified Data.Vector.Generic.Mutable as MVG-import Graphics.Image.Interface as I+import           Graphics.Image.Interface    (checkDims, fromIx,+                                              handleBorderIndex, toIx)+import           Graphics.Image.Utils        (loopM_, swapIx) --- | Generic 'Vector' representation.-data G r = G r deriving Typeable +data VGImage v p =+  VGImage {-# UNPACK #-}!Int+          {-# UNPACK #-}!Int+          !(v p) -instance Show r => Show (G r) where-  show (G r) = "Vector " ++ show r+instance NFData (v p) => NFData (VGImage v p) where+  rnf (VGImage _ _ v) = rnf v+  {-# INLINE rnf #-} -instance SuperClass (G r) cs e => BaseArray (G r) cs e where-  type SuperClass (G r) cs e =-    (Typeable r, ColorSpace cs e,-     VG.Vector (Vector r) Int, VG.Vector (Vector r) Bool,-     VG.Vector (Vector r) (Pixel cs e), NFData ((Vector r) (Pixel cs e)))+instance Eq (v p) => Eq (VGImage v p) where+  (VGImage _ _ v1) == (VGImage _ _ v2) = v1 == v2+  {-# INLINE (==) #-} -  data Image (G r) cs e = VScalar !(Pixel cs e)-                        | VImage {-# UNPACK #-} !Int-                                 {-# UNPACK #-} !Int-                                 !((Vector (G r)) (Pixel cs e))+makeImageVG :: VG.Vector v p =>+               (Int, Int) -> ((Int, Int) -> p) -> VGImage v p+makeImageVG !sz f =+  let !(m, n) = checkDimsVG "makeImageVGM" sz in+    VGImage m n $ VG.generate (m * n) (f . toIx n)+{-# INLINE makeImageVG #-} -  dims (VImage m n _) = (m, n)-  dims (VScalar _)    = (1, 1)-  {-# INLINE dims #-}+dimsVG :: VGImage v p -> (Int, Int)+dimsVG (VGImage m n _) = (m, n)+{-# INLINE dimsVG #-}  -instance (VG.Vector (Vector r) (Pixel cs e),-          MArray (G r) cs e, BaseArray (G r) cs e) => Array (G r) cs e where+scalarVG :: VG.Vector v p => p -> VGImage v p+scalarVG = makeImageVG (1,1) . const+{-# INLINE scalarVG #-} -  type Manifest (G r) = G r+index00VG :: VG.Vector v p => VGImage v p -> p+index00VG (VGImage _ _ v) = v VG.! 0+{-# INLINE index00VG #-} -  type Vector (G r) = Vector r+-- makeImageVG+--   :: forall v p.+--      VG.Vector v p+--   => (Int, Int)+--   -> ((Int, Int) -> p)+--   -> VGImage v p+-- makeImageVG !sz getPx =+--   VGImage m n $ VG.create generateImage+--   where+--     !(m, n) = checkDimsVG "makeImageVG" sz+--     generateImage :: ST s ((VG.Mutable v) s p)+--     generateImage = do+--       mv <- MVG.unsafeNew (m * n)+--       loopM_ 0 (< m) (+ 1) $ \ !i -> do+--         loopM_ 0 (< n) (+ 1) $ \ !j -> do+--           MVG.unsafeWrite mv (fromIx n (i, j)) (getPx (i, j))+--       return mv+--     {-# INLINE generateImage #-}+-- {-# INLINE makeImageVG #-} -  makeImage !(checkDims "(G r).makeImage" -> (m, n)) f =-    VImage m n $ VG.generate (m * n) (f . toIx n)-  {-# INLINE makeImage #-} -  -- TODO: add checkWithin-  makeImageWindowed !sz !((it, jt), (ib, jb)) getWindowPx getBorderPx =-    VImage m n $ VG.create generate where-      !(m, n) = checkDims "(G r).makeImageWindowed" sz-      nestedLoop :: (VG.Mutable (Vector r)) s (Pixel cs e)-                 -> ((Int, Int) -> Pixel cs e)-                 -> Int -> Int -> Int -> Int-                 -> ST s ()-      nestedLoop !mv !getPx !fi !fj !ti !tj = do-        VU.forM_ (VU.enumFromN fi (ti-fi)) $ \i ->-          VU.forM_ (VU.enumFromN fj (tj-fj)) $ \j ->-            MVG.unsafeWrite mv (fromIx n (i, j)) (getPx (i, j))-      {-# INLINE nestedLoop #-}-      generate :: ST s ((VG.Mutable (Vector (G r))) s (Pixel cs e))-      generate = do-        mv <- MVG.unsafeNew (m*n)-        nestedLoop mv getBorderPx 0 0 ib n-        nestedLoop mv getBorderPx it 0 ib jt-        nestedLoop mv getWindowPx it jt ib jb-        nestedLoop mv getBorderPx it jb ib n-        nestedLoop mv getBorderPx ib 0 m n-        return mv-      {-# INLINE generate #-}-  {-# INLINE makeImageWindowed #-}-  -  scalar = VScalar-  {-# INLINE scalar #-}+makeImageWindowedVG+  :: forall v p.+     VG.Vector v p+  => (Int, Int)+  -> (Int, Int)+  -> (Int, Int)+  -> ((Int, Int) -> p)+  -> ((Int, Int) -> p)+  -> VGImage v p+makeImageWindowedVG !sz !(it, jt) !(wm, wn) getWindowPx getBorderPx =+  VGImage m n $ VG.create generate+  where+    !(ib, jb) = (wm + it, wn + jt)+    !(m, n) = checkDimsVG "makeImageWindowedVG" sz+    !_ = checkDimsVG "makeImageWindowedVG (window size)" (wm, wn)+    generate :: ST s ((VG.Mutable v) s p)+    generate = do+      when (it < 0 || it >= ib || jt < 0 || jt >= jb || ib > m || jb > n) $+        error+          ("Window index is outside the image dimensions. window start: " +++           show (it, jt) +++           " window size: " +++           show (wm, wn) ++ " image dimensions: " ++ show (m, n))+      mv <- MVG.unsafeNew (m * n)+      loopM_ 0 (< n) (+ 1) $ \ !j -> do+        loopM_ 0 (< it) (+ 1) $ \ !i -> do+          MVG.unsafeWrite mv (fromIx n (i, j)) (getBorderPx (i, j))+        loopM_ ib (< m) (+ 1) $ \ !i -> do+          MVG.unsafeWrite mv (fromIx n (i, j)) (getBorderPx (i, j))+      loopM_ it (< ib) (+ 1) $ \ !i -> do+        loopM_ 0 (< jt) (+ 1) $ \ !j -> do+          MVG.unsafeWrite mv (fromIx n (i, j)) (getBorderPx (i, j))+        loopM_ jt (< jb) (+ 1) $ \ !j -> do+          MVG.unsafeWrite mv (fromIx n (i, j)) (getWindowPx (i, j))+        loopM_ jb (< n) (+ 1) $ \ !j -> do+          MVG.unsafeWrite mv (fromIx n (i, j)) (getBorderPx (i, j))+      return mv+    {-# INLINE generate #-}+{-# INLINE makeImageWindowedVG #-} -  index00 (VScalar px) = px-  index00 (VImage _ _ v) = v VG.! 0-  {-# INLINE index00 #-}-  -  map f (VScalar px)   = VScalar (f px)-  map f (VImage m n v) = VImage m n (VG.map f v)-  {-# INLINE map #-} -  imap f (VScalar px)   = VScalar (f (0, 0) px)-  imap f (VImage m n v) = VImage m n (VG.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) (VImage m n v2) = VImage m n (VG.map (f px1) v2)-  zipWith f (VImage m n v1) (VScalar px2) = VImage m n (VG.map (`f` px2) v1)-  zipWith f img1@(VImage m1 n1 v1) img2@(VImage 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 VImage m1 n1 (VG.zipWith f v1 v2)-  {-# INLINE zipWith #-} -  izipWith f (VScalar px1) (VScalar px2)    = VScalar (f (0, 0) px1 px2)-  izipWith f (VScalar px1) (VImage m n v2) =-    VImage m n (VG.imap (\ !k !px2 -> f (toIx n k) px1 px2) v2)-  izipWith f (VImage m n v1) (VScalar px2) =-    VImage m n (VG.imap (\ !k !px1 -> f (toIx n k) px1 px2) v1)-  izipWith f img1@(VImage m1 n1 v1) img2@(VImage 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 VImage m1 n1 (VG.izipWith (\ !k !px1 !px2 -> f (toIx n1 k) px1 px2) v1 v2)-  {-# INLINE izipWith #-} -  traverse !img getNewDims getNewPx = makeImage (getNewDims (dims img)) (getNewPx (index img))-  {-# INLINE traverse #-}+mapVG :: (VG.Vector v p1, VG.Vector v p)+      => (p1 -> p) -> VGImage v p1 -> VGImage v p+mapVG f (VGImage m n v) = VGImage m n (VG.map f v)+{-# INLINE mapVG #-} -  traverse2 !img1 !img2 getNewDims getNewPx =-    makeImage (getNewDims (dims img1) (dims img2)) (getNewPx (index img1) (index img2))-  {-# INLINE traverse2 #-}+imapVG :: (VG.Vector v p1, VG.Vector v p)+       => ((Int, Int) -> p1 -> p) -> VGImage v p1 -> VGImage v p+imapVG f (VGImage m n v) = VGImage m n (VG.imap (\ !k !px -> f (toIx n k) px) v)+{-# INLINE imapVG #-} -  -- TODO: switch directly to VG.unsafeBackpermute (no need to check ixs)-  transpose !img = backpermute (n, m) movePx img where-    !(m, n) = dims img-    movePx !(i, j) = (j, i)-    {-# INLINE movePx #-}-  {-# INLINE transpose #-}+zipWithVG+  :: ( VG.Vector v p1+     , VG.Vector v p2+     , VG.Vector v p+     )+  => (p1 -> p2 -> p)+  -> VGImage v p1+  -> VGImage v p2+  -> VGImage v p+zipWithVG f (VGImage 1 1 v1) (VGImage m n v2) =+  let !px1 = VG.unsafeIndex v1 0+  in VGImage m n (VG.map (f px1) v2)+zipWithVG f (VGImage m n v1) (VGImage 1 1 v2) =+  let !px2 = VG.unsafeIndex v2 0+  in VGImage m n (VG.map (`f` px2) v1)+zipWithVG f (VGImage m1 n1 v1) (VGImage m2 n2 v2) =+  if m1 == m2 || n1 == n2+    then VGImage m1 n1 (VG.zipWith f v1 v2)+    else let !(m, n) = (min m1 m2, min n1 n2)+             getPx !k =+               let !ix = toIx n k+                   !px1 = VG.unsafeIndex v1 (fromIx n1 ix)+                   !px2 = VG.unsafeIndex v2 (fromIx n2 ix)+               in f px1 px2+         in VGImage m n $ VG.generate (m * n) getPx+{-# INLINE zipWithVG #-} -  -- TODO: add index verification and switch to VG.unsafeBackpermute-  backpermute !(checkDims "(G r).backpermute" -> (m, n)) !f (VImage _ n' v) =-    VImage m n $ VG.backpermute v $ VG.generate (m*n) (fromIx n' . f . toIx n)-  backpermute !sz _ (VScalar px) = makeImage sz (const px)-  {-# INLINE backpermute #-}-  -  fromLists !ls = if all (== n) (P.map length ls)-                  then VImage m n . VG.fromList . concat $ ls-                  else error "fromLists: Inner lists are of different lengths."-    where-      !(m, n) = checkDims "(G r).fromLists" (length ls, length $ head ls)-  {-# INLINE fromLists #-} -  fold !f !px0 (VImage _ _ v) = VG.foldl' f px0 v-  fold !f !px0 (VScalar px)    = f px0 px-  {-# INLINE fold #-}+izipWithVG+  :: (VG.Vector v p1, VG.Vector v p2, VG.Vector v p)+  => ((Int, Int) -> p1 -> p2 -> p)+  -> VGImage v p1+  -> VGImage v p2+  -> VGImage v p+izipWithVG f (VGImage 1 1 v1) (VGImage m n v2) =+  let !px1 = VG.unsafeIndex v1 0+  in VGImage m n (VG.imap (\ !k !px2 -> f (toIx n k) px1 px2) v2)+izipWithVG f (VGImage m n v1) (VGImage 1 1 v2) =+  let !px2 = VG.unsafeIndex v2 0+  in VGImage m n (VG.imap (\ !k !px1 -> f (toIx n k) px1 px2) v1)+izipWithVG f (VGImage m1 n1 v1) (VGImage m2 n2 v2) =+  if m1 == m2 || n1 == n2+    then VGImage m1 n1 (VG.izipWith (\ !k !px1 !px2 -> f (toIx n1 k) px1 px2) v1 v2)+    else let !(m, n) = (min m1 m2, min n1 n2)+             getPx !k =+               let !ix = toIx n k+                   !px1 = VG.unsafeIndex v1 (fromIx n1 ix)+                   !px2 = VG.unsafeIndex v2 (fromIx n2 ix)+               in f ix px1 px2+         in VGImage m n $ VG.generate (m * n) getPx+{-# INLINE izipWithVG #-} -  foldIx !f !px0 (VImage _ n v) = VG.ifoldl' f' px0 v where-    f' !acc !k !px = f acc (toIx n k) px-  foldIx !f !px0 (VScalar px)    = f px0 (0,0) px-  {-# INLINE foldIx #-} -  (|*|) img1@(VImage m1 n1 v1) !img2@VImage {} =-    if n1 /= m2 -    then error ("Inner dimensions of multiplying images must be the same, but received: "++-                show img1 ++" X "++ show img2)-    else-      makeImage (m1, n2) getPx where-        VImage n2 m2 v2 = transpose img2-        getPx !(i, j) = VG.sum $ VG.zipWith (*) (VG.slice (i*n1) n1 v1) (VG.slice (j*m2) m2 v2)-        {-# INLINE getPx #-}-  (|*|) (VScalar px1) (VScalar px2) = VScalar (px1 * px2)-  (|*|) _ _ = error "Scalar Images cannot be multiplied."-  {-# INLINE (|*|) #-}+unsafeIndexV :: VG.Vector v a => Int -> v a -> (Int, Int) -> a+unsafeIndexV !n !v !ix = let !k = fromIx n ix in VG.unsafeIndex v k+{-# INLINE unsafeIndexV #-} -  eq (VImage m1 n1 v1) (VImage m2 n2 v2) =-    m1 == m2 && n1 == n2 && VG.all id (VG.zipWith (==) v1 v2)-  eq (VScalar px1)           (VScalar px2) = px1 == px2-  eq (VImage 1 1 v1) (VScalar px2) = v1 VG.! 0 == px2-  eq (VScalar px1) (VImage 1 1 v2) = v2 VG.! 0 == px1-  eq _ _ = False-  {-# INLINE eq #-}+indexV :: VG.Vector v p => (Int, Int) -> v p -> (Int, Int) -> p+indexV !sz@(_, n) !v !ix =+  handleBorderIndex+    (errorVG "indexV" ("Index out of bounds <" ++ show sz ++ ">: " ++ show ix))+    sz+    (unsafeIndexV n v)+    ix+{-# INLINE indexV #-} -  compute (VImage m n v) = v `deepseq` (VImage m n v)-  compute (VScalar px)   = px `seq` (VScalar px)-  {-# INLINE compute #-} -  toManifest = id-  {-# INLINE toManifest #-} -  toVector (VImage _ _ v) = VG.convert v-  toVector (VScalar px)   = VG.singleton px-  {-# INLINE[1] toVector #-}+unsafeTraverseVG+  :: (VG.Vector v p1, VG.Vector v p)+  => VGImage v p1+  -> ((Int, Int) -> (Int, Int))+  -> (((Int, Int) -> p1) -> (Int, Int) -> p)+  -> VGImage v p+unsafeTraverseVG (VGImage m n v) getNewDims getNewPx =+  makeImageVG (getNewDims (m, n)) (getNewPx (unsafeIndexV n v))+{-# INLINE unsafeTraverseVG #-} -  fromVector !(m, n) !v-    | m * n /= VG.length v =-       error $ "fromVector: m * n doesn't equal the length of a Vector: " ++-               show m ++ " * " ++ show n ++ " /= " ++ show (VG.length v)-    | m == 1 && n == 1     = VScalar (VG.unsafeIndex v 0)-    | otherwise            = VImage m n v-  {-# INLINE fromVector #-} -instance (BaseArray (G r) cs e) => MArray (G r) cs e where-  -  data MImage s (G r) cs e = MVImage !Int !Int ((VG.Mutable (Vector (G r))) s (Pixel cs e))-                            | MVScalar (MutVar s (Pixel cs e))-  -  unsafeIndex (VImage _ n v) !ix = VG.unsafeIndex v (fromIx n ix)-  unsafeIndex (VScalar px)     _ = px-  {-# INLINE unsafeIndex #-}+traverseVG+  :: (VG.Vector v p1, VG.Vector v p)+  => VGImage v p1+  -> ((Int, Int) -> (Int, Int))+  -> (((Int, Int) -> p1) -> (Int, Int) -> p)+  -> VGImage v p+traverseVG (VGImage m n v) getNewDims getNewPx =+  makeImageVG (getNewDims (m, n)) (getNewPx (indexV (m, n) v))+{-# INLINE traverseVG #-} -  deepSeqImage (VImage _ _ v) = deepseq v-  deepSeqImage (VScalar px)   = seq px-  {-# INLINE deepSeqImage #-} -  foldl f !a (VImage _ _ v) = VG.foldl' f a v-  foldl f !a (VScalar px)   = f a px+unsafeTraverse2VG+  :: (VG.Vector v p1, VG.Vector v p2, VG.Vector v p)+  => VGImage v p1+  -> VGImage v p2+  -> ((Int, Int) -> (Int, Int) -> (Int, Int))+  -> (((Int, Int) -> p1) -> ((Int, Int) -> p2) -> (Int, Int) -> p)+  -> VGImage v p+unsafeTraverse2VG (VGImage m1 n1 v1) (VGImage m2 n2 v2) getNewDims getNewPx =+  makeImageVG+    (getNewDims (m1, n1) (m2, n2))+    (getNewPx (unsafeIndexV n1 v1) (unsafeIndexV n2 v2))+{-# INLINE unsafeTraverse2VG #-} -  foldr f !a (VImage _ _ v) = VG.foldr' f a v-  foldr f !a (VScalar px)   = f px a-  {-# INLINE foldr #-} -  makeImageM !(checkDims "(G r).makeImageM" -> (m, n)) !f =-    VImage m n <$> VG.generateM (m * n) (f . toIx n)-  {-# INLINE makeImageM #-}+traverse2VG+  :: (VG.Vector v p1, VG.Vector v p2, VG.Vector v p)+  => VGImage v p1+  -> VGImage v p2+  -> ((Int, Int) -> (Int, Int) -> (Int, Int))+  -> (((Int, Int) -> p1) -> ((Int, Int) -> p2) -> (Int, Int) -> p)+  -> VGImage v p+traverse2VG (VGImage m1 n1 v1) (VGImage m2 n2 v2) getNewDims getNewPx =+  makeImageVG+    (getNewDims (m1, n1) (m2, n2))+    (getNewPx (indexV (m1, n1) v1) (indexV (m2, n2) v2))+{-# INLINE traverse2VG #-} -  mapM f (VImage m n v) = VImage m n <$> VG.mapM f v-  mapM f (VScalar px)   = VScalar <$> f px-  {-# INLINE mapM #-} -  mapM_ f (VImage _ _ v) = VG.mapM_ f v-  mapM_ f (VScalar px)    = void $ f px-  {-# INLINE mapM_ #-}+transposeVG :: (VG.Vector v Int, VG.Vector v p) =>+               VGImage v p -> VGImage v p+transposeVG (VGImage m n v) =+  VGImage n m $ VG.unsafeBackpermute v $ VG.generate (m * n) (fromIx n . swapIx . toIx m)+{-# INLINE transposeVG #-} -  foldM f !a (VImage _ _ v) = VG.foldM' f a v-  foldM f !a (VScalar px)    = f a px-  {-# INLINE foldM #-}+backpermuteWithCheckVG+  :: (VG.Vector v Int, VG.Vector v p)+  => ((Int, Int) -> (Int, Int) -> (Int, Int))+  -> (Int, Int)+  -> ((Int, Int) -> (Int, Int))+  -> VGImage v p+  -> VGImage v p+backpermuteWithCheckVG checkIx !sz f (VGImage m' n' v) =+  let !(m, n) = checkDimsVG "backpermuteWithCheckVG" sz+  in VGImage m n $+     VG.unsafeBackpermute v $+     VG.generate (m * n) (fromIx n' . checkIx (m', n') . f . toIx n)+{-# INLINE backpermuteWithCheckVG #-} -  foldM_ f !a (VImage _ _ v) = VG.foldM'_ f a v-  foldM_ f !a (VScalar px)    = void $ f a px-  {-# INLINE foldM_ #-} +unsafeBackpermuteVG+  :: (VG.Vector v Int, VG.Vector v p)+  => (Int, Int)+  -> ((Int, Int) -> (Int, Int))+  -> VGImage v p+  -> VGImage v p+unsafeBackpermuteVG = backpermuteWithCheckVG (const id)+{-# INLINE unsafeBackpermuteVG #-} -  mdims (MVImage m n _) = (m, n)-  mdims (MVScalar _)    = (1, 1)-  {-# INLINE mdims #-} -  thaw (VImage m n v) = MVImage m n <$> VG.thaw v-  thaw (VScalar px)   = MVScalar <$> newMutVar px-  {-# INLINE thaw #-}+backpermuteVG+  :: (VG.Vector v Int, VG.Vector v p)+  => (Int, Int)+  -> ((Int, Int) -> (Int, Int))+  -> VGImage v p+  -> VGImage v p+backpermuteVG =+  backpermuteWithCheckVG $ \ !sz !ix ->+    let err =+          errorVG+            "backpermuteVG"+            ("Index out of bounds <" ++ show sz ++ ">: " ++ show ix)+    in handleBorderIndex err sz id ix+{-# INLINE backpermuteVG #-} -  freeze (MVImage m n mv) = VImage m n <$> VG.freeze mv-  freeze (MVScalar mpx)    = VScalar <$> readMutVar mpx-  {-# INLINE freeze #-} -  new (m, n) = MVImage m n <$> MVG.new (m*n)-  {-# INLINE new #-}+fromListsVG :: VG.Vector v p => [[p]] -> VGImage v p+fromListsVG !ls =+  if all (== n) (fmap length ls)+    then VGImage m n . VG.fromList . concat $ ls+    else errorVG "fromListsVG" "Inner lists are of different lengths."+  where+    (m, n) =+      checkDimsVG "fromListsVG" (length ls, maybe 0 length $ listToMaybe ls)+{-# NOINLINE fromListsVG #-} -  read (MVImage _ n mv) !ix = MVG.read mv (fromIx n ix)-  read (MVScalar mpx)   !ix = do-    unless ((0, 0) == ix) $ error $ "Index out of bounds: " ++ show ix-    readMutVar mpx-  {-# INLINE read #-}+foldlVG :: VG.Vector v p =>+           (a -> p -> a) -> a -> VGImage v p -> a+foldlVG !f !px0 (VGImage _ _ v) = VG.foldl' f px0 v+{-# INLINE foldlVG #-} -  write (MVImage _ n mv) !ix !px = MVG.write mv (fromIx n ix) px-  write (MVScalar mv)    !ix !px = do-    unless ((0, 0) == ix) $ error $ "Index out of bounds: " ++ show ix-    writeMutVar mv px-  {-# INLINE write #-}+foldrVG :: VG.Vector v p =>+           (p -> a -> a) -> a -> VGImage v p -> a+foldrVG !f !px0 (VGImage _ _ v) = VG.foldr' f px0 v+{-# INLINE foldrVG #-} -  swap (MVImage _ n mv) !ix1 !ix2 = MVG.swap mv (fromIx n ix1) (fromIx n ix2)-  swap _                _    _    = return ()-  {-# INLINE swap #-}++ifoldlVG :: VG.Vector v p =>+            (a -> (Int, Int) -> p -> a) -> a -> VGImage v p -> a+ifoldlVG !f !px0 (VGImage _ n v) =+  VG.ifoldl' (\ !acc !k -> f acc (toIx n k)) px0 v+{-# INLINE ifoldlVG #-}+++toVectorVG :: (VG.Vector v p)+           => VGImage v p -> v p+toVectorVG (VGImage _ _ v) = v+{-# INLINE toVectorVG #-}++fromVectorVG :: VG.Vector v p =>+                (Int, Int) -> v p -> VGImage v p+fromVectorVG !(m, n) !v+  | m * n == VG.length v = VGImage m n v+  | otherwise =+    errorVG "fromVectorVG" $+    " image dimensions do not match the length of a vector: " +++    show m ++ " * " ++ show n ++ " /= " ++ show (VG.length v)+{-# INLINE fromVectorVG #-}++multVG :: ( VG.Vector v Int+          , VG.Vector v p+          , Num p+          ) => VGImage v p -> VGImage v p -> VGImage v p+multVG (VGImage m1 n1 v1) img2 =+  if n1 /= m2+    then errorVG "multVG" $+         "Inner dimensions of images must agree, but received: " +++         show (m1, n1) ++ " X " ++ show (m2, n2)+    else makeImageVG (m1, n2) getPx+  where+    VGImage n2 m2 v2 = transposeVG img2+    getPx !(i, j) =+      VG.sum $+      VG.zipWith (*) (VG.slice (i * n1) n1 v1) (VG.slice (j * m2) m2 v2)+    {-# INLINE getPx #-}+{-# INLINE multVG #-}++++------ Manifest+++data MVGImage s v p = MVGImage !Int !Int (VG.Mutable v s p)+++unsafeIndexVG :: VG.Vector v p => VGImage v p -> (Int, Int) -> p+unsafeIndexVG (VGImage _ n v) = VG.unsafeIndex v . fromIx n+{-# INLINE unsafeIndexVG #-}+++makeImageMVG :: (Functor m, Monad m, VG.Vector v p) =>+                (Int, Int) -> ((Int, Int) -> m p) -> m (VGImage v p)+makeImageMVG !sz !f =+  let !(m, n) = checkDimsVG "makeImageMVG" sz in+    VGImage m n <$> VG.generateM (m * n) (f . toIx n)+{-# INLINE makeImageMVG #-}++mapMVG+  :: (Functor m, Monad m, VG.Vector v a, VG.Vector v p) =>+     (a -> m p) -> VGImage v a -> m (VGImage v p)+mapMVG f (VGImage m n v) = VGImage m n <$> VG.mapM f v+{-# INLINE mapMVG #-}++mapM_VG+  :: (Monad m, VG.Vector v a) => (a -> m b) -> VGImage v a -> m ()+mapM_VG f (VGImage _ _ v) = VG.mapM_ f v+{-# INLINE mapM_VG #-}++foldMVG+  :: (Monad m, VG.Vector v b) =>+     (a -> b -> m a) -> a -> VGImage v b -> m a+foldMVG f !a (VGImage _ _ v) = VG.foldM' f a v+{-# INLINE foldMVG #-}++foldM_VG+  :: (Monad m, VG.Vector v b) =>+     (a -> b -> m a) -> a -> VGImage v b -> m ()+foldM_VG f !a (VGImage _ _ v) = VG.foldM'_ f a v+{-# INLINE foldM_VG #-}+++mdimsVG :: MVGImage t2 t1 t -> (Int, Int)+mdimsVG (MVGImage m n _) = (m, n)+{-# INLINE mdimsVG #-}++thawVG :: (VG.Mutable v1 ~ VG.Mutable v, Functor f, PrimMonad f, VG.Vector v1 p) =>+     VGImage v1 p -> f (MVGImage (PrimState f) v p)+thawVG (VGImage m n v) = MVGImage m n <$> VG.thaw v+{-# INLINE thawVG #-}++freezeVG :: (VG.Mutable t ~ VG.Mutable v, Functor f, PrimMonad f, VG.Vector v p) =>+     MVGImage (PrimState f) t p -> f (VGImage v p)+freezeVG (MVGImage m n mv) = VGImage m n <$> VG.freeze mv+{-# INLINE freezeVG #-}++newVG :: (Functor f, PrimMonad f, MVG.MVector (VG.Mutable v) p) =>+     (Int, Int) -> f (MVGImage (PrimState f) v p)+newVG (m, n) = MVGImage m n <$> MVG.new (m*n)+{-# INLINE newVG #-}++readVG :: (PrimMonad m, MVG.MVector (VG.Mutable t) a) =>+     MVGImage (PrimState m) t a -> (Int, Int) -> m a+readVG (MVGImage _ n mv) !ix = MVG.read mv (fromIx n ix)+{-# INLINE readVG #-}++writeVG :: (PrimMonad m, MVG.MVector (VG.Mutable t) a) =>+     MVGImage (PrimState m) t a -> (Int, Int) -> a -> m ()+writeVG (MVGImage _ n mv) !ix !px = MVG.write mv (fromIx n ix) px+{-# INLINE writeVG #-}++swapVG :: (PrimMonad m, MVG.MVector (VG.Mutable v) p) =>+           MVGImage (PrimState m) v p -> (Int, Int) -> (Int, Int) -> m ()+swapVG (MVGImage _ n mv) !ix1 !ix2 = MVG.swap mv (fromIx n ix1) (fromIx n ix2)+{-# INLINE swapVG #-}+++errorVG :: String -> String -> a+errorVG fName errMsg =+  error $ "Graphics.Image.Interface.Vector.Generic." ++ fName ++ ": " ++ errMsg++++checkDimsVG :: String -> (Int, Int) -> (Int, Int)+checkDimsVG fName = checkDims ("Graphics.Image.Interface.Vector.Generic." ++ fName)+{-# INLINE checkDimsVG #-}

@@ -1,15 +1,14 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-} -- | -- Module      : Graphics.Image.Interface.Vector.Storable -- Copyright   : (c) Alexey Kuleshevich 2017@@ -22,14 +21,15 @@   VS(..), Image(..)   ) where -import Prelude hiding (map, zipWith)+import           Prelude                                 hiding (map, zipWith) #if !MIN_VERSION_base(4,8,0)-import Data.Functor+import           Data.Functor #endif-import Data.Typeable (Typeable)-import qualified Data.Vector.Storable as VS-import Graphics.Image.Interface as I-import Graphics.Image.Interface.Vector.Generic+import           Control.DeepSeq                         (deepseq)+import           Data.Typeable                           (Typeable)+import qualified Data.Vector.Storable                    as VS+import           Graphics.Image.Interface                as I+import           Graphics.Image.Interface.Vector.Generic   @@ -43,9 +43,9 @@   type SuperClass VS cs e =     (ColorSpace cs e, VS.Storable (Pixel cs e)) -  newtype Image VS cs e = VSImage (Image (G VS) cs e)+  newtype Image VS cs e = VSImage (VGImage VS.Vector (Pixel cs e)) -  dims (VSImage img) = dims img+  dims (VSImage img) = dimsVG img   {-# INLINE dims #-}  @@ -53,122 +53,121 @@ instance (MArray VS cs e, BaseArray VS cs e) => Array VS cs e where    type Manifest VS = VS-  +   type Vector VS = VS.Vector -  makeImage !sh = VSImage . makeImage sh+  makeImage !sh = VSImage . makeImageVG sh   {-# INLINE makeImage #-} -  makeImageWindowed !sh !window f g = VSImage $ makeImageWindowed sh window f g+  makeImageWindowed !sh !wIx !wSz f g = VSImage $ makeImageWindowedVG sh wIx wSz f g   {-# INLINE makeImageWindowed #-}-  -  scalar = VSImage . scalar++  scalar = VSImage . scalarVG   {-# INLINE scalar #-} -  index00 (VSImage img) = index00 img+  index00 (VSImage img) = index00VG img   {-# INLINE index00 #-}-  -  map f (VSImage img) = VSImage $ I.map f img++  map f (VSImage img) = VSImage $ mapVG f img   {-# INLINE map #-} -  imap f (VSImage img) = VSImage $ I.imap f img+  imap f (VSImage img) = VSImage $ imapVG f img   {-# INLINE imap #-}-  -  zipWith f (VSImage img1) (VSImage img2) = VSImage $ I.zipWith f img1 img2++  zipWith f (VSImage img1) (VSImage img2) = VSImage $ zipWithVG f img1 img2   {-# INLINE zipWith #-} -  izipWith f (VSImage img1) (VSImage img2) = VSImage $ I.izipWith f img1 img2+  izipWith f (VSImage img1) (VSImage img2) = VSImage $ izipWithVG f img1 img2   {-# INLINE izipWith #-} -  traverse (VSImage img) f g = VSImage $ I.traverse img f g+  traverse (VSImage img) f g = VSImage $ traverseVG img f g   {-# INLINE traverse #-} -  traverse2 (VSImage img1) (VSImage img2) f g = VSImage $ I.traverse2 img1 img2 f g+  traverse2 (VSImage img1) (VSImage img2) f g = VSImage $ traverse2VG img1 img2 f g   {-# INLINE traverse2 #-} -  transpose (VSImage img) = VSImage $ I.transpose img+  transpose (VSImage img) = VSImage $ transposeVG img   {-# INLINE transpose #-} -  backpermute !sz f (VSImage img) = VSImage $ I.backpermute sz f img+  backpermute !sz f (VSImage img) = VSImage $ backpermuteVG sz f img   {-# INLINE backpermute #-}-  -  fromLists = VSImage . I.fromLists++  fromLists = VSImage . fromListsVG   {-# INLINE fromLists #-} -  fold f !px0 (VSImage img) = fold f px0 img+  fold f !px0 (VSImage img) = foldlVG f px0 img   {-# INLINE fold #-} -  foldIx f !px0 (VSImage img) = foldIx f px0 img+  foldIx f !px0 (VSImage img) = ifoldlVG f px0 img   {-# INLINE foldIx #-} -  (|*|) (VSImage img1) (VSImage img2) = VSImage (img1 |*| img2)+  (|*|) (VSImage img1) (VSImage img2) = VSImage (multVG img1 img2)   {-# INLINE (|*|) #-}    eq (VSImage img1) (VSImage img2) = img1 == img2   {-# INLINE eq #-} -  compute (VSImage img) = VSImage (compute img)+  compute (VSImage img) = img `deepseq` VSImage img   {-# INLINE compute #-}    toManifest = id   {-# INLINE toManifest #-} -  toVector (VSImage (VImage _ _ v)) = v-  toVector (VSImage (VScalar px))   = VS.singleton px+  toVector (VSImage img) = toVectorVG img   {-# INLINE toVector #-} -  fromVector !sz = VSImage . fromVector sz+  fromVector !sz = VSImage . fromVectorVG sz   {-# INLINE fromVector #-}   instance BaseArray VS cs e => MArray VS cs e where-  -  newtype MImage s VS cs e = MVSImage (MImage s (G VS) cs e)-                              -  unsafeIndex (VSImage img) = unsafeIndex img++  newtype MImage s VS cs e = MVSImage (MVGImage s VS.Vector (Pixel cs e))++  unsafeIndex (VSImage img) = unsafeIndexVG img   {-# INLINE unsafeIndex #-} -  deepSeqImage (VSImage img) = deepSeqImage img+  deepSeqImage (VSImage img) = deepseq img   {-# INLINE deepSeqImage #-} -  foldl f !px0 (VSImage img) = I.foldl f px0 img+  foldl f !px0 (VSImage img) = foldlVG f px0 img   {-# INLINE foldl #-} -  foldr f !px0 (VSImage img) = I.foldr f px0 img+  foldr f !px0 (VSImage img) = foldrVG f px0 img   {-# INLINE foldr #-} -  makeImageM !sh f = VSImage <$> makeImageM sh f+  makeImageM !sh f = VSImage <$> makeImageMVG sh f   {-# INLINE makeImageM #-} -  mapM f (VSImage img) = VSImage <$> I.mapM f img+  mapM f (VSImage img) = VSImage <$> mapMVG f img   {-# INLINE mapM #-} -  mapM_ f (VSImage img) = I.mapM_ f img+  mapM_ f (VSImage img) = mapM_VG f img   {-# INLINE mapM_ #-} -  foldM f !px0 (VSImage img) = I.foldM f px0 img+  foldM f !px0 (VSImage img) = foldMVG f px0 img   {-# INLINE foldM #-} -  foldM_ f !px0 (VSImage img) = I.foldM_ f px0 img+  foldM_ f !px0 (VSImage img) = foldM_VG f px0 img   {-# INLINE foldM_ #-} -  mdims (MVSImage mimg) = mdims mimg+  mdims (MVSImage mimg) = mdimsVG mimg   {-# INLINE mdims #-} -  thaw (VSImage img) = MVSImage <$> I.thaw img+  thaw (VSImage img) = MVSImage <$> thawVG img   {-# INLINE thaw #-} -  freeze (MVSImage img) = VSImage <$> I.freeze img+  freeze (MVSImage img) = VSImage <$> freezeVG img   {-# INLINE freeze #-} -  new !ix = MVSImage <$> I.new ix+  new !ix = MVSImage <$> newVG ix   {-# INLINE new #-} -  read (MVSImage img) = I.read img+  read (MVSImage img) = readVG img   {-# INLINE read #-} -  write (MVSImage img) = I.write img+  write (MVSImage img) = writeVG img   {-# INLINE write #-} -  swap (MVSImage img) = I.swap img+  swap (MVSImage img) = swapVG img   {-# INLINE swap #-}

@@ -1,15 +1,14 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-} -- | -- Module      : Graphics.Image.Interface.Vector.Unboxed -- Copyright   : (c) Alexey Kuleshevich 2017@@ -22,15 +21,16 @@   VU(..), VU.Unbox, Image(..)   ) where -import Prelude hiding (map, zipWith)+import           Control.DeepSeq                          (deepseq)+import           Prelude                                  hiding (map, zipWith) #if !MIN_VERSION_base(4,8,0)-import Data.Functor+import           Data.Functor #endif-import Data.Typeable (Typeable)-import qualified Data.Vector.Unboxed as VU-import Graphics.Image.Interface as I-import Graphics.Image.Interface.Vector.Generic-import Graphics.Image.Interface.Vector.Unboxing()+import           Data.Typeable                            (Typeable)+import qualified Data.Vector.Unboxed                      as VU+import           Graphics.Image.Interface                 as I+import           Graphics.Image.Interface.Vector.Generic+import           Graphics.Image.Interface.Vector.Unboxing ()   @@ -44,9 +44,9 @@   type SuperClass VU cs e =     (ColorSpace cs e, VU.Unbox (Components cs e)) -  newtype Image VU cs e = VUImage (Image (G VU) cs e)+  newtype Image VU cs e = VUImage (VGImage VU.Vector (Pixel cs e)) -  dims (VUImage img) = dims img+  dims (VUImage img) = dimsVG img   {-# INLINE dims #-}  @@ -57,120 +57,119 @@    type Vector VU = VU.Vector -  makeImage !sh = VUImage . makeImage sh+  makeImage !sh = VUImage . makeImageVG sh   {-# INLINE makeImage #-} -  makeImageWindowed !sh !window f g = VUImage $ makeImageWindowed sh window f g+  makeImageWindowed !sh !wIx !wSz f g = VUImage $ makeImageWindowedVG sh wIx wSz f g   {-# INLINE makeImageWindowed #-}-  -  scalar = VUImage . scalar++  scalar = VUImage . scalarVG   {-# INLINE scalar #-} -  index00 (VUImage img) = index00 img+  index00 (VUImage img) = index00VG img   {-# INLINE index00 #-}-  -  map f (VUImage img) = VUImage $ I.map f img++  map f (VUImage img) = VUImage $ mapVG f img   {-# INLINE map #-} -  imap f (VUImage img) = VUImage $ I.imap f img+  imap f (VUImage img) = VUImage $ imapVG f img   {-# INLINE imap #-}-  -  zipWith f (VUImage img1) (VUImage img2) = VUImage $ I.zipWith f img1 img2++  zipWith f (VUImage img1) (VUImage img2) = VUImage $ zipWithVG f img1 img2   {-# INLINE zipWith #-} -  izipWith f (VUImage img1) (VUImage img2) = VUImage $ I.izipWith f img1 img2+  izipWith f (VUImage img1) (VUImage img2) = VUImage $ izipWithVG f img1 img2   {-# INLINE izipWith #-} -  traverse (VUImage img) f g = VUImage $ I.traverse img f g+  traverse (VUImage img) f g = VUImage $ traverseVG img f g   {-# INLINE traverse #-} -  traverse2 (VUImage img1) (VUImage img2) f g = VUImage $ I.traverse2 img1 img2 f g+  traverse2 (VUImage img1) (VUImage img2) f g = VUImage $ traverse2VG img1 img2 f g   {-# INLINE traverse2 #-} -  transpose (VUImage img) = VUImage $ I.transpose img+  transpose (VUImage img) = VUImage $ transposeVG img   {-# INLINE transpose #-} -  backpermute !sz f (VUImage img) = VUImage $ I.backpermute sz f img+  backpermute !sz f (VUImage img) = VUImage $ backpermuteVG sz f img   {-# INLINE backpermute #-}-  -  fromLists = VUImage . I.fromLists-  {-# INLINE fromLists #-} -  fold f !px0 (VUImage img) = fold f px0 img+  fromLists = VUImage . fromListsVG+  {-# NOINLINE fromLists #-}++  fold f !px0 (VUImage img) = foldlVG f px0 img   {-# INLINE fold #-} -  foldIx f !px0 (VUImage img) = foldIx f px0 img+  foldIx f !px0 (VUImage img) = ifoldlVG f px0 img   {-# INLINE foldIx #-} -  (|*|) (VUImage img1) (VUImage img2) = VUImage (img1 |*| img2)+  (|*|) (VUImage img1) (VUImage img2) = VUImage (multVG img1 img2)   {-# INLINE (|*|) #-}    eq (VUImage img1) (VUImage img2) = img1 == img2   {-# INLINE eq #-} -  compute (VUImage img) = VUImage (compute img)+  compute (VUImage img) = img `deepseq` VUImage img   {-# INLINE compute #-}    toManifest = id   {-# INLINE toManifest #-} -  toVector (VUImage (VImage _ _ v)) = v-  toVector (VUImage (VScalar px))   = VU.singleton px+  toVector (VUImage img) = toVectorVG img   {-# INLINE toVector #-} -  fromVector !sz = VUImage . fromVector sz+  fromVector !sz = VUImage . fromVectorVG sz   {-# INLINE fromVector #-}   instance BaseArray VU cs e => MArray VU cs e where-  -  newtype MImage s VU cs e = MVUImage (MImage s (G VU) cs e)-                              -  unsafeIndex (VUImage img) = unsafeIndex img++  newtype MImage s VU cs e = MVUImage (MVGImage s VU.Vector (Pixel cs e))++  unsafeIndex (VUImage img) = unsafeIndexVG img   {-# INLINE unsafeIndex #-} -  deepSeqImage (VUImage img) = deepSeqImage img+  deepSeqImage (VUImage img) = deepseq img   {-# INLINE deepSeqImage #-} -  foldl f !px0 (VUImage img) = I.foldl f px0 img+  foldl f !px0 (VUImage img) = foldlVG f px0 img   {-# INLINE foldl #-} -  foldr f !px0 (VUImage img) = I.foldr f px0 img+  foldr f !px0 (VUImage img) = foldrVG f px0 img   {-# INLINE foldr #-} -  makeImageM !sh f = VUImage <$> makeImageM sh f+  makeImageM !sh f = VUImage <$> makeImageMVG sh f   {-# INLINE makeImageM #-} -  mapM f (VUImage img) = VUImage <$> I.mapM f img+  mapM f (VUImage img) = VUImage <$> mapMVG f img   {-# INLINE mapM #-} -  mapM_ f (VUImage img) = I.mapM_ f img+  mapM_ f (VUImage img) = mapM_VG f img   {-# INLINE mapM_ #-} -  foldM f !px0 (VUImage img) = I.foldM f px0 img+  foldM f !px0 (VUImage img) = foldMVG f px0 img   {-# INLINE foldM #-} -  foldM_ f !px0 (VUImage img) = I.foldM_ f px0 img+  foldM_ f !px0 (VUImage img) = foldM_VG f px0 img   {-# INLINE foldM_ #-} -  mdims (MVUImage mimg) = mdims mimg+  mdims (MVUImage mimg) = mdimsVG mimg   {-# INLINE mdims #-} -  thaw (VUImage img) = MVUImage <$> I.thaw img+  thaw (VUImage img) = MVUImage <$> thawVG img   {-# INLINE thaw #-} -  freeze (MVUImage img) = VUImage <$> I.freeze img+  freeze (MVUImage img) = VUImage <$> freezeVG img   {-# INLINE freeze #-} -  new !ix = MVUImage <$> I.new ix+  new !ix = MVUImage <$> newVG ix   {-# INLINE new #-} -  read (MVUImage img) = I.read img+  read (MVUImage img) = readVG img   {-# INLINE read #-} -  write (MVUImage img) = I.write img+  write (MVUImage img) = writeVG img   {-# INLINE write #-} -  swap (MVUImage img) = I.swap img+  swap (MVUImage img) = swapVG img   {-# INLINE swap #-}