hip 1.1.0.2 → 1.2.0.0

raw patch · 16 files changed

+597/−167 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +2/−0
• hip.cabal +4/−2
• src/Graphics/Image/ColorSpace/Binary.hs +1/−1
• src/Graphics/Image/IO.hs +4/−4
• src/Graphics/Image/IO/Formats/JuicyPixels.hs +5/−3
• src/Graphics/Image/IO/Formats/Netpbm.hs +15/−15
• src/Graphics/Image/IO/Histogram.hs +3/−2
• src/Graphics/Image/Interface.hs +59/−23
• src/Graphics/Image/Interface/Repa/Internal.hs +84/−55
• src/Graphics/Image/Interface/Vector.hs +3/−1
• src/Graphics/Image/Interface/Vector/Unboxed.hs +37/−14
• src/Graphics/Image/Processing/Geometric.hs +85/−41
• src/Graphics/Image/Processing/Interpolation.hs +6/−5
• tests/Graphics/Image/ColorSpaceSpec.hs +5/−1
• tests/Graphics/Image/Interface/VectorSpec.hs +29/−0
• tests/Graphics/Image/InterfaceSpec.hs +255/−0

@@ -5,6 +5,8 @@  Documentation is on [Hackage](http://hackage.haskell.org/package/hip). +[![Build Status](https://travis-ci.org/lehins/hip.svg?branch=master)](https://travis-ci.org/lehins/hip)+ Installation ------------ 

@@ -1,5 +1,5 @@ Name:              hip-Version:           1.1.0.2+Version:           1.2.0.0 License:           BSD3 License-File:      LICENSE Author:            Alexey Kuleshevich@@ -98,12 +98,14 @@   HS-Source-Dirs:     tests   Main-Is:            Spec.hs   Other-Modules:      Graphics.Image.ColorSpaceSpec+                    , Graphics.Image.InterfaceSpec+                    , Graphics.Image.Interface.VectorSpec   Build-Depends:      base            >= 4.5 && < 5                     , hip                     , hspec                     , QuickCheck   Default-Language:   Haskell2010-  GHC-Options:        -Wall+  GHC-Options:        -Wall -O0  Source-Repository head   Type:     git

@@ -99,7 +99,7 @@  instance ColorSpace Binary where   type PixelElt Binary e = e-  data Pixel Binary e = PixelBinary !e deriving Eq+  data Pixel Binary e = PixelBinary !e deriving (Ord, Eq)    fromChannel = PixelBinary   {-# INLINE fromChannel #-}

@@ -35,8 +35,8 @@ import Prelude as P hiding (readFile, writeFile) import qualified Control.Monad as M (foldM) - import Control.Concurrent (forkIO)+import Control.Monad (void) import Data.Char (toLower) import Data.Maybe (fromMaybe) @@ -175,14 +175,14 @@               displayImageFile viewer imgPath)   if block     then display-    else forkIO display >> return ()+    else void $ forkIO display    -- | Displays an image file by calling an external image viewer. displayImageFile :: ExternalViewer -> FilePath -> IO () displayImageFile (ExternalViewer exe args ix) imgPath =-  readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) "" >> return ()+  void $ readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) ""   where (argsBefore, argsAfter) = splitAt ix args  @@ -209,7 +209,7 @@ #elif defined(OS_Mac)   (ExternalViewer "open" [] 0) #else-  error $ "Graphics.Image.IO.defaultViewer: Could not determine default viewer."+  error "Graphics.Image.IO.defaultViewer: Could not determine default viewer." #endif  

@@ -392,7 +392,7 @@ -- BMP Format Reading  instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) BMP where-  decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeBitmap+  decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeBitmap  instance Array arr Y Word8 => Readable (Image arr Y Word8) BMP where   decode _ = jpImageY8ToImage . JP.decodeBitmap@@ -786,8 +786,10 @@  jpCSError :: String -> Either String JP.DynamicImage -> Either String a jpCSError _  (Left err)   = jpError err-jpCSError cs (Right jimg) = jpError ("Input image is in "++(jpImageShowCS jimg)++-                                     ", cannot convert it to "++cs++" colorspace.")+jpCSError cs (Right jimg) =+  jpError $+  "Input image is in " +++  jpImageShowCS jimg ++ ", cannot convert it to " ++ cs ++ " colorspace."   --------------------------------------------------------------------------------

