diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +1.3.0.0 +======= + +* Significantly simplified interface: + * Removed `ManifestArray`, `SequentialArray` and `MutableArray` classes in favor of `MArray`. +* Rewrite of Repa image representations. Removed `RD` representation. +* Introduced function `canvasSize`. + +1.2.0.0 +======= + +* Changed `Interpolation` in a way that border resolution is supplied separatly + from the method. +* Introduced function `translate`. +* Added a better test suite. Improved coverage. +* Fixed a bug with border resolution strategy `Continue`. +* Added better error messaging for border checks. + 1.1.0.1 ======= @@ -18,8 +36,6 @@ * Changed the way image displaying works. Now `displayImage` function will try to automatically detect the default external viewer program. -* Made Histogram plotting using Chart dependency optional, which is controlled - by a compile time flag `use-chart`. * Renamed module `Graphics.Image.IO.External` to `Graphics.Image.IO.Formats`, so it reflects the purpose slightly better. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,5 @@ +BSD 3-Clause License + Copyright (c) 2016, Alexey Kuleshevich All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,9 +3,10 @@ Haskell Image Processing (HIP) Library -Documentation is on [Hackage](http://hackage.haskell.org/package/hip). +Documentation is on [Hackage](http://hackage.haskell.org/package/hip), and [Stackage](https://www.stackage.org/nightly/package/hip). -[![Build Status](https://travis-ci.org/lehins/hip.svg?branch=master)](https://travis-ci.org/lehins/hip) +[![Build Status](https://travis-ci.org/lehins/hip.svg?branch=master)](https://travis-ci.org/lehins/hip) +[![Hackage](https://img.shields.io/hackage/v/hip.svg?style=flat)](https://hackage.haskell.org/package/hip) Installation ------------ @@ -14,8 +15,9 @@ * `$ cabal update && cabal install hip` -and using `stack` (from source code only, not yet on stackage): -* `$ stack install` +and using `stack`: + +* `$ stack install hip` In order to be able to view images in GHCi and external image viewer is used. On Linux I recommend `GPicView`, but you can use any viewer that accepts a filename diff --git a/benchmarks/Interface.hs b/benchmarks/Interface.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Interface.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Prelude as P +import Criterion.Main +import Graphics.Image.Interface as I +--import Graphics.Image.Processing + +--import qualified Graphics.Image.Interface.Vector as V +import Graphics.Image.Types + +main :: IO () +main = do + defaultMain + [ bgroup + "RP fusion" + [ bench "native" $ + whnf + (compute . (noFusion :: (Int, Int) -> Image RP Y Double)) + (1000, 1000) + , bench "RP fusion" $ + whnf + (compute . (fusion :: (Int, Int) -> Image RP Y Double)) + (1000, 1000) + ] + , bgroup + "RS fusion" + [ bench "native" $ + whnf + (compute . (noFusion :: (Int, Int) -> Image RS Y Double)) + (1000, 1000) + , bench "RS fusion" $ + whnf + (compute . (fusion :: (Int, Int) -> Image RS Y Double)) + (1000, 1000) + ] + , bgroup + "VU fusion" + [ bench "no fusion" $ + nf (noFusion :: (Int, Int) -> Image VU Y Double) (1000, 1000) + , bench "VU fusion" $ + nf (fusion :: (Int, Int) -> Image VU Y Double) (1000, 1000) + ] + ] +--frog <- V.readImageY "images/frog.jpg" +-- [ bgroup +-- ("makeImage big " ++ show bigDims) +-- [ bench "makeImage VU" $ nf (`V.makeImage` getPxY) bigDims +-- , bench "computeS" $ nf R.computeS (R.makeImage bigDims getPxY) +-- -- parallel +-- , bench "computeP" $ nf R.computeP (R.makeImage bigDims getPxY) +-- ] +-- , bgroup +-- "Sobel operator" +-- [ bench "sobel VU" $ nf sobel frog +-- , bench "sobel RS" $ nf (sobel . exchange RS) frog +-- -- parallel +-- , bench "sobel RP" $ nf (sobel . R.computeP . exchange RP) frog +-- ] +-- ] + where +-- bigDims = (2000, 2000) + getPxY :: (Int, Int) -> Pixel Y Double + getPxY (i, j) = fromIntegral (i * j) + noFusion ds = makeImage ds getPx + where getPx :: (Int, Int) -> Pixel Y Double + getPx (i, j) = (getPxY (i, j) / 5 - fromIntegral i) * 21 + fusion ds = imap (\ (i, _) px -> (px - fromIntegral i) * 21) $ (makeImage ds getPxY / 5) + + +-- sobel :: ManifestArray arr cs Double => Image arr cs Double -> Image arr cs Double +-- sobel img = sqrt (imgX ^ (2 :: Int) + imgY ^ (2 :: Int)) +-- where +-- imgX = convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]]) img +-- imgY = convolve Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]]) img diff --git a/hip.cabal b/hip.cabal --- a/hip.cabal +++ b/hip.cabal @@ -1,5 +1,5 @@ Name: hip -Version: 1.2.0.0 +Version: 1.3.0.0 License: BSD3 License-File: LICENSE Author: Alexey Kuleshevich @@ -98,6 +98,7 @@ HS-Source-Dirs: tests Main-Is: Spec.hs Other-Modules: Graphics.Image.ColorSpaceSpec + , Graphics.Image.ProcessingSpec , Graphics.Image.InterfaceSpec , Graphics.Image.Interface.VectorSpec Build-Depends: base >= 4.5 && < 5 @@ -105,7 +106,20 @@ , hspec , QuickCheck Default-Language: Haskell2010 - GHC-Options: -Wall -O0 + GHC-Options: -Wall -threaded -with-rtsopts=-N + + +benchmark interface-benchmarks + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Interface.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , criterion + , deepseq + , hip + , vector + default-language: Haskell2010 Source-Repository head Type: git diff --git a/images/frog_translate_edge.jpg b/images/frog_translate_edge.jpg new file mode 100644 Binary files /dev/null and b/images/frog_translate_edge.jpg differ diff --git a/images/frog_translate_wrap.jpg b/images/frog_translate_wrap.jpg new file mode 100644 Binary files /dev/null and b/images/frog_translate_wrap.jpg differ diff --git a/images/logo_40.png b/images/logo_40.png new file mode 100644 Binary files /dev/null and b/images/logo_40.png differ diff --git a/images/logo_center.png b/images/logo_center.png new file mode 100644 Binary files /dev/null and b/images/logo_center.png differ diff --git a/images/logo_tile.png b/images/logo_tile.png new file mode 100644 Binary files /dev/null and b/images/logo_tile.png differ diff --git a/src/Graphics/Image.hs b/src/Graphics/Image.hs --- a/src/Graphics/Image.hs +++ b/src/Graphics/Image.hs @@ -20,14 +20,9 @@ -- representation, @__cs__@ is the `ColorSpace` of an image and @__e__@ is the -- type denoting precision of an image. -- --- * @__`ManifestArray` arr cs e__@ - is a kind of array that is represented by an --- actual data in memory. --- --- * @__`SequentialArray` arr cs e__@ - contains functionality that can only be --- computed sequentially. --- --- * @__`MutableArray` arr cs e__@ - allows mutation on __@`MImage`@ @st@ @arr@ @cs@ @e@__, --- which is `Image`'s mutable cousin. +-- * @__`MArray` arr cs e__@ - is a kind of array, that can be indexed in +-- constant time and allows monadic operations and mutation on __@`MImage`@ @st@ +-- @arr@ @cs@ @e@__, which is `Image`'s mutable cousin. -- -- Array representation type and the above classes it is installed in determine -- operations that can be done on the image with that representation. @@ -36,20 +31,18 @@ -- packages: -- -- * `VU` - Unboxed Vector representation. (Default) --- * `RD` - Delayed Repa array representation. -- * `RS` - Unboxed Repa array representation (computation is done sequentially). -- * `RP` - Unboxed Repa array representation (computation is done in parallel). -- --- Images with `RD` type hold functions rather then actual data, so this --- representation should be used for fusing computation together, and later --- changed to `RS` or `RP` using `exchange`, which in turn performs the fused --- computation. +-- Images with `RS` and `RP` types, most of the time hold functions rather then +-- actual data, this way computation can be fused together, and later changed to +-- `VU` using `toManifest`, which in turn performs the fused computation. If at +-- any time computation needs to be forced, `compute` can be used for that +-- purpose. -- -- Just as it is mentioned above, Vector representation is a default one, so in -- order to create images with Repa representation --- "Graphics.Image.Interface.Repa" module should be used. It has to be imported --- as qualified, since it contains image generating functions with same names as --- here. +-- "Graphics.Image.Interface.Repa" module should be used. -- -- Many of the function names exported by this module will clash with the ones -- from "Prelude", hence it can be more convenient to import it qualified and @@ -73,14 +66,26 @@ -- -- @ makeImage (256, 256) (PixelY . fromIntegral . fst) :: Image RP Y Word8 @ -- - makeImage, fromLists, toLists, + makeImage, makeImageS, makeImageP, fromLists, fromListsS, fromListsP, toLists, -- * IO -- ** Reading - -- | Read any supported image file into an 'Image' with 'VU' (Vector Unboxed) - -- representation and pixels with 'Double' precision. In order to read an - -- image with different representation, color space and precision 'readImage' - -- or 'readImageExact' from can be - -- used. + -- | Read supported files into an 'Image' with pixels in 'Double' + -- precision. In order to read an image in a different representation, color + -- space or precision, use 'readImage' or 'readImageExact' from + -- instead. While reading an + -- image, it's underlying representation can be specified by passing one of + -- `VU`, `RS` or `RP` as the first argument to @readImage*@ functions. Here is + -- a quick demonstration of how two images can be read as different + -- representations and later easily combined as their average. + -- + -- >>> cluster <- readImageRGB RP "images/cluster.jpg" + -- >>> displayImage cluster + -- >>> centaurus <- readImageRGB VU "images/centaurus.jpg" + -- >>> displayImage centaurus + -- >>> displayImage ((cluster + exchange RP centaurus) / 2) + -- + -- <> <> <> + -- readImageY, readImageYA, readImageRGB, readImageRGBA, readImageExact, -- ** Writing writeImage, writeImageExact, displayImage, @@ -100,7 +105,7 @@ fold, sum, product, maximum, minimum, normalize, -- * Representations exchange, - VU(..), RD(..), RS(..), RP(..), + VU(..), RS(..), RP(..), ) where #if MIN_VERSION_base(4,8,0) @@ -112,9 +117,9 @@ import qualified Data.Foldable as F import Graphics.Image.ColorSpace import Graphics.Image.IO -import Graphics.Image.Interface hiding (makeImage, fromLists) -import Graphics.Image.Interface.Vector as V -import Graphics.Image.Interface.Repa as R (RD(..), RS(..), RP(..)) +import Graphics.Image.Interface as I hiding (makeImage, fromLists) +import Graphics.Image.Interface.Vector +import Graphics.Image.Interface.Repa import Graphics.Image.Processing @@ -124,59 +129,82 @@ import Graphics.Image.IO.Histogram +-- | Read image as luma (brightness). +readImageY :: Array arr Y Double => arr -> FilePath -> IO (Image arr Y Double) +readImageY _ = fmap (either error id) . readImage +{-# INLINE readImageY #-} + +-- | Read image as luma with 'Alpha' channel. +readImageYA :: Array arr YA Double => arr -> FilePath -> IO (Image arr YA Double) +readImageYA _ = fmap (either error id) . readImage +{-# INLINE readImageYA #-} + + +-- | Read image in RGB colorspace. +readImageRGB :: Array arr RGB Double => arr -> FilePath -> IO (Image arr RGB Double) +readImageRGB _ = fmap (either error id) . readImage +{-# INLINE readImageRGB #-} + + +-- | Read image in RGB colorspace with 'Alpha' channel. +readImageRGBA :: Array arr RGBA Double => arr -> FilePath -> IO (Image arr RGBA Double) +readImageRGBA _ = fmap (either error id) . readImage +{-# INLINE readImageRGBA #-} + + -- | Get the number of rows in an image. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> frog -- -- >>> rows frog -- 200 -- -rows :: Array arr cs e => Image arr cs e -> Int +rows :: BaseArray arr cs e => Image arr cs e -> Int rows = fst . dims {-# INLINE rows #-} -- | Get the number of columns in an image. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> frog -- -- >>> cols frog -- 320 -- -cols :: Array arr cs e => Image arr cs e -> Int +cols :: BaseArray arr cs e => Image arr cs e -> Int cols = snd . dims {-# INLINE cols #-} -- | Sum all pixels in the image. -sum :: ManifestArray arr cs e => Image arr cs e -> Pixel cs e +sum :: Array arr cs e => Image arr cs e -> Pixel cs e sum = fold (+) 0 {-# INLINE sum #-} -- | Multiply all pixels in the image. -product :: ManifestArray arr cs e => Image arr cs e -> Pixel cs e +product :: Array arr cs e => Image arr cs e -> Pixel cs e product = fold (+) 1 {-# INLINE product #-} -- | Retrieve the biggest pixel from an image -maximum :: (ManifestArray arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e -maximum !img = fold max (index img (0, 0)) img +maximum :: (Array arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e +maximum !img = fold max (index00 img) img {-# INLINE maximum #-} -- | Retrieve the smallest pixel from an image -minimum :: (ManifestArray arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e -minimum !img = fold min (index img (0, 0)) img +minimum :: (Array arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e +minimum !img = fold min (index00 img) img {-# INLINE minimum #-} -- | Scales all of the pixels to be in the range @[0, 1]@. -normalize :: (ManifestArray arr cs e, ManifestArray arr Gray e, Fractional e, Ord e) => +normalize :: (Array arr cs e, Array arr Gray e, Fractional e, Ord e) => Image arr cs e -> Image arr cs e normalize !img = if l == s then (if s < 0 then (*0) else if s > 1 then (*1) else id) img @@ -193,7 +221,7 @@ -- -- @ img == fromLists (toLists img) @ -- -toLists :: ManifestArray arr cs e => Image arr cs e -> [[Pixel cs e]] +toLists :: MArray arr cs e => Image arr cs e -> [[Pixel cs e]] toLists img = [[index img (i, j) | j <- [0..cols img - 1]] | i <- [0..rows img - 1]] -- $colorspace diff --git a/src/Graphics/Image/ColorSpace/Gray.hs b/src/Graphics/Image/ColorSpace/Gray.hs --- a/src/Graphics/Image/ColorSpace/Gray.hs +++ b/src/Graphics/Image/ColorSpace/Gray.hs @@ -59,7 +59,7 @@ -- -- <> <> -- --- It is worth noting though, that separating image channels can be sometimes +-- It is worth noting though, despite that separating image channels can be sometimes -- pretty useful, the same effect as above can be achieved in a much simpler and -- more efficient way: -- diff --git a/src/Graphics/Image/IO.hs b/src/Graphics/Image/IO.hs --- a/src/Graphics/Image/IO.hs +++ b/src/Graphics/Image/IO.hs @@ -105,7 +105,7 @@ -- The drawback here is that colorspace and precision has to match exactly, -- otherwise it will return an error: -- --- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RD RGB Word8)) +-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RP RGB Word8)) -- Left "JuicyPixel decoding error: Input image is in YCbCr8 (Pixel YCbCr Word8), cannot convert it to RGB8 (Pixel RGB Word8) colorspace." -- -- Attempt to read an image in a particular color space that is not supported by @@ -141,7 +141,7 @@ -- | Write an image in a specific format, while supplying any format specific --- options. Precision and color space that an image will be written is decided +-- options. Precision and color space, that an image will be written as, is decided -- from image's type. Attempt to write image file in a format that does not -- support color space and precision combination will result in a compile error. writeImageExact :: Writable img format => @@ -190,7 +190,7 @@ the OS. This is a non-blocking function call, so it will take some time before an image will appear. - >>> frog <- readImageRGB "images/frog.jpg" + >>> frog <- readImageRGB VU "images/frog.jpg" >>> displayImage frog -} diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels.hs b/src/Graphics/Image/IO/Formats/JuicyPixels.hs --- a/src/Graphics/Image/IO/Formats/JuicyPixels.hs +++ b/src/Graphics/Image/IO/Formats/JuicyPixels.hs @@ -796,38 +796,38 @@ -- Encoding images using JuicyPixels ------------------------------------------- -------------------------------------------------------------------------------- -instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) BMP where +instance Array arr Y Word8 => Writable (Image arr Y Word8) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) -instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) BMP where +instance Array arr RGB Word8 => Writable (Image arr RGB Word8) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) BMP where +instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) -instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) BMP where +instance Array arr Binary Bit => Writable (Image arr Binary Bit) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . fromPixelBinary) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) BMP where +instance Array arr Y Double => Writable (Image arr Y Double) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . toWord8) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) BMP where +instance Array arr YA Double => Writable (Image arr YA Double) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . toWord8 . dropAlpha) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) BMP where +instance Array arr RGB Double => Writable (Image arr RGB Double) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) BMP where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) BMP where encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) . toWord8) -- Writable GIF -encodeGIF :: ManifestArray arr cs e => +encodeGIF :: Array arr cs e => [SaveOption GIF] -> (Pixel cs e -> JP.PixelRGB8) -> Image arr cs e -> BL.ByteString encodeGIF [] !conv = @@ -838,27 +838,27 @@ JP.palettize palOpts . imageToJPImage conv -instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) GIF where +instance Array arr RGB Word8 => Writable (Image arr RGB Word8) GIF where encode _ opts = encodeGIF opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) GIF where +instance Array arr Y Double => Writable (Image arr Y Double) GIF where encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8 . toPixelRGB) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) GIF where +instance Array arr YA Double => Writable (Image arr YA Double) GIF where encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8 . toPixelRGB . dropAlpha) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) GIF where +instance Array arr RGB Double => Writable (Image arr RGB Double) GIF where encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) GIF where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) GIF where encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8 . dropAlpha) -encodeGIFs :: ManifestArray arr cs e => +encodeGIFs :: Array arr cs e => [SaveOption [GIF]] -> (Pixel cs e -> JP.PixelRGB8) -> [(JP.GifDelay, Image arr cs e)] -> BL.ByteString encodeGIFs !opts !conv = @@ -873,31 +873,31 @@ !(jimg, p) = JP.palettize (getGIFsPal opts) $ imageToJPImage conv img -instance ManifestArray arr RGB Word8 => Writable [(JP.GifDelay, Image arr RGB Word8)] [GIF] where +instance Array arr RGB Word8 => Writable [(JP.GifDelay, Image arr RGB Word8)] [GIF] where encode _ opts = encodeGIFs opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr RGB Double => Writable [(JP.GifDelay, Image arr RGB Double)] [GIF] where +instance Array arr RGB Double => Writable [(JP.GifDelay, Image arr RGB Double)] [GIF] where encode _ opts = encodeGIFs opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8) -- Writable HDR -instance ManifestArray arr RGB Float => Writable (Image arr RGB Float) HDR where +instance Array arr RGB Float => Writable (Image arr RGB Float) HDR where encode _ _ = JP.encodeHDR . imageToJPImage (convert :: Pixel RGB Float -> JP.PixelRGBF) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) HDR where +instance Array arr Y Double => Writable (Image arr Y Double) HDR where encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) . toFloat . toPixelRGB) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) HDR where +instance Array arr YA Double => Writable (Image arr YA Double) HDR where encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) . toFloat . toPixelRGB . dropAlpha) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) HDR where +instance Array arr RGB Double => Writable (Image arr RGB Double) HDR where encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) . toFloat) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) HDR where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) HDR where encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) . toFloat . dropAlpha) @@ -905,7 +905,7 @@ -- Writable JPG -encodeJPG :: (JP.JpgEncodable px, ManifestArray arr cs e) => +encodeJPG :: (JP.JpgEncodable px, Array arr cs e) => [SaveOption JPG] -> (Pixel cs e -> px) -> Image arr cs e -> BL.ByteString encodeJPG [] conv = JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage conv @@ -913,185 +913,188 @@ JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage conv -instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) JPG where +instance Array arr Y Word8 => Writable (Image arr Y Word8) JPG where encode _ opts = encodeJPG opts (convert :: Pixel Y Word8 -> JP.Pixel8) -instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) JPG where +instance Array arr RGB Word8 => Writable (Image arr RGB Word8) JPG where encode _ opts = encodeJPG opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr CMYK Word8 => Writable (Image arr CMYK Word8) JPG where +instance Array arr CMYK Word8 => Writable (Image arr CMYK Word8) JPG where encode _ opts = encodeJPG opts (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) -instance ManifestArray arr YCbCr Word8 => Writable (Image arr YCbCr Word8) JPG where +instance Array arr YCbCr Word8 => Writable (Image arr YCbCr Word8) JPG where encode _ opts = encodeJPG opts (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) JPG where +instance Array arr Y Double => Writable (Image arr Y Double) JPG where encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8) . toWord8) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) JPG where +instance Array arr YA Double => Writable (Image arr YA Double) JPG where encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8) . toWord8 . dropAlpha) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) JPG where +instance Array arr RGB Double => Writable (Image arr RGB Double) JPG where encode _ opts = encodeJPG opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) JPG where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) JPG where encode _ opts = encodeJPG opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8 . dropAlpha) -- Writable PNG -instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) PNG where +instance Array arr Binary Bit => Writable (Image arr Binary Bit) PNG where encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . fromPixelBinary) -instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) PNG where +instance Array arr Y Word8 => Writable (Image arr Y Word8) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) -instance ManifestArray arr Y Word16 => Writable (Image arr Y Word16) PNG where +instance Array arr Y Word16 => Writable (Image arr Y Word16) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) -instance ManifestArray arr YA Word8 => Writable (Image arr YA Word8) PNG where +instance Array arr YA Word8 => Writable (Image arr YA Word8) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) -instance ManifestArray arr YA Word16 => Writable (Image arr YA Word16) PNG where +instance Array arr YA Word16 => Writable (Image arr YA Word16) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) -instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) PNG where +instance Array arr RGB Word8 => Writable (Image arr RGB Word8) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr RGB Word16 => Writable (Image arr RGB Word16) PNG where +instance Array arr RGB Word16 => Writable (Image arr RGB Word16) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) -instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) PNG where +instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) -instance ManifestArray arr RGBA Word16 => Writable (Image arr RGBA Word16) PNG where +instance Array arr RGBA Word16 => Writable (Image arr RGBA Word16) PNG where encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) PNG where +instance Array arr Y Double => Writable (Image arr Y Double) PNG where encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16) . toWord16) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) PNG where +instance Array arr YA Double => Writable (Image arr YA Double) PNG where encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16) . toWord16) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) PNG where +instance Array arr RGB Double => Writable (Image arr RGB Double) PNG where encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16) . toWord16) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) PNG where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) PNG where encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) . toWord16) -- Writable TGA -instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) TGA where +instance Array arr Binary Bit => Writable (Image arr Binary Bit) TGA where encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . fromPixelBinary) -instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) TGA where +instance Array arr Y Word8 => Writable (Image arr Y Word8) TGA where encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) -instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) TGA where +instance Array arr RGB Word8 => Writable (Image arr RGB Word8) TGA where encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) TGA where +instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) TGA where encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) TGA where +instance Array arr Y Double => Writable (Image arr Y Double) TGA where encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . toWord8) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) TGA where +instance Array arr YA Double => Writable (Image arr YA Double) TGA where encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . toWord8 . dropAlpha) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) TGA where +instance Array arr RGB Double => Writable (Image arr RGB Double) TGA where encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) . toWord8) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) TGA where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) TGA where encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) . toWord8) -- Writable TIF -instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) TIF where +instance Array arr Y Word8 => Writable (Image arr Y Word8) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) -instance ManifestArray arr Y Word16 => Writable (Image arr Y Word16) TIF where +instance Array arr Y Word16 => Writable (Image arr Y Word16) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) -instance ManifestArray arr YA Word8 => Writable (Image arr YA Word8) TIF where +instance Array arr YA Word8 => Writable (Image arr YA Word8) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) -instance ManifestArray arr YA Word16 => Writable (Image arr YA Word16) TIF where +instance Array arr YA Word16 => Writable (Image arr YA Word16) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) -instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) TIF where +instance Array arr RGB Word8 => Writable (Image arr RGB Word8) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) -instance ManifestArray arr RGB Word16 => Writable (Image arr RGB Word16) TIF where +instance Array arr RGB Word16 => Writable (Image arr RGB Word16) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) -instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) TIF where +instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) -instance ManifestArray arr RGBA Word16 => Writable (Image arr RGBA Word16) TIF where +instance Array arr RGBA Word16 => Writable (Image arr RGBA Word16) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) -instance ManifestArray arr YCbCr Word8 => Writable (Image arr YCbCr Word8) TIF where +instance Array arr YCbCr Word8 => Writable (Image arr YCbCr Word8) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) -instance ManifestArray arr CMYK Word8 => Writable (Image arr CMYK Word8) TIF where +instance Array arr CMYK Word8 => Writable (Image arr CMYK Word8) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) -instance ManifestArray arr CMYK Word16 => Writable (Image arr CMYK Word16) TIF where +instance Array arr CMYK Word16 => Writable (Image arr CMYK Word16) TIF where encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word16 -> JP.PixelCMYK16) -instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) TIF where +instance Array arr Binary Bit => Writable (Image arr Binary Bit) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) . fromPixelBinary) -instance ManifestArray arr Y Double => Writable (Image arr Y Double) TIF where +instance Array arr Y Double => Writable (Image arr Y Double) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16) . toWord16) -instance ManifestArray arr YA Double => Writable (Image arr YA Double) TIF where +instance Array arr YA Double => Writable (Image arr YA Double) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16) . toWord16) -instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) TIF where +instance Array arr RGB Double => Writable (Image arr RGB Double) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16) . toWord16) -instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) TIF where +instance Array arr RGBA Double => Writable (Image arr RGBA Double) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) . toWord16) -instance ManifestArray arr YCbCr Double => Writable (Image arr YCbCr Double) TIF where +instance Array arr YCbCr Double => Writable (Image arr YCbCr Double) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) . toWord8) -instance ManifestArray arr CMYK Double => Writable (Image arr CMYK Double) TIF where +instance Array arr CMYK Double => Writable (Image arr CMYK Double) TIF where encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel CMYK Word16 -> JP.PixelCMYK16) . toWord16) -imageToJPImage :: (JP.Pixel a, ManifestArray arr cs e) => +imageToJPImage :: (JP.Pixel a, Array arr cs e) => (Pixel cs e -> a) -> Image arr cs e -> JP.Image a -imageToJPImage !f img@(dims -> (m, n)) = JP.generateImage g n m - where g !j !i = f (index img (i, j)) - {-# INLINE g #-} +imageToJPImage !f !imgD = JP.generateImage g n m + where + !(m, n) = dims imgD + !img = toManifest imgD + g !j !i = f (index img (i, j)) + {-# INLINE g #-} {-# INLINE imageToJPImage #-} diff --git a/src/Graphics/Image/IO/Histogram.hs b/src/Graphics/Image/IO/Histogram.hs --- a/src/Graphics/Image/IO/Histogram.hs +++ b/src/Graphics/Image/IO/Histogram.hs @@ -18,7 +18,6 @@ import Prelude as P import Control.Concurrent (forkIO) import Control.Monad (void) -import Control.Monad.Primitive (PrimMonad (..)) import Graphics.Image.Interface as I import Graphics.Image.IO import Graphics.Image.ColorSpace @@ -26,12 +25,23 @@ import Graphics.Rendering.Chart.Backend.Diagrams import qualified Data.Colour as C import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Unboxed.Mutable as MV import System.Directory (getTemporaryDirectory) import System.FilePath (()) import System.IO.Temp (createTempDirectory) +#if MIN_VERSION_vector(0,11,0) +import Data.Vector.Unboxed.Mutable (modify) +#else +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 + e <- MV.read v idx + MV.write v idx $ f e +#endif + + -- | A single channel histogram of an image. data Histogram = Histogram { hBins :: V.Vector Int -- ^ Vector containing pixel counts. Index of a @@ -47,8 +57,8 @@ type Histograms = [Histogram] -- | Create a histogram per channel with 256 bins each. -getHistograms :: forall arr cs e . (SequentialArray arr Gray e, - SequentialArray arr cs e, Elevator e) => +getHistograms :: forall arr cs e . (MArray arr Gray e, Array arr Gray e, + MArray arr cs e, Array arr cs e, Elevator e) => Image arr cs e -> Histograms getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toGrayImages @@ -56,7 +66,7 @@ , hColour = csColour cs } -- | Generate a histogram with 256 bins for a single channel Gray image. -getHistogram :: (SequentialArray arr Gray e, Elevator e) => +getHistogram :: (MArray arr Gray e, Elevator e) => Image arr Gray e -> Histogram getHistogram img = Histogram { hBins = V.modify countBins $ @@ -70,7 +80,7 @@ -- | Write histograms into a PNG image file. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeHistograms "images/frog_histogram.svg" $ getHistograms frog -- -- <> @@ -88,7 +98,7 @@ -- | Display image histograms using an external program. Works in a similar way as -- `Graphics.Image.IO.displayImage`. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> displayHistograms $ getHistograms frog -- displayHistograms :: Histograms -> IO () @@ -109,11 +119,3 @@ if block then display else void $ forkIO display - - - --- | Used for backwards compatibility with vector. -modify :: (PrimMonad m, V.Unbox a) => MV.MVector (PrimState m) a -> (a -> a) -> Int -> m () -modify v f idx = do - e <- MV.read v idx - MV.write v idx $ f e diff --git a/src/Graphics/Image/Interface.hs b/src/Graphics/Image/Interface.hs --- a/src/Graphics/Image/Interface.hs +++ b/src/Graphics/Image/Interface.hs @@ -22,7 +22,7 @@ -- module Graphics.Image.Interface ( ColorSpace(..), Alpha(..), Elevator(..), - Array(..), ManifestArray(..), SequentialArray(..), MutableArray(..), + BaseArray(..), Array(..), MArray(..), Exchangable(..), exchangeFrom, defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex, ) where @@ -137,15 +137,30 @@ class (Show arr, ColorSpace cs, Num (Pixel cs e), Functor (Pixel cs), Applicative (Pixel cs), Foldable (Pixel cs), Num e, Typeable e, Elt arr cs e) => - Array arr cs e where + BaseArray arr cs e where -- | Required array specific constraints for an array element. type Elt arr cs e :: Constraint type Elt arr cs e = () - + -- | Underlying image representation. data Image arr cs e + -- | Get dimensions of an image. + -- + -- >>> frog <- readImageRGB VU "images/frog.jpg" + -- >>> frog + -- + -- >>> dims frog + -- (200,320) + -- + dims :: Image arr cs e -> (Int, Int) + +class (MArray (Manifest arr) cs e, BaseArray arr cs e) => Array arr cs e where + + type Manifest arr :: * + + -- | Create an Image by supplying it's dimensions and a pixel generating -- function. makeImage :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. @@ -158,15 +173,9 @@ -- a scalar. singleton :: Pixel cs e -> Image arr cs e - -- | Get dimensions of an image. - -- - -- >>> frog <- readImageRGB "images/frog.jpg" - -- >>> frog - -- - -- >>> dims frog - -- (200,320) - -- - dims :: Image arr cs e -> (Int, Int) + -- | Retrieves a pixel at @(0, 0)@ index. Useful together with `fold`, when + -- arbitrary initial pixel is needed. + index00 :: Image arr cs e -> Pixel cs e -- | Map a function over a an image. map :: Array arr cs' e' => @@ -236,10 +245,30 @@ fromLists :: [[Pixel cs e]] -> Image arr cs e + -- | Perform matrix multiplication on two images. Inner dimensions must agree. + (|*|) :: Image arr cs e -> Image arr cs e -> Image arr cs e + -- | Undirected reduction of an image. + fold :: (Pixel cs e -> Pixel cs e -> Pixel cs e) -- ^ An associative folding function. + -> Pixel cs e -- ^ Initial element, that is neutral with respect to the folding function. + -> Image arr cs e -- ^ Source image. + -> Pixel cs e + + -- | Pixelwise equality function of two images. Images are + -- considered distinct if either images' dimensions or at least one pair of + -- corresponding pixels are not the same. Used in defining an in instance for + -- the 'Eq' typeclass. + eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool + + compute :: Image arr cs e -> Image arr cs e + + toManifest :: Image arr cs e -> Image (Manifest 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 Array arr cs e => ManifestArray arr cs e where +class BaseArray arr cs e => MArray arr cs e where + data MImage st arr cs e unsafeIndex :: Image arr cs e -> (Int, Int) -> Pixel cs e @@ -256,26 +285,6 @@ -- | Make sure that an image is fully evaluated. deepSeqImage :: Image arr cs e -> a -> a - -- | Perform matrix multiplication on two images. Inner dimensions must agree. - (|*|) :: Image arr cs e -> Image arr cs e -> Image arr cs e - - -- | Undirected reduction of an image. - fold :: (Pixel cs e -> Pixel cs e -> Pixel cs e) -- ^ An associative folding function. - -> Pixel cs e -- ^ Initial element, that is neutral with respect to the folding function. - -> Image arr cs e -- ^ Source image. - -> Pixel cs e - - -- | Pixelwise equality function of two images. Images are - -- considered distinct if either images' dimensions or at least one pair of - -- corresponding pixels are not the same. Used in defining an in instance for - -- the 'Eq' typeclass. - eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool - - --- | Array representation that allows computation, which depends on some specific --- order, consequently making it possible to be computed only sequentially. -class ManifestArray arr cs e => SequentialArray arr cs e where - -- | Fold an image from the left in a row major order. foldl :: (a -> Pixel cs e -> a) -> a -> Image arr cs e -> a @@ -292,21 +301,18 @@ -> m (Image arr cs e) -- | Monading mapping over an image. - mapM :: (SequentialArray arr cs' e', Functor m, Monad m) => + mapM :: (MArray arr cs' e', Functor m, Monad m) => (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m (Image arr cs e) -- | Monading mapping over an image. Result is discarded. mapM_ :: (Functor m, Monad m) => (Pixel cs e -> m b) -> Image arr cs e -> m () + -- | Monadic folding. foldM :: (Functor m, Monad m) => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m a + -- | Monadic folding. Result is discarded. foldM_ :: (Functor m, Monad m) => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m () - --- | Array representation that supports mutation. -class ManifestArray arr cs e => MutableArray arr cs e where - data MImage st arr cs e - -- | Get dimensions of a mutable image. mdims :: MImage st arr cs e -> (Int, Int) @@ -344,24 +350,25 @@ -> Image arr' cs e -- ^ Source image. -> Image arr cs e --- | `exchange` function that is allows restricting the representation type of --- source image. -exchangeFrom :: (Exchangable arr' arr, Array arr' cs e, Array arr cs e) => - arr' - -> arr -- ^ New representation of an image. - -> Image arr' cs e -- ^ Source image. - -> Image arr cs e -exchangeFrom _ = exchange - -- | Changing to the same array representation as before is disabled and `exchange` -- will behave simply as an identitity function. instance Exchangable arr arr where - exchange _ = id + exchange _ !img = img {-# INLINE exchange #-} +-- | `exchange` function that allows restricting representation type of the +-- source image. +exchangeFrom :: (Exchangable arr' arr, Array arr' cs e, Array arr cs e) => + arr' + -> arr -- ^ New representation of an image. + -> Image arr' cs e -- ^ Source image. + -> Image arr cs e +exchangeFrom _ to !img = exchange to img +{-# INLINE exchangeFrom #-} + -- | Approach to be used near the borders during various transformations. -- Whenever a function needs information not only about a pixel of interest, but -- also about it's neighbours, it will go out of bounds around the image edges, @@ -431,7 +438,7 @@ -- | Image indexing function that returns a default pixel if index is out of bounds. -defaultIndex :: ManifestArray arr cs e => +defaultIndex :: MArray arr cs e => Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e defaultIndex !px !img = handleBorderIndex (Fill px) (dims img) (index img) {-# INLINE defaultIndex #-} @@ -439,7 +446,7 @@ -- | Image indexing function that uses a special border resolutions strategy for -- out of bounds pixels. -borderIndex :: ManifestArray arr cs e => +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) {-# INLINE borderIndex #-} @@ -447,7 +454,7 @@ -- | Image indexing function that returns @'Nothing'@ if index is out of bounds, -- @'Just' px@ otherwise. -maybeIndex :: ManifestArray arr cs e => +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 @@ -555,7 +562,7 @@ {-# INLINE minBound #-} -instance (ManifestArray arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where +instance (Array arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where (==) = eq {-# INLINE (==) #-} @@ -631,13 +638,13 @@ {-# INLINE acosh #-} -instance ManifestArray arr cs e => NFData (Image arr cs e) where +instance MArray arr cs e => NFData (Image arr cs e) where rnf img = img `deepSeqImage` () {-# INLINE rnf #-} -instance Array arr cs e => +instance BaseArray arr cs e => Show (Image arr cs e) where show (dims -> (m, n)) = "" -instance MutableArray arr cs e => +instance MArray arr cs e => Show (MImage st arr cs e) where show (mdims -> (m, n)) = " +-- | Create an image with sequential array representation. +makeImageS :: Array RS cs Double => (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. -> ((Int, Int) -> Pixel cs Double) -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument -- and returns a pixel for that location. - -> Image RD cs Double -makeImage = I.makeImage -{-# INLINE makeImage #-} - - --- | Construct an image from a nested rectangular shaped list of pixels. -fromLists :: Array RD cs e => - [[Pixel cs e]] - -> Image RD cs e -fromLists = I.fromLists -{-# INLINE fromLists #-} - - --- | Read image as luma (brightness). -readImageY :: FilePath -> IO (Image RD Y Double) -readImageY = fmap (either error id) . readImage -{-# INLINE readImageY #-} - - --- | Read image as luma with 'Alpha' channel. -readImageYA :: FilePath -> IO (Image RD YA Double) -readImageYA = fmap (either error id) . readImage -{-# INLINE readImageYA #-} - + -> Image RS cs Double +makeImageS = I.makeImage +{-# INLINE makeImageS #-} --- | Read image in RGB colorspace. -readImageRGB :: FilePath -> IO (Image RD RGB Double) -readImageRGB = fmap (either error id) . readImage -{-# INLINE readImageRGB #-} +-- | Create an image with parallel array representation. +makeImageP :: Array RP cs Double => + (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. + -> ((Int, Int) -> Pixel cs Double) + -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument + -- and returns a pixel for that location. + -> Image RP cs Double +makeImageP = I.makeImage +{-# INLINE makeImageP #-} --- | Read image in RGB colorspace with 'Alpha' channel. -readImageRGBA :: FilePath -> IO (Image RD RGBA Double) -readImageRGBA = fmap (either error id) . readImage -{-# INLINE readImageRGBA #-} +-- | Construct an image from a nested rectangular shaped list of pixels sequentially. +fromListsS + :: Array RS cs e + => [[Pixel cs e]] -> Image RS cs e +fromListsS = I.fromLists +{-# INLINE fromListsS #-} +-- | Construct an image from a nested rectangular shaped list of pixels in parallel. +fromListsP + :: Array RP cs e + => [[Pixel cs e]] -> Image RP cs e +fromListsP = I.fromLists +{-# INLINE fromListsP #-} diff --git a/src/Graphics/Image/Interface/Repa/Internal.hs b/src/Graphics/Image/Interface/Repa/Internal.hs --- a/src/Graphics/Image/Interface/Repa/Internal.hs +++ b/src/Graphics/Image/Interface/Repa/Internal.hs @@ -18,8 +18,8 @@ -- Portability : non-portable -- module Graphics.Image.Interface.Repa.Internal ( - RD(..), RP(..), RS(..), computeP, computeS, delay, - fromRepaArray, toRepaArray + RP(..), RS(..), + fromRepaArrayS, fromRepaArrayP, toRepaArray ) where #if MIN_VERSION_base(4,8,0) @@ -33,7 +33,7 @@ import Graphics.Image.Interface.Vector.Unboxed (VU(..), fromUnboxedVector, toUnboxedVector, checkDims) import Data.Array.Repa.Repr.Unboxed (Unbox) -import qualified Data.Vector.Unboxed as V ((!)) +import qualified Data.Vector.Unboxed as V (singleton) import Data.Typeable (Typeable) import Data.Array.Repa.Index @@ -41,469 +41,430 @@ import qualified Data.Array.Repa.Eval as R (Elt(..), suspendedComputeP) --- | Repa 'D'elayed Array representation, which allows for fusion of computation. -data RD = RD - -- | Repa 'U'nboxed Array representation, which is computed in parallel. data RP = RP -- | Repa 'U'nboxed Array representation, which is computed sequentially. data RS = RS -instance Show RD where - show _ = "RepaDelayed" - instance Show RP where show _ = "RepaParallel" instance Show RS where show _ = "RepaSequential" -instance Elt RD cs e => Array RD cs e where - type Elt RD cs e = (ColorSpace cs, Num e, Typeable e, R.Elt e, Unbox e, - R.Elt (PixelElt cs e), Unbox (PixelElt cs e), - R.Elt (Pixel cs e), Unbox (Pixel cs e)) - - data Image RD cs e = RScalar !(Pixel cs e) - | RUImage !(R.Array R.U R.DIM2 (Pixel cs e)) - | RDImage !(R.Array R.D R.DIM2 (Pixel cs e)) - dims (RScalar _ ) = (1, 1) - dims (RUImage (R.extent -> (Z :. m :. n))) = (m, n) - dims (RDImage (R.extent -> (Z :. m :. n))) = (m, n) - {-# INLINE dims #-} - singleton = RScalar - {-# INLINE singleton #-} - - makeImage !(checkDims "RD.makeImage" -> (m, n)) !f = - RDImage $ R.fromFunction (Z :. m :. n) (f . shT2) - {-# INLINE makeImage #-} - - map f (RScalar px) = RScalar (f px) - map f (getDelayed -> arr) = RDImage (R.map f arr) - {-# INLINE map #-} - - imap f (RScalar px) = RScalar (f (0, 0) px) - imap f (getDelayed -> arr) = RDImage (R.zipWith f (R.fromFunction (R.extent arr) shT2) arr) - {-# INLINE imap #-} - - zipWith f (RScalar px1) (RScalar px2) = RScalar (f px1 px2) - zipWith f (RScalar px1) (getDelayed -> arr2) = RDImage (R.map (f px1) arr2) - zipWith f (getDelayed -> arr1) (RScalar px2) = RDImage (R.map (`f` px2) arr1) - zipWith f (getDelayed -> arr1) (getDelayed -> arr2) = RDImage (R.zipWith f arr1 arr2) - {-# INLINE zipWith #-} - - izipWith f (RScalar px1) (RScalar px2) = RScalar (f (0, 0) px1 px2) - izipWith f (RScalar px1) !img2 = imap (`f` px1) img2 - izipWith f !img1 (RScalar px2) = imap (\ !ix !px -> f ix px px2) img1 - izipWith f (getDelayed -> arr1) (getDelayed -> arr2) = - RDImage (R.traverse2 arr1 arr2 const getNewPx) where - getNewPx !getPx1 !getPx2 !sh = f (shT2 sh) (getPx1 sh) (getPx2 sh) - {-# INLINE getNewPx #-} - {-# INLINE izipWith #-} - - traverse (getDelayed -> arr) newDims newPx = - RDImage $ R.traverse arr (tSh2 . checkDims "RD.traverse" . newDims . shT2) newPixel - where - newPixel getPx = newPx (getPx . tSh2) . shT2 - {-# INLINE traverse #-} - - traverse2 (getDelayed -> arr1) (getDelayed -> arr2) newDims newPx = - RDImage $ R.traverse2 arr1 arr2 getNewDims getNewPx - where getNewPx getPx1 getPx2 = newPx (getPx1 . tSh2) (getPx2 . tSh2) . shT2 - {-# INLINE getNewPx #-} - getNewDims !dims1 !dims2 = - tSh2 . checkDims "RD.traverse2" $ newDims (shT2 dims1) (shT2 dims2) - {-# INLINE getNewDims #-} - {-# INLINE traverse2 #-} - - transpose (RDImage arr) = RDImage (R.transpose arr) - transpose (RUImage arr) = RDImage (R.transpose arr) - transpose !img = img - {-# INLINE transpose #-} - - backpermute ds _ img@(RScalar _) = checkDims "RD.backpermute" ds `seq` img - backpermute !(tSh2 . checkDims "RD.backpermute" -> sh) g (getDelayed -> arr) = - RDImage (R.backpermute sh (tSh2 . g . shT2) arr) - {-# INLINE backpermute #-} - - fromLists !ls = if isRect - then RUImage . R.fromListUnboxed (Z :. m :. n) . concat $ ls - else error "fromLists: Inner lists do not all have an equal length." - where - !(m, n) = (length ls, length $ head ls) - !isRect = (m > 0) && (n > 0) && all (==n) (P.map length ls) - {-# INLINE fromLists #-} - - - -instance Elt RS cs e => Array RS cs e where +instance Elt RS cs e => BaseArray RS cs e where type Elt RS cs e = (ColorSpace cs, R.Elt e, Unbox e, Num e, Typeable e, R.Elt (PixelElt cs e), Unbox (PixelElt cs e), R.Elt (Pixel cs e), Unbox (Pixel cs e)) - data Image RS cs e = RSImage !(Image RD cs e) - - dims (RSImage img) = dims img + data Image RS cs e = SScalar !(Pixel cs e) + | SUImage !(R.Array R.U R.DIM2 (Pixel cs e)) + | SDImage !(R.Array R.D R.DIM2 (Pixel cs e)) + + dims (SScalar _ ) = (1, 1) + dims (SUImage (R.extent -> (Z :. m :. n))) = (m, n) + dims (SDImage (R.extent -> (Z :. m :. n))) = (m, n) {-# INLINE dims #-} - makeImage !(checkDims "RS.makeImage" -> ix) !f = computeS (makeImage ix f :: Image RD cs e) - {-# INLINE makeImage #-} - singleton = RSImage . singleton +instance (BaseArray RS cs e) => Array RS cs e where + + type Manifest RS = VU + + makeImage !(checkDims "RS.makeImage" -> (m, n)) !f = + SDImage $ R.fromFunction (Z :. m :. n) (f . sh2dims) + {-# INLINE makeImage #-} + + singleton = SScalar {-# INLINE singleton #-} - map !f (RSImage img) = computeS . map f $ img + index00 (SScalar px) = px + index00 (SUImage arr) = R.index arr (Z :. 0 :. 0) + index00 (SDImage arr) = R.index arr (Z :. 0 :. 0) + {-# INLINE index00 #-} + + map !f (SScalar px) = SScalar (f px) + map !f (SUImage arr) = SDImage (R.map f arr) + map !f (SDImage arr) = SDImage (R.map f arr) {-# INLINE map #-} - imap !f (RSImage img) = computeS . imap f $ img + imap !f (SScalar px) = SScalar (f (0, 0) px) + imap !f (SUImage arr) = SDImage (imapR f arr) + imap !f (SDImage arr) = SDImage (imapR f arr) {-# INLINE imap #-} - zipWith !f (RSImage img1) (RSImage img2) = computeS . zipWith f img1 $ img2 + zipWith f (SScalar px1) (SScalar px2) = SScalar (f px1 px2) + zipWith f (SScalar px1) img2 = map (f px1) img2 + zipWith f img1 (SScalar px2) = map (`f` px2) img1 + zipWith f img1 img2 = + SDImage (R.zipWith f (getDelayedS img1) (getDelayedS img2)) {-# INLINE zipWith #-} - izipWith !f (RSImage img1) (RSImage img2) = computeS . izipWith f img1 $ img2 + 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 (RSImage img) newDims = computeS . traverse img newDims + + -- traverse (SScalar px) getNewDims getNewPx = + -- makeImage (getNewDims (1, 1)) (getNewPx (const px)) + traverse img getNewDims getNewPx = + SDImage (traverseR (getDelayedS img) getNewDims getNewPx) {-# INLINE traverse #-} - traverse2 (RSImage img1) (RSImage img2) newDims = computeS . traverse2 img1 img2 newDims + -- traverse2 (SScalar px1) (SScalar px2) getNewDims getNewPx = + -- makeImage (getNewDims (1, 1) (1, 1)) (getNewPx (const px1) (const px2)) + traverse2 img1 img2 getNewDims getNewPx = + SDImage (traverse2R (getDelayedS img1) (getDelayedS img2) getNewDims getNewPx) {-# INLINE traverse2 #-} - transpose (RSImage img) = computeS . transpose $ img + transpose (SDImage arr) = SDImage (R.transpose arr) + transpose (SUImage arr) = SDImage (R.transpose arr) + transpose !img = img {-# INLINE transpose #-} - - backpermute !f !g (RSImage img) = computeS $ backpermute f g img + + -- backpermute !newDims _ (SScalar px) = + -- SDImage $ R.fromFunction (dims2sh $ checkDims "RS.backpermute" newDims) (const px) + backpermute !newDims g !img = SDImage (backpermuteR (getDelayedS img) newDims g) {-# INLINE backpermute #-} - fromLists = RSImage . fromLists + fromLists = SUImage . fromListsR {-# INLINE fromLists #-} + fold f !px0 (SDImage arr) = R.foldAllS f px0 arr + fold f !px0 (SUImage arr) = R.foldAllS f px0 arr + fold f !px0 (SScalar px) = f px0 px + {-# INLINE fold #-} + eq (SScalar px1) (SScalar px2) = px1 == px2 + eq img1 img2 = R.equalsS (getDelayedS img1) (getDelayedS img2) + {-# INLINE eq #-} -instance Elt RP cs e => Array RP cs e where + compute img@(SScalar _) = img + compute img@(SUImage _) = img + compute (SDImage arr) = SUImage $ R.computeS arr + {-# INLINE compute #-} + + (SUImage arr1) |*| (SUImage arr2) = SDImage (multR arr1 arr2) + img1@(SDImage _) |*| img2 = compute img1 |*| img2 + img1 |*| img2@(SDImage _) = img1 |*| compute img2 + (SScalar px1) |*| img2 = SUImage (singletonR px1) |*| img2 + img1 |*| (SScalar px2) = img1 |*| SUImage (singletonR px2) + {-# INLINE (|*|) #-} + + toManifest img@(SUImage arr) = fromUnboxedVector (dims img) (R.toUnboxed arr) + toManifest (SScalar px) = singleton px + toManifest img = toManifest (compute img) + {-# INLINE toManifest #-} + +--------------------- +-- Parallel Arrays -- +--------------------- + +instance Elt RP cs e => BaseArray RP cs e where type Elt RP cs e = (ColorSpace cs, R.Elt e, Unbox e, Num e, Typeable e, R.Elt (PixelElt cs e), Unbox (PixelElt cs e), R.Elt (Pixel cs e), Unbox (Pixel cs e)) - data Image RP cs e = RPImage !(Image RD cs e) - - dims (RPImage img) = dims img + data Image RP cs e = PScalar !(Pixel cs e) + | PUImage !(R.Array R.U R.DIM2 (Pixel cs e)) + | PDImage !(R.Array R.D R.DIM2 (Pixel cs e)) + + dims (PScalar _ ) = (1, 1) + dims (PUImage (R.extent -> (Z :. m :. n))) = (m, n) + dims (PDImage (R.extent -> (Z :. m :. n))) = (m, n) {-# INLINE dims #-} - makeImage !(checkDims "RP.makeImage" -> ix) !f = suspendedComputeP $ makeImage ix f - {-# INLINE makeImage #-} - singleton = RPImage . singleton +instance (BaseArray RP cs e) => Array RP cs e where + + type Manifest RP = VU + + makeImage !(checkDims "RP.makeImage" -> (m, n)) !f = + PDImage $ R.fromFunction (Z :. m :. n) (f . sh2dims) + {-# INLINE makeImage #-} + + singleton = PScalar {-# INLINE singleton #-} - map !f (RPImage img) = suspendedComputeP . map f $ img + index00 (PScalar px) = px + index00 (PUImage arr) = R.index arr (Z :. 0 :. 0) + index00 (PDImage arr) = R.index arr (Z :. 0 :. 0) + {-# INLINE index00 #-} + + map !f (PScalar px) = PScalar (f px) + map !f (PUImage arr) = PDImage (R.map f arr) + map !f (PDImage arr) = PDImage (R.map f arr) {-# INLINE map #-} - imap !f (RPImage img) = suspendedComputeP . imap f $ img + imap !f (PScalar px) = PScalar (f (0, 0) px) + imap !f (PUImage arr) = PDImage (imapR f arr) + imap !f (PDImage arr) = PDImage (imapR f arr) {-# INLINE imap #-} - zipWith !f (RPImage img1) (RPImage img2) = suspendedComputeP . zipWith f img1 $ img2 + zipWith f (PScalar px1) (PScalar px2) = PScalar (f px1 px2) + zipWith f (PScalar px1) img2 = map (f px1) img2 + zipWith f img1 (PScalar px2) = map (`f` px2) img1 + zipWith f img1 img2 = + PDImage (R.zipWith f (getDelayedP img1) (getDelayedP img2)) {-# INLINE zipWith #-} - izipWith !f (RPImage img1) (RPImage img2) = suspendedComputeP . izipWith f img1 $ img2 + 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 (RPImage img) newDims = suspendedComputeP . traverse img newDims + + -- traverse (PScalar px) getNewDims getNewPx = + -- makeImage (getNewDims (1, 1)) (getNewPx (const px)) + traverse img getNewDims getNewPx = + PDImage (traverseR (getDelayedP img) getNewDims getNewPx) {-# INLINE traverse #-} - traverse2 (RPImage img1) (RPImage img2) newDims = - suspendedComputeP . traverse2 img1 img2 newDims + -- traverse2 (PScalar px1) (PScalar px2) getNewDims getNewPx = + -- makeImage (getNewDims (1, 1) (1, 1)) (getNewPx (const px1) (const px2)) + traverse2 img1 img2 getNewDims getNewPx = + PDImage (traverse2R (getDelayedP img1) (getDelayedP img2) getNewDims getNewPx) {-# INLINE traverse2 #-} - transpose (RPImage img) = suspendedComputeP . transpose $ img + transpose (PDImage arr) = PDImage (R.transpose arr) + transpose (PUImage arr) = PDImage (R.transpose arr) + transpose !img = img {-# INLINE transpose #-} - - backpermute !f !g (RPImage img) = suspendedComputeP $ backpermute f g img + + -- backpermute !newDims _ (PScalar px) = + -- PDImage $ R.fromFunction (dims2sh $ checkDims "RS.backpermute" newDims) (const px) + backpermute !newDims g !img = PDImage (backpermuteR (getDelayedP img) newDims g) {-# INLINE backpermute #-} - fromLists = RPImage . fromLists + fromLists = PUImage . fromListsR {-# INLINE fromLists #-} - - -instance Array RS cs e => ManifestArray RS cs e where - - unsafeIndex (RSImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j) - unsafeIndex (RSImage (RScalar px)) _ = px - unsafeIndex _ _ = _errorCompute "ManifestArray RS cs e :: unsafeIndex" - {-# INLINE unsafeIndex #-} - - deepSeqImage (RSImage (RUImage arr)) = R.deepSeqArray arr - deepSeqImage (RSImage (RScalar px)) = seq px - deepSeqImage _ = _errorCompute "ManifestArray RS cs e :: deepSeqImage" - {-# INLINE deepSeqImage #-} - - (|*|) i1@(RSImage img1) i2@(RSImage img2) = - i1 `deepSeqImage` i2 `deepSeqImage` computeS (mult img1 img2) - {-# INLINE (|*|) #-} - - fold !f !px0 (RSImage (RUImage arr)) = R.foldAllS f px0 arr - fold !f !px0 (RSImage (RScalar px)) = f px0 px - fold _ _ _ = _errorCompute "ManifestArray RS cs e :: fold" + fold f !px0 (PDImage arr) = head $ R.foldAllP f px0 arr + fold f !px0 (PUImage arr) = head $ R.foldAllP f px0 arr + fold f !px0 (PScalar px) = f px0 px {-# INLINE fold #-} - eq (RSImage (RUImage arr1)) (RSImage (RUImage arr2)) = R.equalsS arr1 arr2 - eq (RSImage (RScalar arr1)) (RSImage (RScalar arr2)) = arr1 == arr2 - eq (RSImage (RUImage arr1)) (RSImage (RScalar arr2)) - | R.extent arr1 == (Z :. 1 :. 1) = R.index arr1 (Z :. 0 :. 0) == arr2 - | otherwise = False - eq img1@(RSImage (RScalar _)) img2@(RSImage (RUImage _)) = img2 `eq` img1 - eq (RSImage (RDImage _)) _ = _errorCompute "ManifestArray RS cs e :: eq" - eq _ (RSImage (RDImage _)) = _errorCompute "ManifestArray RS cs e :: eq" + eq (PScalar px1) (PScalar px2) = px1 == px2 + eq img1 img2 = R.equalsS (getDelayedP img1) (getDelayedP img2) {-# INLINE eq #-} - -instance Array RP cs e => ManifestArray RP cs e where - - unsafeIndex (RPImage (RUImage arr)) (i, j) = R.unsafeIndex arr (Z :. i :. j) - unsafeIndex (RPImage (RScalar px)) _ = px - unsafeIndex _ _ = _errorCompute "ManifestArray RP cs e :: unsafeIndex" - {-# INLINE unsafeIndex #-} - - deepSeqImage (RPImage (RUImage arr)) = R.deepSeqArray arr - deepSeqImage (RPImage (RScalar px)) = seq px - deepSeqImage _ = _errorCompute "ManifestArray RP cs e :: deepSeqImage" - {-# INLINE deepSeqImage #-} + compute img@(PScalar _) = img + compute img@(PUImage _) = img + compute (PDImage arr) = arrU `R.deepSeqArray` PUImage arrU + where arrU = R.suspendedComputeP arr + {-# INLINE compute #-} - (|*|) i1@(RPImage img1) i2@(RPImage img2) = - i1 `deepSeqImage` i2 `deepSeqImage` suspendedComputeP (mult img1 img2) + (PUImage arr1) |*| (PUImage arr2) = PDImage (multR arr1 arr2) + img1@(PDImage _) |*| img2 = compute img1 |*| img2 + img1 |*| img2@(PDImage _) = img1 |*| compute img2 + (PScalar px1) |*| img2 = PUImage (singletonR px1) |*| img2 + img1 |*| (PScalar px2) = img1 |*| PUImage (singletonR px2) {-# INLINE (|*|) #-} - fold !f !px0 (RPImage (RUImage arr)) = head . R.foldAllP f px0 $ arr - fold !f !px0 (RPImage (RScalar px)) = f px0 px - fold _ _ _ = _errorCompute "ManifestArray RP cs e :: fold" - {-# INLINE fold #-} + toManifest img@(PUImage arr) = fromUnboxedVector (dims img) (R.toUnboxed arr) + toManifest (PScalar px) = singleton px + toManifest img = toManifest (compute img) + {-# INLINE toManifest #-} - eq (RPImage (RUImage arr1)) (RPImage (RUImage arr2)) = head $ R.equalsP arr1 arr2 - eq (RPImage (RScalar arr1)) (RPImage (RScalar arr2)) = arr1 == arr2 - eq (RPImage (RUImage arr1)) (RPImage (RScalar arr2)) - | R.extent arr1 == (Z :. 1 :. 1) = R.index arr1 (Z :. 0 :. 0) == arr2 - | otherwise = False - eq img1@(RPImage (RScalar _)) img2@(RPImage (RUImage _)) = img2 `eq` img1 - eq (RPImage (RDImage _)) _ = _errorCompute "ManifestArray RP cs e :: eq" - eq _ (RPImage (RDImage _)) = _errorCompute "ManifestArray RP cs e :: eq" - {-# INLINE eq #-} - -instance ManifestArray RS cs e => SequentialArray RS cs e where +---------------------- +-- Helper functions -- +---------------------- - foldl !f !a = foldl f a . exchange VU - {-# INLINE foldl #-} +sh2dims :: DIM2 -> (Int, Int) +sh2dims (Z :. i :. j) = (i, j) +{-# INLINE sh2dims #-} - foldr !f !a = foldr f a . exchange VU - {-# INLINE foldr #-} +dims2sh :: (Int, Int) -> DIM2 +dims2sh !(i, j) = Z :. i :. j +{-# INLINE dims2sh #-} - makeImageM !(checkDims "RS.makeImageM" -> ix) !f = fmap (exchangeFrom VU RS) (makeImageM ix f) - mapM !f img = fmap (exchange RS) (mapM f (exchange VU img)) - {-# INLINE mapM #-} +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) sh2dims) arr - mapM_ !f img = mapM_ f (exchange VU img) - {-# INLINE mapM_ #-} - foldM !f !a = foldM f a . exchange VU - {-# INLINE foldM #-} +-- | 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 (sh2dims sh) (getPx1 sh) (getPx2 sh) + getNewDims (Z :. m1 :. n1) (Z :. m2 :. n2) = Z :. min m1 m2 :. min n1 n2 + {-# INLINE getNewPx #-} +{-# INLINE izipWithR #-} - foldM_ !f !a = foldM_ f a . exchange VU - {-# INLINE foldM_ #-} +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 (dims2sh . checkDims "traverseR" . getNewDims . sh2dims) getNewE + where + getNewE getPx = getNewPx (getPx . dims2sh) . sh2dims + {-# INLINE getNewE #-} +{-# INLINE traverseR #-} -instance ManifestArray RS cs e => MutableArray RS cs e where +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 . dims2sh) (getPx2 . dims2sh) . sh2dims + {-# INLINE getNewE #-} + getNewSh !sh1 !sh2 = + dims2sh . checkDims "traverse2R" $ getNewDims (sh2dims sh1) (sh2dims sh2) + {-# INLINE getNewSh #-} +{-# INLINE traverse2R #-} - data MImage st RS cs e = MRSImage !(MImage st VU cs e) +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 + (dims2sh (checkDims "backpermuteR" newDims)) + (dims2sh . g . sh2dims) + arr +{-# INLINE backpermuteR #-} - mdims (MRSImage (mdims -> sz)) = sz - {-# INLINE mdims #-} - thaw img = fmap MRSImage (thaw (exchange VU img)) - {-# INLINE thaw #-} +fromListsR :: Unbox a => [[a]] -> R.Array R.U DIM2 a +fromListsR ls = + if all (== n) (P.map length ls) + then R.fromListUnboxed (Z :. m :. n) . concat $ ls + else error "fromListsR: Inner lists do not all have an equal length." + where + !(m, n) = checkDims "fromListsR" (length ls, length $ head ls) +{-# INLINE fromListsR #-} - freeze (MRSImage mimg) = fmap (exchange RS) (freeze mimg) - {-# INLINE freeze #-} - new sz = fmap MRSImage (new sz) - {-# INLINE new #-} - read (MRSImage mimg) = read mimg - {-# INLINE read #-} - - write (MRSImage mimg) = write mimg - {-# INLINE write #-} - - swap (MRSImage mimg) = swap mimg - {-# INLINE swap #-} +multR + :: (Num a, Unbox a, R.Elt a) + => R.Array R.U DIM2 a -> R.Array R.U DIM2 a -> R.Array R.D DIM2 a +multR arr1 arr2 = + if n1 /= m2 + then error $ + "Inner dimensions of multiplied images must be the same, but received: " ++ "" + --show img1 ++ " X " ++ show img2 + 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 #-} --- | O(1) - Delays manifest array. -instance Exchangable RS RD where - - exchange _ (RSImage img) = img - {-# INLINE exchange #-} +singletonR :: Unbox e => e -> R.Array R.U DIM2 e +singletonR px = R.fromUnboxed (Z :. 1 :. 1) $ V.singleton px --- | O(1) - Delays manifest array. -instance Exchangable RP RD where - - exchange _ (RPImage img) = img - {-# INLINE exchange #-} - --- | Computes delayed array sequentially. -instance Exchangable RD RS where +getDelayedS :: Array RS cs e => Image RS cs e -> R.Array R.D DIM2 (Pixel cs e) +getDelayedS (SUImage arr) = R.delay arr +getDelayedS (SDImage arr) = arr +getDelayedS (SScalar px) = R.fromFunction (Z :. 1 :. 1) (const px) +{-# INLINE getDelayedS #-} - exchange _ (RDImage arr) = RSImage . RUImage . R.computeS $ arr - exchange _ img = RSImage img - {-# INLINE exchange #-} +getDelayedP :: Array RP cs e => Image RP cs e -> R.Array R.D DIM2 (Pixel cs e) +getDelayedP (PUImage arr) = R.delay arr +getDelayedP (PDImage arr) = arr +getDelayedP (PScalar px) = R.fromFunction (Z :. 1 :. 1) (const px) +{-# INLINE getDelayedP #-} --- | O(1) - Changes computation strategy. +-- | Changes computation strategy. Will casue all fused operations to be computed. instance Exchangable RP RS where - exchange _ (RPImage img) = RSImage img - {-# INLINE exchange #-} - - --- | Computes delayed array in parallel. -instance Exchangable RD RP where - - exchange _ (RDImage arr) = RPImage . RUImage . R.suspendedComputeP $ arr - exchange _ img = RPImage img + exchange _ (PScalar px) = SScalar px + exchange _ (PUImage arr) = SUImage arr + exchange r img@(PDImage _) = exchange r (compute img) {-# INLINE exchange #-} --- | O(1) - Changes computation strategy. +-- | Changes computation strategy. Will casue all fused operations to be computed. instance Exchangable RS RP where - exchange _ (RSImage img) = RPImage img - {-# INLINE exchange #-} - - --- | O(1) - Changes to Repa representation. -instance Exchangable VU RD where - exchange _ = delay . exchange RS + exchange _ (SScalar px) = PScalar px + exchange _ (SUImage arr) = PUImage arr + exchange r img@(SDImage _) = exchange r (compute img) {-# INLINE exchange #-} -- | O(1) - Changes to Repa representation. instance Exchangable VU RS where - exchange _ img@(dims -> (1, 1)) = singleton (toUnboxedVector img V.! 0) - exchange _ img = RSImage . RUImage . R.fromUnboxed (tSh2 $ dims img) . toUnboxedVector $ img + exchange _ img@(dims -> (1, 1)) = singleton (img `index` (0, 0)) + exchange _ img = SUImage . R.fromUnboxed (dims2sh $ dims img) . toUnboxedVector $ img {-# INLINE exchange #-} -- | O(1) - Changes to Repa representation. instance Exchangable VU RP where - exchange _ img@(dims -> (1, 1)) = singleton (toUnboxedVector img V.! 0) - exchange _ img = RPImage . RUImage . R.fromUnboxed (tSh2 $ dims img) . toUnboxedVector $ img + exchange _ img@(dims -> (1, 1)) = singleton (img `index` (0, 0)) + exchange _ img = PUImage . R.fromUnboxed (dims2sh $ dims img) . toUnboxedVector $ img {-# INLINE exchange #-} -- | O(1) - Changes to Vector representation. instance Exchangable RS VU where - exchange _ img@(RSImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr) - exchange _ (RSImage (RScalar px)) = singleton px - exchange _ _ = _errorCompute "Exchangable RS VU :: unsafeIndex" + exchange _ = toManifest {-# INLINE exchange #-} -- | O(1) - Changes to Vector representation. instance Exchangable RP VU where - exchange _ img@(RPImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr) - exchange _ (RPImage (RScalar px)) = singleton px - exchange _ _ = _errorCompute "Exchangable RP VU :: unsafeIndex" + exchange _ = toManifest {-# INLINE exchange #-} --- | Computes an image in parallel and ensures that all elements are evaluated. -computeP :: (Array arr cs e, Array RP cs e, Exchangable arr RP) => - Image arr cs e -> Image RP cs e -computeP !img = head $! do - let img' = exchange RP img - img' `deepSeqImage` return img' -{-# INLINE computeP #-} --- | Computes an image sequentially and ensures that all elements are evaluated. -computeS :: (Array arr cs e, Array RS cs e, Exchangable arr RS) => - Image arr cs e -> Image RS cs e -computeS !img = head $! do - let img' = exchange RS img - img' `deepSeqImage` return img' -{-# INLINE computeS #-} - --- | Delays an image, so further operations can be fused together. -delay :: (ManifestArray arr cs e, Array RD cs e, Exchangable arr RD) => - Image arr cs e -> Image RD cs e -delay = exchange RD -{-# INLINE delay #-} - - -mult :: Array RD cs e => Image RD cs e -> Image RD cs e -> Image RD cs e -mult img1@(RUImage arr1) img2@(RUImage arr2) = - if n1 /= m2 - then error $ - "Inner dimensions of multiplied images must be the same, but received: " ++ - show img1 ++ " X " ++ show img2 - else RDImage . 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 #-} -mult _ _ = _errorCompute "Graphics.Image.Interface.Repa.Internal.mult" -{-# INLINE mult #-} - - -shT2 :: DIM2 -> (Int, Int) -shT2 (Z :. i :. j) = (i, j) -{-# INLINE shT2 #-} - -tSh2 :: (Int, Int) -> DIM2 -tSh2 !(i, j) = Z :. i :. j -{-# INLINE tSh2 #-} - - -suspendedComputeP :: Array RD cs e => - Image RD cs e -> Image RP cs e -suspendedComputeP (RDImage arr) = RPImage . RUImage . R.suspendedComputeP $ arr -suspendedComputeP !img = RPImage img -{-# INLINE suspendedComputeP #-} - - -getDelayed :: Array RD cs e => Image RD cs e -> R.Array R.D DIM2 (Pixel cs e) -getDelayed (RUImage arr) = R.delay arr -getDelayed (RDImage arr) = arr -getDelayed _ = error "Scalar image is not an array." -{-# INLINE getDelayed #-} +-- | Create a sequential image from a 2D Repa delayed array. +fromRepaArrayS :: R.Array R.D DIM2 (Pixel cs e) -> Image RS cs e +fromRepaArrayS = SDImage --- | Create an image from a 2D Repa delayed array. -fromRepaArray :: R.Array R.D DIM2 (Pixel cs e) -> Image RD cs e -fromRepaArray = RDImage +-- | Create a parallel image from a 2D Repa delayed array. +fromRepaArrayP :: R.Array R.D DIM2 (Pixel cs e) -> Image RP cs e +fromRepaArrayP = PDImage --- | Retrieve an underlying Repa array from `RD` image type. -toRepaArray :: (ColorSpace cs, Unbox (PixelElt cs e)) => - Image RD cs e -> R.Array R.D DIM2 (Pixel cs e) -toRepaArray (RUImage arr) = R.delay arr -toRepaArray (RDImage arr) = arr -toRepaArray (RScalar px) = R.fromFunction (Z :. 1 :. 1) $ const px - -_errorCompute :: String -> t -_errorCompute err = - error $ - err ++ ": Image should be computed at ths point. Please report this error." - +-- | Retrieve an underlying Repa array from an image. +toRepaArray + :: (Array arr cs e, Array RS cs e, Exchangable arr RS) + => Image arr cs e -> R.Array R.U DIM2 (Pixel cs e) +toRepaArray img = + case compute (exchange RS img) of + SUImage arr -> arr + SDImage arr -> R.computeS arr -- shouldn't occur, but for completeness + SScalar px -> R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px instance R.Elt Bit where touch (Bit w) = R.touch w diff --git a/src/Graphics/Image/Interface/Vector.hs b/src/Graphics/Image/Interface/Vector.hs --- a/src/Graphics/Image/Interface/Vector.hs +++ b/src/Graphics/Image/Interface/Vector.hs @@ -10,23 +10,19 @@ module Graphics.Image.Interface.Vector ( -- * Construction makeImage, fromLists, fromUnboxedVector, toUnboxedVector, - -- * IO - readImageY, readImageYA, readImageRGB, readImageRGBA, -- * Representation VU(..), - -- * Flat index conversion + -- * Linear index conversion toIx, fromIx ) where -import Graphics.Image.IO import Graphics.Image.Interface hiding (makeImage, fromLists) import qualified Graphics.Image.Interface as I (makeImage, fromLists) import Graphics.Image.Interface.Vector.Unboxed -import Graphics.Image.ColorSpace -- | Create an image with 'VU' (Vector Unboxed) representation and pixels of 'Double' --- precision. Note, that for 'Double' precision pixels it is essential to keep values +-- precision. Note, that it is essential for 'Double' precision pixels to keep values -- normalized in the @[0, 1]@ range in order for an image to be written to file -- properly. -- @@ -68,28 +64,3 @@ -> Image VU cs e fromLists = I.fromLists {-# INLINE fromLists #-} - - --- | Read image as luma (brightness). -readImageY :: FilePath -> IO (Image VU Y Double) -readImageY = fmap (either error id) . readImage -{-# INLINE readImageY #-} - - --- | Read image as luma with 'Alpha' channel. -readImageYA :: FilePath -> IO (Image VU YA Double) -readImageYA = fmap (either error id) . readImage -{-# INLINE readImageYA #-} - - --- | Read image in RGB colorspace. -readImageRGB :: FilePath -> IO (Image VU RGB Double) -readImageRGB = fmap (either error id) . readImage -{-# INLINE readImageRGB #-} - - --- | Read image in RGB colorspace with 'Alpha' channel. -readImageRGBA :: FilePath -> IO (Image VU RGBA Double) -readImageRGBA = fmap (either error id) . readImage -{-# INLINE readImageRGBA #-} - diff --git a/src/Graphics/Image/Interface/Vector/Unboxed.hs b/src/Graphics/Image/Interface/Vector/Unboxed.hs --- a/src/Graphics/Image/Interface/Vector/Unboxed.hs +++ b/src/Graphics/Image/Interface/Vector/Unboxed.hs @@ -43,23 +43,32 @@ show _ = "VectorUnboxed" -instance Elt VU cs e => Array VU cs e where +instance Elt VU cs e => BaseArray VU cs e where type Elt VU cs e = (ColorSpace cs, Num e, Unbox e, Typeable e, Unbox (PixelElt cs e), Unbox (Pixel cs e)) - + data Image VU cs e = VScalar !(Pixel cs e) | VUImage !Int !Int !(Vector (Pixel cs e)) - + + dims (VUImage m n _) = (m, n) + dims (VScalar _) = (1, 1) + {-# INLINE dims #-} + + +instance BaseArray VU cs e => Array VU cs e where + + type Manifest VU = VU + makeImage !(checkDims "VU.makeImage" -> (m, n)) !f = VUImage m n $ V.generate (m * n) (f . toIx n) {-# INLINE makeImage #-} singleton = VScalar {-# INLINE singleton #-} - - dims (VUImage m n _) = (m, n) - dims _ = (1, 1) - {-# INLINE dims #-} + + index00 (VScalar px) = px + index00 (VUImage _ _ v) = v V.! 0 + {-# INLINE index00 #-} map !f (VScalar px) = VScalar (f px) map !f (VUImage m n v) = VUImage m n (V.map f v) @@ -105,8 +114,7 @@ backpermute !(checkDims "VU.backpermute" -> (m, n)) !f (VUImage _ n' v) = VUImage m n $ V.backpermute v $ V.generate (m*n) (fromIx n' . f . toIx n) - backpermute !sz _ (VScalar px) = - if sz == (1, 1) then VScalar px else makeImage sz (const px) + backpermute !sz _ (VScalar px) = makeImage sz (const px) {-# INLINE backpermute #-} fromLists !ls = if isSquare @@ -117,17 +125,6 @@ !isSquare = (n > 0) && all (==n) (P.map length ls) {-# INLINE fromLists #-} - -instance Array VU cs e => ManifestArray VU cs e where - - unsafeIndex (VUImage _ n v) !ix = V.unsafeIndex v (fromIx n ix) - unsafeIndex (VScalar px) _ = px - {-# INLINE unsafeIndex #-} - - deepSeqImage (VUImage m n v) = m `seq` n `seq` deepseq v - deepSeqImage (VScalar px) = seq px - {-# INLINE deepSeqImage #-} - fold !f !px0 (VUImage _ _ v) = V.foldl' f px0 v fold !f !px0 (VScalar px) = f px0 px {-# INLINE fold #-} @@ -153,9 +150,28 @@ eq _ _ = False {-# INLINE eq #-} + compute (VUImage m n v) = m `seq` n `seq` v `deepseq` (VUImage m n v) + compute (VScalar px) = px `seq` (VScalar px) + {-# INLINE compute #-} -instance ManifestArray VU cs e => SequentialArray VU cs e where + toManifest = id + {-# INLINE toManifest #-} + +instance Array VU cs e => MArray VU cs e where + + data MImage st VU cs e = MVImage !Int !Int (MV.MVector st (Pixel cs e)) + | MVScalar (MV.MVector st (Pixel cs e)) + + + unsafeIndex (VUImage _ n v) !ix = V.unsafeIndex v (fromIx n ix) + unsafeIndex (VScalar px) _ = px + {-# INLINE unsafeIndex #-} + + deepSeqImage (VUImage m n v) = m `seq` n `seq` deepseq v + deepSeqImage (VScalar px) = seq px + {-# INLINE deepSeqImage #-} + foldl !f !a (VUImage _ _ v) = V.foldl' f a v foldl !f !a (VScalar px) = f a px {-# INLINE foldl #-} @@ -185,11 +201,6 @@ {-# INLINE foldM_ #-} -instance ManifestArray VU cs e => MutableArray VU cs e where - - data MImage st VU cs e = MVImage !Int !Int (MV.MVector st (Pixel cs e)) - | MVScalar (MV.MVector st (Pixel cs e)) - mdims (MVImage m n _) = (m, n) mdims (MVScalar _) = (1, 1) {-# INLINE mdims #-} @@ -258,7 +269,7 @@ toIx :: Int -- ^ @n@ columns -> Int -- ^ Flat vector index -> (Int, Int) -- ^ @(i, j)@ row, column index -toIx !n !k = (k `div` n, k `mod` n) +toIx !n !k = divMod k n {-# INLINE toIx #-} diff --git a/src/Graphics/Image/Processing.hs b/src/Graphics/Image/Processing.hs --- a/src/Graphics/Image/Processing.hs +++ b/src/Graphics/Image/Processing.hs @@ -34,7 +34,7 @@ -- | This function magnifies an image by a positive factor and draws a grid -- around the original pixels. It is here simply as useful inspection tool. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_eye_grid.png" $ pixelGrid 10 $ crop (51, 112) (20, 20) frog -- -- <> <> diff --git a/src/Graphics/Image/Processing/Binary.hs b/src/Graphics/Image/Processing/Binary.hs --- a/src/Graphics/Image/Processing/Binary.hs +++ b/src/Graphics/Image/Processing/Binary.hs @@ -47,7 +47,7 @@ -- construction, which is done by comparing either a single pixel with every -- pixel in an image or two same size images pointwise. For example: -- --- >>> frog <- readImageY "images/frog.jpg" +-- >>> frog <- readImageY VU "images/frog.jpg" -- >>> frog .==. PixelY 0 -- (or: PixelY 0 .==. frog) -- >>> frog .<. flipH frog -- (or: flipH frog .>. frog) -- @@ -161,7 +161,7 @@ -- | Threshold a source image with an applicative pixel. -- --- >>> yield <- readImageRGB "images/yield.jpg" +-- >>> yield <- readImageRGB VU "images/yield.jpg" -- >>> writeImageExact PNG [] "images/yield_bin.png" $ thresholdWith (PixelRGB (>0.55) (<0.6) (<0.5)) yield -- -- <> <> @@ -222,7 +222,7 @@ -- -- <> eroded with <> is <> -- -erode :: ManifestArray arr Binary Bit => +erode :: Array arr Binary Bit => Image arr Binary Bit -- ^ Structuring element. -> Image arr Binary Bit -- ^ Binary source image. -> Image arr Binary Bit @@ -236,7 +236,7 @@ -- -- <> dialated with <> is <> -- -dialate :: ManifestArray arr Binary Bit => +dialate :: Array arr Binary Bit => Image arr Binary Bit -- ^ Structuring element. -> Image arr Binary Bit -- ^ Binary source image. -> Image arr Binary Bit @@ -250,7 +250,7 @@ -- -- <> opened with <> is <> -- -open :: ManifestArray arr Binary Bit => +open :: Array arr Binary Bit => Image arr Binary Bit -- ^ Structuring element. -> Image arr Binary Bit -- ^ Binary source image. -> Image arr Binary Bit @@ -264,7 +264,7 @@ -- -- <> closed with <> is <> -- -close :: ManifestArray arr Binary Bit => +close :: Array arr Binary Bit => Image arr Binary Bit -- ^ Structuring element. -> Image arr Binary Bit -- ^ Binary source image. -> Image arr Binary Bit diff --git a/src/Graphics/Image/Processing/Complex.hs b/src/Graphics/Image/Processing/Complex.hs --- a/src/Graphics/Image/Processing/Complex.hs +++ b/src/Graphics/Image/Processing/Complex.hs @@ -31,7 +31,7 @@ -- | Construct a complex image from two images representing real and imaginary parts. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> frog !+! 0 -- -- >>> frog !+! frog @@ -96,7 +96,7 @@ -- | Make a filter by using a function that works around a regular @(x, y)@ -- coordinate system. -makeFilter :: (ManifestArray arr cs e, RealFloat e) => +makeFilter :: (Array arr cs e, RealFloat e) => (Int, Int) -- ^ Dimensions of the filter. Both @m@ and @n@ have to be powers -- of @2@, i.e. @m == 2^k@, where @k@ is some integer. @@ -111,7 +111,7 @@ -- | Apply a filter to an image created by 'makeFilter'. -applyFilter :: (ManifestArray arr cs e, ManifestArray arr cs (Complex e), RealFloat e) => +applyFilter :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => Image arr cs e -- ^ Source image. -> Image arr cs e -- ^ Filter. -> Image arr cs e diff --git a/src/Graphics/Image/Processing/Complex/Fourier.hs b/src/Graphics/Image/Processing/Complex/Fourier.hs --- a/src/Graphics/Image/Processing/Complex/Fourier.hs +++ b/src/Graphics/Image/Processing/Complex/Fourier.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Graphics.Image.Processing.Complex.Fourier -- Copyright : (c) Alexey Kuleshevich 2016 @@ -29,7 +30,7 @@ | Inverse -- | Fast Fourier Transform -fft :: (ManifestArray arr cs (Complex e), RealFloat e) => +fft :: (Array arr cs (Complex e), RealFloat e) => Image arr cs (Complex e) -> Image arr cs (Complex e) fft = fft2d Forward @@ -37,7 +38,7 @@ -- | Inverse Fast Fourier Transform -ifft :: (ManifestArray arr cs (Complex e), RealFloat e) => +ifft :: (Array arr cs (Complex e), RealFloat e) => Image arr cs (Complex e) -> Image arr cs (Complex e) ifft = fft2d Inverse @@ -57,7 +58,7 @@ -- | Compute the DFT of a matrix. Array dimensions must be powers of two else `error`. -fft2d :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) => +fft2d :: (Array arr cs (Complex e), Num e, RealFloat e) => Mode -> Image arr cs (Complex e) -> Image arr cs (Complex e) @@ -76,11 +77,12 @@ {-# INLINE fft2d #-} -fftGeneral :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) => +fftGeneral :: (Array arr cs (Complex e), Num e, RealFloat e) => Pixel cs e -> Image arr cs (Complex e) -> Image arr cs (Complex e) fftGeneral !sign !img = transpose $ go n 0 1 where + imgM = toManifest img !(m, n) = dims img go !len !offset !stride | len == 2 = makeImage (m, 2) swivel @@ -89,8 +91,8 @@ (go (len `div` 2) (offset + stride) (stride * 2)) where swivel (m', j) = case j of - 0 -> index img (m', offset) + index img (m', offset + stride) - 1 -> index img (m', offset) - index img (m', offset + stride) + 0 -> index imgM (m', offset) + index imgM (m', offset + stride) + 1 -> index imgM (m', offset) - index imgM (m', offset + stride) _ -> error "FFT: Image must have exactly 2 columns. Please, report this bug." combine !len' evens odds = let odds' = traverse odds id diff --git a/src/Graphics/Image/Processing/Convolution.hs b/src/Graphics/Image/Processing/Convolution.hs --- a/src/Graphics/Image/Processing/Convolution.hs +++ b/src/Graphics/Image/Processing/Convolution.hs @@ -18,10 +18,10 @@ -convolve'' :: ManifestArray arr cs e => +convolve'' :: Array arr cs e => Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e convolve'' !border !kernel !img = - img `deepSeqImage` kernel `deepSeqImage` traverse2 kernel img (const . const sz) stencil + traverse2 (compute kernel) (compute img) (const . const sz) stencil where !(krnM, krnN) = dims kernel !krnM2 = krnM `div` 2 @@ -46,14 +46,14 @@ -- -- Example using : -- --- >>> frog <- readImageY "frog.jpg" +-- >>> frog <- readImageY RP "images/frog.jpg" -- >>> let frogX = convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]]) frog -- >>> let frogY = convolve Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]]) frog -- >>> displayImage $ normalize $ sqrt (frogX ^ 2 + frogY ^ 2) -- -- <> <> -- -convolve :: ManifestArray arr cs e => +convolve :: Array arr cs e => Border (Pixel cs e) -- ^ Approach to be used near the borders. -> Image arr cs e -- ^ Kernel image. -> Image arr cs e -- ^ Source image. @@ -63,14 +63,14 @@ -- | Convolve image's rows with a vector kernel represented by a list of pixels. -convolveRows :: ManifestArray arr cs e => +convolveRows :: Array arr cs e => Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e convolveRows !out = convolve out . fromLists . (:[]) . reverse {-# INLINE convolveRows #-} -- | Convolve image's columns with a vector kernel represented by a list of pixels. -convolveCols :: ManifestArray arr cs e => +convolveCols :: Array arr cs e => Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e convolveCols !out = convolve out . fromLists . P.map (:[]) . reverse {-# INLINE convolveCols #-} diff --git a/src/Graphics/Image/Processing/Geometric.hs b/src/Graphics/Image/Processing/Geometric.hs --- a/src/Graphics/Image/Processing/Geometric.hs +++ b/src/Graphics/Image/Processing/Geometric.hs @@ -16,7 +16,7 @@ -- ** Concatenation leftToRight, topToBottom, -- ** Canvas - translate, crop, superimpose, + translate, canvasSize, crop, superimpose, -- ** Flipping flipV, flipH, -- ** Rotation @@ -122,18 +122,63 @@ {-# INLINE topToBottom #-} +-- | Shift an image towards its bottom right corner by @(delatM, deltaN)@ rows and +-- columns, while specifying a border resolution strategy. +-- +-- >>> frog <- readImageRGB VU "images/frog.jpg" +-- >>> writeImage "images/frog_translate_wrap.jpg" $ translate Wrap (50, 100) frog +-- >>> writeImage "images/frog_translate_edge.jpg" $ translate Edge (50, 100) frog +-- +-- <> <> <> +-- +-- @since 1.2.0.0 +-- translate :: Array arr cs e - => Border (Pixel cs e) -> (Int, Int) -> Image arr cs e -> Image arr cs e -translate atBorder !(dm, dn) !img = traverse img id newPx where - newPx !getPx !(i, j) = handleBorderIndex atBorder (dims img) getPx (i - dm, j - dn) - {-# INLINE newPx #-} + => Border (Pixel cs e) -- ^ Border resolution strategy + -> (Int, Int) -- ^ Number of rows and columns image will be shifted by. + -> Image arr cs e -> Image arr cs e +translate atBorder !(dm, dn) !img = traverse img id newPx + where + newPx !getPx !(i, j) = + handleBorderIndex atBorder (dims img) getPx (i - dm, j - dn) + {-# INLINE newPx #-} {-# INLINE translate #-} +-- | Change the size of an image. Pixel values and positions will not change, +-- except the ones outside the border, which are handled according to supplied +-- resolution strategy. +-- +-- <> +-- +-- For example, it can be used to make a tile from the image above, or simply +-- scale the canvas and place it in a middle: +-- +-- >>> logo <- readImageRGBA VU "images/logo_40.png" +-- >>> let incBy (fm, fn) = (rows logo * fm, cols logo * fn) +-- >>> writeImage "images/logo_tile.png" $ canvasSize Wrap (incBy (6, 10)) logo +-- >>> writeImage "images/logo_center.png" $ translate (Fill 0) (incBy (2, 3)) $ canvasSize (Fill 0) (incBy (5, 7)) logo +-- +-- <> <> +-- +-- @since 1.2.1.0 +-- +canvasSize + :: Array arr cs e + => Border (Pixel cs e) -- ^ Border resolution strategy + -> (Int, Int) -- ^ New dimensions of the image + -> Image arr cs e -- ^ Source image + -> Image arr cs e +canvasSize atBorder !ds !img = traverse img (const ds) newPx + where + newPx !getPx !ix = handleBorderIndex atBorder (dims img) getPx ix + {-# INLINE newPx #-} +{-# INLINE canvasSize #-} + -- | Crop an image, i.e. retrieves a sub-image image with @m@ rows and @n@ -- columns. Make sure @(i + m, j + n)@ is not greater than dimensions of a --- source image. +-- source image, otherwise it will result in an error. crop :: Array arr cs e => (Int, Int) -- ^ @(i, j)@ starting index from within a source image. -> (Int, Int) -- ^ @(m, n)@ dimensions of a new image. @@ -179,7 +224,7 @@ -- | Flip an image vertically. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_flipV.jpg" $ flipV frog -- -- <> <> @@ -191,7 +236,7 @@ -- | Flip an image horizontally. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_flipH.jpg" $ flipH frog -- -- <> <> @@ -203,7 +248,7 @@ -- | Rotate an image clockwise by 90°. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_rotate90.jpg" $ rotate90 frog -- -- <> <> @@ -215,7 +260,7 @@ -- | Rotate an image by 180°. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_rotate180.jpg" $ rotate180 frog -- -- <> <> @@ -227,7 +272,7 @@ -- | Rotate an image clockwise by 270°. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_rotate270.jpg" $ rotate270 frog -- -- <> <> @@ -240,7 +285,7 @@ -- | Rotate an image clockwise by an angle Θ in radians. -- --- >>> frog <- readImageRGBA "images/frog.jpg" +-- >>> frog <- readImageRGBA VU "images/frog.jpg" -- >>> writeImage "images/frog_rotate330.png" $ rotate Bilinear (Fill 0) (11*pi/6) frog -- -- <> <> @@ -273,7 +318,7 @@ -- | Resize an image using an interpolation method. -- --- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog <- readImageRGB VU "images/frog.jpg" -- >>> writeImage "images/frog_resize.jpg" $ resize Bilinear Edge (100, 640) frog -- -- <> diff --git a/src/Graphics/Image/Processing/Interpolation.hs b/src/Graphics/Image/Processing/Interpolation.hs --- a/src/Graphics/Image/Processing/Interpolation.hs +++ b/src/Graphics/Image/Processing/Interpolation.hs @@ -39,8 +39,8 @@ instance Interpolation Nearest where - interpolate Nearest border !sz !getPx !(round -> i, round -> j) = - handleBorderIndex border sz getPx (i, j) + interpolate Nearest border !sz !getPx !(i, j) = + handleBorderIndex border sz getPx (round i, round j) {-# INLINE interpolate #-} diff --git a/src/Graphics/Image/Types.hs b/src/Graphics/Image/Types.hs --- a/src/Graphics/Image/Types.hs +++ b/src/Graphics/Image/Types.hs @@ -9,14 +9,14 @@ module Graphics.Image.Types ( module Graphics.Image.ColorSpace, module Graphics.Image.IO.Formats, - Array, Image, ManifestArray, SequentialArray, MutableArray, MImage, + Array, Image, MArray, MImage, Exchangable, Border(..), - VU(..), RD(..), RS(..), RP(..), + VU(..), RS(..), RP(..), ) where import Graphics.Image.ColorSpace import Graphics.Image.Interface import Graphics.Image.Interface.Vector (VU(..)) -import Graphics.Image.Interface.Repa (RD(..), RS(..), RP(..)) +import Graphics.Image.Interface.Repa (RS(..), RP(..)) import Graphics.Image.IO.Formats diff --git a/tests/Graphics/Image/ColorSpaceSpec.hs b/tests/Graphics/Image/ColorSpaceSpec.hs --- a/tests/Graphics/Image/ColorSpaceSpec.hs +++ b/tests/Graphics/Image/ColorSpaceSpec.hs @@ -24,7 +24,7 @@ arbitrary = PixelRGB <$> arbitrary <*> arbitrary <*> arbitrary -instance (SequentialArray VU RGB e, Arbitrary e) => Arbitrary (Image VU RGB e) where +instance (MArray VU RGB e, Arbitrary e) => Arbitrary (Image VU RGB e) where arbitrary = do (Positive m, Positive n) <- arbitrary II.mapM (const arbitrary) $ I.makeImage (m, n) (const $ PixelGray (0 :: Double)) diff --git a/tests/Graphics/Image/InterfaceSpec.hs b/tests/Graphics/Image/InterfaceSpec.hs --- a/tests/Graphics/Image/InterfaceSpec.hs +++ b/tests/Graphics/Image/InterfaceSpec.hs @@ -50,7 +50,7 @@ instance Arbitrary (Pixel RGB Double) where arbitrary = PixelRGB <$> arbitraryDouble <*> arbitraryDouble <*> arbitraryDouble -instance (SequentialArray arr cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image arr cs e) where +instance (MArray arr cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image arr cs e) where arbitrary = do (Positive (Small m), Positive (Small n)) <- arbitrary I.makeImageM (m, n) (const arbitrary) @@ -61,7 +61,13 @@ arbitrary = do (Positive (Small m), Positive (Small n)) <- arbitrary getPx <- arbitrary - return $ Identical (I.makeImage (m, n) getPx) (I.makeImage (m, n) getPx) + if (m, n) == (1, 1) + then do + img1 <- elements [I.makeImage (m, n) getPx, I.singleton (getPx (0, 0))] + img2 <- elements [I.makeImage (m, n) getPx, I.singleton (getPx (0, 0))] + return $ Identical img1 img2 + else return $ + Identical (I.makeImage (m, n) getPx) (I.makeImage (m, n) getPx) instance Arbitrary px => Arbitrary (Border px) where @@ -157,12 +163,12 @@ newPx getPx (i, j) = getPx ((i - dm) `mod` m, (j - dn) `mod` n) -prop_toFormLists :: Image VU Y Word8 -> Bool -prop_toFormLists img = img == I.fromLists (IM.toLists img) +prop_toFormLists :: (Array arr Y Word8, MArray arr Y Word8) => arr -> Image arr Y Word8 -> Bool +prop_toFormLists _ img = img == I.fromLists (IM.toLists img) prop_sameDims :: Array arr Y Word8 => arr -> Identical VU arr Y Word8 -> Bool -prop_sameDims _ (Identical img1 img2) = IM.dims img1 == IM.dims img2 +prop_sameDims _ (Identical img1 img2) = I.dims img1 == I.dims img2 prop_sameImage :: (Exchangable arr RS, Array arr Y Word8) @@ -226,30 +232,74 @@ (m, n) = I.dims img1 +prop_sameTraverse2 + :: (Exchangable arr RS, Array arr Y Word8) + => arr + -> ((Int, Int) -> (Int, Int) -> (Positive (Small Int), Positive (Small Int))) + -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8 -> Pixel Y Word8) + -> Identical VU arr Y Word8 + -> Identical VU arr Y Word8 + -> Bool +prop_sameTraverse2 _ g f (Identical img1a img2a) (Identical img1b img2b) = + I.exchange RS (I.traverse2 img1a img1b g' f') == + I.exchange RS (I.traverse2 img2a img2b g' f') + where + g' dimsA dimsB = + case g dimsA dimsB of + (Positive (Small i), Positive (Small j)) -> (i, j) + f' getPx1 getPx2 ix@(i, j) = + f ix (getPx1 (i `mod` ma, j `mod` na)) (getPx2 (i `mod` mb, j `mod` nb)) + (ma, na) = I.dims img1a + (mb, nb) = I.dims img1b + + +prop_sameTranspose + :: (Exchangable arr RS, Array arr Y Word8) + => arr + -> Identical VU arr Y Word8 + -> Bool +prop_sameTranspose _ (Identical img1 img2) = + I.exchange RS (I.transpose img1) == I.exchange RS (I.transpose img2) + + +prop_sameBackpermute + :: (Exchangable arr RP, Array arr Y Word8) + => arr + -> (Positive (Small Int), Positive (Small Int)) + -> ((Int, Int) -> (Int, Int)) + -> Identical VU arr Y Word8 + -> Bool +prop_sameBackpermute _ (Positive (Small m), Positive (Small n)) f (Identical img1 img2) = + I.exchange RP (I.backpermute (m, n) (f' . f) img1) == + I.exchange RP (I.backpermute (m, n) (f' . f) img2) + where + (m', n') = I.dims img1 + f' (i, j) = (i `mod` m', j `mod` n') + + spec :: Spec spec = do describe "Interface Properties" $ do it "borderIndex" $ property prop_borderIndex - it "toFormLists" $ property prop_toFormLists + it "toFormLists" $ property $ prop_toFormLists VU describe "Representation Properties" $ do - it "sameDims RD" $ property $ prop_sameDims RD it "sameDims RS" $ property $ prop_sameDims RS it "sameDims RP" $ property $ prop_sameDims RP - it "sameImage RD" $ property $ prop_sameImage RD it "sameImage RS" $ property $ prop_sameImage RS it "sameImage RP" $ property $ prop_sameImage RP - it "sameMap RD" $ property $ prop_sameMap RD it "sameMap RS" $ property $ prop_sameMap RS it "sameMap RP" $ property $ prop_sameMap RP - it "sameImap RD" $ property $ prop_sameImap RD it "sameImap RS" $ property $ prop_sameImap RS it "sameImap RP" $ property $ prop_sameImap RP - it "sameZipWith RD" $ property $ prop_sameZipWith RD it "sameZipWith RS" $ property $ prop_sameZipWith RS it "sameZipWith RP" $ property $ prop_sameZipWith RP - it "sameIZipWith RD" $ property $ prop_sameIZipWith RD it "sameIZipWith RS" $ property $ prop_sameIZipWith RS it "sameIZipWith RP" $ property $ prop_sameIZipWith RP - it "sameTraverse RD" $ property $ prop_sameTraverse RD it "sameTraverse RS" $ property $ prop_sameTraverse RS it "sameTraverse RP" $ property $ prop_sameTraverse RP + it "sameTraverse2 RS" $ property $ prop_sameTraverse2 RS + it "sameTraverse2 RP" $ property $ prop_sameTraverse2 RP + it "sameTranspose RS" $ property $ prop_sameTranspose RS + it "sameTranspose RP" $ property $ prop_sameTranspose RP + it "sameBackpermute RS" $ property $ prop_sameBackpermute RS + it "sameBackpermute RP" $ property $ prop_sameBackpermute RP diff --git a/tests/Graphics/Image/ProcessingSpec.hs b/tests/Graphics/Image/ProcessingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Image/ProcessingSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Image.ProcessingSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import qualified Graphics.Image.Interface as I +import Graphics.Image.Types +import Graphics.Image.Processing + +import Graphics.Image.InterfaceSpec (translateWrap, dummyImage10x20) + +data Interpol + = I1 Nearest + | I2 Bilinear + +instance Show Interpol where + show (I1 i) = "I1 " ++ show i + show (I2 i) = "I2 " ++ show i + +instance Arbitrary Interpol where + arbitrary = do + ix <- arbitrary + case ix `mod` (2 :: Int) of + 0 -> return $ I1 Nearest + 1 -> return $ I2 Bilinear + _ -> error $ "Unknown interpolation: " ++ show ix + + +prop_sampleRows :: Image VU Y Double -> Bool +prop_sampleRows img = img == downsampleRows (upsampleRows img) + +prop_sampleCols :: Image VU Y Double -> Bool +prop_sampleCols img = img == downsampleCols (upsampleCols img) + +prop_sample :: Image VU Y Double -> Bool +prop_sample img = img == downsample (upsample img) + +prop_translateWrap :: (Int, Int) -> Image VU RGB Double -> Bool +prop_translateWrap shift img = translateWrap shift img == translate Wrap shift img + +prop_cropSuperimpose :: (Positive (Small Int), Positive (Small Int)) + -> (Positive (Small Int), Positive (Small Int)) + -> Image VU Y Double -> Bool +prop_cropSuperimpose (Positive (Small iA), Positive (Small jA)) (Positive (Small mA), Positive (Small nA)) img = + img == superimpose (i0, j0) (crop (i0, j0) (m', n') img) img + where + (m, n) = I.dims img + (i0, j0) = (iA `mod` m, jA `mod` n) + (m', n') = (1 + mA `mod` (m - i0), 1 + nA `mod` (n - j0)) + +prop_concatRotate :: Image VU Y Word8 -> Bool +prop_concatRotate img = + topToBottom (rotate90 img) (rotate270 img) == + rotate90 (leftToRight img $ rotate180 img) + + +prop_rotate90 :: Interpol -> Border (Pixel RGB Double) -> Image VU RGB Double -> Bool +prop_rotate90 (I1 i) border img = rotate90 img == rotate i border (pi/2) img +prop_rotate90 (I2 i) border img = rotate90 img == rotate i border (pi/2) img + +prop_rotate180 :: Interpol -> Border (Pixel RGB Double) -> Image VU RGB Double -> Bool +prop_rotate180 (I1 i) border img = rotate180 img == rotate i border pi img +prop_rotate180 (I2 i) border img = rotate180 img == rotate i border pi img + +prop_rotate270 :: Interpol -> Border (Pixel RGB Double) -> Image VU RGB Double -> Bool +prop_rotate270 (I1 i) border img = rotate270 img == rotate i border (3*pi/2) img +prop_rotate270 (I2 i) border img = rotate270 img == rotate i border (3*pi/2) img + +prop_rotate360 :: Interpol -> Border (Pixel RGB Double) -> Image VU RGB Double -> Bool +prop_rotate360 (I1 i) border img = (rotate270 . rotate90) img == rotate i border (2*pi) img +prop_rotate360 (I2 i) border img = (rotate270 . rotate90) img == rotate i border (2*pi) img + + +spec :: Spec +spec = do + describe "Processing Properties" $ + do it "sampleRows" $ property prop_sampleRows + it "sampleCols" $ property prop_sampleCols + it "sample" $ property prop_sample + it "translateWrap" $ property prop_translateWrap + it "cropSuperimpose" $ property prop_cropSuperimpose + it "concatRotate" $ property prop_concatRotate + it "rotate90" $ property prop_rotate90 + it "rotate180" $ property prop_rotate180 + it "rotate270" $ property prop_rotate270 + it "rotate360" $ property prop_rotate360 + describe "Processing Errors" $ + do it "crop start index outside" $ + do shouldThrow (return $! crop (-1, -1) (1, 1) dummyImage10x20) anyException + shouldThrow (return $! crop (10, 20) (1, 1) dummyImage10x20) anyException + shouldThrow (return $! crop (15, 10) (1, 1) dummyImage10x20) anyException + shouldThrow (return $! crop (5, 21) (1, 1) dummyImage10x20) anyException + it "crop result image outside" $ + do shouldThrow (return $! crop (6, 6) (5, 15) dummyImage10x20) anyException + shouldThrow (return $! crop (5, 15) (5, 15) dummyImage10x20) anyException + it "crop negative dimensions" $ + do shouldThrow (return $! crop (1, 1) (-5, 15) dummyImage10x20) anyException + shouldThrow (return $! crop (1, 1) (5, -15) dummyImage10x20) anyException + it "upsample non-positive" $ + do shouldThrow (return $! upsampleF (0, 1) dummyImage10x20) anyException + shouldThrow (return $! upsampleF (1, 0) dummyImage10x20) anyException + shouldThrow (return $! upsampleF (-1, -1) dummyImage10x20) anyException + it "downsample non-positive" $ + do shouldThrow (return $! downsampleF (0, 1) dummyImage10x20) anyException + shouldThrow (return $! downsampleF (1, 0) dummyImage10x20) anyException + shouldThrow (return $! downsampleF (-1, -1) dummyImage10x20) anyException + it "concat dimension mismatch" $ + do shouldThrow + (return $! leftToRight dummyImage10x20 $ I.transpose dummyImage10x20) + anyException + shouldThrow + (return $! topToBottom dummyImage10x20 $ I.transpose dummyImage10x20) + anyException