@@ -171,22 +171,22 @@ -- BMP Format Reading (general)  instance Array arr Y Double => Readable (Image arr Y Double) PBM where-  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm+  decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm  instance Array arr Y Double => Readable (Image arr Y Double) PGM where-  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm+  decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm  instance Array arr Y Double => Readable (Image arr Y Double) PPM where-  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm+  decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm  instance Array arr YA Double => Readable (Image arr YA Double) PPM where-  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm+  decode _ = fmap (ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm  instance Array arr RGB Double => Readable (Image arr RGB Double) PPM where-  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm+  decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm  instance Array arr RGBA Double => Readable (Image arr RGBA Double) PPM where-  decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm+  decode _ = fmap (ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm  -- BMP Format Reading (exact) @@ -222,10 +222,10 @@   decode _ = pnmToImagesUsing pnmDataPPM16ToImage  -pnmToImagesUsing :: (Int -> Int -> PNM.PpmPixelData -> Either [Char] b)+pnmToImagesUsing :: (Int -> Int -> PNM.PpmPixelData -> Either String b)                  -> B.ByteString -> Either String [b] pnmToImagesUsing conv =-  either Left (Right . map (either error id . ppmToImageUsing conv)) . decodePnm+  fmap (map (either error id . ppmToImageUsing conv)) . decodePnm   getPx :: (Storable a, Convertible a b) => VS.Vector a -> Int -> (Int, Int) -> b@@ -270,9 +270,9 @@   ppmToImageUsing :: (Int -> Int -> PNM.PpmPixelData -> t) -> PNM.PPM -> t-ppmToImageUsing conv (PNM.PPM { PNM.ppmHeader = PNM.PPMHeader { PNM.ppmWidth  = w-                                                              , PNM.ppmHeight = h }-                              , PNM.ppmData   = ppmData }) = conv w h ppmData+ppmToImageUsing conv PNM.PPM {PNM.ppmHeader = PNM.PPMHeader {PNM.ppmWidth = w+                                                            ,PNM.ppmHeight = h}+                             ,PNM.ppmData = ppmData} = conv w h ppmData                                                           decodePnm :: B.ByteString -> Either String [PNM.PPM]@@ -282,15 +282,15 @@   pnmResultToImage (Left err)        = pnmError err  -- pnmError :: String -> Either String a pnmError err = Left ("Netpbm decoding error: "++err)   pnmCSError :: String -> PNM.PpmPixelData -> Either String a-pnmCSError cs ppmData = pnmError ("Input image is in "++(pnmShowData ppmData)++-                                  ", cannot convert it to "++cs++" colorspace.")+pnmCSError cs ppmData =+  pnmError $+  "Input image is in " +++  pnmShowData ppmData ++ ", cannot convert it to " ++ cs ++ " colorspace."  pnmShowData :: PNM.PpmPixelData -> String pnmShowData (PNM.PbmPixelData _)      = "Binary (Pixel Binary Bit)"

@@ -17,6 +17,7 @@  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@@ -102,12 +103,12 @@ displayHistogramsUsing viewer block hists = do   let display = do         tmpDir <- getTemporaryDirectory-        histPath <- fmap (</> "tmp-hist.svg") $ createTempDirectory tmpDir "hip-histogram"+        histPath <- fmap (</> "tmp-hist.svg") (createTempDirectory tmpDir "hip-histogram")         writeHistograms histPath hists         displayImageFile viewer histPath   if block     then display-    else forkIO display >> return ()+    else void $ forkIO display   

@@ -23,7 +23,7 @@ module Graphics.Image.Interface (   ColorSpace(..), Alpha(..), Elevator(..),   Array(..), ManifestArray(..), SequentialArray(..), MutableArray(..), -  Exchangable(..),+  Exchangable(..), exchangeFrom,   defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex,   ) where @@ -241,6 +241,8 @@ -- allowing for image indexing, forcing pixels into computed state etc. class Array arr cs e => ManifestArray arr cs e where +  unsafeIndex :: Image arr cs e -> (Int, Int) -> Pixel cs e+     -- | Get a pixel at @i@-th and @j@-th location.   --   -- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200)@@ -248,7 +250,9 @@   -- True   --   index :: Image arr cs e -> (Int, Int) -> Pixel cs e-  +  index !img !ix = borderIndex (error $ show img ++ " - Index out of bounds: " ++ show ix) img ix+  {-# INLINE index #-}+   -- | Make sure that an image is fully evaluated.   deepSeqImage :: Image arr cs e -> a -> a @@ -278,6 +282,15 @@   -- | Fold an image from the right in a row major order.   foldr :: (Pixel cs e -> a -> a) -> a -> Image arr cs e -> a +  -- | Create an Image by supplying it's dimensions and a monadic pixel+  -- generating action.+  makeImageM :: (Functor m, Monad m) =>+                (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.+             -> ((Int, Int) -> m (Pixel cs e))+                -- ^ A function that takes (@i@-th row, and @j@-th column) as an+                -- argument and generates a pixel for that location.+             -> m (Image arr cs e)+   -- | Monading mapping over an image.   mapM :: (SequentialArray arr cs' e', Functor m, Monad m) =>           (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m (Image arr cs e)@@ -331,6 +344,14 @@            -> 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.@@ -381,15 +402,16 @@               -- 'Continue' : 1 4 3 2 | 1 2 3 4 | 3 2 1 4               -- @               --+  deriving Show  -- | Border handling function. If @(i, j)@ location is within bounds, then supplied -- lookup function will be used, otherwise it will be handled according to a -- supplied border strategy.-handleBorderIndex :: Border (Pixel cs e) -- ^ Border handling strategy.+handleBorderIndex :: Border px -- ^ Border handling strategy.             -> (Int, Int) -- ^ Image dimensions-            -> ((Int, Int) -> Pixel cs e) -- ^ Image's indexing function.+            -> ((Int, Int) -> px) -- ^ Image's indexing function.             -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup.-            -> Pixel cs e+            -> px handleBorderIndex border !(m, n) !getPx !(i, j) =   if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else getPxB border where     getPxB (Fill px) = px@@ -401,9 +423,9 @@                               if j < 0 then (abs j - 1) `mod` n else                                 if j >= n then (n - (j - n + 1)) `mod` n else j)     getPxB Continue  = getPx (if i < 0 then abs i `mod` m else-                                if i >= m then m - (i - m + 2) `mod` m else i,+                                if i >= m then (m - (i - m + 2)) `mod` m else i,                               if j < 0 then abs j `mod` n else-                                if j >= n then n - (j - n + 2) `mod` n else j)+                                if j >= n then (n - (j - n + 2)) `mod` n else j)     {-# INLINE getPxB #-} {-# INLINE handleBorderIndex #-} @@ -418,8 +440,8 @@ -- | Image indexing function that uses a special border resolutions strategy for -- out of bounds pixels. borderIndex :: ManifestArray arr cs e =>-                Border (Pixel cs e) -> Image arr cs e -> (Int, Int) -> Pixel cs e-borderIndex !atBorder !img = handleBorderIndex atBorder (dims img) (index img)+               Border (Pixel cs e) -> Image arr cs e -> (Int, Int) -> Pixel cs e+borderIndex atBorder !img = handleBorderIndex atBorder (dims img) (unsafeIndex img) {-# INLINE borderIndex #-}  @@ -525,6 +547,14 @@   {-# INLINE acosh #-}  +instance (ColorSpace cs, Bounded e) => Bounded (Pixel cs e) where+  maxBound = fromChannel maxBound+  {-# INLINE maxBound #-}+  +  minBound = fromChannel minBound+  {-# INLINE minBound #-}++ instance (ManifestArray arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where   (==) = eq   {-# INLINE (==) #-}@@ -547,7 +577,7 @@   {-# INLINE signum #-}      fromInteger = singleton . fromInteger-  {-# INLINE fromInteger#-}+  {-# INLINE fromInteger #-}   instance (Fractional (Pixel cs e), Array arr cs e) =>@@ -568,7 +598,7 @@   {-# INLINE exp #-}      log   = map log-  {-# INLINE log#-}+  {-# INLINE log #-}      sin   = map sin   {-# INLINE sin #-}@@ -607,17 +637,23 @@   -instance Array arr cs e => Show (Image arr cs e) where-  show ((dims -> (m, n)) :: Image arr cs e) =-    "<Image "++show (undefined :: arr)++" "++-    ((showsTypeRep (typeOf (undefined :: cs))) " (")++-    ((showsTypeRep (typeOf (undefined :: e))) "): "++show m++"x"++show n++">")---instance MutableArray arr cs e => Show (MImage st arr cs e) where-  show ((mdims -> (m, n)) :: MImage st arr cs e) =-    "<MutableImage "++show (undefined :: arr)++" "++-    ((showsTypeRep (typeOf (undefined :: cs))) " (")++-    ((showsTypeRep (typeOf (undefined :: e))) "): "++show m++"x"++show n++">")+instance Array arr cs e =>+         Show (Image arr cs e) where+  show (dims -> (m, n)) =+    "<Image " +++    show (undefined :: arr) +++    " " +++    showsTypeRep (typeOf (undefined :: cs)) " (" +++    showsTypeRep (typeOf (undefined :: e)) "): " +++     show m ++ "x" ++ show n ++ ">"  +instance MutableArray arr cs e =>+         Show (MImage st arr cs e) where+  show (mdims -> (m, n)) =+    "<MutableImage " +++    show (undefined :: arr) +++    " " +++    showsTypeRep (typeOf (undefined :: cs)) " (" +++    showsTypeRep (typeOf (undefined :: e)) "): " +++     show m ++ "x" ++ show n ++ ">"

@@ -30,11 +30,11 @@ import qualified Prelude as P (map, mapM_) import Graphics.Image.Interface import Graphics.Image.ColorSpace.Binary (Bit(..))-import Graphics.Image.Interface.Vector.Unboxed (VU(..), fromUnboxedVector, toUnboxedVector)-import Control.Monad (liftM)+import Graphics.Image.Interface.Vector.Unboxed+       (VU(..), fromUnboxedVector, toUnboxedVector, checkDims) import Data.Array.Repa.Repr.Unboxed (Unbox) import qualified Data.Vector.Unboxed as V ((!))-import Data.Function (on)+ import Data.Typeable (Typeable) import Data.Array.Repa.Index import qualified Data.Array.Repa as R @@ -68,7 +68,7 @@                      | 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 (RScalar _                          ) = (1, 1)   dims (RUImage (R.extent -> (Z :. m :. n))) = (m, n)   dims (RDImage (R.extent -> (Z :. m :. n))) = (m, n)   {-# INLINE dims #-}@@ -76,7 +76,8 @@   singleton = RScalar   {-# INLINE singleton #-} -  makeImage !(m, n) !f = RDImage $ R.fromFunction (Z :. m :. n) (f . shT2)+  makeImage !(checkDims "RD.makeImage" -> (m, n)) !f =+    RDImage $ R.fromFunction (Z :. m :. n) (f . shT2)   {-# INLINE makeImage #-}    map f (RScalar px)        = RScalar (f px)@@ -94,7 +95,7 @@   {-# INLINE zipWith #-}    izipWith f (RScalar px1)        (RScalar px2)        = RScalar (f (0, 0) px1 px2)-  izipWith f (RScalar px1)        !img2                = imap (flip f px1) img2+  izipWith f (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@@ -103,13 +104,18 @@   {-# INLINE izipWith #-}    traverse (getDelayed -> arr) newDims newPx =-    RDImage $ R.traverse arr (tSh2 . newDims . shT2) newPixel where-    newPixel getPx = newPx (getPx . tSh2) . shT2+    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 (((.).(.)) tSh2 (newDims `on` shT2)) newPixel where-    newPixel getPx1 getPx2 = newPx (getPx1 . tSh2) (getPx2 . tSh2) . shT2+    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)@@ -117,17 +123,17 @@   transpose !img          = img   {-# INLINE transpose #-} -  backpermute _ _ img@(RScalar _)                = img-  backpermute (tSh2 -> sh) g (getDelayed -> arr) =+  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 isSquare+  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)-      !isSquare = (n > 0) && all (==n) (P.map length ls)+      !isRect = (m > 0) && (n > 0) && all (==n) (P.map length ls)   {-# INLINE fromLists #-}    @@ -143,7 +149,7 @@   dims (RSImage img) = dims img   {-# INLINE dims #-} -  makeImage !ix !f = computeS (makeImage ix f :: Image RD cs e)+  makeImage !(checkDims "RS.makeImage" -> ix) !f = computeS (makeImage ix f :: Image RD cs e)   {-# INLINE makeImage #-}    singleton = RSImage . singleton@@ -189,7 +195,7 @@   dims (RPImage img) = dims img   {-# INLINE dims #-} -  makeImage !ix = suspendedComputeP . makeImage ix+  makeImage !(checkDims "RP.makeImage" -> ix) !f = suspendedComputeP $ makeImage ix f   {-# INLINE makeImage #-}    singleton = RPImage . singleton@@ -227,41 +233,46 @@    instance Array RS cs e => ManifestArray RS cs e where -  index (RSImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j)-  index (RSImage (RScalar px))  (_, _) = px-  index _ _ = _errorCompute-  {-# INLINE index #-}+  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+  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 (RUImage arr)) = R.foldAllS f px0 arr   fold !f !px0 (RSImage (RScalar px))  = f px0 px-  fold _  _  _ = _errorCompute+  fold _  _  _ = _errorCompute "ManifestArray RS cs e :: fold"   {-# INLINE fold #-}    eq (RSImage (RUImage arr1)) (RSImage (RUImage arr2)) = R.equalsS arr1 arr2-  eq _ _ = _errorCompute+  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"   {-# INLINE eq #-}   instance Array RP cs e => ManifestArray RP cs e where -  index (RPImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j)-  index (RPImage (RScalar px))  (0, 0) = px-  index (RPImage (RScalar _))   (_, _) = error "Scalar Image can only be indexed at (0,0)."-  index _ _ = _errorCompute-  {-# INLINE index #-}+  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+  deepSeqImage _ = _errorCompute "ManifestArray RP cs e :: deepSeqImage"   {-# INLINE deepSeqImage #-}    (|*|) i1@(RPImage img1) i2@(RPImage img2) =@@ -270,11 +281,17 @@    fold !f !px0 (RPImage (RUImage arr)) = head . R.foldAllP f px0 $ arr   fold !f !px0 (RPImage (RScalar px))  = f px0 px-  fold _  _  _ = _errorCompute+  fold _  _  _ = _errorCompute "ManifestArray RP cs e :: fold"   {-# INLINE fold #-}    eq (RPImage (RUImage arr1)) (RPImage (RUImage arr2)) = head $ R.equalsP arr1 arr2-  eq _ _ = _errorCompute+  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 #-}    @@ -286,7 +303,9 @@   foldr !f !a = foldr f a . exchange VU   {-# INLINE foldr #-} -  mapM !f img = liftM (exchange RS) (mapM f (exchange VU img))+  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 #-}    mapM_ !f img = mapM_ f (exchange VU img)@@ -306,13 +325,13 @@   mdims (MRSImage (mdims -> sz)) = sz   {-# INLINE mdims #-} -  thaw img = liftM MRSImage (thaw (exchange VU img))+  thaw img = fmap MRSImage (thaw (exchange VU img))   {-# INLINE thaw #-} -  freeze (MRSImage mimg) = liftM (exchange RS) (freeze mimg)+  freeze (MRSImage mimg) = fmap (exchange RS) (freeze mimg)   {-# INLINE freeze #-} -  new sz = liftM MRSImage (new sz)+  new sz = fmap MRSImage (new sz)   {-# INLINE new #-}    read (MRSImage mimg) = read mimg@@ -367,7 +386,14 @@   exchange _ (RSImage img) = RPImage img   {-# INLINE exchange #-} + -- | O(1) - Changes to Repa representation.+instance Exchangable VU RD where+  exchange _ = delay . exchange RS+  {-# 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@@ -385,7 +411,7 @@ instance Exchangable RS VU where   exchange _ img@(RSImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr)   exchange _ (RSImage (RScalar px)) = singleton px-  exchange _ _                     = _errorCompute+  exchange _ _                     = _errorCompute "Exchangable RS VU :: unsafeIndex"   {-# INLINE exchange #-}  @@ -393,22 +419,22 @@ instance Exchangable RP VU where   exchange _ img@(RPImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr)   exchange _ (RPImage (RScalar px)) = singleton px-  exchange _ _                     = _errorCompute+  exchange _ _                     = _errorCompute "Exchangable RP VU :: unsafeIndex"   {-# INLINE exchange #-}  -- | Computes an image in parallel and ensures that all elements are evaluated. computeP :: (Array arr cs e, Array RP cs e, Exchangable arr RP) =>             Image arr cs e -> Image RP cs e-computeP !img = head $ do-  img' <- return $ exchange RP img+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-  img' <- return $ exchange RS img+computeS !img = head $! do+  let img' = exchange RS img   img' `deepSeqImage` return img' {-# INLINE computeS #-} @@ -421,25 +447,29 @@  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+  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)))+      R.sumAllS+        (R.slice arr1 (R.Any :. (i :: Int) :. R.All) R.*^+         R.slice arr2 (R.Any :. (j :: Int)))     {-# INLINE getPx #-}-mult _ _ = _errorCompute+mult _ _ = _errorCompute "Graphics.Image.Interface.Repa.Internal.mult" {-# INLINE mult #-}   shT2 :: DIM2 -> (Int, Int)-shT2 !(Z :. i :. j) = (i, j)+shT2 (Z :. i :. j) = (i, j) {-# INLINE shT2 #-}  tSh2 :: (Int, Int) -> DIM2-tSh2 !(i, j) = (Z :. i :. j) +tSh2 !(i, j) = Z :. i :. j  {-# INLINE tSh2 #-}  @@ -469,12 +499,11 @@ toRepaArray (RDImage arr) = arr toRepaArray (RScalar px) = R.fromFunction (Z :. 1 :. 1) $ const px   -_errorCompute :: t-_errorCompute = error "Image should be computed at ths point. Please report this error"+_errorCompute :: String -> t+_errorCompute err =+  error $+  err ++ ": Image should be computed at ths point. Please report this error."                          -_errorScalarOp :: t-_errorScalarOp = error "This operation is not allowed on scalar images."-  instance R.Elt Bit where   touch (Bit w) = R.touch w

@@ -13,7 +13,9 @@   -- * IO   readImageY, readImageYA, readImageRGB, readImageRGBA,   -- * Representation-  VU(..), +  VU(..),+  -- * Flat index conversion+  toIx, fromIx   ) where  import Graphics.Image.IO

@@ -17,7 +17,7 @@ -- Portability : non-portable -- module Graphics.Image.Interface.Vector.Unboxed (-  VU(..), Image(..), fromUnboxedVector, toUnboxedVector, fromIx, toIx+  VU(..), Image(..), fromUnboxedVector, toUnboxedVector, fromIx, toIx, checkDims   ) where  import Prelude hiding (map, zipWith)@@ -50,7 +50,8 @@   data Image VU cs e = VScalar !(Pixel cs e)                      | VUImage !Int !Int !(Vector (Pixel cs e))   -  makeImage !(m, n) !f = VUImage m n $ V.generate (m * n) (f . toIx n)+  makeImage !(checkDims "VU.makeImage" -> (m, n)) !f =+    VUImage m n $ V.generate (m * n) (f . toIx n)   {-# INLINE makeImage #-}    singleton = VScalar@@ -90,7 +91,7 @@     else VUImage m1 n1 (V.izipWith (\ !k !px1 !px2 -> f (toIx n1 k) px1 px2) v1 v2)   {-# INLINE izipWith #-} -  traverse !img !getNewDims !getNewPx = makeImage (getNewDims $ dims img) (getNewPx (index img))+  traverse !img !getNewDims !getNewPx = makeImage (getNewDims (dims img)) (getNewPx (index img))   {-# INLINE traverse #-}    traverse2 !img1 !img2 !getNewDims !getNewPx =@@ -102,7 +103,7 @@     {-# INLINE getPx #-}   {-# INLINE transpose #-} -  backpermute !(m, n) !f (VUImage _ n' v) =+  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)@@ -119,9 +120,9 @@  instance Array VU cs e => ManifestArray VU cs e where -  index (VUImage _ n v) !ix = v V.! fromIx n ix-  index (VScalar px)      _ = px-  {-# INLINE index #-}+  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@@ -147,7 +148,9 @@   eq (VUImage m1 n1 v1) (VUImage m2 n2 v2) =     m1 == m2 && n1 == n2 && V.all id (V.zipWith (==) v1 v2)   eq (VScalar px1)           (VScalar px2) = px1 == px2-  eq _                       _             = False+  eq (VUImage 1 1 v1) (VScalar px2) = v1 V.! 0 == px2+  eq (VScalar px1) (VUImage 1 1 v2) = v2 V.! 0 == px1+  eq _ _ = False   {-# INLINE eq #-}  @@ -161,6 +164,10 @@   foldr !f !a (VScalar px)    = f px a   {-# INLINE foldr #-} +  makeImageM !(checkDims "VU.makeImageM" -> (m, n)) !f =+    VUImage m n <$> V.generateM (m * n) (f . toIx n)+  {-# INLINE makeImageM #-}+   mapM !f (VUImage m n v) = VUImage m n <$> V.mapM f v   mapM !f (VScalar px)    = VScalar <$> f px   {-# INLINE mapM #-}@@ -219,6 +226,7 @@ toUnboxedVector :: Array VU cs e => Image VU cs e -> Vector (Pixel cs e) toUnboxedVector (VUImage _ _ v) = v toUnboxedVector (VScalar px) = V.singleton px+{-# INLINE toUnboxedVector #-}   -- | Construct a two dimensional image with @m@ rows and @n@ columns from a flat@@ -230,19 +238,34 @@ -- <<images/grad_fromVector.png>> --  fromUnboxedVector :: Array VU cs e => (Int, Int) -> Vector (Pixel cs e) -> Image VU cs e-fromUnboxedVector (m, n) v+fromUnboxedVector !(m, n) !v   | m * n == V.length v = VUImage m n v   | otherwise = error "fromUnboxedVector: m * n doesn't equal the length of a Vector."+{-# INLINE fromUnboxedVector #-}  --- | 2D index conversion to a flat vector index.-fromIx :: Int -> (Int, Int) -> Int-fromIx !n !(i, j) = i * n + j+-- | 2D to a flat vector index conversion.+--+-- __Note__: There is an implicit assumption that @j < n@+fromIx :: Int -- ^ @n@ columns+       -> (Int, Int) -- ^ @(i, j)@ row, column index+       -> Int -- ^ Flat vector index+fromIx !n !(i, j) = n * i + j {-# INLINE fromIx #-}  --- | Vector to 2D index conversion.-toIx :: Int -> Int -> (Int, Int)+-- | Flat vector to 2D index conversion.+toIx :: Int -- ^ @n@ columns+     -> Int -- ^ Flat vector index+     -> (Int, Int) -- ^ @(i, j)@ row, column index toIx !n !k = (k `div` n, k `mod` n) {-# INLINE toIx #-} ++checkDims :: String -> (Int, Int) -> (Int, Int)+checkDims err !ds@(m, n)+  | m <= 0 || n <= 0 = +    error $+    show err ++ ": Image dimensions are expected to be non-negative: " ++ show ds+  | otherwise = ds+{-# INLINE checkDims #-}

@@ -11,12 +11,12 @@ -- module Graphics.Image.Processing.Geometric (   -- ** Sampling-  downsampleRows, downsampleCols, downsample, -  upsampleRows, upsampleCols, upsample, +  downsampleRows, downsampleCols, downsample, downsampleF,+  upsampleRows, upsampleCols, upsample, upsampleF,   -- ** Concatenation   leftToRight, topToBottom,   -- ** Canvas-  crop,+  translate, crop, superimpose,   -- ** Flipping   flipV, flipH,   -- ** Rotation@@ -33,60 +33,64 @@ import Graphics.Image.Processing.Interpolation  --downsampleF :: Array arr cs e => Int -> Int -> Image arr cs e -> Image arr cs e-downsampleF !fm !fn !img = traverse img-                           (\ !(m, n) -> (m `div` fm, n `div` fn))-                           (\ !getPx !(i, j) -> getPx (i*fm, j*fn))+downsampleF :: Array arr cs e => (Int, Int) -> Image arr cs e -> Image arr cs e+downsampleF !(fm, fn) !img =+  traverse+    img+    (\ !(m, n) -> (m `div` fm, n `div` fn))+    (\ !getPx !(i, j) -> getPx (i * fm, j * fn)) {-# INLINE downsampleF #-}  -upsampleF :: Array arr cs e => Int -> Int -> Image arr cs e -> Image arr cs e-upsampleF !fm !fn !img = traverse img -                         (\ !(m, n) -> (m*fm, n*fn))-                         (\ !getPx !(i, j) ->-                           if i `mod` fm == 0 && j `mod` fn == 0-                           then getPx (i `div` fm, j `div` fn)-                           else fromChannel 0)+-- | Upsample an image by a positive factor. Every +upsampleF :: Array arr cs e => (Int, Int) -> Image arr cs e -> Image arr cs e+upsampleF !(fm, fn) !img =+  traverse+    img+    (\ !(m, n) -> (m * fm, n * fn))+    (\ !getPx !(i, j) ->+        if i `mod` fm == 0 && j `mod` fn == 0+          then getPx (i `div` fm, j `div` fn)+          else fromChannel 0) {-# INLINE upsampleF #-}   -- | Downsample an image by discarding every odd row. downsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e-downsampleRows = downsampleF 2 1+downsampleRows = downsampleF (2, 1) {-# INLINE downsampleRows #-}   -- | Downsample an image by discarding every odd column. downsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e-downsampleCols = downsampleF 1 2+downsampleCols = downsampleF (1, 2) {-# INLINE downsampleCols #-}   -- | Downsample an image by discarding every odd row and column. downsample :: Array arr cs e => Image arr cs e -> Image arr cs e-downsample = downsampleF 2 2+downsample = downsampleF (2, 2) {-# INLINE downsample #-}   -- | Upsample an image by inserting a row of back pixels after each row of a -- source image. upsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e-upsampleRows = upsampleF 2 1+upsampleRows = upsampleF (2, 1) {-# INLINE upsampleRows #-}   -- | Upsample an image by inserting a column of back pixels after each column of a -- source image. upsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e-upsampleCols = upsampleF 1 2+upsampleCols = upsampleF (1, 2) {-# INLINE upsampleCols #-}   -- | Upsample an image by inserting a row and a column of back pixels after each -- row and a column of a source image. upsample :: Array arr cs e => Image arr cs e -> Image arr cs e-upsample = upsampleF 2 2+upsample = upsampleF (2, 2) {-# INLINE upsample #-}  @@ -96,7 +100,7 @@ leftToRight !img1@(dims -> (_, n1)) !img2 = traverse2 img1 img2 newDims newPx where   newDims !(m1, _) !(m2, n2)     | m1 == m2  = (m1, n1 + n2)-    | otherwise = error ("Images must agree in numer of rows, but received: " +    | otherwise = error ("leftToRight: Images must agree in numer of rows, but received: "                           ++ show img1 ++ " and " ++ show img2)   {-# INLINE newDims #-}   newPx !getPx1 !getPx2 !(i, j) = if j < n1 then getPx1 (i, j) else getPx2 (i, j-n1)@@ -110,7 +114,7 @@ topToBottom !img1@(dims -> (m1, _)) !img2 = traverse2 img1 img2 newDims newPx where   newDims !(_, n1) !(m2, n2)     | n1 == n2  = (m1 + m2, n1)-    | otherwise = error ("Images must agree in numer of columns, but received: "+    | otherwise = error ("topToBottom: Images must agree in numer of columns, but received: "                          ++ show img1 ++ " and " ++ show img2)   {-# INLINE newDims #-}   newPx !getPx1 !getPx2 !(i, j) = if i < m1 then getPx1 (i, j) else getPx2 (i-m1, j)@@ -118,18 +122,55 @@ {-# INLINE topToBottom #-}  +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 #-}+{-# INLINE translate #-}++ -- | Crop an image, i.e. retrieves a sub-image image with @m@ rows and @n@--- columns. Make sure @(m + i, n + j)@ is not greater than dimensions of a+-- columns. Make sure @(i + m, j + n)@ is not greater than dimensions of a -- source image. crop :: Array arr cs e =>         (Int, Int)     -- ^ @(i, j)@ starting index from within a source image.      -> (Int, Int)     -- ^ @(m, n)@ dimensions of a new image.      -> Image arr cs e -- ^ Source image.      -> Image arr cs e              -crop !(i, j) sz = backpermute sz (\ !(i', j') -> (i' + i, j' + j))+crop !(i0, j0) !sz@(m', n') !img+  | i0 < 0 || j0 < 0 || i0 >= m || j0 >= n =+    error $+    "Graphics.Image.Processing.crop: Starting index: " +++    show (i0, j0) +++    " is greater than dimensions of the source image: " ++ show img+  | i0 + m' > m || j0 + n' > n =+    error $+    "Graphics.Image.Processing.crop: Result image dimensions: " +++    show (m', n') +++    " plus the offset: " +++    show (i0, j0) ++ " are bigger than the source image: " ++ show img+  | otherwise = backpermute sz (\ !(i, j) -> (i + i0, j + j0)) img+  where !(m, n) = dims img {-# INLINE crop #-}  +-- | Place one image on top of a source image, starting at a particular location within+-- a source image.+superimpose :: Array arr cs e =>+              (Int, Int)     -- ^ @(i, j)@ starting index from within a source image.+           -> Image arr cs e -- ^ Image to be positioned above the source image.+           -> Image arr cs e -- ^ Source image.+           -> Image arr cs e              +superimpose !(i0, j0) !imgA !imgB = traverse2 imgB imgA const newPx where+  (m, n) = dims imgA+  newPx getPxB getPxA (i, j) = let !(i', j') = (i - i0, j - j0) in+    if i' >= 0 && j' >= 0 && i' < m && j' < n then getPxA (i', j') else getPxB (i, j)+{-# INLINE superimpose #-}+++ flipUsing :: Array arr cs e =>              ((Int, Int) -> (Int, Int) -> (Int, Int)) -> Image arr cs e -> Image arr cs e flipUsing getNewIndex !img@(dims -> d) = backpermute d (getNewIndex d) img@@ -200,16 +241,17 @@ -- | Rotate an image clockwise by an angle Θ in radians. -- -- >>> frog <- readImageRGBA "images/frog.jpg"--- >>> writeImage "images/frog_rotate330.png" $ rotate (Bilinear (Fill 0)) (11*pi/6) frog+-- >>> writeImage "images/frog_rotate330.png" $ rotate Bilinear (Fill 0) (11*pi/6) frog -- -- <<images/frog.jpg>> <<images/frog_rotate330.png>> -- rotate :: (Array arr cs e, Elevator e, Interpolation method) =>-          method (Pixel cs e) -- ^ Interpolation method to be used+          method -- ^ Interpolation method to be used+       -> Border (Pixel cs e) -- ^ Border handling strategy        -> Double -- ^ Angle in radians        -> Image arr cs e -- ^ Source image        -> Image arr cs e -- ^ Rotated image-rotate !method !theta' !img = traverse img getNewDims getNewPx where+rotate !method border !theta' !img = traverse img getNewDims getNewPx where   !theta = angle0to2pi (-theta') -- invert angle direction and put it into [0, 2*pi) range   !sz@(m, n) = dims img   !(mD, nD) = (fromIntegral m, fromIntegral n)@@ -218,12 +260,12 @@   !(mD', nD') = (mD * cosThetaAbs + nD * sinThetaAbs, nD * cosThetaAbs + mD * sinThetaAbs)   !(iDelta, jDelta) =     case (sinTheta >= 0, cosTheta >= 0) of-         (True         , True         ) -> (nD * sinTheta, 0)    -- I quadrant-         (True         , False        ) -> (mD', -nD * cosTheta) -- II quadrant-         (False        , False        ) -> (-mD * cosTheta, nD') -- III quadrant-         (False        , True         ) -> (0, -mD * sinTheta)   -- IV quadrant+         (True,  True ) -> (nD * sinTheta, 0)    -- I quadrant+         (True,  False) -> (mD', -nD * cosTheta) -- II quadrant+         (False, False) -> (-mD * cosTheta, nD') -- III quadrant+         (False, True ) -> (0, -mD * sinTheta)   -- IV quadrant   getNewDims _ = (ceiling mD', ceiling nD')-  getNewPx getPx (i, j) = interpolate method sz getPx (i', j') where+  getNewPx getPx (i, j) = interpolate method border sz getPx (i', j') where     (iD, jD) = (fromIntegral i - iDelta + 0.5, fromIntegral j - jDelta + 0.5)     i' = iD * cosTheta + jD * sinTheta - 0.5     j' = jD * cosTheta - iD * sinTheta - 0.5@@ -232,20 +274,21 @@ -- | Resize an image using an interpolation method. -- -- >>> frog <- readImageRGB "images/frog.jpg"--- >>> writeImage "images/frog_resize.jpg" $ resize (Bilinear Edge) (100, 640) frog+-- >>> writeImage "images/frog_resize.jpg" $ resize Bilinear Edge (100, 640) frog -- -- <<images/frog_resize.jpg>> -- resize :: (Interpolation method, Array arr cs e, Elevator e) =>-          method (Pixel cs e) -- ^ Interpolation method to be used during scaling.+          method -- ^ Interpolation method to be used during scaling.+       -> Border (Pixel cs e) -- ^ Border handling strategy        -> (Int, Int)     -- ^ Dimensions of a result image.        -> Image arr cs e -- ^ Source image.        -> Image arr cs e -- ^ Result image.-resize !method !sz'@(m', n') !img = traverse img (const sz') getNewPx where+resize !method border !sz'@(m', n') !img = traverse img (const sz') getNewPx where   !sz@(m, n) = dims img   !(fM, fN) = (fromIntegral m' / fromIntegral m, fromIntegral n' / fromIntegral n)   getNewPx !getPx !(i, j) =-    interpolate method sz getPx ((fromIntegral i + 0.5) / fM - 0.5, (fromIntegral j + 0.5) / fN - 0.5)+    interpolate method border sz getPx ((fromIntegral i + 0.5) / fM - 0.5, (fromIntegral j + 0.5) / fN - 0.5)   {-# INLINE getNewPx #-} {-# INLINE resize #-} @@ -253,17 +296,18 @@ -- | Scale an image. Same as resize, except scaling factors are supplied -- instead of new dimensions. ----- @ scale ('Bilinear' 'Edge') (0.5, 2) frog == resize ('Bilinear' 'Edge') (100, 640) frog @+-- @ scale 'Bilinear' 'Edge' (0.5, 2) frog == resize 'Bilinear' 'Edge' (100, 640) frog @ -- scale :: (Interpolation method, Array arr cs e, Elevator e) =>-         method (Pixel cs e) -- ^ Interpolation method to be used during scaling.+         method -- ^ Interpolation method to be used during scaling.+      -> Border (Pixel cs e) -- ^ Border handling strategy       -> (Double, Double) -- ^ Positive scaling factors.       -> Image arr cs e -- ^ Source image.       -> Image arr cs e-scale !method !(fM, fN) !img@(dims -> (m, n)) =+scale !method border !(fM, fN) !img@(dims -> (m, n)) =   if fM <= 0 || fN <= 0   then error "scale: scaling factor must be greater than 0."-  else resize method (round (fM * fromIntegral m), round (fN * fromIntegral n)) img+  else resize method border (round (fM * fromIntegral m), round (fN * fromIntegral n)) img {-# INLINE scale #-}  

@@ -19,7 +19,8 @@    -- | Construct a new pixel by using information from neighboring pixels.   interpolate :: (Elevator e, Num e, ColorSpace cs) =>-                 method (Pixel cs e) -- ^ Interpolation method+                 method -- ^ Interpolation method+              -> Border (Pixel cs e) -- ^ Border resolution strategy               -> (Int, Int)          -- ^ Image dimensions @m@ rows and @n@ columns.               -> ((Int, Int) -> Pixel cs e)                  -- ^ Lookup function that returns a pixel at @i@th and @j@th@@ -29,23 +30,23 @@   -- | Nearest Neighbor interpolation method.-data Nearest px = Nearest !(Border px)+data Nearest = Nearest deriving Show   -- | Bilinear interpolation method.-data Bilinear px = Bilinear !(Border px)+data Bilinear = Bilinear deriving Show   instance Interpolation Nearest where -  interpolate (Nearest border) !sz !getPx !(round -> i, round -> j) =+  interpolate Nearest border !sz !getPx !(round -> i, round -> j) =     handleBorderIndex border sz getPx (i, j)   {-# INLINE interpolate #-}   instance Interpolation Bilinear where -  interpolate (Bilinear border) !sz !getPx !(i, j) = fi0 + jPx*(fi1-fi0) where+  interpolate Bilinear border !sz !getPx !(i, j) = fi0 + jPx*(fi1-fi0) where     getPx' = handleBorderIndex border sz getPx     {-# INLINE getPx' #-}     !(i0, j0) = (floor i, floor j)

@@ -1,8 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Graphics.Image.ColorSpaceSpec (spec) where +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Test.Hspec import Test.QuickCheck   @@ -26,7 +30,7 @@     II.mapM (const arbitrary) $ I.makeImage (m, n) (const $ PixelGray (0 :: Double))    -prop_ToFromElt :: (ColorSpace cs, Arbitrary cs, Arbitrary (Pixel cs e), Eq (Pixel cs e)) =>+prop_ToFromElt :: (ColorSpace cs, Eq (Pixel cs e)) =>                   Pixel cs e -> Bool prop_ToFromElt px = px == fromElt (toElt px) 

@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}+module Graphics.Image.Interface.VectorSpec (spec) where++import Test.Hspec+import Test.QuickCheck++import qualified Graphics.Image as IM+import qualified Graphics.Image.Interface.Vector as IV+import Graphics.Image.Types++import Graphics.Image.InterfaceSpec ()++prop_fromToIx :: Positive Int -> (NonNegative Int, NonNegative Int) -> Bool+prop_fromToIx (Positive n) (NonNegative i, NonNegative j) =+  (i, j `mod` n) == IV.toIx n (IV.fromIx n (i, j `mod` n))++prop_toFromIx :: Positive Int -> NonNegative Int -> Bool+prop_toFromIx (Positive n) (NonNegative k) = k == IV.fromIx n (IV.toIx n k)++prop_toFromVector+  :: Image VU Y Word8 -> Bool+prop_toFromVector img = img == IV.fromUnboxedVector (IM.dims img) (IV.toUnboxedVector img)++spec :: Spec+spec = do+  describe "Vector Representation Properties" $ do+    it "fromToIx" $ property $ prop_fromToIx+    it "toFromIx" $ property $ prop_toFromIx+    it "toFromVector" $ property $ prop_toFromVector

@@ -0,0 +1,255 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.Image.InterfaceSpec+  ( spec+  , translateWrap+  , dummyImage10x20+  , Identical (..)+  ) where++#if MIN_VERSION_base(4,8,0)+import Data.Typeable (Typeable, typeOf)+#else+import Control.Applicative+#endif+import Test.Hspec+import Test.QuickCheck++import qualified Graphics.Image as IM+import qualified Graphics.Image.Interface as I+import Graphics.Image.Types+import Graphics.Image.Processing+++data Identical arr1 arr2 cs e =+  Identical (Image arr1 cs e)+       (Image arr2 cs e)+  deriving (Show)++-- | Generator for values in range @[0, 1]@+arbitraryDouble :: Gen Double+arbitraryDouble = do+  Positive v <- arbitrary+  let v' = v - fromInteger (floor v)+  if v' == 0+    then choose (0, 1)+    else return v'++instance Arbitrary (Pixel Y Word8) where+  arbitrary = PixelY <$> arbitrary++instance Arbitrary (Pixel Y Double) where+  arbitrary = PixelY <$> arbitraryDouble++instance Arbitrary (Pixel RGB Word8) where+  arbitrary = PixelRGB <$> arbitrary <*> arbitrary <*> arbitrary++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+  arbitrary = do+    (Positive (Small m), Positive (Small n)) <- arbitrary+    I.makeImageM (m, n) (const arbitrary)+++instance (Array arr1 cs e, Array arr2 cs e, Arbitrary (Pixel cs e)) =>+         Arbitrary (Identical arr1 arr2 cs e) where+  arbitrary = do+    (Positive (Small m), Positive (Small n)) <- arbitrary+    getPx <- arbitrary+    return $ Identical (I.makeImage (m, n) getPx) (I.makeImage (m, n) getPx)+++instance Arbitrary px => Arbitrary (Border px) where+  arbitrary = do+    methodIx <- arbitrary+    case methodIx `mod` 5 :: Int of+      0 -> Fill <$> arbitrary+      1 -> return Wrap+      2 -> return Edge+      3 -> return Reflect+      4 -> return Continue+      _ -> error "Unknown method"+++#if MIN_VERSION_base(4,8,0)+instance (Typeable a, Typeable b) => Show (a -> b) where+  show _ = show $ typeOf (undefined :: a -> b)+#else+instance Show (a -> b) where+  show _ = "Function"+#endif+++instance CoArbitrary e => CoArbitrary (Pixel Y e) where+  coarbitrary (PixelY y) = coarbitrary y+++dummyImage10x20 :: Image VU Y Word8+dummyImage10x20 = I.makeImage (10, 20) (fromIntegral . (uncurry (+)))+++prop_borderIndex+  :: Border (Pixel RGB Double)+  -> Image VU RGB Double+  -> (Positive Int, Positive Int)+  -> Bool+prop_borderIndex border img (Positive i, Positive j) =+  I.borderIndex border img (iOut, jOut) == I.index bigImg (iBig, jBig)+  where+    bigImg = foldr1 topToBottom $ map (foldr1 leftToRight) imgs+    (m, n) = I.dims img+    (iBig, jBig) = (i `mod` (3 * m), j `mod` (3 * n))+    (iOut, jOut) = (iBig - m, jBig - n)+    imgs =+      case border of+        Fill px ->+          let filled = I.map (const px) img+          in [ [filled, filled, filled]+             , [filled, img, filled]+             , [filled, filled, filled]+             ]+        Wrap -> [[img, img, img], [img, img, img], [img, img, img]]+        Edge ->+          [ [ I.traverse img id (\getPx _ -> getPx (0, 0))+            , I.traverse img id (\getPx (_, j') -> getPx (0, j'))+            , I.traverse img id (\getPx _ -> getPx (0, n - 1))+            ]+          , [ I.traverse img id (\getPx (i', _) -> getPx (i', 0))+            , img+            , I.traverse img id (\getPx (i', _) -> getPx (i', n - 1))+            ]+          , [ I.traverse img id (\getPx _ -> getPx (m - 1, 0))+            , I.traverse img id (\getPx (_, j') -> getPx (m - 1, j'))+            , I.traverse img id (\getPx _ -> getPx (m - 1, n - 1))+            ]+          ]+        Reflect ->+          let h = flipH img+              v = flipV img+              c = flipH v+          in [[c, v, c], [h, img, h], [c, v, c]]+        Continue ->+          let h = flipH img+              v = flipV img+              c = flipH v+          in+          [ [ translateWrap (1, 1) c+            , translateWrap (1, 0) v+            , translateWrap (1, -1) c+            ]+          , [translateWrap (0, 1) h, img, translateWrap (0, -1) h]+          , [ translateWrap (-1, 1) c+            , translateWrap (-1, 0) v+            , translateWrap (-1, -1) c+            ]+          ]+++translateWrap :: Array arr cs e => (Int, Int) -> Image arr cs e -> Image arr cs e+translateWrap (dm, dn) img = I.traverse img id newPx+  where+    (m, n) = I.dims img+    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_sameDims :: Array arr Y Word8 => arr -> Identical VU arr Y Word8 -> Bool+prop_sameDims _ (Identical img1 img2) = IM.dims img1 == IM.dims img2++prop_sameImage+  :: (Exchangable arr RS, Array arr Y Word8)+  => arr -> Identical VU arr Y Word8 -> Bool+prop_sameImage _ (Identical img1 img2) = I.exchange RS img1 == I.exchange RS img2++prop_sameMap+  :: (Exchangable arr RS, Array arr Y Word8)+  => arr -> (Pixel Y Word8 -> Pixel Y Word8) -> Identical VU arr Y Word8 -> Bool+prop_sameMap _ f (Identical img1 img2) =+  I.exchange RS (I.map f img1) == I.exchange RS (I.map f img2)++prop_sameImap+  :: (Exchangable arr RP, Array arr Y Word8)+  => arr -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8) -> Identical VU arr Y Word8 -> Bool+prop_sameImap _ f (Identical img1 img2) =+  I.exchange RP (I.imap f img1) == I.exchange RP (I.imap f img2)+++prop_sameZipWith+  :: (Exchangable arr RP, Array arr Y Word8)+  => arr+  -> (Pixel Y Word8 -> Pixel Y Word8)+  -> (Pixel Y Word8 -> Pixel Y Word8 -> Pixel Y Word8)+  -> Identical VU arr Y Word8+  -> Bool+prop_sameZipWith _ g f (Identical img1 img2) =+  I.exchange RP (I.zipWith f img1 img1') ==+  I.exchange RP (I.zipWith f img2 img2')+  where+    img1' = I.map g img1+    img2' = I.map g img2++prop_sameIZipWith+  :: (Exchangable arr RP, Array arr Y Word8)+  => arr+  -> (Pixel Y Word8 -> Pixel Y Word8)+  -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8 -> Pixel Y Word8)+  -> Identical VU arr Y Word8+  -> Bool+prop_sameIZipWith _ g f (Identical img1 img2) =+  I.exchange RP (I.izipWith f img1 img1') ==+  I.exchange RP (I.izipWith f img2 img2')+  where+    img1' = I.map g img1+    img2' = I.map g img2++prop_sameTraverse+  :: (Exchangable arr RS, Array arr Y Word8)+  => arr+  -> ((Int, Int) -> (Positive (Small Int), Positive (Small Int)))+  -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8)+  -> Identical VU arr Y Word8+  -> Bool+prop_sameTraverse _ g f (Identical img1 img2) =+  I.exchange RS (I.traverse img1 (g' . g) f') ==+  I.exchange RS (I.traverse img2 (g' . g) f')+  where+    g' (Positive (Small i), Positive (Small j)) = (i, j)+    f' getPx ix@(i, j) = f ix (getPx (i `mod` m, j `mod` n))+    (m, n) = I.dims img1+++spec :: Spec+spec = do+  describe "Interface Properties" $ do+    it "borderIndex" $ property prop_borderIndex+    it "toFormLists" $ property prop_toFormLists+  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