friday 0.1.5 → 0.2.3.2
raw patch · 44 files changed
Files
- bench/Benchmark.hs +0/−190
- changelog +53/−0
- example/Canny.hs +0/−39
- example/Delayed.hs +0/−44
- example/GaussianBlur.hs +0/−35
- example/Histogram.hs +0/−46
- example/ResizeImage.hs +0/−28
- example/Threshold.hs +0/−18
- friday.cabal +26/−109
- src/Vision/Detector/Edge.hs +16/−12
- src/Vision/Histogram.hs +20/−9
- src/Vision/Image.hs +7/−3
- src/Vision/Image/Class.hs +235/−0
- src/Vision/Image/Contour.hs +405/−0
- src/Vision/Image/Conversion.hs +170/−0
- src/Vision/Image/Filter.hs +90/−623
- src/Vision/Image/Filter/Internal.hs +762/−0
- src/Vision/Image/Grey.hs +0/−1
- src/Vision/Image/Grey/Conversion.hs +0/−47
- src/Vision/Image/Grey/Specialize.hs +55/−4
- src/Vision/Image/Grey/Type.hs +5/−2
- src/Vision/Image/HSV.hs +0/−1
- src/Vision/Image/HSV/Conversion.hs +0/−91
- src/Vision/Image/HSV/Type.hs +10/−2
- src/Vision/Image/Interpolate.hs +3/−2
- src/Vision/Image/Mutable.hs +19/−13
- src/Vision/Image/Parallel.hs +67/−0
- src/Vision/Image/RGB.hs +0/−1
- src/Vision/Image/RGB/Conversion.hs +0/−34
- src/Vision/Image/RGB/Type.hs +10/−2
- src/Vision/Image/RGBA.hs +0/−1
- src/Vision/Image/RGBA/Conversion.hs +0/−22
- src/Vision/Image/RGBA/Type.hs +10/−2
- src/Vision/Image/Storage.hsc +0/−381
- src/Vision/Image/Threshold.hs +150/−32
- src/Vision/Image/Transform.hs +11/−9
- src/Vision/Image/Type.hs +46/−239
- src/Vision/Primitive.hs +9/−0
- src/Vision/Primitive/Shape.hs +64/−3
- test/Test.hs +2/−0
- test/Test/Utils.hs +15/−0
- test/Test/Vision/Histogram.hs +114/−0
- test/Test/Vision/Image.hs +131/−0
- test/Test/Vision/Primitive.hs +41/−0
− bench/Benchmark.hs
@@ -1,190 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleContexts #-}-import Control.Monad.ST.Safe (ST)-import Criterion.Main-import Data.Int-import Data.Word--import Vision.Image (- Grey, HSV, RGBA, RGB, RGBDelayed, InterpolMethod- )-import qualified Vision.Detector.Edge as D (canny)-import qualified Vision.Image as I-import Vision.Histogram (Histogram)-import qualified Vision.Histogram as H-import Vision.Primitive--path :: FilePath-path = "bench/image.jpg"--main :: IO ()-main = do- Right io <- I.load Nothing path- let !(Z :. h :. w) = I.shape rgb- !halfSize = Rect (w `quot` 2) (h `quot` 2)- (w `quot` 2) (h `quot` 2)- !rgb = I.convert io :: RGB- !rgba = I.convert rgb :: RGBA- !grey = I.convert rgb :: Grey- !edges = canny' grey- !hsv = I.convert rgb :: HSV- !hist = H.histogram Nothing grey :: H.Histogram DIM1 Int32- !hist2D = H.histogram2D (ix3 256 3 3) grey- :: H.Histogram DIM3 Int32-- defaultMain [- bgroup "IO" [- bench "load" $ whnfIO $ I.load Nothing path- ]- , bgroup "conversion" [- bench "RGB to grey" $ whnf (I.convert :: RGB -> Grey) rgb- , bench "RGBA to grey" $ whnf (I.convert :: RGBA -> Grey) rgba- , bench "RGBA to RGB" $ whnf (I.convert :: RGBA -> RGB) rgba- , bench "RGB to RGBA" $ whnf (I.convert :: RGB -> RGBA) rgb- , bench "RGB to HSV" $ whnf (I.convert :: RGB -> HSV) rgb- , bench "HSV to RGB" $ whnf (I.convert :: HSV -> RGB) hsv- ]- , bgroup "crop" [- bench "RGB" $ whnf (I.crop halfSize :: RGB -> RGB) rgb- ]- , bgroup "detector" [- bench "Canny's edge detector" $ whnf canny' grey- ]- , bgroup "filter" [- bench "erode" $ whnf erode' grey- , bench "blur" $ whnf blur' grey- , bench "gaussian blur" $ whnf gaussianBlur' grey- , bench "scharr" $ whnf scharr' grey- , bench "sobel" $ whnf sobel' grey- ]- , bgroup "flip" [- bench "horizontal" $ whnf (I.horizontalFlip :: RGB -> RGB) rgb- , bench "vertical" $ whnf (I.verticalFlip :: RGB -> RGB) rgb- ]- , bench "flood-fill" $ whnf floodFill' edges- , bgroup "histogram" [- bench "calculate 1D histogram of a grey image" $- whnf (H.histogram Nothing :: Grey -> Histogram DIM1 Int32) grey- , bench "calculate 3D histogram of a RGB image" $- whnf (H.histogram Nothing :: RGB -> Histogram DIM3 Int32) rgb- , bench "calculate 3D histogram (9 regions) of a grey image" $- whnf (H.histogram2D (ix3 256 3 3)- :: Grey -> Histogram DIM3 Int32)- grey-- , bench "reduce an Int32 histogram" $ whnf H.reduce hist2D- , bench "resize an Int32 histogram" $ whnf (H.resize (ix1 128))- hist-- , bench "cumulative Int32 histogram" $ whnf H.cumulative hist-- , bench "normalize histogram" $- whnf (H.normalize 1- :: Histogram DIM1 Int32 -> Histogram DIM1 Double)- hist- , bench "equalize grey image" $- whnf (H.equalizeImage :: Grey -> Grey) grey-- , bench "correlation comparison" $- whnf (H.compareCorrel hist :: Histogram DIM1 Int32 -> Double)- hist- , bench "chi-square comparison" $- whnf (H.compareChi hist :: Histogram DIM1 Int32 -> Double) hist- , bench "intersection comparison" $- whnf (H.compareIntersect hist :: Histogram DIM1 Int32 -> Int32)- hist- , bench "EMD comparison" $ whnf (H.compareEMD hist) hist-- , bench "2D correlation comparison" $- whnf (H.compareCorrel hist2D :: Histogram DIM3 Int32 -> Double)- hist2D- , bench "2D chi-square comparison 2D" $- whnf (H.compareChi hist2D :: Histogram DIM3 Int32 -> Double)- hist2D- , bench "2D intersection comparison 2D" $- whnf (H.compareIntersect hist2D- :: Histogram DIM3 Int32 -> Int32)- hist2D- ]- , bgroup "resize" [- bench "truncate-integer 50%" $- whnf (resize' I.TruncateInteger (ix2 (h `quot` 2) (w `quot` 2)))- rgb- , bench "truncate-integer 200%" $- whnf (resize' I.TruncateInteger (ix2 (h * 2) (w * 2))) rgb- , bench "nearest-neighbor 50%" $- whnf (resize' I.NearestNeighbor (ix2 (h `quot` 2) (w `quot` 2)))- rgb- , bench "nearest-neighbor 200%" $- whnf (resize' I.NearestNeighbor (ix2 (h * 2) (w * 2))) rgb- , bench "bilinear 50%" $- whnf (resize' I.Bilinear (ix2 (h `quot` 2) (w `quot` 2))) rgb- , bench "bilinear 200%" $- whnf (resize' I.Bilinear (ix2 (h * 2) (w * 2))) rgb- ]- , bgroup "threshold" [- bench "simple threshold" $ whnf threshold' grey- , bench "adaptive threshold" $ whnf adaptiveThreshold' grey- , bench "Otsu's method" $ whnf otsu' grey- ]--- , bgroup "application" [- bench "miniature 150x150" $ whnf miniature rgb- ]- ]- where- canny' :: Grey -> Grey- canny' !img = D.canny 2 256 1024 img-- erode' :: Grey -> Grey- erode' !img = I.erode 1 `I.apply` img-- blur' :: Grey -> Grey- blur' !img =- let filt = I.blur 1 :: I.SeparableFilter I.GreyPixel Word32 I.GreyPixel- in filt `I.apply` img-- gaussianBlur' :: Grey -> Grey- gaussianBlur' !img =- let filt = I.gaussianBlur 1 Nothing :: I.SeparableFilter I.GreyPixel- Float- I.GreyPixel- in filt `I.apply` img-- sobel' :: Grey -> I.Manifest Int16- sobel' !img = I.sobel 1 I.DerivativeX `I.apply` img-- scharr' :: Grey -> I.Manifest Int16- scharr' !img = I.scharr I.DerivativeX `I.apply` img-- floodFill' :: Grey -> I.Grey- floodFill' img =- I.create $ do- mut <- I.thaw img :: ST s (I.MutableManifest I.GreyPixel s)- I.floodFill (ix2 5 5) 255 mut- return mut-- resize' :: InterpolMethod -> Size -> RGB -> RGB- resize' = I.resize-- threshold' :: Grey -> Grey- threshold' !img = I.threshold (> 127) (I.BinaryThreshold 0 255) img-- adaptiveThreshold' :: Grey -> Grey- adaptiveThreshold' !img =- let filt :: I.SeparableFilter I.GreyPixel Float I.GreyPixel- filt = I.adaptiveThreshold (I.GaussianKernel Nothing) 1 0- (I.BinaryThreshold 0 255)- in filt `I.apply` img-- otsu' :: Grey -> Grey- otsu' !img = I.otsu (I.BinaryThreshold 0 255) img-- miniature !rgb =- let Z :. h :. w = I.shape rgb- in if w > h- then resizeSquare $ I.crop (Rect ((w - h) `quot` 2) 0 h h) rgb- else resizeSquare $ I.crop (Rect 0 ((h - w) `quot` 2) w w) rgb-- resizeSquare :: RGBDelayed -> RGB- resizeSquare = I.resize I.Bilinear (Z :. 150 :. 150)
+ changelog view
@@ -0,0 +1,53 @@+-*-change-log-*-++v0.2.4.0 TDB+ * Minimum base is now 4.8++v0.2.3.1 December 2016+ * Merge fix for storable instance++v0.2.3.0 December 2016+ * Add Contour Tracing (Vision.Image.Contour)+ * Add pointer to friday-juicypixels+ * First release by TomMD - Raphael is MIA but it remains his package.++v0.2.2.0 June 2015+ * New 'computeP' function to compute an image in parallel.++v0.2.1.2 May 2015+ * Add test modules under `other-modules`.++v0.2.1.1 April 2015+ * Removes an orphan dependency to bytetring.+ * Fixes some warning when compiled with GHC 7.10.++v0.2.1.0 March 2015+ * Grey to HSV conversion.++v0.2.0.2 February 2015+ * Minor documentation improvements.++v0.2.0.1 January 2015+ * Setup.hs script.++v0.2 January 2015+ BREAKING CHANGES:+ * Origin is on the upper left corner of the image (was bottom left).+ * New simplified filters interface. The old interface is still used+ internally to create filters and is available in+ Vision.Image.Filter.Internal.+ * DevIL bindings (Vision.Image.Storage) are now in a separate package+ (friday-devil) and with an improved interface.+ * Benchmarks are now in a separate package (friday-bench).+ * Examples are now in a separate package (friday-examples).+ * Pixel instance is no more required for MaskedImage and Image instances.++ * SCW thresholding.+ * New types aliases for filters.+ * New (!) and (!?) operators for image and histogram indexing.+ * Classes and image types are in two different files (Vision.Image.Class and+ Vision.Image.Type).+ * NFData instance for Manifest images.++v0.1 August 2014+ * Initial release
− example/Canny.hs
@@ -1,39 +0,0 @@-import Prelude hiding (filter)-import System.Environment (getArgs)--import Vision.Detector.Edge (canny)-import Vision.Image---- Detects the edge of the image with the Canny's edge detector.------ usage: ./canny input.png output.png-main :: IO ()-main = do- [input, output] <- getArgs-- -- Loads the image. Automatically infers the format.- io <- load Nothing input-- case io of- Left _err -> putStrLn "Error while reading the image."- Right img -> do- let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to- -- a Grey image (edges are detected on greyscale images).- grey = convert img :: Grey-- -- Creates a Gaussian filter with a 3x3 kernel to remove small- -- noises.- filter = gaussianBlur 1 Nothing :: SeparableFilter GreyPixel- Float- GreyPixel-- -- Applies the Gaussian filter to the grey-scale image.- blurred = apply filter grey :: Grey-- -- Applies the Canny's algorithm with a 5x5 Sobel kernel (radius- -- = 2).- edges = canny 2 256 1024 blurred :: Grey-- -- Saves the edges image. Ignores any runtime error.- _ <- save output edges- return ()
− example/Delayed.hs
@@ -1,44 +0,0 @@-import System.Environment (getArgs)--import Vision.Image-import Vision.Primitive (Z (..), (:.) (..), Rect (..), ix2)---- Reads an image from a file, applies a composition of transformations to--- create a centred and squared miniature and then writes the result to a file:------ usage: ./delayed input.png output.png-main :: IO ()-main = do- [input, output] <- getArgs-- -- Loads the image. Automatically infers the format.- io <- load Nothing input-- case io of- Left _err -> putStrLn "Error while reading the image."- Right img -> do- let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to- -- an RGB image.- rgb = convert img :: RGB-- -- Gets the size of the image.- Z :. h :. w = shape rgb-- -- Creates a Rect object which will be used to define how we- -- will crop our image. The rectangle is centered on the largest- -- side of the image.- rect | w > h = Rect ((w - h) `quot` 2) 0 h h- | otherwise = Rect 0 ((h - w) `quot` 2) w w-- -- Crops the image. Doesn't compute the image into a "real"- -- image: by using a delayed representation, this intermediate- -- image will not exist in the computer memory as a large array.- cropped = delayed $ crop rect rgb-- -- Resizes the image. By using the delayed representation of the- -- cropped image, our compiler should be able to fuse these two- -- transformations into a single loop.- resized = manifest $ resize Bilinear (ix2 250 250) cropped-- _ <- save output resized- return ()
− example/GaussianBlur.hs
@@ -1,35 +0,0 @@-import Prelude hiding (filter)-import System.Environment (getArgs)--import Vision.Image---- Applies a Gaussian blur to an image.------ usage: ./gaussian_blur input.png output.png-main :: IO ()-main = do- [input, output] <- getArgs-- -- Loads the image. Automatically infers the format.- io <- load Nothing input-- case io of- Left _err -> putStrLn "Error while reading the image."- Right img -> do- let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to- -- a Grey image (filters are currently only supported on single- -- channel images).- grey = convert img :: Grey-- -- Creates a Gaussian filter with a 21x21 kernel (kernel radius- -- of 10px).- filter = gaussianBlur 10 Nothing :: SeparableFilter GreyPixel- Float- GreyPixel-- -- Applies the filter to the grey-scale image.- blurred = apply filter grey :: Grey-- -- Saves the blurred image. Ignores any runtime error.- _ <- save output blurred- return ()
− example/Histogram.hs
@@ -1,46 +0,0 @@-import Data.Int-import System.Environment (getArgs)-import Text.Printf--import Vision.Histogram-import Vision.Image-import Vision.Primitive---- Compares two images by their HSV histograms.------ usage: ./histogram input1.png input2.png-main :: IO ()-main = do- [input1, input2] <- getArgs-- -- Loads the images. Automatically infers the format.- io1 <- load Nothing input1- io2 <- load Nothing input2-- case (io1, io2) of- (Right img1, Right img2) -> do- let rgb1 = convert img1 :: RGB- rgb2 = convert img2 :: RGB-- -- Converts both images to the HSV color space as it gives- -- better results when comparing colors.- hsv1 = convert rgb1 :: HSV- hsv2 = convert rgb2 :: HSV-- -- Computes a small histogram so two colors which are similar- -- will be in the same bin.- histSize = Just $ ix3 10 5 5-- hist1 = histogram histSize hsv1 :: Histogram DIM3 Int32- hist2 = histogram histSize hsv2 :: Histogram DIM3 Int32-- -- Normalizes both histograms as the number of pixels in the two- -- images could be different.- hist1' = normalize 100 hist1 :: Histogram DIM3 Double- hist2' = normalize 100 hist2 :: Histogram DIM3 Double-- intersec = compareIntersect hist1' hist2'-- printf "The two images share %.2f%% of their colors.\n" intersec-- _ -> putStrLn "Error while reading the images."
− example/ResizeImage.hs
@@ -1,28 +0,0 @@-import System.Environment (getArgs)--import Vision.Image-import Vision.Primitive (ix2)---- Resizes the input image to a square of 250x250 pixels.------ usage: ./resize_image input.png output.png-main :: IO ()-main = do- [input, output] <- getArgs-- -- Loads the image. Automatically infers the format.- io <- load Nothing input-- case io of- Left _err -> putStrLn "Error while reading the image."- Right img -> do- let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to- -- an RGB image.- rgb = convert img :: RGB-- -- Resizes the RGB image to 250x250 pixels.- miniature = resize Bilinear (ix2 250 250) rgb :: RGB-- -- Saves the miniature. Ignores any runtime error.- _ <- save output miniature- return ()
− example/Threshold.hs
@@ -1,18 +0,0 @@-import System.Environment (getArgs)--import Vision.Image---- Thresholds an image by applying the Otsu's method.------ usage: ./threshold .png output.png-main :: IO ()-main = do- [input, output] <- getArgs- io <- either (\x -> error $ "Load failed: " ++ show x) return- =<< load Nothing input-- let grey = convert io :: Grey- thresholded = otsu (BinaryThreshold 0 255) grey :: Grey-- _ <- save output thresholded- return ()
friday.cabal view
@@ -1,6 +1,9 @@ name: friday-version: 0.1.5-synopsis: A functionnal image processing library for Haskell.+-- +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.2.3.2+synopsis: A functional image processing library for Haskell. homepage: https://github.com/RaphaelJ/friday license: LGPL-3 license-file: LICENSE@@ -12,11 +15,6 @@ The library is designed to be fast, generic and type-safe. .- The library uses FFI calls to the DevIL image library to- read images from a wide variety of formats, including- BMP, JPG, PNG, GIF, ICO and PSD. Except for I/Os, friday- is entirely written in Haskell.- . Images can be represented in two representations: . * the 'Manifest' representation stores images in Haskell@@ -40,34 +38,36 @@ build-type: Simple cabal-version: >= 1.10 -Flag examples- Description: Compiles examples from the example/ directory.- Default: False+extra-source-files: changelog +source-repository head+ type: git+ location: https://github.com/RaphaelJ/friday+ library exposed-modules: Vision.Detector.Edge Vision.Histogram Vision.Image+ Vision.Image.Class+ Vision.Image.Conversion+ Vision.Image.Contour Vision.Image.Grey- Vision.Image.Grey.Conversion Vision.Image.Grey.Specialize Vision.Image.Grey.Type Vision.Image.Filter+ Vision.Image.Filter.Internal Vision.Image.HSV- Vision.Image.HSV.Conversion Vision.Image.HSV.Specialize Vision.Image.HSV.Type Vision.Image.Interpolate Vision.Image.Mutable+ Vision.Image.Parallel Vision.Image.RGBA- Vision.Image.RGBA.Conversion Vision.Image.RGBA.Specialize Vision.Image.RGBA.Type Vision.Image.RGB- Vision.Image.RGB.Conversion Vision.Image.RGB.Specialize Vision.Image.RGB.Type- Vision.Image.Storage Vision.Image.Threshold Vision.Image.Transform Vision.Image.Type@@ -78,106 +78,23 @@ hs-source-dirs: src/ default-language: Haskell2010 - build-depends: base >= 4 && < 5- , bytestring >= 0.10 && < 1.0+ build-depends: base >= 4.8 && < 5+ , containers >= 0.4 && < 0.7.0.0 , convertible >= 1 && < 2- , primitive >= 0.5.2.1 && < 0.6+ , deepseq >= 1.3 && < 2+ , primitive >= 0.5.2.1 && < 0.9 , ratio-int >= 0.1.2 && < 0.2- , vector >= 0.10.0.1 && < 1.0- , transformers >= 0.3 && < 0.5-- Build-tools: hsc2hs-- Extra-Libraries: IL--executable delayed- if !flag(examples)- Buildable: False-- main-is: Delayed.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: example/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , friday--executable canny- if !flag(examples)- Buildable: False-- main-is: Canny.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: example/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , friday--executable gaussian_blur- if !flag(examples)- Buildable: False-- main-is: GaussianBlur.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: example/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , friday--executable histogram- if !flag(examples)- Buildable: False-- main-is: Histogram.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: example/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , friday--executable resize_image- if !flag(examples)- Buildable: False-- main-is: ResizeImage.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: example/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , friday--executable threshold- if !flag(examples)- Buildable: False-- main-is: Threshold.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: example/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , friday--Benchmark benchmark- type: exitcode-stdio-1.0-- main-is: Benchmark.hs- ghc-options: -Wall -O2 -rtsopts- hs-source-dirs: bench/- default-language: Haskell2010-- build-depends: base >= 4 && < 5- , criterion >= 1.0 && < 2.0- , friday+ , vector >= 0.10.0.1 && < 1+ , transformers >= 0.3 && < 0.7 Test-Suite test type: exitcode-stdio-1.0 main-is: Test.hs+ other-modules: Test.Vision.Histogram+ Test.Vision.Image+ Test.Vision.Primitive+ Test.Utils ghc-options: -Wall -O2 -rtsopts hs-source-dirs: test/ default-language: Haskell2010@@ -187,4 +104,4 @@ , friday , test-framework >= 0.8 && < 0.9 , test-framework-quickcheck2 >= 0.3.0.2 && < 0.4- , vector >= 0.10.0.1 && < 1.0+ , vector >= 0.10.0.1 && < 1
src/Vision/Detector/Edge.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, MultiWayIf #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , MultiWayIf #-} module Vision.Detector.Edge (canny) where import Control.Monad (when)-import Control.Monad.ST.Safe (ST)+import Control.Monad.ST (ST) import Data.Int import Data.Vector.Storable (enumFromN, forM_)+import Foreign.Storable (Storable) import Vision.Image (- Image, Pixel, ImagePixel, Manifest, MutableManifest, Grey, Derivative (..)- , shape, index, linearIndex, fromFunction+ Image, ImagePixel, Manifest, MutableManifest, Grey, DerivativeType (..)+ , (!), shape, linearIndex, fromFunction , create, new', linearRead, linearWrite- , apply, sobel+ , sobel ) import Vision.Primitive (Z (..), (:.) (..), inShape, ix2) @@ -34,7 +37,8 @@ -- -- This function is specialized for 'Grey' images but is declared @INLINABLE@ -- to be further specialized for new image types.-canny :: (Image src, Integral (ImagePixel src), Bounded res, Eq res, Pixel res)+canny :: ( Image src, Integral (ImagePixel src), Bounded res, Eq res+ , Storable res) => Int -- ^ Radius of the Sobel's filter. -> Int32@@ -62,16 +66,16 @@ (!lowThres', !highThres') = (square lowThres, square highThres) dx, dy :: Manifest Int16- !dx = sobel derivSize DerivativeX `apply` img- !dy = sobel derivSize DerivativeY `apply` img+ !dx = sobel derivSize DerivativeX img+ !dy = sobel derivSize DerivativeY img -- Gradient magnitude, squared. dxy :: Manifest Int32 !dxy = fromFunction size $ \pt ->- square (fromIntegral $ dx `index` pt)- + square (fromIntegral $ dy `index` pt)+ square (fromIntegral $ dx ! pt)+ + square (fromIntegral $ dy ! pt) - newManifest :: (Pixel p, Bounded p) => ST s (MutableManifest p s)+ newManifest :: (Storable p, Bounded p) => ST s (MutableManifest p s) newManifest = new' size minBound -- Visits a point and compares its gradient magnitude to the given@@ -118,7 +122,7 @@ in tryCompare ptDxy (>) (x1, y1) && tryCompare ptDxy (>=) (x2, y2) tryCompare !ptDxy op !(x, y)- | inShape size (ix2 y x) = ptDxy `op` fromIntegral (dxy `index` ix2 y x)+ | inShape size (ix2 y x) = ptDxy `op` fromIntegral (dxy ! ix2 y x) | otherwise = True -- Returns the direction of the edge, not to be confused with the direction
src/Vision/Histogram.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances- , ParallelListComp, TypeFamilies, TypeOperators #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , FlexibleInstances+ , ParallelListComp+ , TypeFamilies+ , TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Contains functions to compute and manipulate histograms as well as some@@ -11,7 +15,7 @@ module Vision.Histogram ( -- * Types & helpers Histogram (..), HistogramShape (..), ToHistogram (..)- , index, linearIndex, map, assocs, pixToBin+ , index, (!), linearIndex, map, assocs, pixToBin -- * Histogram computations , histogram, histogram2D, reduce, resize, cumulative, normalize -- * Images processing@@ -21,21 +25,23 @@ ) where import Data.Int-import Data.Vector.Storable (Vector, (!))-import qualified Data.Vector.Storable as V+import Data.Vector.Storable (Vector) import Foreign.Storable (Storable) import Prelude hiding (map) +import qualified Data.Vector.Storable as V++import Vision.Image.Class (Pixel, MaskedImage, Image, ImagePixel, FunctorImage) import Vision.Image.Grey.Type (GreyPixel (..)) import Vision.Image.HSV.Type (HSVPixel (..)) import Vision.Image.RGBA.Type (RGBAPixel (..)) import Vision.Image.RGB.Type (RGBPixel (..))-import Vision.Image.Type (Pixel, MaskedImage, Image, ImagePixel, FunctorImage)-import qualified Vision.Image.Type as I import Vision.Primitive ( Z (..), (:.) (..), Shape (..), DIM1, DIM3, DIM4, DIM5, ix1, ix3, ix4 ) +import qualified Vision.Image.Class as I+ -- There is no rule to simplify the conversion from Int32 to Double and Float -- when using realToFrac. Both conversions are using a temporary yet useless -- Rational value.@@ -128,10 +134,15 @@ index !hist = linearIndex hist . toLinearIndex (shape hist) {-# INLINE index #-} +-- | Alias of 'index'.+(!) :: (Shape sh, Storable a) => Histogram sh a -> sh -> a+(!) = index+{-# INLINE (!) #-}+ -- | Returns the value at the index as if the histogram was a single dimension -- vector (row-major representation). linearIndex :: (Shape sh, Storable a) => Histogram sh a -> Int -> a-linearIndex !hist = (!) (vector hist)+linearIndex !hist = (V.!) (vector hist) {-# INLINE linearIndex #-} map :: (Storable a, Storable b) => (a -> b) -> Histogram sh a -> Histogram sh b@@ -306,7 +317,7 @@ Z :. nBins = shape hist cumNormalized = cumulative $ normalize (double nBins) hist !cumNormalized' = map round cumNormalized :: Histogram DIM1 Int32- equalizePixel !val = fromIntegral $ cumNormalized' `index` ix1 (int val)+ equalizePixel !val = fromIntegral $ cumNormalized' ! ix1 (int val) {-# INLINE equalizePixel #-} {-# INLINABLE equalizeImage #-}
src/Vision/Image.hs view
@@ -13,27 +13,31 @@ -- <https://github.com/RaphaelJ/friday/blob/master/README.md README file> for a -- detailed usage and examples. module Vision.Image (- module Vision.Image.Grey+ module Vision.Image.Class+ , module Vision.Image.Conversion+ , module Vision.Image.Grey , module Vision.Image.Filter , module Vision.Image.HSV , module Vision.Image.Interpolate , module Vision.Image.Mutable+ , module Vision.Image.Parallel , module Vision.Image.RGB , module Vision.Image.RGBA- , module Vision.Image.Storage , module Vision.Image.Threshold , module Vision.Image.Transform , module Vision.Image.Type ) where +import Vision.Image.Class+import Vision.Image.Conversion import Vision.Image.Grey import Vision.Image.Filter import Vision.Image.HSV import Vision.Image.Interpolate import Vision.Image.Mutable+import Vision.Image.Parallel import Vision.Image.RGB import Vision.Image.RGBA-import Vision.Image.Storage import Vision.Image.Threshold import Vision.Image.Transform import Vision.Image.Type
+ src/Vision/Image/Class.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses+ , TypeFamilies #-}++module Vision.Image.Class (+ -- * Classes+ Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..)+ , FunctorImage (..)+ -- * Functions+ , (!), (!?), nChannels, pixel+ ) where++import Data.Int+import Data.Vector.Storable (Vector, generate, unfoldr)+import Data.Word+import Foreign.Storable (Storable)+import Prelude hiding (map, read)++import Vision.Primitive (+ Z (..), (:.) (..), Point, Size+ , fromLinearIndex, toLinearIndex, shapeLength+ )++-- Classes ---------------------------------------------------------------------++-- | Determines the number of channels and the type of each pixel of the image+-- and how images are represented.+class Pixel p where+ type PixelChannel p++ -- | Returns the number of channels of the pixel.+ --+ -- Must not consume 'p' (could be 'undefined').+ pixNChannels :: p -> Int++ pixIndex :: p -> Int -> PixelChannel p++instance Pixel Int16 where+ type PixelChannel Int16 = Int16+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Int32 where+ type PixelChannel Int32 = Int32+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Int where+ type PixelChannel Int = Int+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word8 where+ type PixelChannel Word8 = Word8+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word16 where+ type PixelChannel Word16 = Word16+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word32 where+ type PixelChannel Word32 = Word32+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word where+ type PixelChannel Word = Word+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Float where+ type PixelChannel Float = Float+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Double where+ type PixelChannel Double = Double+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Bool where+ type PixelChannel Bool = Bool+ pixNChannels _ = 1+ pixIndex p _ = p++-- | Provides an abstraction for images which are not defined for each of their+-- pixels. The interface is similar to 'Image' except that indexing functions+-- don't always return.+--+-- Image origin (@'ix2' 0 0@) is located in the upper left corner.+class Storable (ImagePixel i) => MaskedImage i where+ type ImagePixel i++ shape :: i -> Size++ -- | Returns the pixel\'s value at 'Z :. y, :. x'.+ maskedIndex :: i -> Point -> Maybe (ImagePixel i)+ maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img)+ {-# INLINE maskedIndex #-}++ -- | Returns the pixel\'s value as if the image was a single dimension+ -- vector (row-major representation).+ maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i)+ maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img)+ {-# INLINE maskedLinearIndex #-}++ -- | Returns the non-masked values of the image.+ values :: i -> Vector (ImagePixel i)+ values !img =+ unfoldr step 0+ where+ !n = shapeLength (shape img)++ step !i | i >= n = Nothing+ | Just p <- img `maskedLinearIndex` i = Just (p, i + 1)+ | otherwise = step (i + 1)+ {-# INLINE values #-}++ {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}++type ImageChannel i = PixelChannel (ImagePixel i)++-- | Provides an abstraction over the internal representation of an image.+--+-- Image origin (@'ix2' 0 0@) is located in the upper left corner.+class MaskedImage i => Image i where+ -- | Returns the pixel value at 'Z :. y :. x'.+ index :: i -> Point -> ImagePixel i+ index img = (img `linearIndex`) . toLinearIndex (shape img)+ {-# INLINE index #-}++ -- | Returns the pixel value as if the image was a single dimension vector+ -- (row-major representation).+ linearIndex :: i -> Int -> ImagePixel i+ linearIndex img = (img `index`) . fromLinearIndex (shape img)+ {-# INLINE linearIndex #-}++ -- | Returns every pixel values as if the image was a single dimension+ -- vector (row-major representation).+ vector :: i -> Vector (ImagePixel i)+ vector img = generate (shapeLength $ shape img) (img `linearIndex`)+ {-# INLINE vector #-}++ {-# MINIMAL index | linearIndex #-}++-- | Provides ways to construct an image from a function.+class FromFunction i where+ type FromFunctionPixel i++ -- | Generates an image by calling the given function for each pixel of the+ -- constructed image.+ fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i++ -- | Generates an image by calling the last function for each pixel of the+ -- constructed image.+ --+ -- The first function is called for each line, generating a line invariant+ -- value.+ --+ -- This function is faster for some image representations as some recurring+ -- computation can be cached.+ fromFunctionLine :: Size -> (Int -> a)+ -> (a -> Point -> FromFunctionPixel i) -> i+ fromFunctionLine size line f =+ fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt)+ {-# INLINE fromFunctionLine #-}++ -- | Generates an image by calling the last function for each pixel of the+ -- constructed image.+ --+ -- The first function is called for each column, generating a column+ -- invariant value.+ --+ -- This function *can* be faster for some image representations as some+ -- recurring computations can be cached. However, it may requires a vector+ -- allocation for these values. If the column invariant is cheap to+ -- compute, prefer 'fromFunction'.+ fromFunctionCol :: Storable b => Size -> (Int -> b)+ -> (b -> Point -> FromFunctionPixel i) -> i+ fromFunctionCol size col f =+ fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt)+ {-# INLINE fromFunctionCol #-}++ -- | Generates an image by calling the last function for each pixel of the+ -- constructed image.+ --+ -- The two first functions are called for each line and for each column,+ -- respectively, generating common line and column invariant values.+ --+ -- This function is faster for some image representations as some recurring+ -- computation can be cached. However, it may requires a vector+ -- allocation for column values. If the column invariant is cheap to+ -- compute, prefer 'fromFunctionLine'.+ fromFunctionCached :: Storable b => Size+ -> (Int -> a) -- ^ Line function+ -> (Int -> b) -- ^ Column function+ -> (a -> b -> Point+ -> FromFunctionPixel i) -- ^ Pixel function+ -> i+ fromFunctionCached size line col f =+ fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt)+ {-# INLINE fromFunctionCached #-}++ {-# MINIMAL fromFunction #-}++-- | Defines a class for images on which a function can be applied. The class is+-- different from 'Functor' as there could be some constraints and+-- transformations the pixel and image types.+class (MaskedImage src, MaskedImage res) => FunctorImage src res where+ map :: (ImagePixel src -> ImagePixel res) -> src -> res++-- Functions -------------------------------------------------------------------++-- | Alias of 'maskedIndex'.+(!?) :: MaskedImage i => i -> Point -> Maybe (ImagePixel i)+(!?) = maskedIndex+{-# INLINE (!?) #-}++-- | Alias of 'index'.+(!) :: Image i => i -> Point -> ImagePixel i+(!) = index+{-# INLINE (!) #-}++-- | Returns the number of channels of an image.+nChannels :: (Pixel (ImagePixel i), MaskedImage i) => i -> Int+nChannels img = pixNChannels (pixel img)+{-# INLINE nChannels #-}++-- | Returns an 'undefined' instance of a pixel of the image. This is sometime+-- useful to satisfy the type checker as in a call to 'pixNChannels' :+--+-- > nChannels img = pixNChannels (pixel img)+pixel :: MaskedImage i => i -> ImagePixel i+pixel _ = undefined
+ src/Vision/Image/Contour.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , CPP+ , GeneralizedNewtypeDeriving+ , ScopedTypeVariables+ , FlexibleInstances+ , MultiWayIf #-}+-- | Contour tracing of binary images (zero ~ background, nonzero ~ object).+--+-- Terminology:+--+-- A binary image is an image in which the pixel is boolean (represented+-- here using 'Grey' and zero or non-zero pixel values).+--+-- All zero-value pixels are part of the "background".+--+-- An object is an connected group of non-zero pixels.+--+-- A 'Contour' is a trace of an objects' outer or inner edges. Some+-- objects are solid, having no inner contours (consider a filled circle,+-- or letters such as 'h', 's', 'k' and 'l'). Other objects have "holes", also known as inner+-- contours. The letters 'a' and 'e' have one hole while the letter 'B' has two.+--+-- After obtaining a 'Contours' structure (via the 'contours' function) the+-- raw traces ('Contour' type) can be used for further processing or the contours can be+-- filtered by aspects of interest and selectively re-drawn ('drawContour') , perhaps used to+-- mask the original image.+--+-- About Holes:+--+-- In cases where there is only one hole it is uniquely recorded in the+-- 'Contours' structure. Objects with more than one hole record all inner+-- contours in one vector making them hard to extract separately - this is+-- due to the main data structure not being rich enough to record the holes+-- separately. As of writing, this is not seen as an issue because the+-- desired operation, drawContour, can still be achieved. Changing this+-- behavior should be trivial if desired.+--+-- Use:+--+-- To use this library it is advised that you preprocess the image,+-- including thresholding (ex: 'otsu' on a grey scale image), to obtain a binary image then call:+--+-- @+-- cs = contours img+-- @+--+-- The 'Contours' structure can be accessed directly if desired. It+-- includes an 'Map' of all contours (numbered counting from 1) and+-- a vector of the contour sizes (indexed by contour number, zero index is+-- unused/zero).+--+-- The algorithm implemented in this module follows the design laid out in+-- 'A Linear-Time Component-Labeling Algorithm Using Contour Tracing Technique' [1].+--+-- [1] http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.95.6330&rep=rep1&type=pdf+module Vision.Image.Contour (+ -- * Main Interface+ Contours(..), ContourId, OneContour, ContourValue, Contour(..), RowContour+ , contours+ -- * ADT style interface (hides 'Contours' internals)+ , allContourIds, lookupContour, rowContour, contourSize, contourPerimeter+ -- * Reconstructing Image Elements+ , ContourDrawStyle(..), drawContour, drawContours+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Control.Monad (when)+import Control.Monad.ST+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (catMaybes)+import Data.List (groupBy,sort)+import Data.Function (on)+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VM+import Foreign.Storable++import Vision.Image.Mutable (MutableManifest, new', write)+import qualified Vision.Image.Mutable as Mut+import Vision.Image.Grey (Grey,GreyPixel)+import Vision.Image.Type (Delayed)+import Vision.Image.Class (+ MaskedImage (..), Image (..), FromFunction (..), index+ )+import Vision.Primitive (+ Z (..), (:.) (..), Point, ix2, Size+ )++--------------------------------------------------------------------------------+-- Types and ADT-Style Interface++-- | Contours of an image include:+-- * A map from contour number to outer points and negative contour number of inner contour points.+-- * A vector of sizes for each contour for domain [1..size contourOutlines] (the zero index is meaningless)+data Contours =+ Contours { contourOutlines :: Map ContourId Contour+ , contourSizes :: !(VU.Vector Int)+ }++allContourIds :: Contours -> [ContourId]+allContourIds = Map.keys . contourOutlines++contourPerimeter :: Contours -> ContourId -> [Point]+contourPerimeter m i =+ maybe [] (map fst . VU.toList . outerContour) (lookupContour m i)++contourSize :: Contours -> ContourId -> Int+contourSize (Contours _ s) i+ | unCID i < 0 || unCID i >= VU.length s = 0+ | otherwise = s VU.! unCID i++lookupContour :: Contours -> ContourId -> Maybe Contour+lookupContour m i = Map.lookup i (contourOutlines m)++-- |Contours are identified by a numeric ID number.+newtype ContourId = CID { unCID :: Int } deriving (Eq, Ord, Storable, Num, Show)++-- |A contour is described by the points on the perimeter and a boolean+-- indicating if that point is "terminal" (next pixel to+-- the right is background iff the point is terminal). The terminal+-- information allows for a slightly simpler 'drawContour' implementation.+type OneContour = VU.Vector ContourValue+type ContourValue = (Point,Bool)+data Contour = Contour { outerContour :: OneContour+ , innerContours :: [OneContour]+ } -- Pair of outer and inner contours++insOuterContour :: ContourId -> OneContour -> Map ContourId Contour+ -> Map ContourId Contour+insOuterContour cid o mp =+ let c = Contour o []+ in Map.insert cid c mp++insInnerContour :: ContourId -> OneContour -> Map ContourId Contour+ -> Map ContourId Contour+insInnerContour cid i mp =+ let c = Contour (error "Impossible: Inner contour with no outer!") [i]+ f _ (Contour o is) = Contour o (i:is)+ in Map.insertWith f cid c mp++-- |RowContour is a method of expressing contours by, for each row,+-- recording the start of an object and the end (due to reaching the other+-- side or a hole/inner contour) for each row.+type RowContour = VU.Vector (Point,Point)++--------------------------------------------------------------------------------+-- Image Reconstruction++-- | Outline: Just draw the edge.+--+-- OuterOutline: Outline the outer contours only, no hole contours+-- AllOutlines: Draw all contours+-- Fill: Draw the object but fill it in, ignoring holes.+-- FillWithHoles: Draw the object and do not fill in the holes.+data ContourDrawStyle = OuterOutline | AllOutlines | Fill | FillWithHoles+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | Draws a given contour. The size specified must be large enough to+-- include the coordinate originally occupied by the contour being drawn,+-- no cropping or other transformation is done.+drawContour :: Contours -> Size -> ContourDrawStyle -> ContourId -> Grey+drawContour master sz sty c = drawContours master sz sty [c]++-- |Draws many contours. See 'drawContour'.+drawContours :: Contours -> Size -> ContourDrawStyle -> [ContourId] -> Grey+drawContours m sz AllOutlines ids = drawOutlines listOfUVec m ids sz+ where listOfUVec (Contour o is) = o:is+drawContours m sz OuterOutline ids = drawOutlines listOfUVec m ids sz+ where listOfUVec (Contour o _) = [o]+drawContours m sz sty ids = drawRows pnts sz+ where lk = lookupContour m+ pnts = case sty of+ Fill -> map (VU.toList . outerContour) $ catMaybes $ map lk ids -- map (map (\(a,x) -> (a,not x)) . lk) innerIds ++ map lk outerIds+ FillWithHoles -> map (concatMap VU.toList . maybe [] (\x -> outerContour x : innerContours x) . lk) ids+ _ -> error "Impossible: Style is not Fill, FillWithHoles"++drawOutlines :: (Contour -> [VU.Vector ContourValue]) -> Contours -> [ContourId] -> Size -> Grey+drawOutlines oper m ids sz = runST f+ where+ f = do+ i <- new' sz 0 :: ST s (MutableManifest GreyPixel s)+ let vs = map fst $ concatMap VU.toList $ concatMap oper $ catMaybes $ map (lookupContour m) ids+ mapM_ (\p -> write i p 255) vs+ Mut.unsafeFreeze i+++-- | Draws rows, throwing an exception when the size is too small for the+-- coordinates.+drawRows :: [[ContourValue]] -> Size -> Grey+drawRows vs sz = runST $ do+ i <- new' sz 0+ mapM_ (drawMutable i) vs+ Mut.unsafeFreeze i++drawMutable :: MutableManifest GreyPixel s -> [ContourValue] -> ST s ()+drawMutable i cs = VU.mapM_ (f i) rs+ where+ rs = rowContour cs+ f img (start,stop) = go (start, stop)+ where go (s@(Z:.row:.col),t) = do+ write img s 255+ when (s /= t) $ go (Z :. row :. (col+1),t)++-- |Given a vector including outer (and optionally inner) contour points,+-- make 'row contour' from which is easier to transform back into a binary+-- image. By not including the inner contour points the row will be filled, making+-- traces of objects with holes appear solid.+rowContour :: [ContourValue] -> RowContour+rowContour cs =+ let rows :: [[(Point,Bool)]]+ rows = groupBy ((==) `on` ((\(Z:.r:._) -> r) . fst)) $ sort cs -- XXX consider vector quick/tim sort+ in VU.fromList $ concatMap walkM rows+ where+ walkM :: [(Point,Bool)] -> [(Point,Point)]+ walkM [x] = [(fst x,fst x)]+ walkM x = maybe (error $ "Impossible: No terminal when walking contour: " ++ show (x,cs)) id $ walk x+ walk :: [(Point,Bool)] -> Maybe [(Point,Point)]+ walk [] = Just []+ walk xs@(x:_) = case dropWhile (not . snd) xs of+ [] -> Nothing+ (t:ys) -> ((fst x,fst t) :) <$> walk ys++-- |The meat of this module is the 'contours' function, which extracts+-- the contours (outer and inner outlines) of a binary image.+-- Zero-valued pixels are the background and non-zero are active/objects to+-- trace. The output, 'Contours', contains enough information to determine+-- the number of contours, their traces, the size in pixels (filled size+-- and perimeter), number of holes, etc.+contours :: (Image src, Num (ImagePixel src), Eq (ImagePixel src)) => src -> Contours+contours src = runST $ do+ let bsrc = fromFunction (Z :. y+2 :. x+2) mkBorder+ mutImg <- new' (shape bsrc) zid+ (outlines,sz) <- doLabeling bsrc mutImg+ sizes <- freezeBlobSizes sz+ return (Contours outlines sizes)+ where+ (Z :. y :. x) = shape src++ mkBorder (Z :. j :. i)+ | j == 0 || j == (y+1) || i == 0 || i == (x+1) = background+ | otherwise = index src (Z :. j-1 :. i-1)++-- The image is assumed to be binary and should have values of either 0 (black) or... nonzero (white)+-- here we assume the background is black. Nonzero would require more+-- change elsewhere!+background :: Num a => a+background = 0++zid :: ContourId+zid = CID 0++data BlobSizes s = BS (VM.MVector s Int)++freezeBlobSizes :: BlobSizes s -> ST s (VU.Vector Int)+freezeBlobSizes (BS v) = VU.unsafeFreeze v++incBlobSizes :: ContourId -> BlobSizes s -> ST s (BlobSizes s)+incBlobSizes (CID i) s@(BS v)+ | i > 0 =+ if VM.length v <= i+ then do nv <- VM.unsafeGrow v (i*2)+ mapM_ (\ix -> VM.unsafeWrite nv ix 0) [i..i*2-1]+ VM.unsafeWrite nv i 1+ return (BS nv)+ else do p <- VM.unsafeRead v i+ VM.unsafeWrite v i (p+1)+ return s+ | otherwise = return s++zeroBlobSizes :: ST s (BlobSizes s)+zeroBlobSizes = BS <$> VM.replicate 1024 0++-- Make a contour image of the same dimension but with ContourIDs instead+-- of pixels.+doLabeling :: forall s p. (Storable p, Num p, Eq p) => Delayed p -> MutableManifest ContourId s -> ST s (Map ContourId Contour,BlobSizes s)+doLabeling src mutImg = zeroBlobSizes >>= go (Just $ ix2 1 1) (CID 0) (CID 1) mempty+ where+ getCID :: Point -> ST s ContourId+ getCID = Mut.read mutImg+ setCID i c = write mutImg i c+ getPixel :: Point -> ImagePixel (Delayed p)+ getPixel = index src++ incIx :: Point -> Maybe Point+ incIx !(Z :. (!y) :. (!x))+ | x < xMax-1 = Just $ Z :. y :. (x+1)+ | y < yMax-1 = Just $ Z :. (y+1) :. 1+ | otherwise = Nothing++ (Z :. yMax :. xMax) = shape src++ -- Traverse the source image top to bottom, left to right. If the pixel+ -- has an ID then propagate that ID to all the following active pixels in+ -- the row. If the pixel is active and has no ID then trace either an+ -- inner or outer contour. If the pixel is inactive then skip it.+ go Nothing _ _ !mp v = return (mp,v)+ go (Just idx) leftCID !newCID !mp v =+ do thisCID <- getCID idx+ if | val == background -> skipForward -- this step doesn't appear in the paper! D'oh+ | thisCID == zid && above == background ->+ do -- Step 1: Outer contour trace (active pixel with id=0 and above is background)+ newContour <- traceContour src mutImg ExternalContour idx newCID+ go (Just idx) newCID (newCID + 1) (insOuterContour newCID newContour mp) v+ | below == background -> -- Step 2: P is an white pixel+ do belowCID <- getCID belowIdx -- ^ ^+ if | belowCID == zid -> -- ^ unmarked ^+ do -- Step 2a: Inner contour trace, below pixel was unmarked+ let innerCID = if zid == thisCID then leftCID else thisCID+ inner <- traceContour src mutImg InternalContour idx innerCID+ go (incIx idx) innerCID newCID (insInnerContour innerCID inner mp) v+ -- there can be more than one inner contour, make a richer container structure than IntMap?+ -- Notice this isn't entirely necessary, one+ -- CID can contain all inner contours and they can be redrawn correctly.+ | otherwise -> stepForward -- Step 2b: Previously-observed contour+ | otherwise -> stepForward -- Active pixel not on a contour+ where val = getPixel idx+ above = getPixel (Z :. y-1 :. x)+ below = getPixel belowIdx+ belowIdx = Z :. y+1 :. x+ Z :. y :. x = idx+ stepForward = do xId <- if leftCID <= zid+ then getCID idx+ else return leftCID+ setCID idx xId+ nv <- incBlobSizes xId v+ go (incIx idx) xId newCID mp nv+ skipForward = go (incIx idx) (-2) newCID mp v++-- Mark surrounding background pixels+-- label non-background pixels with CID+--+-- Unroll the loop one step to account for the lone-pixel case. Without+-- lone pixels the tight inner loop can save a check (See 'Impossible')+--+-- TODO: optimize later, duplicate tracer and remove the p==pos, after a benchmarking method is setup.+traceContour :: forall p s. (Storable p, Num p, Eq p) => Delayed p -> MutableManifest ContourId s -> ContourType -> Point -> ContourId -> ST s OneContour+traceContour src mutImg contourTy origPnt assignedCID =+ do next <- tracer origPnt startPos+ case next of+ Nothing -> return (VU.fromList $ fixList [(origPnt,True)])+ Just (sndPnt,sndPos) -> do+ let f pnt pos = do (nPnt,nPos) <- maybe (error "Impossible: Nothing in inner") id <$> tracer pnt pos+ if pnt == origPnt && nPnt == sndPnt+ then return [] -- XXX some algorithms duplicate the start point, pnt, as the last point `return [pnt]`. Should we?+ else ((pnt,terminal pnt) :) <$> f nPnt nPos+ VU.fromList . fixList . ((origPnt, terminal origPnt):) <$> f sndPnt sndPos++ where+ terminal (Z :. row :. col) = 0 == getPixel (Z :. row :. (col+1))+ -- Translate between indexes in our border-added image and the original+ fixList xs = let f (Z :. a :. b, t) = (Z :. a-1 :. b-1,t) in map f xs+ startPos = case contourTy of { ExternalContour -> UR ; InternalContour -> LL }+ setCID i c = write mutImg i c+ getPixel :: Point -> ImagePixel (Delayed p)+ getPixel = index src++ {-# INLINE tracer #-}+ tracer pnt pos =+ let tracer' True p | p == pos = setCID pnt assignedCID >> return Nothing+ tracer' _ p = do let rpnt = relPoint pnt p+ v = getPixel rpnt+ if | v == background -> do setCID rpnt (-1)+ tracer' True (incCP p)+ | otherwise -> do setCID pnt assignedCID+ return (Just (rpnt, decCP2 p))+ in tracer' False pos+++--------------------------------------------------------------------------------+-- Internal Types and Utilities++data ContourType = ExternalContour | InternalContour deriving (Eq)++-- A contour position is Upper/Lower/Middle Left/Center/Right pixel+-- relative to the current. Because we add a border to the image prior+-- to processing, all original pixels `cross` contours positions are+-- a valid point.+data ContourPos = MR | LR | LC | LL+ | ML | UL | UC | UR+ deriving (Enum, Bounded, Eq, Show)++relPoint :: Point -> ContourPos -> Point+relPoint (Z :. row :. col) pos = Z :. row' :. col'+ where !row' = row + y+ !col' = col + x+ x = colOffset VU.! fromEnum pos+ y = rowOffset VU.! fromEnum pos++-- Rather than have branching (and expected poor performance),+-- use a table of x/y offsets for the relative pixel position.+colOffset,rowOffset :: VU.Vector Int+rowOffset = VU.fromList [0,1,1,1,0,-1,-1,-1]+colOffset = VU.fromList [1,1,0,-1,-1,-1,0,1]++-- Position clockwise by one tick+incCP :: ContourPos -> ContourPos+incCP = toEnum . ((`rem` 8) . (+ 1)) . fromEnum++-- Position counter-clockwise by two ticks+decCP2 :: ContourPos -> ContourPos+decCP2 = toEnum . ((`rem` 8) . (+ 6)) . fromEnum
+ src/Vision/Image/Conversion.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE BangPatterns+ , MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- 'Convertible' instances for conversions between pixel types.+module Vision.Image.Conversion (Convertible (..), convert) where++import Data.Convertible (Convertible (..), ConvertResult, convert)+import Data.Word++import qualified Data.Vector.Storable as VS++import Vision.Image.Grey.Type (GreyPixel (..))+import Vision.Image.HSV.Type (HSVPixel (..))+import Vision.Image.RGBA.Type (RGBAPixel (..))+import Vision.Image.RGB.Type (RGBPixel (..))++-- to Grey ---------------------------------------------------------------------++instance Convertible GreyPixel GreyPixel where+ safeConvert = Right+ {-# INLINE safeConvert #-}++instance Convertible HSVPixel GreyPixel where+ safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)+ >>= safeConvert++instance Convertible RGBAPixel GreyPixel where+ safeConvert !(RGBAPixel r g b a) =+ Right $ GreyPixel $ word8 $ int (rgbToGrey r g b) * int a `quot` 255+ {-# INLINE safeConvert #-}++instance Convertible RGBPixel GreyPixel where+ safeConvert !(RGBPixel r g b) =+ Right $ GreyPixel $ rgbToGrey r g b+ {-# INLINE safeConvert #-}++-- | Converts the colors to greyscale using the human eye colors perception.+rgbToGrey :: Word8 -> Word8 -> Word8 -> Word8+rgbToGrey !r !g !b = (redLookupTable VS.! int r)+ + (greenLookupTable VS.! int g)+ + (blueLookupTable VS.! int b)+{-# INLINE rgbToGrey #-}++redLookupTable, greenLookupTable, blueLookupTable :: VS.Vector Word8+redLookupTable = VS.generate 256 (\val -> round $ double val * 0.299)+greenLookupTable = VS.generate 256 (\val -> round $ double val * 0.587)+blueLookupTable = VS.generate 256 (\val -> round $ double val * 0.114)++-- to HSV ----------------------------------------------------------------------++instance Convertible HSVPixel HSVPixel where+ safeConvert = Right+ {-# INLINE safeConvert #-}++instance Convertible GreyPixel HSVPixel where+ safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)+ >>= safeConvert++instance Convertible RGBPixel HSVPixel where+-- Based on :+-- http://en.wikipedia.org/wiki/HSL_and_HSV#General_approach+ safeConvert !(RGBPixel r g b) =+ Right pix+ where+ (!r', !g', !b') = (int r, int g, int b)++ !pix | r >= g && r >= b = -- r == max r g b+ let !c = r' - min b' g'+ !h = fixHue $ hue c b' g' -- Hue can be negative+ in HSVPixel (word8 h) (sat c r') r+ | g >= r && g >= b = -- g == max r g b+ let !c = g' - min r' b'+ !h = 60 + hue c r' b'+ in HSVPixel (word8 h) (sat c g') g+ | otherwise = -- b == max r g b+ let !c = b' - min r' g'+ !h = 120 + hue c g' r'+ in HSVPixel (word8 h) (sat c b') b++ -- Returns a value in [-30; +30].+ hue 0 _ _ = 0+ hue !c !left !right = (30 * (right - left)) `quot` c++ sat _ 0 = 0+ sat !c v = word8 $ (c * 255) `quot` v++ -- Keeps the value of the hue between [0, 179].+ -- As the Hue's unit is 2°, 180 is equal to 360° and to 0°.+ fixHue !h | h < 0 = h + 180+ | otherwise = h++instance Convertible RGBAPixel HSVPixel where+ safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)+ >>= safeConvert++-- to RGB ----------------------------------------------------------------------++instance Convertible RGBPixel RGBPixel where+ safeConvert = Right+ {-# INLINE safeConvert #-}++instance Convertible GreyPixel RGBPixel where+ safeConvert !(GreyPixel pix) = Right $ RGBPixel pix pix pix+ {-# INLINE safeConvert #-}++instance Convertible RGBAPixel RGBPixel where+ safeConvert !(RGBAPixel r g b a) =+ Right $ RGBPixel (withAlpha r) (withAlpha g) (withAlpha b)+ where+ !a' = int a+ withAlpha !val = word8 $ int val * a' `quot` 255+ {-# INLINE withAlpha #-}+ {-# INLINE safeConvert #-}++instance Convertible HSVPixel RGBPixel where+-- Based on :+-- http://en.wikipedia.org/wiki/HSL_and_HSV#Converting_to_RGB+ safeConvert !(HSVPixel h s v) =+ Right $! case h `quot` 30 of+ 0 -> RGBPixel v (word8 x1') (word8 m)+ 1 -> RGBPixel (word8 (x2 60)) v (word8 m)+ 2 -> RGBPixel (word8 m) v (word8 (x1 60))+ 3 -> RGBPixel (word8 m) (word8 (x2 120)) v+ 4 -> RGBPixel (word8 (x1 120)) (word8 m) v+ 5 -> RGBPixel v (word8 m) (word8 (x2 180))+ _ -> error "Invalid hue value."+ where+ (!h', v') = (int h, int v)++ -- v is the major color component whereas m is the minor one.+ !m = (v' * (255 - int s)) `quot` 255++ -- Computes the remaining component by resolving the hue equation,+ -- knowing v and m. x1 is when the component is on the right of the+ -- major one, x2 when on the left.+ x1 d = (d * m - d * v' + h' * v' - h' * m + 30 * m) `quot` 30+ x1' = ( h' * v' - h' * m + 30 * m) `quot` 30 -- == x1 0++ x2 d = (d * v' - d * m + h' * m - h' * v' + 30 * m) `quot` 30+ {-# INLINE safeConvert #-}++-- to RGBA ---------------------------------------------------------------------++instance Convertible RGBAPixel RGBAPixel where+ safeConvert = Right+ {-# INLINE safeConvert #-}++instance Convertible GreyPixel RGBAPixel where+ safeConvert !(GreyPixel pix) = Right $ RGBAPixel pix pix pix 255+ {-# INLINE safeConvert #-}++instance Convertible HSVPixel RGBAPixel where+ safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)+ >>= safeConvert++instance Convertible RGBPixel RGBAPixel where+ safeConvert !(RGBPixel r g b) = Right $ RGBAPixel r g b 255+ {-# INLINE safeConvert #-}++-- -----------------------------------------------------------------------------++double :: Integral a => a -> Double+double = fromIntegral++int :: Integral a => a -> Int+int = fromIntegral++word8 :: Integral a => a -> Word8+word8 = fromIntegral
src/Vision/Image/Filter.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, GADTs- , MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , TypeFamilies #-} --- | Provides high level functions to define and apply filters on images.+-- | Provides high level filtering functions for images. --+-- Use 'Vision.Image.Filter.Internal' if you want to create new image filters.+-- -- Filters are operations on images on which the surrounding of each processed -- pixel is considered according to a kernel. --@@ -11,607 +14,86 @@ -- The @radius@ argument of some filters is used to determine the kernel size. -- A radius as of 1 means a kernel of size 3, 2 a kernel of size 5 and so on. ----- The @acc@ type argument of some filters defines the type which will be used--- to store the accumulated value of the kernel (e.g. by setting @acc@ to--- 'Double' in the computation of a Gaussian blur, the kernel average will be--- computed using a 'Double').------ To apply a filter to an image, use the 'apply' method:------ @--- let filter :: 'SeparableFilter' GreyPixel Double GreyPixel--- filter = 'gaussianBlur' 2 Nothing--- in 'apply' filter img :: Grey--- @+-- /Note:/ filters are currently not supported on multi-channel images (RGB,+-- RGBA ...) are currently not supported. module Vision.Image.Filter (- -- * Types- Filterable (..), Filter (..)- , BoxFilter, BoxFilter1, SeparableFilter, SeparableFilter1- , KernelAnchor (..)- , Kernel (..)- , SeparableKernel (..), SeparatelyFiltrable (..)- , FilterFold (..), FilterFold1 (..)- , BorderInterpolate (..)- -- * Functions- , kernelAnchor, borderInterpolate- -- * Filters- -- ** Morphological operators+ -- * Classes and type+ Filterable, Filter, SeparatelyFiltrable+ -- * Morphological operators , dilate, erode- -- ** Blur+ -- * Blur , blur, gaussianBlur- -- ** Derivation- , Derivative (..), scharr, sobel+ -- * Derivation+ , DerivativeType (..), scharr, sobel+ -- * Others+ , mean ) where -import Data.List-import Data.Ratio-import qualified Data.Vector.Storable as V-import Data.Word+import Data.Int import Foreign.Storable (Storable) -import Vision.Image.Type (- MaskedImage (..), Image (..), FromFunction (..)- , Manifest, Delayed+import Vision.Image.Class (MaskedImage (..), Image (..), FromFunction (..))+import Vision.Image.Filter.Internal (+ Filterable, Filter, SeparatelyFiltrable (..)+ , DerivativeType )-import Vision.Primitive (Z (..), (:.) (..), DIM1, DIM2, Size, ix1, ix2)---- Types --------------------------------------------------------------------------- | Provides an implementation to execute a type of filter.------ 'src' is the original image, 'res' the resulting image and 'f' the filter.-class Filterable src res f where- -- | Applies the given filter on the given image.- apply :: f -> src -> res--data Filter src kernel init acc res = Filter {- fKernelSize :: !Size- , fKernelCenter :: !KernelAnchor- -- | See 'Kernel' and 'SeparableKernel'.- , fKernel :: !kernel- -- | Defines how the accumulated value is initialized.- --- -- See 'FilterFold' and 'FilterFold1'.- , fInit :: !init- , fPost :: !(src -> acc -> res)- , fInterpol :: !(BorderInterpolate src)- }---- | 2D filters which are initialized with a value.-type BoxFilter src acc res = Filter src (Kernel src acc) (FilterFold acc)- acc res---- | 2D filters which are not initialized with a value.-type BoxFilter1 src res = Filter src (Kernel src src) FilterFold1 src- res---- | Separable 2D filters which are initialized with a value.-type SeparableFilter src acc res = Filter src (SeparableKernel src acc)- (FilterFold acc) acc res---- | Separable 2D filters which are not initialized with a value.-type SeparableFilter1 src res = Filter src (SeparableKernel src src)- FilterFold1 src res---- | Defines how the center of the kernel will be determined.-data KernelAnchor = KernelAnchor !DIM2 | KernelAnchorCenter---- | A simple 2D kernel.------ The kernel function accepts the coordinates in the kernel, the value of the--- pixel at these coordinates ('src'), the current accumulated value and returns--- a new accumulated value.------ Non-separable filters computational complexity grows quadratically according--- to the size of the sides of the kernel.-newtype Kernel src acc = Kernel (DIM2 -> src -> acc -> acc)---- | Some kernels can be factorized in two uni-dimensional kernels (horizontal--- and vertical).------ Separable filters computational complexity grows linearly according to the--- size of the sides of the kernel.------ See <http://http://en.wikipedia.org/wiki/Separable_filter>.-data SeparableKernel src acc = SeparableKernel {- -- | Vertical (column) kernel.- skVertical :: !(DIM1 -> src -> acc -> acc)- -- | Horizontal (row) kernel.- , skHorizontal :: !(DIM1 -> acc -> acc -> acc)- }---- | Used to determine the type of the accumulator image used when computing--- separable filters.------ 'src' and 'res' are respectively the source and the result image types while--- 'acc' is the pixel type of the accumulator.-class SeparatelyFiltrable src res acc where- type SeparableFilterAccumulator src res acc--instance SeparatelyFiltrable src (Manifest p) acc where- type SeparableFilterAccumulator src (Manifest p) acc = Manifest acc--instance SeparatelyFiltrable src (Delayed p) acc where- type SeparableFilterAccumulator src (Delayed p) acc = Delayed acc---- | Uses an initial value to initialize the filter.-data FilterFold acc = FilterFold acc---- | Uses the first pixel in the kernel as initial value. The kernel must not be--- empty and the accumulator type must be the same as the source pixel type.------ This kind of initialization is needed by morphological filters.-data FilterFold1 = FilterFold1---- | Defines how image boundaries are extrapolated by the algorithms.------ '|' characters in examples are image borders.-data BorderInterpolate a =- -- | Replicates the first and last pixels of the image.- --- -- > aaaaaa|abcdefgh|hhhhhhh- BorderReplicate- -- | Reflects the border of the image.- --- -- > fedcba|abcdefgh|hgfedcb- | BorderReflect- -- | Considers that the last pixel of the image is before the first one.- --- -- > cdefgh|abcdefgh|abcdefg- | BorderWrap- -- | Assigns a constant value to out of image pixels.- --- -- > iiiiii|abcdefgh|iiiiiii with some specified 'i'- | BorderConstant !a---- Instances ----------------------------------------------------------------------- Following implementations share a lot of similar processing. However, GHC--- fails to specialise and optimise correctly when goXXX functions are top-level--- functions, even with static argument transformations.---- | Box filters initialized with a given value.-instance (Image src, FromFunction res, src_p ~ ImagePixel src- , res_p ~ FromFunctionPixel res)- => Filterable src res (BoxFilter src_p acc res_p) where- apply !(Filter ksize anchor (Kernel kernel) ini post interpol) !img =- let !(FilterFold acc) = ini- in fromFunction size $ \(!pt@(Z :. iy :. ix)) ->- let !iy0 = iy - kcy- !ix0 = ix - kcx- !safe = iy0 >= 0 && iy0 + kh <= ih- && ix0 >= 0 && ix0 + kw <= iw- !pix = img `index` pt- in post pix $! if safe then goColumnSafe (iy0 * iw) ix0 0 acc- else goColumn iy0 ix0 0 acc- where- !size@(Z :. ih :. iw) = shape img-- !(Z :. kh :. kw) = ksize- !(Z :. kcy :. kcx) = kernelAnchor anchor ksize-- goColumn !iy !ix !ky !acc- | ky < kh = case borderInterpolate interpol ih iy of- Left iy' -> goLine iy (iy' * iw) ix ix ky 0 acc- Right val -> goLineConst iy ix ky 0 val acc- | otherwise = acc-- goColumnSafe !linearIY !ix !ky !acc- | ky < kh = goLineSafe linearIY ix ix ky 0 acc- | otherwise = acc-- goLine !iy !linearIY !ix0 !ix !ky !kx !acc- | kx < kw =- let !val = case borderInterpolate interpol iw ix of- Left ix' -> img `linearIndex` (linearIY + ix')- Right val' -> val'- !acc' = kernel (ix2 ky kx) val acc- in goLine iy linearIY ix0 (ix + 1) ky (kx + 1) acc'- | otherwise = goColumn (iy + 1) ix0 (ky + 1) acc-- goLineSafe !linearIY !ix0 !ix !ky !kx !acc- | kx < kw =- let !val = img `linearIndex` (linearIY + ix)- !acc' = kernel (ix2 ky kx) val acc- in goLineSafe linearIY ix0 (ix + 1) ky (kx + 1) acc'- | otherwise = goColumnSafe (linearIY + iw) ix0 (ky + 1) acc-- goLineConst !iy !ix !ky !kx !val !acc- | kx < kw = let !acc' = kernel (ix2 ky kx) val acc- in goLineConst iy ix ky (kx + 1) val acc'- | otherwise = goColumn (iy + 1) ix (ky + 1) acc- {-# INLINE apply #-}---- | Box filters initialized using the first pixel of the kernel.-instance (Image src, FromFunction res, src_p ~ ImagePixel src- , res_p ~ FromFunctionPixel res)- => Filterable src res (BoxFilter1 src_p res_p) where- apply !(Filter ksize anchor (Kernel kernel) _ post interpol) !img- | kh == 0 || kw == 0 =- error "Using FilterFold1 with an empty kernel."- | otherwise =- fromFunction size $ \(!pt@(Z :. iy :. ix)) ->- let !iy0 = iy - kcy- !ix0 = ix - kcx- !safe = iy0 >= 0 && iy0 + kh <= ih- && ix0 >= 0 && ix0 + kw <= iw- !pix = img `index` pt- in post pix $! if safe then goColumn1Safe iy0 ix0- else goColumn1 iy0 ix0- where- !size@(Z :. ih :. iw) = shape img-- !(Z :. kh :. kw) = ksize- !(Z :. kcy :. kcx) = kernelAnchor anchor ksize-- goColumn1 !iy !ix =- case borderInterpolate interpol ih iy of- Left iy' ->- let !linearIY = iy' * iw- !acc = safeIndex linearIY ix- in goLine iy linearIY ix (ix + 1) 0 1 acc- Right val -> goLineConst iy ix 0 1 val val-- goColumn1Safe !iy !ix =- let !linearIY = iy * iw- !acc = img `linearIndex` (linearIY + ix)- in goLineSafe linearIY ix (ix + 1) 0 1 acc-- goColumn !iy !ix !ky !acc- | ky < kh = case borderInterpolate interpol ih iy of- Left iy' -> goLine iy (iy' * iw) ix ix ky 0 acc- Right val -> goLineConst iy ix ky 0 val acc- | otherwise = acc-- goColumnSafe !linearIY !ix !ky !acc- | ky < kh = goLineSafe linearIY ix ix ky 0 acc- | otherwise = acc-- goLine !iy !linearIY !ix0 !ix !ky !kx !acc- | kx < kw =- let !val = safeIndex linearIY ix- !acc' = kernel (ix2 ky kx) val acc- in goLine iy linearIY ix0 (ix + 1) ky (kx + 1) acc'- | otherwise = goColumn (iy + 1) ix0 (ky + 1) acc-- goLineSafe !linearIY !ix0 !ix !ky !kx !acc- | kx < kw =- let !val = img `linearIndex` (linearIY + ix)- !acc' = kernel (ix2 ky kx) val acc- in goLineSafe linearIY ix0 (ix + 1) ky (kx + 1) acc'- | otherwise = goColumnSafe (linearIY + iw) ix0 (ky + 1) acc-- goLineConst !iy !ix !ky !kx !val !acc- | kx < kw = let !acc' = kernel (ix2 ky kx) val acc- in goLineConst iy ix ky (kx + 1) val acc'- | otherwise = goColumn (iy + 1) ix (ky + 1) acc-- safeIndex !linearIY !ix =- case borderInterpolate interpol iw ix of- Left ix' -> img `linearIndex` (linearIY + ix')- Right val -> val- {-# INLINE apply #-}---- | Separable filters initialized with a given value.-instance (Image src, FromFunction res, SeparatelyFiltrable src res acc- , src_p ~ ImagePixel src, res_p ~ FromFunctionPixel res- , FromFunction (SeparableFilterAccumulator src res acc)- , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc- , Image (SeparableFilterAccumulator src res acc)- , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc)- => Filterable src res (SeparableFilter src_p acc res_p)- where- apply !f !img =- fst $! wrapper img f- where- wrapper :: (Image src, FromFunction res- , FromFunction (SeparableFilterAccumulator src res acc)- , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc- , Image (SeparableFilterAccumulator src res acc)- , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc)- => src- -> SeparableFilter (ImagePixel src) acc (FromFunctionPixel res)- -> (res, SeparableFilterAccumulator src res acc)- wrapper !src !(Filter ksize anchor kernel ini post interpol) =- (res, tmp)- where- !size@(Z :. ih :. iw) = shape src-- !(Z :. kh :. kw) = ksize- !(Z :. kcy :. kcx) = kernelAnchor anchor ksize-- !(SeparableKernel vert horiz) = kernel- !(FilterFold acc0) = ini-- !tmp = fromFunction size $ \(!(Z :. iy :. ix)) ->- let !iy0 = iy - kcy- in if iy0 >= 0 && iy0 + kh <= ih- then goColumnSafe iy0 ix 0 acc0- else goColumn iy0 ix 0 acc0-- !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) ->- let !ix0 = ix - kcx- !pix = src `index` pt- in post pix $! if ix0 >= 0 && ix0 + kw <= iw- then goLineSafe (iy * iw) ix0 0 acc0- else goLine (iy * iw) ix0 0 acc0-- goColumn !iy !ix !ky !acc- | ky < kh =- let !val = case borderInterpolate interpol ih iy of- Left iy' -> src `index` ix2 iy' ix- Right val' -> val'- !acc' = vert (ix1 ky) val acc- in goColumn (iy + 1) ix (ky + 1) acc'- | otherwise = acc-- goColumnSafe !iy !ix !ky !acc- | ky < kh =- let !val = src `index` ix2 iy ix- !acc' = vert (ix1 ky) val acc- in goColumnSafe (iy + 1) ix (ky + 1) acc'- | otherwise = acc-- goLine !linearIY !ix !kx !acc- | kx < kw =- let !val =- case borderInterpolate interpol iw ix of- Left ix'-> tmp `linearIndex` (linearIY + ix')- Right _ -> constLine- !acc' = horiz (ix1 kx) val acc- in goLine linearIY (ix + 1) (kx + 1) acc'- | otherwise = acc-- goLineSafe !linearIY !ix !kx !acc- | kx < kw =- let !val = tmp `linearIndex` (linearIY + ix)- !acc' = horiz (ix1 kx) val acc- in goLineSafe linearIY (ix + 1) (kx + 1) acc'- | otherwise = acc-- constLine | BorderConstant val <- interpol =- foldl' (\acc ky -> vert (ix1 ky) val acc) acc0 [0..kh-1]- | otherwise = undefined- {-# INLINE wrapper #-}- {-# INLINE apply #-}---- | Separable filters initialized using the first pixel of the kernel.-instance (Image src, FromFunction res, SeparatelyFiltrable src res src_p- , src_p ~ ImagePixel src, res_p ~ FromFunctionPixel res- , FromFunction (SeparableFilterAccumulator src res src_p)- , FromFunctionPixel (SeparableFilterAccumulator src res src_p) ~ src_p- , Image (SeparableFilterAccumulator src res src_p)- , ImagePixel (SeparableFilterAccumulator src res src_p) ~ src_p)- => Filterable src res (SeparableFilter1 src_p res_p)- where- apply !f !img =- fst $! wrapper img f- where- wrapper :: (Image src, FromFunction res, acc ~ ImagePixel src- , FromFunction (SeparableFilterAccumulator src res acc)- , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc- , Image (SeparableFilterAccumulator src res acc)- , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc)- => src- -> SeparableFilter1 (ImagePixel src) (FromFunctionPixel res)- -> (res, SeparableFilterAccumulator src res acc)- wrapper !src !(Filter ksize anchor kernel _ post interpol)- | kh == 0 || kw == 0 =- error "Using FilterFold1 with an empty kernel."- | otherwise =- (res, tmp)- where- !size@(Z :. ih :. iw) = shape src-- !(Z :. kh :. kw) = ksize- !(Z :. kcy :. kcx) = kernelAnchor anchor ksize-- !(SeparableKernel vert horiz) = kernel-- !tmp = fromFunction size $ \(!(Z :. iy :. ix)) ->- let !iy0 = iy - kcy- in if iy0 >= 0 && iy0 + kh <= ih- then goColumn1Safe iy0 ix- else goColumn1 iy0 ix-- !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) ->- let !ix0 = ix - kcx- !pix = src `index` pt- in post pix $! if ix0 >= 0 && ix0 + kw <= iw- then goLine1Safe (iy * iw) ix0- else goLine1 (iy * iw) ix0-- goColumn1 !iy !ix =- case borderInterpolate interpol ih iy of- Left iy' ->- let !acc = src `index` ix2 iy' ix- in goColumn (iy + 1) ix 1 acc- Right val ->- goColumn (iy + 1) ix 1 val-- goColumn1Safe !iy !ix =- let !linearIY = iy * iw- !acc = src `linearIndex` (linearIY + ix)- in goColumnSafe (linearIY + iw) ix 1 acc-- goColumn !iy !ix !ky !acc- | ky < kh =- let !val = case borderInterpolate interpol ih iy of- Left iy' -> src `index` ix2 iy' ix- Right val' -> val'- !acc' = vert (ix1 ky) val acc- in goColumn (iy + 1) ix (ky + 1) acc'- | otherwise = acc-- goColumnSafe !linearIY !ix !ky !acc- | ky < kh =- let !val = src `linearIndex` (linearIY + ix)- !acc' = vert (ix1 ky) val acc- in goColumnSafe (linearIY + iw) ix (ky + 1) acc'- | otherwise = acc-- goLine1 !linearIY !ix =- let !acc =- case borderInterpolate interpol iw ix of- Left ix' -> tmp `linearIndex` (linearIY + ix')- Right _ -> columnConst- in goLine linearIY (ix + 1) 1 acc-- goLine1Safe !linearIY !ix =- let !linearIX = linearIY + ix- !acc = tmp `linearIndex` linearIX- in goLineSafe (linearIX + 1) 1 acc-- goLine !linearIY !ix !kx !acc- | kx < kw =- let !val =- case borderInterpolate interpol iw ix of- Left ix'-> tmp `linearIndex` (linearIY + ix')- Right _ -> columnConst- !acc' = horiz (ix1 kx) val acc- in goLine linearIY (ix + 1) (kx + 1) acc'- | otherwise = acc-- goLineSafe !linearIX !kx !acc- | kx < kw =- let !val = tmp `linearIndex` linearIX- !acc' = horiz (ix1 kx) val acc- in goLineSafe (linearIX + 1) (kx + 1) acc'- | otherwise = acc-- columnConst- | BorderConstant val <- interpol = goColumnConst 1 val val- | otherwise = undefined-- goColumnConst !ky !val !acc- | ky < kh = goColumnConst (ky + 1) val (vert (ix1 ky) acc val)- | otherwise = acc- {-# INLINE wrapper #-}- {-# INLINE apply #-}---- Functions ----------------------------------------------------------------------- | Given a method to compute the kernel anchor and the size of the kernel,--- returns the anchor of the kernel as coordinates.-kernelAnchor :: KernelAnchor -> Size -> DIM2-kernelAnchor (KernelAnchor ix) _ = ix-kernelAnchor (KernelAnchorCenter) (Z :. kh :. kw) = ix2 (round $ (kh - 1) % 2)- (round $ (kw - 1) % 2)+import Vision.Primitive (Size) --- | Given a method of interpolation, the number of pixel in the dimension and--- an index in this dimension, returns either the index of the interpolated--- pixel or a constant value.-borderInterpolate :: BorderInterpolate a- -> Int -- ^ The size of the dimension.- -> Int -- ^ The index in the dimension.- -> Either Int a-borderInterpolate !interpol !len !ix- | word ix < word len = Left ix- | otherwise =- case interpol of- BorderReplicate | ix < 0 -> Left 0- | otherwise -> Left $! len - 1- BorderReflect -> Left $! goReflect ix- BorderWrap -> Left $! ix `mod` len- BorderConstant i -> Right i- where- goReflect !ix' | ix' < 0 = goReflect (-ix' - 1)- | ix' >= len = goReflect ((len - 1) - (ix' - len))- | otherwise = ix'-{-# INLINE borderInterpolate #-}+import qualified Vision.Image.Filter.Internal as Internal -- Morphological operators ----------------------------------------------------- -dilate :: Ord src => Int -> SeparableFilter1 src src-dilate radius =- Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel)- FilterFold1 (\_ acc -> acc) BorderReplicate- where- !size = radius * 2 + 1-- kernel _ = max-{-# INLINE dilate #-}+dilate, erode :: ( Image src, Ord (ImagePixel src)+ , FromFunction res, FromFunctionPixel res ~ ImagePixel src+ , SeparatelyFiltrable src res (ImagePixel src))+ => Int -- ^ Kernel radius.+ -> src+ -> res -erode :: Ord src => Int -> SeparableFilter1 src src-erode radius =- Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel)- FilterFold1 (\_ acc -> acc) BorderReplicate- where- !size = radius * 2 + 1+dilate radius img = Internal.dilate radius `Internal.apply` img+{-# INLINABLE dilate #-} - kernel _ = min-{-# INLINE erode #-}+erode radius img = Internal.erode radius `Internal.apply` img+{-# INLINABLE erode #-} -- Blur ------------------------------------------------------------------------ -- | Blurs the image by averaging the pixel inside the kernel. ----- Considers using a type for 'acc' with--- @maxBound acc >= maxBound src * (kernel size)²@.-blur :: (Integral src, Integral acc, Num res)- => Int -- ^ Blur radius.- -> SeparableFilter src acc res-blur radius =- Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz)- (FilterFold 0) post BorderReplicate- where- !size = radius * 2 + 1- !nPixs = fromIntegral $ square size-- vert _ !val !acc = acc + fromIntegral val-- horiz _ !acc' !acc = acc + acc'-- post _ acc = fromIntegral $ acc `div` nPixs-{-# INLINE blur #-}+-- Uses an 'Int32' as accumulator during the averaging operation.+blur :: ( Image src, Integral (ImagePixel src)+ , FromFunction res, Num (FromFunctionPixel res)+ , SeparatelyFiltrable src res Int32)+ => Int -- ^ Blur radius.+ -> src+ -> res+blur radius img =+ let filt :: (Integral src, Num res) => Internal.Blur src Int32 res+ filt = Internal.blur radius+ in filt `Internal.apply` img+{-# INLINABLE blur #-} -- | Blurs the image by averaging the pixel inside the kernel using a Gaussian -- function. -- -- See <http://en.wikipedia.org/wiki/Gaussian_blur>-gaussianBlur :: (Integral src, Floating acc, RealFrac acc, Storable acc- , Integral res)- => Int -- ^ Blur radius.+gaussianBlur :: ( Image src, Integral (ImagePixel src)+ , FromFunction res, Integral (FromFunctionPixel res)+ , Floating acc, RealFrac acc, Storable acc+ , SeparatelyFiltrable src res acc)+ => Int -- ^ Blur radius. -> Maybe acc -- ^ Sigma value of the Gaussian function. If not given, will be -- automatically computed from the radius so that the kernel -- fits 3σ of the distribution.- -> SeparableFilter src acc res-gaussianBlur !radius !mSig =- Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz)- (FilterFold 0) (\_ !acc -> round acc) BorderReplicate- where- !size = radius * 2 + 1-- -- If σ is not provided, tries to fit 3σ in the kernel.- !sig = case mSig of Just s -> s- Nothing -> (0.5 + fromIntegral radius) / 3-- vert !(Z :. y) !val !acc = let !coeff = kernelVec V.! y- in acc + fromIntegral val * coeff-- horiz !(Z :. x) !val !acc = let !coeff = kernelVec V.! x- in acc + val * coeff-- !kernelVec =- -- Creates a vector of Gaussian values and normalizes it so its sum- -- equals 1.- let !unormalized = V.generate size $ \x ->- gaussian $! fromIntegral $! abs $! x - radius- !kernelSum = V.sum unormalized- in V.map (/ kernelSum) unormalized-- gaussian !x = invSigSqrt2Pi * exp (inv2xSig2 * square x)-- -- Pre-computed terms of the Gaussian function.- !invSigSqrt2Pi = 1 / (sig * sqrt (2 * pi))- !inv2xSig2 = -1 / (2 * square sig)-{-# INLINE gaussianBlur #-}+ -> src+ -> res+gaussianBlur radius mSig img =+ Internal.gaussianBlur radius mSig `Internal.apply` img+{-# INLINABLE gaussianBlur #-} -- Derivation ------------------------------------------------------------------ -data Derivative = DerivativeX | DerivativeY- -- | Estimates the first derivative using the Scharr's 3x3 kernel. -- -- Convolves the following kernel for the X derivative:@@ -630,61 +112,46 @@ -- 3 10 3 -- @ ----- Considers using a signed integer type for 'res' with--- @maxBound res >= 16 * maxBound src@.-scharr :: (Integral src, Integral res)- => Derivative -> SeparableFilter src res res-scharr der =- let !kernel =- case der of- DerivativeX -> SeparableKernel kernel1 kernel2- DerivativeY -> SeparableKernel kernel2 kernel1- in Filter (ix2 3 3) KernelAnchorCenter kernel (FilterFold 0) (\_ acc -> acc)- BorderReplicate- where- kernel1 !(Z :. 1) !val !acc = acc + 10 * fromIntegral val- kernel1 !(Z :. _) !val !acc = acc + 3 * fromIntegral val-- kernel2 !(Z :. 0) !val !acc = acc - fromIntegral val- kernel2 !(Z :. 1) !_ !acc = acc- kernel2 !(Z :. ~2) !val !acc = acc + fromIntegral val-{-# INLINE scharr #-}+-- Uses an 'Int32' as accumulator during kernel application.+scharr :: ( Image src, Integral (ImagePixel src)+ , FromFunction res, Integral (FromFunctionPixel res)+ , Storable (FromFunctionPixel res)+ , SeparatelyFiltrable src res (FromFunctionPixel res))+ => DerivativeType -> src -> res+scharr der img = Internal.scharr der `Internal.apply` img+{-# INLINABLE scharr #-} -- | Estimates the first derivative using a Sobel's kernel. -- -- Prefer 'scharr' when radius equals @1@ as Scharr's kernel is more accurate -- and is implemented faster. ----- Considers using a signed integer type for 'res' which is significantly larger--- than 'src', especially for large kernels.-sobel :: (Integral src, Integral res, Storable res)- => Int -- ^ Kernel radius.- -> Derivative- -> SeparableFilter src res res-sobel radius der =- Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz)- (FilterFold 0) (\_ acc -> acc) BorderReplicate- where- !size = radius * 2 + 1-- vert !(Z :. x) !val !acc = let !coeff = vec1 V.! x- in acc + fromIntegral val * coeff-- horiz !(Z :. x) !val !acc = let !coeff = vec2 V.! x- in acc + fromIntegral val * coeff-- !radius' = fromIntegral radius-- (!vec1, !vec2) = case der of DerivativeX -> (vec1', vec2')- DerivativeY -> (vec2', vec1')-- !vec1' = let pows = [ 2^i | i <- [0..radius'] ]- in V.fromList $ pows ++ (tail (reverse pows))- !vec2' = V.fromList $ map negate [1..radius'] ++ [0] ++ [1..radius']-{-# INLINE sobel #-}+-- Uses an 'Int32' as accumulator during kernel application.+sobel :: ( Image src, Integral (ImagePixel src)+ , FromFunction res, Integral (FromFunctionPixel res)+ , Storable (FromFunctionPixel res)+ , SeparatelyFiltrable src res (FromFunctionPixel res))+ => Int -- ^ Kernel radius.+ -> DerivativeType+ -> src+ -> res+sobel radius der img = Internal.sobel radius der `Internal.apply` img+{-# INLINABLE sobel #-} -square :: Num a => a -> a-square a = a * a+-- Others ---------------------------------------------------------------------- -word :: Integral a => a -> Word-word = fromIntegral+-- | Computes the average of a kernel of the given size.+--+-- This is similar to 'blur' but with a rectangular kernel and a 'Fractional'+-- result.+--+-- Uses an 'Int32' as accumulator during the averaging operation.+mean :: ( Image src, Integral (ImagePixel src)+ , FromFunction res, Fractional (FromFunctionPixel res)+ , SeparatelyFiltrable src res Int32)+ => Size -> src -> res+mean size img =+ let filt :: (Integral src, Fractional res) => Internal.Mean src Int32 res+ filt = Internal.mean size+ in filt `Internal.apply` img+{-# INLINABLE mean #-}
+ src/Vision/Image/Filter/Internal.hs view
@@ -0,0 +1,762 @@+{-# LANGUAGE BangPatterns+ , CPP+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , MultiParamTypeClasses+ , TypeFamilies+ , TupleSections+ , ScopedTypeVariables #-}++-- | Provides high level functions to define and apply filters on images.+--+-- Filters are operations on images on which the surrounding of each processed+-- pixel is considered according to a kernel.+--+-- Please use 'Vision.Image.Filter' if you only want to apply filter to images.+--+-- To apply a filter to an image, use the 'apply' method:+--+-- @+-- let -- Creates a filter which will blur the image. Uses a 'Double' as+-- -- accumulator of the Gaussian kernel.+-- filter :: 'Blur' GreyPixel Double GreyPixel+-- filter = 'gaussianBlur' 2 Nothing+-- in 'apply' filter img :: Grey+-- @+--+-- The @radius@ argument of some filters is used to determine the kernel size.+-- A radius as of 1 means a kernel of size 3, 2 a kernel of size 5 and so on.+--+-- The @acc@ type argument of some filters defines the type which will be used+-- to store the accumulated value of the kernel (e.g. by setting @acc@ to+-- 'Double' in the computation of a Gaussian blur, the kernel average will be+-- computed using a 'Double').+module Vision.Image.Filter.Internal (+ -- * Types+ Filterable (..), Filter (..)+ , BoxFilter, BoxFilter1, SeparableFilter, SeparableFilter1+ , KernelAnchor (..)+ , Kernel (..)+ , SeparableKernel (..), SeparatelyFiltrable (..)+ , FilterFold (..), FilterFold1 (..)+ , BorderInterpolate (..)+ -- * Functions+ , kernelAnchor, borderInterpolate+ -- * Filters+ -- ** Morphological operators+ , Morphological, dilate, erode+ -- ** Blur+ , Blur, blur, gaussianBlur+ -- ** Derivation+ , Derivative, DerivativeType (..), scharr, sobel+ -- ** Others+ , Mean, mean+ ) where++#if __GLASGOW_HASKELL__ < 710+import Data.Word+#endif++import Data.List+import Data.Ratio+import Foreign.Storable (Storable)++import qualified Data.Vector.Storable as V++import Vision.Image.Class (MaskedImage (..), Image (..), FromFunction (..), (!))+import Vision.Image.Type (Manifest, Delayed)+import Vision.Primitive (Z (..), (:.) (..), DIM1, Point, Size, ix1, ix2)++-- Types -----------------------------------------------------------------------++-- | Provides an implementation to execute a type of filter.+--+-- 'src' is the original image, 'res' the resulting image and 'f' the filter.+class Filterable src res f where+ -- | Applies the given filter on the given image.+ apply :: f -> src -> res++data Filter src kernel init fold acc res = Filter {+ fKernelSize :: !Size+ , fKernelCenter :: !KernelAnchor+ -- | See 'Kernel' and 'SeparableKernel'.+ , fKernel :: !kernel+ -- | Computes a constant value for each pixel before applying the kernel.+ --+ -- This value will be passed to 'fKernel' functions and to the 'fPost'+ -- function.+ -- For most filters, @fInit@ will be @\_ _ -> ()@.+ , fInit :: !(Point -> src -> init)+ -- | Defines how the accumulated value is initialized.+ --+ -- See 'FilterFold' and 'FilterFold1'.+ , fFold :: !fold+ -- | This function will be executed after the iteration of the kernel on a+ -- given point.+ --+ -- Can be used to normalize the accumulated value, for example.+ , fPost :: !(Point -> src -> init -> acc -> res)+ , fInterpol :: !(BorderInterpolate src)+ }++-- | 2D filters which are initialized with a value.+type BoxFilter src init acc res = Filter src (Kernel src init acc) init+ (FilterFold acc) acc res++-- | 2D filters which are not initialized with a value.+type BoxFilter1 src init res = Filter src (Kernel src init src) init+ FilterFold1 src res++-- | Separable 2D filters which are initialized with a value.+type SeparableFilter src init acc res = Filter src+ (SeparableKernel src init acc)+ init (FilterFold acc) acc res++-- | Separable 2D filters which are not initialized with a value.+type SeparableFilter1 src init res = Filter src+ (SeparableKernel src init src)+ init FilterFold1 src res++-- | Defines how the center of the kernel will be determined.+data KernelAnchor = KernelAnchor !Point | KernelAnchorCenter++-- | A simple 2D kernel.+--+-- The kernel function accepts the coordinates in the kernel, the value of the+-- pixel at these coordinates ('src'), the current accumulated value and returns+-- a new accumulated value.+--+-- Non-separable filters computational complexity grows quadratically according+-- to the size of the sides of the kernel.+newtype Kernel src init acc = Kernel (init -> Point -> src -> acc -> acc)++-- | Some kernels can be factorized in two uni-dimensional kernels (horizontal+-- and vertical).+--+-- Separable filters computational complexity grows linearly according to the+-- size of the sides of the kernel.+--+-- See <http://http://en.wikipedia.org/wiki/Separable_filter>.+data SeparableKernel src init acc = SeparableKernel {+ -- | Vertical (column) kernel.+ skVertical :: !(init -> DIM1 -> src -> acc -> acc)+ -- | Horizontal (row) kernel.+ , skHorizontal :: !(init -> DIM1 -> acc -> acc -> acc)+ }++-- | Used to determine the type of the accumulator image used when computing+-- separable filters.+--+-- 'src' and 'res' are respectively the source and the result image types while+-- 'acc' is the pixel type of the accumulator.+class ( Image (SeparableFilterAccumulator src res acc)+ , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc+ , FromFunction (SeparableFilterAccumulator src res acc)+ , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc)+ => SeparatelyFiltrable src res acc where+ type SeparableFilterAccumulator src res acc++instance Storable acc => SeparatelyFiltrable src (Manifest p) acc where+ type SeparableFilterAccumulator src (Manifest p) acc = Manifest acc++instance Storable acc => SeparatelyFiltrable src (Delayed p) acc where+ type SeparableFilterAccumulator src (Delayed p) acc = Delayed acc++-- | Uses the result of the provided function as the initial value of the+-- kernel's accumulator, depending on the center coordinates in the image.+--+-- For most filters, the function will always return the same value (i.e.+-- defined as @const 0@), but this kind of initialization could be required for+-- some filters.+data FilterFold acc = FilterFold (Point -> acc)++-- | Uses the first pixel in the kernel as initial value. The kernel must not be+-- empty and the accumulator type must be the same as the source pixel type.+--+-- This kind of initialization is needed by morphological filters.+data FilterFold1 = FilterFold1++-- | Defines how image boundaries are extrapolated by the algorithms.+--+-- '|' characters in examples are image borders.+data BorderInterpolate a =+ -- | Replicates the first and last pixels of the image.+ --+ -- > aaaaaa|abcdefgh|hhhhhhh+ BorderReplicate+ -- | Reflects the border of the image.+ --+ -- > fedcba|abcdefgh|hgfedcb+ | BorderReflect+ -- | Considers that the last pixel of the image is before the first one.+ --+ -- > cdefgh|abcdefgh|abcdefg+ | BorderWrap+ -- | Assigns a constant value to out of image pixels.+ --+ -- > iiiiii|abcdefgh|iiiiiii with some specified 'i'+ | BorderConstant !a++-- Instances -------------------------------------------------------------------++-- Following implementations share a lot of similar processing. However, GHC+-- fails to specialise and optimise correctly when goXXX functions are top-level+-- functions, even with static argument transformations.++-- | Box filters initialized with a given value.+instance (Image src, FromFunction res, src_pix ~ ImagePixel src+ , res_pix ~ FromFunctionPixel res)+ => Filterable src res (BoxFilter src_pix init acc res_pix) where+ apply !(Filter ksize anchor (Kernel kernel) initF fold post interpol) !img =+ let !(FilterFold fAcc) = fold+ in fromFunction size $ \(!pt@(Z :. iy :. ix)) ->+ let pix = img ! pt+ !ini = initF pt pix+ !acc = fAcc pt+ !iy0 = iy - kcy+ !ix0 = ix - kcx+ !safe = iy0 >= 0 && iy0 + kh <= ih+ && ix0 >= 0 && ix0 + kw <= iw+ in post pt pix ini $!+ if safe then goColumnSafe ini (iy0 * iw) ix0 0 acc+ else goColumn ini iy0 ix0 0 acc+ where+ !size@(Z :. ih :. iw) = shape img++ !(Z :. kh :. kw) = ksize+ !(Z :. kcy :. kcx) = kernelAnchor anchor ksize++ goColumn !ini !iy !ix !ky !acc+ | ky < kh = case borderInterpolate interpol ih iy of+ Left iy' -> goLine ini iy (iy' * iw) ix ix ky 0 acc+ Right val -> goLineConst ini iy ix ky 0 val acc+ | otherwise = acc++ goColumnSafe !ini !linearIY !ix !ky !acc+ | ky < kh = goLineSafe ini linearIY ix ix ky 0 acc+ | otherwise = acc++ goLine !ini !iy !linearIY !ix0 !ix !ky !kx !acc+ | kx < kw =+ let !val = case borderInterpolate interpol iw ix of+ Left ix' -> img `linearIndex` (linearIY + ix')+ Right val' -> val'+ !acc' = kernel ini (ix2 ky kx) val acc+ in goLine ini iy linearIY ix0 (ix + 1) ky (kx + 1) acc'+ | otherwise = goColumn ini (iy + 1) ix0 (ky + 1) acc++ goLineSafe !ini !linearIY !ix0 !ix !ky !kx !acc+ | kx < kw =+ let !val = img `linearIndex` (linearIY + ix)+ !acc' = kernel ini (ix2 ky kx) val acc+ in goLineSafe ini linearIY ix0 (ix + 1) ky (kx + 1) acc'+ | otherwise = goColumnSafe ini (linearIY + iw) ix0 (ky + 1) acc++ goLineConst !ini !iy !ix !ky !kx !val !acc+ | kx < kw = let !acc' = kernel ini (ix2 ky kx) val acc+ in goLineConst ini iy ix ky (kx + 1) val acc'+ | otherwise = goColumn ini (iy + 1) ix (ky + 1) acc+ {-# INLINE apply #-}++-- | Box filters initialized using the first pixel of the kernel.+instance (Image src, FromFunction res, src_pix ~ ImagePixel src+ , res_pix ~ FromFunctionPixel res)+ => Filterable src res (BoxFilter1 src_pix init res_pix) where+ apply !(Filter ksize anchor (Kernel kernel) initF _ post interpol) !img+ | kh == 0 || kw == 0 =+ error "Using FilterFold1 with an empty kernel."+ | otherwise =+ fromFunction size $ \(!pt@(Z :. iy :. ix)) ->+ let pix = img ! pt+ !ini = initF pt pix+ !iy0 = iy - kcy+ !ix0 = ix - kcx+ !safe = iy0 >= 0 && iy0 + kh <= ih+ && ix0 >= 0 && ix0 + kw <= iw+ in post pt pix ini $! if safe then goColumn1Safe ini iy0 ix0+ else goColumn1 ini iy0 ix0+ where+ !size@(Z :. ih :. iw) = shape img++ !(Z :. kh :. kw) = ksize+ !(Z :. kcy :. kcx) = kernelAnchor anchor ksize++ goColumn1 !ini !iy !ix =+ case borderInterpolate interpol ih iy of+ Left iy' ->+ let !linearIY = iy' * iw+ !acc = safeIndex linearIY ix+ in goLine ini iy linearIY ix (ix + 1) 0 1 acc+ Right val -> goLineConst ini iy ix 0 1 val val++ goColumn1Safe !ini !iy !ix =+ let !linearIY = iy * iw+ !acc = img `linearIndex` (linearIY + ix)+ in goLineSafe ini linearIY ix (ix + 1) 0 1 acc++ goColumn !ini !iy !ix !ky !acc+ | ky < kh = case borderInterpolate interpol ih iy of+ Left iy' -> goLine ini iy (iy' * iw) ix ix ky 0 acc+ Right val -> goLineConst ini iy ix ky 0 val acc+ | otherwise = acc++ goColumnSafe !ini !linearIY !ix !ky !acc+ | ky < kh = goLineSafe ini linearIY ix ix ky 0 acc+ | otherwise = acc++ goLine !ini !iy !linearIY !ix0 !ix !ky !kx !acc+ | kx < kw =+ let !val = safeIndex linearIY ix+ !acc' = kernel ini (ix2 ky kx) val acc+ in goLine ini iy linearIY ix0 (ix + 1) ky (kx + 1) acc'+ | otherwise = goColumn ini (iy + 1) ix0 (ky + 1) acc++ goLineSafe !ini !linearIY !ix0 !ix !ky !kx !acc+ | kx < kw =+ let !val = img `linearIndex` (linearIY + ix)+ !acc' = kernel ini (ix2 ky kx) val acc+ in goLineSafe ini linearIY ix0 (ix + 1) ky (kx + 1) acc'+ | otherwise = goColumnSafe ini (linearIY + iw) ix0 (ky + 1) acc++ goLineConst !ini !iy !ix !ky !kx !val !acc+ | kx < kw = let !acc' = kernel ini (ix2 ky kx) val acc+ in goLineConst ini iy ix ky (kx + 1) val acc'+ | otherwise = goColumn ini (iy + 1) ix (ky + 1) acc++ safeIndex !linearIY !ix =+ case borderInterpolate interpol iw ix of+ Left ix' -> img `linearIndex` (linearIY + ix')+ Right val -> val+ {-# INLINE apply #-}++-- | Separable filters initialized with a given value.+instance ( Image src, FromFunction res+ , src_pix ~ ImagePixel src+ , res_pix ~ FromFunctionPixel res+ , SeparatelyFiltrable src res acc)+ => Filterable src res (SeparableFilter src_pix init acc res_pix)+ where+ apply !f !img =+ fst $! wrapper img f+ where+ wrapper :: (Image src, FromFunction res)+ => src+ -> SeparableFilter (ImagePixel src) init acc (FromFunctionPixel res)+ -> (res, SeparableFilterAccumulator src res acc)+ wrapper !src !(Filter ksize anchor kernel initF fold post interpol) =+ (res, tmp)+ where+ !size@(Z :. ih :. iw) = shape src++ !(Z :. kh :. kw) = ksize+ !(Z :. kcy :. kcx) = kernelAnchor anchor ksize++ !(SeparableKernel vert horiz) = kernel+ !(FilterFold fAcc) = fold++ !tmp = fromFunction size $ \(!pt@(Z :. iy :. ix)) ->+ let pix = src ! pt+ !ini = initF pt pix+ !acc0 = fAcc pt+ !iy0 = iy - kcy+ in if iy0 >= 0 && iy0 + kh <= ih+ then goColumnSafe ini iy0 ix 0 acc0+ else goColumn ini iy0 ix 0 acc0++ !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) ->+ let pix = src ! pt+ !ini = initF pt pix+ !acc0 = fAcc pt+ !ix0 = ix - kcx+ in post pt pix ini $!+ if ix0 >= 0 && ix0 + kw <= iw+ then goLineSafe ini (iy * iw) ix0 0 acc0+ else goLine ini acc0 (iy * iw) ix0 0+ acc0++ goColumn !ini !iy !ix !ky !acc+ | ky < kh =+ let !val = case borderInterpolate interpol ih iy of+ Left iy' -> src ! ix2 iy' ix+ Right val' -> val'+ !acc' = vert ini (ix1 ky) val acc+ in goColumn ini (iy + 1) ix (ky + 1) acc'+ | otherwise = acc++ goColumnSafe !ini !iy !ix !ky !acc+ | ky < kh =+ let !val = src ! ix2 iy ix+ !acc' = vert ini (ix1 ky) val acc+ in goColumnSafe ini (iy + 1) ix (ky + 1) acc'+ | otherwise = acc++ goLine !ini !acc0 !linearIY !ix !kx !acc+ | kx < kw =+ let !val =+ case borderInterpolate interpol iw ix of+ Left ix' -> tmp `linearIndex` (linearIY + ix')+ Right val' -> constCol ini acc0 val'+ !acc' = horiz ini (ix1 kx) val acc+ in goLine ini acc0 linearIY (ix + 1) (kx + 1) acc'+ | otherwise = acc++ goLineSafe !ini !linearIY !ix !kx !acc+ | kx < kw =+ let !val = tmp `linearIndex` (linearIY + ix)+ !acc' = horiz ini (ix1 kx) val acc+ in goLineSafe ini linearIY (ix + 1) (kx + 1) acc'+ | otherwise = acc++ -- Computes the value of an out of image column when the+ -- interpolation method is BorderConstant.+ constCol !ini !acc0 !constVal =+ foldl' (\acc ky -> vert ini (ix1 ky) constVal acc) acc0+ [0..kh-1]+ {-# INLINE wrapper #-}+ {-# INLINE apply #-}++-- | Separable filters initialized using the first pixel of the kernel.+instance ( Image src, FromFunction res+ , src_pix ~ ImagePixel src+ , res_pix ~ FromFunctionPixel res+ , SeparatelyFiltrable src res src_pix)+ => Filterable src res (SeparableFilter1 src_pix init res_pix)+ where+ apply !f !img =+ fst $! wrapper img f+ where+ wrapper :: (Image src, FromFunction res, acc ~ ImagePixel src+ , FromFunction (SeparableFilterAccumulator src res acc)+ , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc+ , Image (SeparableFilterAccumulator src res acc)+ , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc)+ => src+ -> SeparableFilter1 (ImagePixel src) init (FromFunctionPixel res)+ -> (res, SeparableFilterAccumulator src res acc)+ wrapper !src !(Filter ksize anchor kernel initF _ post interpol)+ | kh == 0 || kw == 0 =+ error "Using FilterFold1 with an empty kernel."+ | otherwise =+ (res, tmp)+ where+ !size@(Z :. ih :. iw) = shape src++ !(Z :. kh :. kw) = ksize+ !(Z :. kcy :. kcx) = kernelAnchor anchor ksize++ !(SeparableKernel vert horiz) = kernel++ !tmp = fromFunction size $ \(!pt@(Z :. iy :. ix)) ->+ let pix = src ! pt+ !ini = initF pt pix+ !iy0 = iy - kcy+ in if iy0 >= 0 && iy0 + kh <= ih+ then goColumn1Safe ini iy0 ix+ else goColumn1 ini iy0 ix++ !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) ->+ let pix = src ! pt+ !ini = initF pt pix+ !ix0 = ix - kcx+ in post pt pix ini $!+ if ix0 >= 0 && ix0 + kw <= iw+ then goLine1Safe ini (iy * iw) ix0+ else goLine1 ini (iy * iw) ix0++ goColumn1 !ini !iy !ix =+ case borderInterpolate interpol ih iy of+ Left iy' ->+ let !acc = src ! ix2 iy' ix+ in goColumn ini (iy + 1) ix 1 acc+ Right val ->+ goColumn ini (iy + 1) ix 1 val++ goColumn1Safe !ini !iy !ix =+ let !linearIY = iy * iw+ !acc = src `linearIndex` (linearIY + ix)+ in goColumnSafe ini (linearIY + iw) ix 1 acc++ goColumn !ini !iy !ix !ky !acc+ | ky < kh =+ let !val = case borderInterpolate interpol ih iy of+ Left iy' -> src ! ix2 iy' ix+ Right val' -> val'+ !acc' = vert ini (ix1 ky) val acc+ in goColumn ini (iy + 1) ix (ky + 1) acc'+ | otherwise = acc++ goColumnSafe !ini !linearIY !ix !ky !acc+ | ky < kh =+ let !val = src `linearIndex` (linearIY + ix)+ !acc' = vert ini (ix1 ky) val acc+ in goColumnSafe ini (linearIY + iw) ix (ky + 1) acc'+ | otherwise = acc++ goLine1 !ini !linearIY !ix =+ let !acc =+ case borderInterpolate interpol iw ix of+ Left ix' -> tmp `linearIndex` (linearIY + ix')+ Right val -> columnConst ini val+ in goLine ini linearIY (ix + 1) 1 acc++ goLine1Safe !ini !linearIY !ix =+ let !linearIX = linearIY + ix+ !acc = tmp `linearIndex` linearIX+ in goLineSafe ini (linearIX + 1) 1 acc++ goLine !ini !linearIY !ix !kx !acc+ | kx < kw =+ let !val =+ case borderInterpolate interpol iw ix of+ Left ix' -> tmp `linearIndex` (linearIY + ix')+ Right val' -> columnConst ini val'+ !acc' = horiz ini (ix1 kx) val acc+ in goLine ini linearIY (ix + 1) (kx + 1) acc'+ | otherwise = acc++ goLineSafe !ini !linearIX !kx !acc+ | kx < kw =+ let !val = tmp `linearIndex` linearIX+ !acc' = horiz ini (ix1 kx) val acc+ in goLineSafe ini (linearIX + 1) (kx + 1) acc'+ | otherwise = acc++ columnConst !ini !constVal = goColumnConst ini 1 constVal constVal++ goColumnConst !ini !ky !constVal !acc+ | ky < kh = goColumnConst ini (ky + 1) constVal+ (vert ini (ix1 ky) acc constVal)+ | otherwise = acc+ {-# INLINE wrapper #-}+ {-# INLINE apply #-}++-- Functions -------------------------------------------------------------------++-- | Given a method to compute the kernel anchor and the size of the kernel,+-- returns the anchor of the kernel as coordinates.+kernelAnchor :: KernelAnchor -> Size -> Point+kernelAnchor (KernelAnchor ix) _ = ix+kernelAnchor (KernelAnchorCenter) (Z :. kh :. kw) = ix2 (round $ (kh - 1) % 2)+ (round $ (kw - 1) % 2)++-- | Given a method of interpolation, the number of pixel in the dimension and+-- an index in this dimension, returns either the index of the interpolated+-- pixel or a constant value.+borderInterpolate :: BorderInterpolate a+ -> Int -- ^ The size of the dimension.+ -> Int -- ^ The index in the dimension.+ -> Either Int a+borderInterpolate !interpol !len !ix+ | word ix < word len = Left ix+ | otherwise =+ case interpol of+ BorderReplicate | ix < 0 -> Left 0+ | otherwise -> Left $! len - 1+ BorderReflect -> Left $! goReflect ix+ BorderWrap -> Left $! ix `mod` len+ BorderConstant i -> Right i+ where+ goReflect !ix' | ix' < 0 = goReflect (-ix' - 1)+ | ix' >= len = goReflect ((len - 1) - (ix' - len))+ | otherwise = ix'+{-# INLINE borderInterpolate #-}++-- Morphological operators -----------------------------------------------------++type Morphological pix = SeparableFilter1 pix () pix++dilate :: Ord pix => Int -> Morphological pix+dilate radius =+ Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel)+ (\_ _ -> ()) FilterFold1 (\_ _ _ !acc -> acc) BorderReplicate+ where+ !size = radius * 2 + 1++ kernel _ _ = max+{-# INLINE dilate #-}++erode :: Ord pix => Int -> Morphological pix+erode radius =+ Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel)+ (\_ _ -> ()) FilterFold1 (\_ _ _ !acc -> acc) BorderReplicate+ where+ !size = radius * 2 + 1++ kernel _ _ = min+{-# INLINE erode #-}++-- Blur ------------------------------------------------------------------------++type Blur src acc res = SeparableFilter src () acc res++-- | Blurs the image by averaging the pixel inside the kernel.+--+-- Considers using a type for 'acc' with+-- @maxBound acc >= maxBound src * (kernel size)²@.+blur :: (Integral src, Integral acc, Num res)+ => Int -- ^ Blur radius.+ -> Blur src acc res+blur radius =+ Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz)+ (\_ _ -> ()) (FilterFold (const 0)) post BorderReplicate+ where+ !size = radius * 2 + 1+ !nPixs = fromIntegral $ square size++ vert _ _ !val !acc = acc + fromIntegral val+ horiz _ _ !acc' !acc = acc + acc'++ post _ _ _ !acc = fromIntegral $ acc `div` nPixs+{-# INLINE blur #-}++-- | Blurs the image by averaging the pixel inside the kernel using a Gaussian+-- function.+--+-- See <http://en.wikipedia.org/wiki/Gaussian_blur>+gaussianBlur :: (Integral src, Floating acc, RealFrac acc, Storable acc+ , Integral res)+ => Int -- ^ Blur radius.+ -> Maybe acc+ -- ^ Sigma value of the Gaussian function. If not given, will be+ -- automatically computed from the radius so that the kernel+ -- fits 3σ of the distribution.+ -> Blur src acc res+gaussianBlur !radius !mSig =+ Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) + (\_ _ -> ()) (FilterFold (const 0)) (\_ _ _ !acc -> round acc)+ BorderReplicate+ where+ !size = radius * 2 + 1++ -- If σ is not provided, tries to fit 3σ in the kernel.+ !sig = case mSig of Just s -> s+ Nothing -> (0.5 + fromIntegral radius) / 3++ vert _ !(Z :. y) !val !acc = let !coeff = kernelVec V.! y+ in acc + fromIntegral val * coeff++ horiz _ !(Z :. x) !val !acc = let !coeff = kernelVec V.! x+ in acc + val * coeff++ !kernelVec =+ -- Creates a vector of Gaussian values and normalizes it so its sum+ -- equals 1.+ let !unormalized = V.generate size $ \x ->+ gaussian $! fromIntegral $! abs $! x - radius+ !kernelSum = V.sum unormalized+ in V.map (/ kernelSum) unormalized++ gaussian !x = invSigSqrt2Pi * exp (inv2xSig2 * square x)++ -- Pre-computed terms of the Gaussian function.+ !invSigSqrt2Pi = 1 / (sig * sqrt (2 * pi))+ !inv2xSig2 = -1 / (2 * square sig)+{-# INLINE gaussianBlur #-}++-- Derivation ------------------------------------------------------------------++type Derivative src res = SeparableFilter src () res res++data DerivativeType = DerivativeX | DerivativeY++-- | Estimates the first derivative using the Scharr's 3x3 kernel.+--+-- Convolves the following kernel for the X derivative:+--+-- @+-- -3 0 3+-- -10 0 10+-- -3 0 3+-- @+--+-- And this kernel for the Y derivative:+--+-- @+-- -3 -10 -3+-- 0 0 0+-- 3 10 3+-- @+--+-- Considers using a signed integer type for 'res' with+-- @maxBound res >= 16 * maxBound src@.+scharr :: (Integral src, Integral res)+ => DerivativeType -> Derivative src res+scharr der =+ let !kernel =+ case der of+ DerivativeX -> SeparableKernel kernel1 kernel2+ DerivativeY -> SeparableKernel kernel2 kernel1+ in Filter (ix2 3 3) KernelAnchorCenter kernel (\_ _ -> ())+ (FilterFold (const 0)) (\_ _ _ !acc -> acc) BorderReplicate+ where+ kernel1 _ !(Z :. 1) !val !acc = acc + 10 * fromIntegral val+ kernel1 _ !(Z :. _) !val !acc = acc + 3 * fromIntegral val++ kernel2 _ !(Z :. 0) !val !acc = acc - fromIntegral val+ kernel2 _ !(Z :. 1) !_ !acc = acc+ kernel2 _ !(Z :. ~2) !val !acc = acc + fromIntegral val+{-# INLINE scharr #-}++-- | Estimates the first derivative using a Sobel's kernel.+--+-- Prefer 'scharr' when radius equals @1@ as Scharr's kernel is more accurate+-- and is implemented faster.+--+-- Considers using a signed integer type for 'res' which is significantly larger+-- than 'src', especially for large kernels.+sobel :: (Integral src, Integral res, Storable res)+ => Int -- ^ Kernel radius.+ -> DerivativeType+ -> Derivative src res+sobel radius der =+ Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz)+ (\_ _ -> ()) (FilterFold (const 0)) (\_ _ _ !acc -> acc)+ BorderReplicate+ where+ !size = radius * 2 + 1++ vert _ !(Z :. x) !val !acc = let !coeff = vec1 V.! x+ in acc + fromIntegral val * coeff++ horiz _ !(Z :. x) !val !acc = let !coeff = vec2 V.! x+ in acc + fromIntegral val * coeff++ !radius' = fromIntegral radius++ (!vec1, !vec2) = case der of DerivativeX -> (vec1', vec2')+ DerivativeY -> (vec2', vec1')++ !vec1' = let pows = [ 2^i | i <- [0..radius'] ]+ in V.fromList $ pows ++ (tail (reverse pows))+ !vec2' = V.fromList $ map negate [1..radius'] ++ [0] ++ reverse [1..radius']+{-# INLINE sobel #-}++-- Others ----------------------------------------------------------------------++type Mean src acc res = SeparableFilter src () acc res++-- | Computes the average of a kernel of the given size.+--+-- This is similar to 'blur' but with a rectangular kernel and a 'Fractional'+-- result.+mean :: (Integral src, Integral acc, Fractional res)+ => Size -> SeparableFilter src () acc res+mean size@(Z :. h :. w) =+ Filter size KernelAnchorCenter (SeparableKernel vert horiz) (\_ _ -> ())+ (FilterFold (const 0)) post BorderReplicate+ where+ vert _ _ !val !acc = acc + fromIntegral val+ horiz _ _ !acc' !acc = acc + acc'++ !nPixsFactor = 1 / (fromIntegral $! h * w)+ post _ _ _ !acc = fromIntegral acc * nPixsFactor+{-# INLINE mean #-}++-- -----------------------------------------------------------------------------++square :: Num a => a -> a+square a = a * a++word :: Integral a => a -> Word+word = fromIntegral
src/Vision/Image/Grey.hs view
@@ -2,6 +2,5 @@ module Vision.Image.Grey.Type ) where -import Vision.Image.Grey.Conversion () import Vision.Image.Grey.Specialize () import Vision.Image.Grey.Type
− src/Vision/Image/Grey/Conversion.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE BangPatterns, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Vision.Image.Grey.Conversion () where--import Data.Convertible (Convertible (..))-import qualified Data.Vector.Storable as V-import Data.Word--import Vision.Image.Grey.Type (GreyPixel (..))-import Vision.Image.RGBA.Type (RGBAPixel (..))-import Vision.Image.RGB.Type (RGBPixel (..))--instance Convertible GreyPixel GreyPixel where- safeConvert = Right- {-# INLINE safeConvert #-}--instance Convertible RGBAPixel GreyPixel where- safeConvert !(RGBAPixel r g b a) =- Right $ GreyPixel $ word8 $ int (rgbToGrey r g b) * int a `quot` 255- {-# INLINE safeConvert #-}--instance Convertible RGBPixel GreyPixel where- safeConvert !(RGBPixel r g b) =- Right $ GreyPixel $ rgbToGrey r g b- {-# INLINE safeConvert #-}---- | Converts the colors to greyscale using the human eye colors perception.-rgbToGrey :: Word8 -> Word8 -> Word8 -> Word8-rgbToGrey !r !g !b = (redLookupTable V.! int r)- + (greenLookupTable V.! int g)- + (blueLookupTable V.! int b)-{-# INLINE rgbToGrey #-}--redLookupTable, greenLookupTable, blueLookupTable :: V.Vector Word8-redLookupTable = V.generate 256 (\val -> round $ double val * 0.299)-greenLookupTable = V.generate 256 (\val -> round $ double val * 0.587)-blueLookupTable = V.generate 256 (\val -> round $ double val * 0.114)--double :: Integral a => a -> Double-double = fromIntegral--int :: Integral a => a -> Int-int = fromIntegral--word8 :: Integral a => a -> Word8-word8 = fromIntegral
src/Vision/Image/Grey/Specialize.hs view
@@ -6,11 +6,17 @@ import Data.Int import Vision.Histogram (Histogram, histogram, histogram2D, equalizeImage)+import Vision.Image.Filter (+ DerivativeType, dilate, erode, blur, gaussianBlur, scharr, sobel, mean+ ) import Vision.Image.Grey.Type (Grey, GreyPixel)-import Vision.Image.Threshold (ThresholdType, otsu)+import Vision.Image.Threshold (+ ThresholdType, AdaptiveThresholdKernel, adaptiveThreshold, otsu, scw+ ) import Vision.Image.Transform ( InterpolMethod, crop, resize, horizontalFlip, verticalFlip )+import Vision.Image.Type (Manifest) import Vision.Primitive (DIM1, DIM3, Rect, Size) {-# SPECIALIZE histogram :: Maybe DIM1 -> Grey -> Histogram DIM1 Int32@@ -24,10 +30,55 @@ -- FIXME: GHC 7.8.2 fails to specialize {-# SPECIALIZE equalizeImage :: Grey -> Grey #-} +{-# SPECIALIZE dilate :: Int -> Grey -> Grey #-}+{-# SPECIALIZE erode :: Int -> Grey -> Grey #-}+{-# SPECIALIZE blur :: Int -> Grey -> Grey #-}+{-# SPECIALIZE gaussianBlur :: Int -> Maybe Double -> Grey -> Grey #-}+{-# SPECIALIZE gaussianBlur :: Int -> Maybe Float -> Grey -> Grey #-}+{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Grey #-}+{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Manifest Int16 #-}+{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Manifest Int32 #-}+{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Manifest Int #-}+{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey -> Grey #-}+{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey+ -> Manifest Int16 #-}+{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey+ -> Manifest Int32 #-}+{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey+ -> Manifest Int #-}+{-# SPECIALIZE mean :: Size -> Grey -> Manifest Double #-}+{-# SPECIALIZE mean :: Size -> Grey -> Manifest Float #-}++{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Int -> Int+ -> GreyPixel+ -> ThresholdType GreyPixel GreyPixel+ -> Grey -> Grey #-}+{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Int16 -> Int+ -> GreyPixel+ -> ThresholdType GreyPixel GreyPixel+ -> Grey -> Grey #-}+{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Int32 -> Int+ -> GreyPixel+ -> ThresholdType GreyPixel GreyPixel+ -> Grey -> Grey #-}+{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Double -> Int+ -> GreyPixel+ -> ThresholdType GreyPixel GreyPixel+ -> Grey -> Grey #-}+{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Float -> Int+ -> GreyPixel+ -> ThresholdType GreyPixel GreyPixel+ -> Grey -> Grey #-}+{-# SPECIALIZE otsu :: ThresholdType GreyPixel GreyPixel -> Grey+ -> Grey #-}+{-# SPECIALIZE scw :: Size -> Size -> Double+ -> ThresholdType GreyPixel GreyPixel -> Grey+ -> Grey #-}+{-# SPECIALIZE scw :: Size -> Size -> Float+ -> ThresholdType GreyPixel GreyPixel -> Grey+ -> Grey #-}+ {-# SPECIALIZE crop :: Rect -> Grey -> Grey #-} {-# SPECIALIZE resize :: InterpolMethod -> Size -> Grey -> Grey #-} {-# SPECIALIZE horizontalFlip :: Grey -> Grey #-} {-# SPECIALIZE verticalFlip :: Grey -> Grey #-}--{-# SPECIALIZE otsu :: ThresholdType GreyPixel GreyPixel -> Grey- -> Grey #-}
src/Vision/Image/Grey/Type.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# LANGUAGE BangPatterns+ , GeneralizedNewtypeDeriving+ , TypeFamilies #-} module Vision.Image.Grey.Type ( Grey, GreyPixel (..), GreyDelayed@@ -8,8 +10,9 @@ import Data.Word import Foreign.Storable (Storable) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..))-import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Image.Type (Manifest, Delayed) newtype GreyPixel = GreyPixel Word8 deriving (Bits, Bounded, Enum, Eq, Integral, Num, Ord, Real, Read, Show
src/Vision/Image/HSV.hs view
@@ -2,6 +2,5 @@ module Vision.Image.HSV.Type ) where -import Vision.Image.HSV.Conversion () import Vision.Image.HSV.Specialize () import Vision.Image.HSV.Type
− src/Vision/Image/HSV/Conversion.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE BangPatterns, MultiParamTypeClasses, PatternGuards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Vision.Image.HSV.Conversion () where--import Data.Convertible (Convertible (..), ConvertResult)-import Data.Word--import Vision.Image.HSV.Type (HSVPixel (..))-import Vision.Image.RGB.Type (RGBPixel (..))-import Vision.Image.RGB.Conversion ()-import Vision.Image.RGBA.Type (RGBAPixel (..))-import Vision.Image.RGBA.Conversion ()--instance Convertible HSVPixel HSVPixel where- safeConvert = Right- {-# INLINE safeConvert #-}--instance Convertible RGBPixel HSVPixel where--- Based on :--- http://en.wikipedia.org/wiki/HSL_and_HSV#General_approach- safeConvert !(RGBPixel r g b) =- Right pix- where- (!r', !g', !b') = (int r, int g, int b)-- !pix | r >= g && r >= b = -- r == max r g b- let !c = r' - min b' g'- !h = fixHue $ hue c b' g' -- Hue can be negative- in HSVPixel (word8 h) (sat c r') r- | g >= r && g >= b = -- g == max r g b- let !c = g' - min r' b'- !h = 60 + hue c r' b'- in HSVPixel (word8 h) (sat c g') g- | otherwise = -- b == max r g b- let !c = b' - min r' g'- !h = 120 + hue c g' r'- in HSVPixel (word8 h) (sat c b') b-- -- Returns a value in [-30; +30].- hue 0 _ _ = 0- hue !c !left !right = (30 * (right - left)) `quot` c-- sat _ 0 = 0- sat !c v = word8 $ (c * 255) `quot` v-- -- Keeps the value of the hue between [0, 179].- -- As the Hue's unit is 2°, 180 is equal to 360° and to 0.- fixHue !h | h < 0 = h + 180- | otherwise = h--instance Convertible HSVPixel RGBPixel where--- Based on :--- http://en.wikipedia.org/wiki/HSL_and_HSV#Converting_to_RGB- safeConvert !(HSVPixel h s v) =- Right $! case h `quot` 30 of- 0 -> RGBPixel v (word8 x1') (word8 m)- 1 -> RGBPixel (word8 (x2 60)) v (word8 m)- 2 -> RGBPixel (word8 m) v (word8 (x1 60))- 3 -> RGBPixel (word8 m) (word8 (x2 120)) v- 4 -> RGBPixel (word8 (x1 120)) (word8 m) v- 5 -> RGBPixel v (word8 m) (word8 (x2 180))- _ -> error "Invalid hue value."- where- (!h', v') = (int h, int v)-- -- v is the major color component whereas m is the minor one.- !m = (v' * (255 - int s)) `quot` 255-- -- Computes the remaining component by resolving the hue equation,- -- knowing v and m. x1 is when the component is on the right of the- -- major one, x2 when on the left.- x1 d = (d * m - d * v' + h' * v' - h' * m + 30 * m) `quot` 30- x1' = ( h' * v' - h' * m + 30 * m) `quot` 30 -- == x1 0-- x2 d = (d * v' - d * m + h' * m - h' * v' + 30 * m) `quot` 30- {-# INLINE safeConvert #-}--instance Convertible RGBAPixel HSVPixel where- safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)- >>= safeConvert--instance Convertible HSVPixel RGBAPixel where- safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)- >>= safeConvert--int :: Integral a => a -> Int-int = fromIntegral--word8 :: Integral a => a -> Word8-word8 = fromIntegral
src/Vision/Image/HSV/Type.hs view
@@ -1,16 +1,24 @@-{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-}+{-# LANGUAGE BangPatterns+ , CPP+ , RecordWildCards+ , TypeFamilies+ , TypeOperators #-} module Vision.Image.HSV.Type ( HSV, HSVPixel (..), HSVDelayed ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>))+#endif+ import Data.Word import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..))-import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Image.Type (Manifest, Delayed) data HSVPixel = HSVPixel { hsvHue :: {-# UNPACK #-} !Word8, hsvSat :: {-# UNPACK #-} !Word8
src/Vision/Image/Interpolate.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns, FlexibleContexts #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts #-} -- | Provides a way to estimate the value of a pixel at rational coordinates -- using a linear interpolation.@@ -10,7 +11,7 @@ import Data.RatioInt (denominator, numerator) import Data.Word -import Vision.Image.Type (Pixel (..), Image (..), ImagePixel, ImageChannel)+import Vision.Image.Class (Pixel (..), Image (..), ImagePixel, ImageChannel) import Vision.Primitive (RPoint (..), ix2) -- | Provides a way to apply the interpolation to every component of a pixel.
src/Vision/Image/Mutable.hs view
@@ -1,25 +1,30 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes, TypeFamilies #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , RankNTypes+ , TypeFamilies #-} +-- | Contains an stateful image type which can be modified inside a 'ST' monad. module Vision.Image.Mutable ( MutableImage (..), create , MutableManifest (..) ) where import Control.Monad.Primitive (PrimMonad (..))-import Control.Monad.ST.Safe (ST, runST)+import Control.Monad.ST (ST, runST) import Data.Vector.Storable (MVector)-import qualified Data.Vector.Storable as V-import qualified Data.Vector.Storable.Mutable as MV import Foreign.Storable (Storable) import Prelude hiding (read) -import Vision.Image.Type (Image, Pixel, ImagePixel, Manifest (..))+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as MV++import Vision.Image.Class (Image, ImagePixel)+import Vision.Image.Type (Manifest (..)) import Vision.Primitive (- DIM2, Size, fromLinearIndex, toLinearIndex, shapeLength+ Point, Size, fromLinearIndex, toLinearIndex, shapeLength ) -- | Class for images which can be constructed from a mutable image.- class Image (Freezed i) => MutableImage i where -- | The type of the immutable version of the mutable image 'i'. type Freezed i@@ -37,19 +42,20 @@ new' :: PrimMonad m => Size -> ImagePixel (Freezed i) -> m (i (PrimState m)) -- | Returns the pixel value at @Z :. y :. x@.- read :: PrimMonad m => i (PrimState m) -> DIM2 -> m (ImagePixel (Freezed i))+ read :: PrimMonad m => i (PrimState m) -> Point+ -> m (ImagePixel (Freezed i)) read !img !ix = img `linearRead` toLinearIndex (mShape img) ix {-# INLINE read #-} -- | Returns the pixel value as if the image was a single dimension vector -- (row-major representation).- linearRead :: PrimMonad m => i (PrimState m) -> Int- -> m (ImagePixel (Freezed i))+ linearRead :: PrimMonad m+ => i (PrimState m) -> Int -> m (ImagePixel (Freezed i)) linearRead !img !ix = img `read` fromLinearIndex (mShape img) ix {-# INLINE linearRead #-} -- | Overrides the value of the pixel at @Z :. y :. x@.- write :: PrimMonad m => i (PrimState m) -> DIM2 -> ImagePixel (Freezed i)+ write :: PrimMonad m => i (PrimState m) -> Point -> ImagePixel (Freezed i) -> m () write !img !ix !val = linearWrite img (toLinearIndex (mShape img) ix) val {-# INLINE write #-}@@ -83,12 +89,12 @@ -- Instances ------------------------------------------------------------------- -data Storable p => MutableManifest p s = MutableManifest {+data MutableManifest p s = MutableManifest { mmSize :: !Size , mmVector :: !(MVector s p) } -instance (Pixel p, Storable p) => MutableImage (MutableManifest p) where+instance Storable p => MutableImage (MutableManifest p) where type Freezed (MutableManifest p) = Manifest p mShape = mmSize
+ src/Vision/Image/Parallel.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BangPatterns+ , FlexibleContexts #-}++module Vision.Image.Parallel (computeP) where++import Control.Concurrent (+ forkIO, getNumCapabilities, newEmptyMVar, putMVar, takeMVar)+import Control.Monad.ST (ST, stToIO)+import Data.Vector (enumFromN, forM, forM_)+import Foreign.Storable (Storable)+import System.IO.Unsafe (unsafePerformIO)++import Vision.Image.Class (MaskedImage (..), Image (..), (!))+import Vision.Image.Type (Manifest (..))+import Vision.Image.Mutable (MutableManifest, linearWrite, new, unsafeFreeze)+import Vision.Primitive (Z (..), (:.) (..), ix2)+++-- | Parallel version of 'compute'.+--+-- Computes the value of an image into a manifest representation in parallel.+--+-- The monad ensures that the image is fully evaluated before continuing.+computeP :: (Monad m, Image i, Storable (ImagePixel i))+ => i -> m (Manifest (ImagePixel i))+computeP !src =+ return $! unsafePerformIO $ do+ dst <- stToIO newManifest++ -- Forks 'nCapabilities' threads.+ childs <- forM (enumFromN 0 nCapabilities) $ \c -> do+ child <- newEmptyMVar++ _ <- forkIO $ do+ let nLines | c == 0 = nLinesPerThread + remain+ | otherwise = nLinesPerThread++ stToIO $ fillFromN dst (c * nLinesPerThread) nLines++ -- Sends a signal to the main thread.+ putMVar child ()++ return child++ -- Waits for all threads to finish.+ forM_ childs takeMVar++ stToIO $ unsafeFreeze dst+ where+ !size@(Z :. h :. w) = shape src++ !nCapabilities = unsafePerformIO getNumCapabilities++ !(nLinesPerThread, remain) = h `quotRem` nCapabilities++ -- Computes 'n' lines starting at 'from' of the image.+ fillFromN !dst !from !n =+ forM_ (enumFromN from n) $ \y -> do+ let !lineOffset = y * w+ forM_ (enumFromN 0 w) $ \x -> do+ let !offset = lineOffset + x+ !val = src ! (ix2 y x)+ linearWrite dst offset val++ newManifest :: Storable p => ST s (MutableManifest p s)+ newManifest = new size+{-# INLINE computeP #-}
src/Vision/Image/RGB.hs view
@@ -2,6 +2,5 @@ module Vision.Image.RGB.Type ) where -import Vision.Image.RGB.Conversion () import Vision.Image.RGB.Specialize () import Vision.Image.RGB.Type
− src/Vision/Image/RGB/Conversion.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE BangPatterns, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Vision.Image.RGB.Conversion () where--import Data.Convertible (Convertible (..))-import Data.Word--import Vision.Image.Grey.Type (GreyPixel (..))-import Vision.Image.RGBA.Type (RGBAPixel (..))-import Vision.Image.RGB.Type (RGBPixel (..))--instance Convertible RGBPixel RGBPixel where- safeConvert = Right- {-# INLINE safeConvert #-}--instance Convertible GreyPixel RGBPixel where- safeConvert !(GreyPixel pix) = Right $ RGBPixel pix pix pix- {-# INLINE safeConvert #-}--instance Convertible RGBAPixel RGBPixel where- safeConvert !(RGBAPixel r g b a) =- Right $ RGBPixel (withAlpha r) (withAlpha g) (withAlpha b)- where- !a' = int a- withAlpha !val = word8 $ int val * a' `quot` 255- {-# INLINE withAlpha #-}- {-# INLINE safeConvert #-}--int :: Integral a => a -> Int-int = fromIntegral--word8 :: Integral a => a -> Word8-word8 = fromIntegral
src/Vision/Image/RGB/Type.hs view
@@ -1,16 +1,24 @@-{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-}+{-# LANGUAGE BangPatterns+ , CPP+ , RecordWildCards+ , TypeFamilies+ , TypeOperators #-} module Vision.Image.RGB.Type ( RGB, RGBPixel (..), RGBDelayed ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>))+#endif+ import Data.Word import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..))-import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Image.Type (Manifest, Delayed) data RGBPixel = RGBPixel { rgbRed :: {-# UNPACK #-} !Word8, rgbGreen :: {-# UNPACK #-} !Word8
src/Vision/Image/RGBA.hs view
@@ -2,6 +2,5 @@ module Vision.Image.RGBA.Type ) where -import Vision.Image.RGBA.Conversion () import Vision.Image.RGBA.Specialize () import Vision.Image.RGBA.Type
− src/Vision/Image/RGBA/Conversion.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE BangPatterns, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Vision.Image.RGBA.Conversion () where--import Data.Convertible (Convertible (..))--import Vision.Image.Grey.Type (GreyPixel (..))-import Vision.Image.RGBA.Type (RGBAPixel (..))-import Vision.Image.RGB.Type (RGBPixel (..))--instance Convertible RGBAPixel RGBAPixel where- safeConvert = Right- {-# INLINE safeConvert #-}--instance Convertible GreyPixel RGBAPixel where- safeConvert !(GreyPixel pix) = Right $ RGBAPixel pix pix pix 255- {-# INLINE safeConvert #-}--instance Convertible RGBPixel RGBAPixel where- safeConvert !(RGBPixel r g b) = Right $ RGBAPixel r g b 255- {-# INLINE safeConvert #-}
src/Vision/Image/RGBA/Type.hs view
@@ -1,16 +1,24 @@-{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-}+{-# LANGUAGE BangPatterns+ , CPP+ , RecordWildCards+ , TypeFamilies+ , TypeOperators #-} module Vision.Image.RGBA.Type ( RGBA, RGBAPixel (..), RGBADelayed ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>))+#endif+ import Data.Word import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..))-import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Image.Type (Manifest, Delayed) data RGBAPixel = RGBAPixel { rgbaRed :: {-# UNPACK #-} !Word8, rgbaGreen :: {-# UNPACK #-} !Word8
− src/Vision/Image/Storage.hsc
@@ -1,381 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances- , ForeignFunctionInterface, MultiParamTypeClasses #-}---- | Uses the DevIL C library to read and write images from and to files.------ /Note:/ As the underlier DevIL library is *not* tread-safe, there is a global--- lock which will prevent two load/save calls to be performed at the same time.-module Vision.Image.Storage (- ImageType (..), StorageImage (..), StorageError (..), load, loadBS, save- ) where--import Control.Applicative ((<$>))-import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)-import Control.Monad (when)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Error (Error (..), ErrorT, runErrorT, throwError)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS-import Data.Convertible (Convertible (..), convert)-import Data.Int-import Data.Vector.Storable (unsafeFromForeignPtr0, unsafeWith)-import Data.Word-import Foreign.C.String (CString, withCString)-import Foreign.Concurrent (newForeignPtr)-import Foreign.Marshal.Alloc (alloca)-import Foreign.Marshal.Utils (with)-import Foreign.Ptr (Ptr, castPtr)-import Foreign.Storable (peek)-import System.IO.Unsafe (unsafePerformIO)--import Vision.Image.Grey (Grey, GreyPixel)-import Vision.Image.RGBA (RGBA, RGBAPixel)-import Vision.Image.RGB (RGB, RGBPixel)-import Vision.Image.Type (Manifest (..), Delayed (..), delay, nChannels)-import Vision.Primitive (Z (..), (:.) (..), ix2)--data StorageImage = GreyStorage Grey | RGBAStorage RGBA | RGBStorage RGB--data ImageType = BMP | CUT- | DDS -- ^ DirectDraw Surface (.dds).- | Doom -- ^ Doom texture.- | DoomFlat -- ^ Doom flat texture (floor).- | GIF | ICO | JPG- | LIF -- ^ Homeworld (.lif).- | MNG | PCD | PCX | PIC | PNG- | PNM -- ^ Portable AnyMap (.pbm, .pgm or .ppm).- | PSD | PSP | SGI | TGA | TIFF- | RAW -- Raw data with a 13-byte header.- deriving (Eq, Show)--data StorageError = FailedToInit -- ^ Failed to initialise the library.- | FailedToOpenFile -- ^ Failed to open the given file.- | InvalidType -- ^ The file could not be loaded based- -- on extension or header.- | OutOfMemory -- ^ Could not allocate memory for the new- -- image data.- | FailedToLoad -- ^ Failed to load the image, invalid- -- format.- | FailedToHaskell -- ^ Failed to convert the loaded image to- -- its Haskell representation.- | FailedToDevil -- ^ Failed to write the image content- -- through the inner DevIL library.- | FailedToSave -- ^ Could not open the file for writing.- | UnknownError (Maybe String)- deriving (Eq)--type StorageMonad = ErrorT StorageError IO--instance Convertible StorageImage StorageImage where- safeConvert = Right--instance Convertible (Manifest GreyPixel) StorageImage where- safeConvert = Right . GreyStorage--instance Convertible (Manifest RGBAPixel) StorageImage where- safeConvert = Right . RGBAStorage--instance Convertible (Manifest RGBPixel) StorageImage where- safeConvert = Right . RGBStorage--instance Convertible StorageImage (Manifest GreyPixel) where- safeConvert (GreyStorage img) = Right img- safeConvert (RGBAStorage img) = Right $ convert img- safeConvert (RGBStorage img) = Right $ convert img--instance Convertible StorageImage (Manifest RGBAPixel) where- safeConvert (GreyStorage img) = Right $ convert img- safeConvert (RGBAStorage img) = Right img- safeConvert (RGBStorage img) = Right $ convert img--instance Convertible StorageImage (Manifest RGBPixel) where- safeConvert (GreyStorage img) = Right $ convert img- safeConvert (RGBAStorage img) = Right $ convert img- safeConvert (RGBStorage img) = Right img--instance Convertible StorageImage (Delayed GreyPixel) where- safeConvert (GreyStorage img) = Right $ delay img- safeConvert (RGBAStorage img) = Right $ convert img- safeConvert (RGBStorage img) = Right $ convert img--instance Convertible StorageImage (Delayed RGBAPixel) where- safeConvert (GreyStorage img) = Right $ convert img- safeConvert (RGBAStorage img) = Right $ delay img- safeConvert (RGBStorage img) = Right $ convert img--instance Convertible StorageImage (Delayed RGBPixel) where- safeConvert (GreyStorage img) = Right $ convert img- safeConvert (RGBAStorage img) = Right $ convert img- safeConvert (RGBStorage img) = Right $ delay img--instance Error StorageError where- noMsg = UnknownError Nothing- strMsg = UnknownError . Just--instance Show StorageError where- show FailedToInit = "Failed to initialise the DevIL library."- show FailedToOpenFile = "Failed to open the given file."- show InvalidType =- "The file could not be loaded based on extension or header."- show OutOfMemory = "Could not allocate memory for the new image data."- show FailedToLoad = "Failed to load the image."- show FailedToHaskell =- "Failed to convert the loaded image to its Haskell representation."- show FailedToDevil =- "Failed to write the image content through the inner DevIL library."- show FailedToSave = "Could not open the file for writing."- show (UnknownError (Just msg)) = msg- show (UnknownError Nothing ) = "Unknown error."---- | Reads an image into a manifest vector from a file.------ If no image type is given, type will be determined automatically.-load :: Maybe ImageType -> FilePath -> IO (Either StorageError StorageImage)-load mType path =- lockDevil $- bindAndLoad $- withCString path $ \cPath ->- ilLoadC (toIlType mType) cPath---- | Reads an image into a manifest vector from a strict 'ByteString'.------ If no image type is given, type will be determined automatically.--- TIFF images are not supported.-loadBS :: Maybe ImageType -> BS.ByteString- -> IO (Either StorageError StorageImage)-loadBS (Just TIFF) _ = return $ Left FailedToLoad-loadBS mType bs =- lockDevil $- bindAndLoad $- BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->- ilLoadLC (toIlType mType) ptr (fromIntegral len)---- | Saves the image to the given file.------ /Note:/ The image type is determined by the filename extension.--- Will fail if the file already exists.-save :: (Convertible i StorageImage) => FilePath -> i -> IO (Maybe StorageError)-save path img = lockDevil $ do- res <- runErrorT $ do- ilInit- name <- ilGenImageName- ilBindImage name-- toDevil $ convert img- ilSaveImage path-- ilDeleteImage name-- return $ case res of Right () -> Nothing- Left err -> Just err---- C wrappers and helpers --------------------------------------------------------devilLock :: MVar ()-devilLock = unsafePerformIO $ newMVar ()-{-# NOINLINE devilLock #-}---- | Uses a global lock ('devilLock') to prevent two threads to call the--- library at the same time.-lockDevil :: IO a -> IO a-lockDevil action = do- takeMVar devilLock- ret <- action- putMVar devilLock ()- return ret---- | Allocates a new image name, executes the given action to load the image--- and then converts it into its Haskell representation.-bindAndLoad :: IO ILboolean -> IO (Either StorageError StorageImage)-bindAndLoad action = runErrorT $ do- ilInit- name <- ilGenImageName- ilBindImage name-- res <- lift action- when (res == 0) $ do- err <- lift ilGetErrorC- throwError $ case err of- (#const IL_COULD_NOT_OPEN_FILE) -> FailedToOpenFile- (#const IL_INVALID_EXTENSION) -> InvalidType- (#const IL_INVALID_FILE_HEADER) -> InvalidType- (#const IL_OUT_OF_MEMORY) -> OutOfMemory- _ -> FailedToLoad-- fromDevil name--toIlType :: Maybe ImageType -> ILenum-toIlType (Just BMP) = (#const IL_BMP)-toIlType (Just CUT) = (#const IL_CUT)-toIlType (Just DDS) = (#const IL_DDS)-toIlType (Just Doom) = (#const IL_DOOM)-toIlType (Just DoomFlat) = (#const IL_DOOM_FLAT)-toIlType (Just GIF) = (#const IL_GIF)-toIlType (Just ICO) = (#const IL_ICO)-toIlType (Just JPG) = (#const IL_JPG)-toIlType (Just LIF) = (#const IL_LIF)-toIlType (Just MNG) = (#const IL_MNG)-toIlType (Just PCD) = (#const IL_PCD)-toIlType (Just PCX) = (#const IL_PCX)-toIlType (Just PIC) = (#const IL_PIC)-toIlType (Just PNG) = (#const IL_PNG)-toIlType (Just PNM) = (#const IL_PNM)-toIlType (Just PSD) = (#const IL_PSD)-toIlType (Just PSP) = (#const IL_PSP)-toIlType (Just SGI) = (#const IL_SGI)-toIlType (Just TGA) = (#const IL_TGA)-toIlType (Just TIFF) = (#const IL_TIF)-toIlType (Just RAW) = (#const IL_RAW)-toIlType Nothing = (#const IL_TYPE_UNKNOWN)--#include "IL/il.h"--type ILuint = #type ILuint-type ILsizei = #type ILsizei-type ILboolean = #type ILboolean-type ILenum = #type ILenum-type ILint = #type ILint-type ILubyte = #type ILubyte---- DevIL uses unsigned integers as names for each image in processing.-newtype ImageName = ImageName ILuint- deriving (Show)--foreign import ccall unsafe "ilInit" ilInitC :: IO ()-foreign import ccall unsafe "ilGetError" ilGetErrorC :: IO ILenum-foreign import ccall unsafe "ilOriginFunc" ilOriginFuncC- :: ILenum -> IO ILboolean-foreign import ccall unsafe "ilEnable" ilEnableC :: ILenum -> IO ILboolean--il_RGB, il_RGBA, il_LUMINANCE :: ILenum-il_RGB = (#const IL_RGB)-il_RGBA = (#const IL_RGBA)-il_LUMINANCE = (#const IL_LUMINANCE)--il_IMAGE_HEIGHT, il_IMAGE_WIDTH :: ILenum-il_IMAGE_FORMAT, il_IMAGE_TYPE :: ILenum-il_IMAGE_HEIGHT = (#const IL_IMAGE_HEIGHT)-il_IMAGE_WIDTH = (#const IL_IMAGE_WIDTH)-il_IMAGE_FORMAT = (#const IL_IMAGE_FORMAT)-il_IMAGE_TYPE = (#const IL_IMAGE_TYPE)--il_UNSIGNED_BYTE :: ILenum-il_UNSIGNED_BYTE = (#const IL_UNSIGNED_BYTE)---- | Initialize the library.-ilInit :: StorageMonad ()-ilInit = do- lift ilInitC-- -- By default, origin is undefined and depends on the image type- ilOriginFuncC (#const IL_ORIGIN_LOWER_LEFT) <?> FailedToInit- ilEnableC (#const IL_ORIGIN_SET) <?> FailedToInit--foreign import ccall unsafe "ilGenImages" ilGenImagesC- :: ILsizei -> Ptr ILuint -> IO ()---- | Allocates a new image name.-ilGenImageName :: StorageMonad ImageName-ilGenImageName = lift $ do- alloca $ \pName -> do- ilGenImagesC 1 pName- name <- peek pName- return $! ImageName name--foreign import ccall unsafe "ilBindImage" ilBindImageC :: ILuint -> IO ()---- | Sets the image name as the current image for processing.-ilBindImage :: ImageName -> StorageMonad ()-ilBindImage (ImageName name) = lift $ ilBindImageC name--foreign import ccall unsafe "ilLoad" ilLoadC :: ILenum -> CString- -> IO ILboolean-foreign import ccall unsafe "ilLoadL" ilLoadLC :: ILenum -> CString -> ILuint- -> IO ILboolean--foreign import ccall unsafe "ilGetInteger" ilGetIntegerC :: ILenum -> IO ILint-foreign import ccall unsafe "ilConvertImage" ilConvertImageC- :: ILenum -> ILenum -> IO ILboolean-foreign import ccall unsafe "ilGetData" ilGetDataC :: IO (Ptr ILubyte)-foreign import ccall unsafe "ilDeleteImages" ilDeleteImagesC- :: ILsizei -> Ptr ILuint -> IO ()---- | Puts the current image inside a 'Vector'.-fromDevil :: ImageName -> StorageMonad StorageImage-fromDevil (ImageName name) = do- format <- ilGetInteger il_IMAGE_FORMAT- w <- ilGetInteger il_IMAGE_WIDTH- h <- ilGetInteger il_IMAGE_HEIGHT- let !size = ix2 h w-- case format of- _ | format == il_RGB -> do- convertChannels il_RGB- RGBStorage <$> toManifest size- | format == il_RGBA -> do- convertChannels il_RGBA- RGBAStorage <$> toManifest size- | format == il_RGBA -> do- convertChannels il_LUMINANCE- GreyStorage <$> toManifest size- | otherwise -> do -- Unsupported formats are converted to RGBA.- ilConvertImage il_RGBA il_UNSIGNED_BYTE- RGBAStorage <$> toManifest size- where- -- Converts the image to the given format if the pixel type isn't Word8.- convertChannels destFormat = do- pixelType <- ilGetInteger il_IMAGE_TYPE- when (pixelType /= il_UNSIGNED_BYTE) $- ilConvertImage destFormat il_UNSIGNED_BYTE-- -- Converts the C vector of unsigned bytes to a garbage collected 'Vector'- -- inside a 'Manifest' image.- toManifest size@(Z :. h :. w) = lift $ do- pixels <- castPtr <$> ilGetDataC- managedPixels <- newForeignPtr pixels (with name (ilDeleteImagesC 1))- return $! Manifest size (unsafeFromForeignPtr0 managedPixels (w * h))-- ilGetInteger mode = lift $ fromIntegral <$> ilGetIntegerC mode-- ilConvertImage format pixelType = do- ilConvertImageC format pixelType <?> FailedToHaskell---- | Removes the image and any allocated memory.-ilDeleteImage :: ImageName -> StorageMonad ()-ilDeleteImage (ImageName name) = lift $ with name (ilDeleteImagesC 1)--foreign import ccall unsafe "ilTexImage" ilTexImageC- :: ILuint -> ILuint -> ILuint -- w h depth- -> ILubyte -> ILenum -> ILenum -- numberOfChannels format type- -> Ptr () -- data (copy from this pointer)- -> IO ILboolean---- | Sets the current DevIL image to the vector's internal array.-toDevil :: StorageImage -> StorageMonad ()-toDevil storImg =- case storImg of GreyStorage img -> writeManifest img il_LUMINANCE- RGBAStorage img -> writeManifest img il_RGBA- RGBStorage img -> writeManifest img il_RGB- where- writeManifest img@(Manifest (Z :. h :. w) vec) format =- (unsafeWith vec $ \p ->- ilTexImageC (fromIntegral w) (fromIntegral h) 1- (fromIntegral $ nChannels img)- format il_UNSIGNED_BYTE (castPtr p)- ) <?> FailedToDevil--foreign import ccall unsafe "ilSaveImage" ilSaveImageC- :: CString -> IO ILboolean---- | Saves the current image.-ilSaveImage :: FilePath -> StorageMonad ()-ilSaveImage file = withCString file ilSaveImageC <?> FailedToSave--infix 0 <?>--- | Wraps a breakable DevIL action (which returns 0 on failure) in the--- 'StorageMonad'. Throws the given error in the monad if the action fails.-(<?>) :: IO ILboolean -> StorageError -> StorageMonad ()-action <?> err = do- res <- lift action- when (res == 0) $- throwError err
src/Vision/Image/Threshold.hs view
@@ -1,44 +1,78 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, GADTs #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , GADTs #-} module Vision.Image.Threshold (- ThresholdType (..)+ -- * Simple threshold+ ThresholdType (..), thresholdType , threshold- , AdaptiveThresholdKernel (..), adaptiveThreshold- , otsu+ -- * Adaptive threshold+ , AdaptiveThresholdKernel (..), AdaptiveThreshold+ , adaptiveThreshold, adaptiveThresholdFilter+ -- * Other methods+ , otsu, scw ) where +import Data.Int import Foreign.Storable (Storable) -import Vision.Image.Filter (Filter (..), SeparableFilter, blur, gaussianBlur)-import Vision.Image.Type (ImagePixel, FunctorImage)-import Vision.Histogram-import Vision.Histogram as H-import Vision.Primitive.Shape (shapeLength)-import qualified Vision.Image.Type as I- import qualified Data.Vector.Storable as V import qualified Data.Vector as VU +import Vision.Image.Class (+ Image, ImagePixel, FromFunction (..), FunctorImage, (!), shape+ )+import Vision.Image.Filter.Internal (+ Filter (..), BoxFilter, Kernel (..), SeparableFilter, SeparatelyFiltrable+ , KernelAnchor (KernelAnchorCenter), FilterFold (..)+ , BorderInterpolate (BorderReplicate)+ , apply, blur, gaussianBlur, Mean, mean+ )+import Vision.Image.Type (Manifest, delayed, manifest)+import Vision.Histogram (+ HistogramShape, PixelValueSpace, ToHistogram, histogram+ )+import Vision.Primitive (Z (..), (:.) (..), Size, shapeLength)++import qualified Vision.Histogram as H+import qualified Vision.Image.Class as I+ -- | Specifies what to do with pixels matching the threshold predicate. -- -- @'BinaryThreshold' a b@ will replace matching pixels by @a@ and non-matchings -- pixels by @b@. -- -- @'Truncate' a@ will replace matching pixels by @a@.+--+-- @'TruncateInv' a@ will replace non-matching pixels by @a@. data ThresholdType src res where BinaryThreshold :: res -> res -> ThresholdType src res Truncate :: src -> ThresholdType src src+ TruncateInv :: src -> ThresholdType src src +-- | Given the thresholding method, a boolean indicating if the pixel match the+-- thresholding condition and the pixel, returns the new pixel value.+thresholdType :: ThresholdType src res -> Bool -> src -> res+thresholdType (BinaryThreshold ifTrue ifFalse) match _ | match = ifTrue+ | otherwise = ifFalse+thresholdType (Truncate ifTrue) match pix | match = ifTrue+ | otherwise = pix+thresholdType (TruncateInv ifFalse) match pix | match = pix+ | otherwise = ifFalse+{-# INLINE thresholdType #-}++-- -----------------------------------------------------------------------------+ -- | Applies the given predicate and threshold policy on the image. threshold :: FunctorImage src res => (ImagePixel src -> Bool) -> ThresholdType (ImagePixel src) (ImagePixel res) -> src -> res-threshold !cond !(BinaryThreshold ifTrue ifFalse) !img =- I.map (\pix -> if cond pix then ifTrue else ifFalse) img-threshold !cond !(Truncate ifTrue) !img =- I.map (\pix -> if cond pix then ifTrue else pix) img+threshold !cond !thresType =+ I.map (\pix -> thresholdType thresType (cond pix) pix) {-# INLINE threshold #-} +-- -----------------------------------------------------------------------------+ -- | Defines how pixels of the kernel of the adaptive threshold will be -- weighted. --@@ -52,34 +86,62 @@ GaussianKernel :: (Floating acc, RealFrac acc) => Maybe acc -> AdaptiveThresholdKernel acc --- | Applies a thresholding adaptively.+-- | Compares every pixel to its surrounding ones in the kernel of the given+-- radius.+adaptiveThreshold :: ( Image src, Integral (ImagePixel src)+ , Ord (ImagePixel src)+ , FromFunction res, Integral (FromFunctionPixel res)+ , Storable acc+ , SeparatelyFiltrable src res acc)+ => AdaptiveThresholdKernel acc+ -> Int+ -- ^ Kernel radius.+ -> ImagePixel src+ -- ^ Minimum difference between the pixel and the kernel+ -- average. The pixel is thresholded if+ -- @pixel_value - kernel_mean > difference@ where difference+ -- is this number. Can be negative.+ -> ThresholdType (ImagePixel src) (FromFunctionPixel res)+ -> src+ -> res+adaptiveThreshold kernelType radius thres thresType img =+ adaptiveThresholdFilter kernelType radius thres thresType `apply` img+{-# INLINABLE adaptiveThreshold #-}++type AdaptiveThreshold src acc res = SeparableFilter src () acc res++-- | Creates an adaptive thresholding filter to be used with 'apply'. --+-- Use 'adaptiveThreshold' if you only want to apply the filter on the image.+-- -- Compares every pixel to its surrounding ones in the kernel of the given -- radius.-adaptiveThreshold :: (Integral src, Num src, Ord src, Storable acc)- => AdaptiveThresholdKernel acc- -> Int -- ^ Kernel radius.- -> src -- ^ Minimum difference between the pixel and the- -- kernel average. The pixel is thresholded if- -- @pixel_value - kernel_mean > difference@ where- -- difference if this number. Can be negative.- -> ThresholdType src res -> SeparableFilter src acc res-adaptiveThreshold !kernelType !radius !thres !thresType =+adaptiveThresholdFilter :: (Integral src, Ord src, Storable acc)+ => AdaptiveThresholdKernel acc+ -> Int+ -- ^ Kernel radius.+ -> src+ -- ^ Minimum difference between the pixel and the kernel+ -- average. The pixel is thresholded if+ -- @pixel_value - kernel_mean > difference@ where+ -- difference is this number. Can be negative.+ -> ThresholdType src res+ -> AdaptiveThreshold src acc res+adaptiveThresholdFilter !kernelType !radius !thres !thresType = kernelFilter { fPost = post } where !kernelFilter = case kernelType of MeanKernel -> blur radius GaussianKernel sig -> gaussianBlur radius sig - post !pix !acc =- let !acc' = (fPost kernelFilter) pix acc+ post ix pix ini acc =+ let !acc' = (fPost kernelFilter) ix pix ini acc !cond = (pix - acc') > thres- in case thresType of- BinaryThreshold ifTrue ifFalse -> if cond then ifTrue- else ifFalse- Truncate ifTrue -> if cond then ifTrue else pix-{-# INLINE adaptiveThreshold #-}+ in thresholdType thresType cond pix+{-# INLINE adaptiveThresholdFilter #-} +-- -----------------------------------------------------------------------------+ -- | Applies a clustering-based image thresholding using the Otsu's method. -- -- See <https://en.wikipedia.org/wiki/Otsu's_method>.@@ -114,6 +176,62 @@ !two = 2 :: Int {-# INLINABLE otsu #-}++-- -----------------------------------------------------------------------------++-- | This is a sliding concentric window filter (SCW) that uses the ratio of the+-- standard deviations of two sliding windows centered on a same point to detect+-- regions of interest (ROI).+--+-- > scw sizeWindowA sizeWindowB beta thresType img+--+-- Let @σA@ be the standard deviation of a fist window around a pixel and @σB@+-- be the standard deviation of another window around the same pixel.+-- Then the pixel will match the threshold if @σB / σA >= beta@, and will be+-- thresholded according to the given 'ThresholdType'.+--+-- See <http://www.academypublisher.com/jcp/vol04/no08/jcp0408771777.pdf>.+scw :: ( Image src, Integral (ImagePixel src), FromFunction dst+ , Floating stdev, Fractional stdev, Ord stdev, Storable stdev)+ => Size -> Size -> stdev+ -> ThresholdType (ImagePixel src) (FromFunctionPixel dst) -> src -> dst+scw !sizeA !sizeB !beta !thresType !img =+ betaThreshold (stdDev sizeA) (stdDev sizeB)+ where+ betaThreshold a b =+ fromFunction (shape img) $ \pt ->+ let !cond = (b ! pt) / (a ! pt) < beta+ in thresholdType thresType cond (img ! pt)++ stdDev size =+ let filt :: (Integral src, Fractional res) => Mean src Int16 res+ filt = mean size+ !meanImg = manifest $ apply filt img+ !varImg = manifest $ apply (variance size meanImg) img+ in delayed $ I.map sqrt varImg+{-# INLINABLE scw #-}++-- | Given a mean image and an original image, computes the variance of the+-- kernel of the given size.+--+-- @average [ (origPix - mean)^2 | origPix <- kernel pixels on original ]@.+variance :: (Integral src, Fractional res, Storable res)+ => Size -> Manifest res -> BoxFilter src res res res+variance !size@(Z :. h :. w) !meanImg =+ Filter size KernelAnchorCenter (Kernel kernel) (\pt _ -> meanImg ! pt)+ (FilterFold (const 0)) post BorderReplicate+ where+ kernel !kernelMean _ !val !acc =+ acc + square (fromIntegral val - kernelMean)++ !nPixsFactor = 1 / (fromIntegral $! h * w)+ post _ _ _ !acc = acc * nPixsFactor+{-# INLINABLE variance #-}++-- -----------------------------------------------------------------------------++square :: Num a => a -> a+square a = a * a double :: Integral a => a -> Double double = fromIntegral
src/Vision/Image/Transform.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, TypeFamilies #-}+{-# LANGUAGE BangPatterns+ , FlexibleContexts+ , TypeFamilies #-} -- | Provides high level functions to do geometric transformations on images. --@@ -12,11 +14,11 @@ import Control.Monad.Primitive (PrimMonad (..)) import Data.RatioInt (RatioInt, (%)) +import Vision.Image.Class (+ MaskedImage (..), Image (..), ImageChannel, FromFunction (..), (!)+ ) import Vision.Image.Interpolate (Interpolable, bilinearInterpol) import Vision.Image.Mutable (MutableImage (..))-import Vision.Image.Type (- MaskedImage (..), Image (..), ImageChannel, FromFunction (..)- ) import Vision.Primitive ( Z (..), (:.) (..), Point, RPoint (..), Rect (..), Size, ix2, toLinearIndex )@@ -34,7 +36,7 @@ => Rect -> i1 -> i2 crop !(Rect rx ry rw rh) !img = fromFunction (Z :. rh :. rw) $ \(Z :. y :. x) ->- img `index` ix2 (ry + y) (rx + x)+ img ! ix2 (ry + y) (rx + x) {-# INLINABLE crop #-} -- | Resizes the 'Image' using the given interpolation method.@@ -51,7 +53,7 @@ col !x' = truncate $ (double x' + 0.5) * widthRatio - 0.5 {-# INLINE col #-} f !y !(Z :. _ :. x') = let !x = col x'- in img `index` ix2 y x+ in img ! ix2 y x {-# INLINE f #-} in fromFunctionLine size' line f NearestNeighbor ->@@ -62,7 +64,7 @@ col !x' = round $ (double x' + 0.5) * widthRatio - 0.5 {-# INLINE col #-} f !y !(Z :. _ :. x') = let !x = col x'- in img `index` ix2 y x+ in img ! ix2 y x {-# INLINE f #-} in fromFunctionLine size' line f Bilinear ->@@ -95,7 +97,7 @@ => i1 -> i2 horizontalFlip !img = let f !(Z :. y :. x') = let !x = maxX - x'- in img `index` ix2 y x+ in img ! ix2 y x {-# INLINE f #-} in fromFunction size f where@@ -110,7 +112,7 @@ verticalFlip !img = let line !y' = maxY - y' {-# INLINE line #-}- f !y !(Z :. _ :. x) = img `index` ix2 y x+ f !y !(Z :. _ :. x) = img ! ix2 y x {-# INLINE f #-} in fromFunctionLine size line f where
src/Vision/Image/Type.hs view
@@ -1,245 +1,67 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances- , MultiParamTypeClasses, PatternGuards, TypeFamilies+{-# LANGUAGE BangPatterns+ , CPP+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , PatternGuards+ , TypeFamilies , UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Vision.Image.Type (- -- * Classes- Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..)- , FunctorImage (..) -- * Manifest images- , Manifest (..)+ Manifest (..) -- * Delayed images , Delayed (..) -- * Delayed masked images , DelayedMask (..)- -- * Functions- , nChannels, pixel- -- * Conversion- , Convertible (..), convert, delay, compute- -- * Types helpers- , delayed, manifest+ -- * Conversion and type helpers+ , delay, compute, delayed, manifest ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>))+#endif++import Control.DeepSeq (NFData (..)) import Data.Convertible (Convertible (..), convert)-import Data.Int-import Data.Vector.Storable (- Vector, (!), create, enumFromN, forM_, generate, unfoldr- )+import Data.Vector.Storable (Vector, create, enumFromN, forM_, generate) import Data.Vector.Storable.Mutable (new, write)-import Data.Word import Foreign.Storable (Storable) import Prelude hiding (map, read) -import Vision.Primitive (- Z (..), (:.) (..), Point, Size- , ix2, fromLinearIndex, toLinearIndex, shapeLength- )---- Classes ------------------------------------------------------------------------- | Determines the number of channels and the type of each pixel of the image--- and how images are represented.-class Storable p => Pixel p where- type PixelChannel p-- -- | Returns the number of channels of the pixel.- -- Must not consume 'p' (could be 'undefined').- pixNChannels :: p -> Int-- pixIndex :: p -> Int -> PixelChannel p--instance Pixel Int16 where- type PixelChannel Int16 = Int16- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Int32 where- type PixelChannel Int32 = Int32- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Int where- type PixelChannel Int = Int- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Word8 where- type PixelChannel Word8 = Word8- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Word16 where- type PixelChannel Word16 = Word16- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Word32 where- type PixelChannel Word32 = Word32- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Word where- type PixelChannel Word = Word- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Float where- type PixelChannel Float = Float- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Double where- type PixelChannel Double = Double- pixNChannels _ = 1- pixIndex p _ = p--instance Pixel Bool where- type PixelChannel Bool = Bool- pixNChannels _ = 1- pixIndex p _ = p---- | Provides an abstraction for images which are not defined for each of their--- pixels. The interface is similar to 'Image' except that indexing functions--- don't always return.--- Image origin is located in the lower left corner.-class Pixel (ImagePixel i) => MaskedImage i where- type ImagePixel i-- shape :: i -> Size-- -- | Returns the pixel\'s value at 'Z :. y, :. x'.- maskedIndex :: i -> Point -> Maybe (ImagePixel i)- maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img)- {-# INLINE maskedIndex #-}-- -- | Returns the pixel\'s value as if the image was a single dimension- -- vector (row-major representation).- maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i)- maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img)- {-# INLINE maskedLinearIndex #-}-- -- | Returns the non-masked values of the image.- values :: i -> Vector (ImagePixel i)- values !img =- unfoldr step 0- where- !n = shapeLength (shape img)-- step !i | i >= n = Nothing- | Just p <- img `maskedLinearIndex` i = Just (p, i + 1)- | otherwise = step (i + 1)- {-# INLINE values #-}-- {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}--type ImageChannel i = PixelChannel (ImagePixel i)---- | Provides an abstraction over the internal representation of an image.--- Image origin is located in the lower left corner.-class MaskedImage i => Image i where- -- | Returns the pixel value at 'Z :. y :. x'.- index :: i -> Point -> ImagePixel i- index img = (img `linearIndex`) . toLinearIndex (shape img)- {-# INLINE index #-}-- -- | Returns the pixel value as if the image was a single dimension vector- -- (row-major representation).- linearIndex :: i -> Int -> ImagePixel i- linearIndex img = (img `index`) . fromLinearIndex (shape img)- {-# INLINE linearIndex #-}-- -- | Returns every pixel values as if the image was a single dimension- -- vector (row-major representation).- vector :: i -> Vector (ImagePixel i)- vector img = generate (shapeLength $ shape img) (img `linearIndex`)- {-# INLINE vector #-}-- {-# MINIMAL index | linearIndex #-}---- | Provides ways to construct an image from a function.-class FromFunction i where- type FromFunctionPixel i-- -- | Generates an image by calling the given function for each pixel of the- -- constructed image.- fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i-- -- | Generates an image by calling the last function for each pixel of the- -- constructed image.- -- The first function is called for each line, generating a line invariant- -- value.- -- This function is faster for some image representations as some recurring- -- computation can be cached.- fromFunctionLine :: Size -> (Int -> a)- -> (a -> Point -> FromFunctionPixel i) -> i- fromFunctionLine size line f =- fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt)- {-# INLINE fromFunctionLine #-}-- -- | Generates an image by calling the last function for each pixel of the- -- constructed image.- -- The first function is called for each column, generating a column- -- invariant value.- -- This function *can* be faster for some image representations as some- -- recurring computations can be cached. However, it may requires a vector- -- allocation for these values. If the column invariant is cheap to- -- compute, prefer 'fromFunction'.- fromFunctionCol :: Storable b => Size -> (Int -> b)- -> (b -> Point -> FromFunctionPixel i) -> i- fromFunctionCol size col f =- fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt)- {-# INLINE fromFunctionCol #-}-- -- | Generates an image by calling the last function for each pixel of the- -- constructed image.- -- The two first functions are called for each line and for each column,- -- respectively, generating common line and column invariant values.- -- This function is faster for some image representations as some recurring- -- computation can be cached. However, it may requires a vector- -- allocation for column values. If the column invariant is cheap to- -- compute, prefer 'fromFunctionLine'.- fromFunctionCached :: Storable b => Size- -> (Int -> a) -- ^ Line function- -> (Int -> b) -- ^ Column function- -> (a -> b -> Point- -> FromFunctionPixel i) -- ^ Pixel function- -> i- fromFunctionCached size line col f =- fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt)- {-# INLINE fromFunctionCached #-}-- {-# MINIMAL fromFunction #-}+import qualified Data.Vector.Storable as V --- | Defines a class for images on which a function can be applied. The class is--- different from 'Functor' as there could be some constraints and--- transformations the pixel and image types.-class (MaskedImage src, MaskedImage res) => FunctorImage src res where- map :: (ImagePixel src -> ImagePixel res) -> src -> res+import Vision.Image.Class (+ MaskedImage (..), Image (..), FromFunction (..), FunctorImage (..), (!)+ )+import Vision.Primitive (Z (..), (:.) (..), Point, Size, ix2) -- Manifest images ------------------------------------------------------------- -- | Stores the image content in a 'Vector'.-data Storable p => Manifest p = Manifest {+data Manifest p = Manifest { manifestSize :: !Size , manifestVector :: !(Vector p) } deriving (Eq, Ord, Show) -instance Pixel p => MaskedImage (Manifest p) where+instance NFData (Manifest p) where+ rnf !_ = ()++instance Storable p => MaskedImage (Manifest p) where type ImagePixel (Manifest p) = p shape = manifestSize {-# INLINE shape #-} - Manifest _ vec `maskedLinearIndex` ix = Just $! vec ! ix+ Manifest _ vec `maskedLinearIndex` ix = vec V.!? ix {-# INLINE maskedLinearIndex #-} values = manifestVector {-# INLINE values #-} -instance Pixel p => Image (Manifest p) where- Manifest _ vec `linearIndex` ix = vec ! ix+instance Storable p => Image (Manifest p) where+ Manifest _ vec `linearIndex` ix = vec V.! ix {-# INLINE linearIndex #-} vector = manifestVector@@ -287,7 +109,7 @@ let !lineOffset = y * w forM_ (enumFromN 0 w) $ \x -> do let !offset = lineOffset + x- !val = f (cols ! x) (ix2 y x)+ !val = f (cols V.! x) (ix2 y x) write arr offset val return arr@@ -305,7 +127,7 @@ !lineOffset = y * w forM_ (enumFromN 0 w) $ \x -> do let !offset = lineOffset + x- !val = f lineVal (cols ! x) (ix2 y x)+ !val = f lineVal (cols V.! x) (ix2 y x) write arr offset val return arr@@ -313,8 +135,8 @@ !cols = generate w col {-# INLINE fromFunctionCached #-} -instance (Image src, Pixel p) => FunctorImage src (Manifest p) where- map f img = fromFunction (shape img) (f . (img `index`))+instance (Image src, Storable p) => FunctorImage src (Manifest p) where+ map f img = fromFunction (shape img) (f . (img !)) {-# INLINE map #-} -- Delayed images --------------------------------------------------------------@@ -330,7 +152,7 @@ , delayedFun :: !(Point -> p) } -instance Pixel p => MaskedImage (Delayed p) where+instance Storable p => MaskedImage (Delayed p) where type ImagePixel (Delayed p) = p shape = delayedSize@@ -339,7 +161,7 @@ maskedIndex img = Just . delayedFun img {-# INLINE maskedIndex #-} -instance Pixel p => Image (Delayed p) where+instance Storable p => Image (Delayed p) where index = delayedFun {-# INLINE index #-} @@ -349,8 +171,8 @@ fromFunction = Delayed {-# INLINE fromFunction #-} -instance (Image src, Pixel p) => FunctorImage src (Delayed p) where- map f img = fromFunction (shape img) (f . (img `index`))+instance (Image src, Storable p) => FunctorImage src (Delayed p) where+ map f img = fromFunction (shape img) (f . (img !)) {-# INLINE map #-} -- Masked delayed images -------------------------------------------------------@@ -360,7 +182,7 @@ , delayedMaskFun :: !(Point -> Maybe p) } -instance Pixel p => MaskedImage (DelayedMask p) where+instance Storable p => MaskedImage (DelayedMask p) where type ImagePixel (DelayedMask p) = p shape = delayedMaskSize@@ -369,31 +191,18 @@ maskedIndex = delayedMaskFun {-# INLINE maskedIndex #-} -instance Pixel p => FromFunction (DelayedMask p) where+instance Storable p => FromFunction (DelayedMask p) where type FromFunctionPixel (DelayedMask p) = Maybe p fromFunction = DelayedMask {-# INLINE fromFunction #-} -instance (MaskedImage src, Pixel p) => FunctorImage src (DelayedMask p) where+instance (MaskedImage src, Storable p) => FunctorImage src (DelayedMask p) where map f img = fromFunction (shape img) (\pt -> f <$> (img `maskedIndex` pt)) {-# INLINE map #-} --- Functions ------------------------------------------------------------------- --- | Returns the number of channels of an image.-nChannels :: MaskedImage i => i -> Int-nChannels img = pixNChannels (pixel img)-{-# INLINE nChannels #-}---- | Returns an 'undefined' instance of a pixel of the image. This is sometime--- useful to satisfy the type checker as in a call to 'pixNChannels' :------ > nChannels img = pixNChannels (pixel img)-pixel :: MaskedImage i => i -> ImagePixel i-pixel _ = undefined---- Conversion ------------------------------------------------------------------+-- Conversion and type helpers ------------------------------------------------- -- | Delays an image in its delayed representation. delay :: Image i => i -> Delayed (ImagePixel i)@@ -405,32 +214,30 @@ compute = map id {-# INLINE compute #-} -instance (Pixel p1, Pixel p2, Storable p1, Storable p2, Convertible p1 p2)+instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Manifest p1) (Manifest p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} -instance (Pixel p1, Pixel p2, Convertible p1 p2)+instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Delayed p1) (Delayed p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} -instance (Pixel p1, Pixel p2, Storable p2, Convertible p1 p2)+instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Delayed p1) (Manifest p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} -instance (Pixel p1, Pixel p2, Storable p1, Convertible p1 p2)+instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Manifest p1) (Delayed p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} --- Types helpers ------------------------------------------------------------------------- | Forces an image to be in its delayed represenation. Does nothing.+-- | Forces an image to be in its delayed representation. Does nothing. delayed :: Delayed p -> Delayed p delayed = id --- | Forces an image to be in its delayed represenation. Does nothing.+-- | Forces an image to be in its manifest representation. Does nothing. manifest :: Manifest p -> Manifest p manifest = id
src/Vision/Primitive.hs view
@@ -9,8 +9,17 @@ import Vision.Primitive.Shape +-- | Coordinates inside the image.+--+-- Can be constructed using 'ix2'. The first parameter is the y coordinate while+-- the second is the x coordinate (i.e. @'ix2' y x@). Image origin (@'ix2' 0 0@)+-- is located in the upper left corner. type Point = DIM2 +-- | Size of an object.+--+-- Can be constructed using 'ix2'. The first parameter is the height while the+-- second is the width (i.e. @ix2 h w@). type Size = DIM2 data Rect = Rect {
src/Vision/Primitive/Shape.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE BangPatterns, FlexibleInstances, TypeOperators #-}+{-# LANGUAGE BangPatterns+ , CPP+ , FlexibleInstances+ , TypeFamilies, MultiParamTypeClasses, FlexibleContexts+ , TypeOperators #-} -- | 'Shape's are similar to what you could found in @repa@. 'Shape' are used -- both for indexes and shapes.@@ -18,11 +22,17 @@ , ix1, ix2, ix3, ix4, ix5, ix6, ix7, ix8, ix9 ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Word+#endif import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr)+import Data.Vector.Unboxed (Unbox)+import qualified Data.Vector.Unboxed as VU+import Data.Vector.Generic.Mutable (MVector(..))+import qualified Data.Vector.Generic as VG -- | Class of types that can be used as array shapes and indices. class Eq sh => Shape sh where@@ -66,6 +76,57 @@ data tail :. head = !tail :. !head deriving (Show, Read, Eq, Ord) +newtype instance VU.MVector s Z = MV_Z (VU.MVector s ())+newtype instance VU.Vector Z = V_Z (VU.Vector ())++instance MVector VU.MVector Z where+ {-# INLINE basicLength #-}+ basicLength (MV_Z v) = basicLength v+ basicUnsafeSlice s e (MV_Z v) = MV_Z $ basicUnsafeSlice s e v+ basicUnsafeRead (MV_Z v) i = basicUnsafeRead v i >>= \_ -> return Z+ basicUnsafeNew i = MV_Z `fmap` basicUnsafeNew i+ basicUnsafeWrite (MV_Z v) i a = a `seq` basicUnsafeWrite v i ()+ basicOverlaps (MV_Z a) (MV_Z b) = basicOverlaps a b++instance VG.Vector VU.Vector Z where+ {-# INLINE basicLength #-}+ basicLength (V_Z v) = VG.basicLength v+ basicUnsafeFreeze (MV_Z v) = V_Z `fmap` VG.basicUnsafeFreeze v+ basicUnsafeThaw (V_Z v) = MV_Z `fmap` VG.basicUnsafeThaw v+ basicUnsafeSlice s e (V_Z v) = V_Z $ VG.basicUnsafeSlice s e v+ basicUnsafeIndexM (V_Z v) i = VG.basicUnsafeIndexM v i >>= \_ -> return Z++instance Unbox Z++newtype instance VU.MVector s (t :. h) = MV_Dim (VU.MVector s (t , h))+newtype instance VU.Vector (t :. h) = V_Dim (VU.Vector (t , h))++instance (Unbox t, Unbox h) => MVector VU.MVector (t :. h) where+ {-# INLINE basicLength #-}+ basicLength (MV_Dim v) = basicLength v+ basicUnsafeSlice s e (MV_Dim v) = MV_Dim $ basicUnsafeSlice s e v+ basicUnsafeRead (MV_Dim v) i = pairToPoint `fmap` basicUnsafeRead v i+ basicUnsafeNew i = MV_Dim `fmap` basicUnsafeNew i+ basicUnsafeWrite (MV_Dim v) i a = basicUnsafeWrite v i (pointToPair a)+ basicOverlaps (MV_Dim a) (MV_Dim b) = basicOverlaps a b++instance (Unbox t, Unbox h) => VG.Vector VU.Vector (t :. h) where+ {-# INLINE basicLength #-}+ basicLength (V_Dim v) = VG.basicLength v+ basicUnsafeFreeze (MV_Dim v) = V_Dim `fmap` VG.basicUnsafeFreeze v+ basicUnsafeThaw (V_Dim v) = MV_Dim `fmap` VG.basicUnsafeThaw v+ basicUnsafeSlice s e (V_Dim v) = V_Dim $ VG.basicUnsafeSlice s e v+ basicUnsafeIndexM (V_Dim v) i = pairToPoint `fmap` VG.basicUnsafeIndexM v i++instance (Unbox t, Unbox h) => Unbox (t :. h)++pairToPoint :: (tail, head) -> tail :. head+pairToPoint (a,b) = a :. b++pointToPair :: tail :. head -> (tail, head)+pointToPair (a :. b) = (a,b)++ -- Common dimensions. type DIM0 = Z type DIM1 = DIM0 :. Int@@ -161,12 +222,12 @@ peek !ptr = do let !ptr' = castPtr ptr- (:.) <$> peek (castPtr $! ptr' `plusPtr` 1) <*> peek ptr'+ (:.) <$> peek (castPtr $! ptr' `plusPtr` sizeOf (undefined :: Int)) <*> peek ptr' {-# INLINE peek #-} poke !ptr (sh :. n) = do let !ptr' = castPtr ptr- poke (castPtr $! ptr' `plusPtr` 1) sh >> poke ptr' n+ poke (castPtr $! ptr' `plusPtr` sizeOf n) sh >> poke ptr' n {-# INLINE poke #-} -- | Helper for index construction.
test/Test.hs view
@@ -2,9 +2,11 @@ import qualified Test.Vision.Image as I import qualified Test.Vision.Histogram as H+import qualified Test.Vision.Primitive as P main :: IO () main = defaultMain [ testGroup "Images" I.tests , testGroup "Histograms" H.tests+ , testGroup "Primitives" P.tests ]
+ test/Test/Utils.hs view
@@ -0,0 +1,15 @@++module Test.Utils+( propStorableRoundtrip+) where++import Foreign (Storable, with, peek)++import Test.QuickCheck (Property)+import Test.QuickCheck.Monadic (monadicIO, run, assert)++propStorableRoundtrip :: (Eq a, Storable a) => a -> Property+propStorableRoundtrip a = monadicIO $ do+ a' <- run . with a $ peek+ assert $ a' == a+
+ test/Test/Vision/Histogram.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE BangPatterns+ , CPP+ , FlexibleContexts+ , FlexibleInstances+ , UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Vision.Histogram (tests) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif++import Data.Int+import qualified Data.Vector.Storable as V+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary (..), Positive, getPositive)++import Vision.Histogram+import Vision.Image (Grey)+import qualified Vision.Image as I+import Vision.Primitive (Z (..), (:.) (..), DIM1, ix1, ix3)+import Test.Vision.Image ()++instance (Arbitrary (Positive p), Bounded p, Integral p, V.Storable p)+ => Arbitrary (Histogram DIM1 p) where+ arbitrary = do+ let !maxVal = maxBound `quot` 256 -- Sum musn't overflow.+ vec <- V.replicateM 256 (getPositive <$> arbitrary)+ return $ Histogram (Z :. 256) $ V.map (`rem` maxVal) vec++tests :: [Test]+tests = [+ testProperty "Sum of bins equals the number of pixels" propCalcHist++ , testProperty "The reduction of a 2D histogram gives the linear one."+ propReduceHist++ , testProperty "Resizing an histogram equals computing the smallest one."+ propResizeHist++ , testProperty "Cumulative histogram last bin equals original's sum"+ propCumulatHist++ , testProperty "Sum of an normalized histogram equals its size"+ propNormalizedHist++ , testProperty "Comparing the same histogram returns a perfect correlation"+ propCorrelation+ , testProperty "Comparing the same histogram returns a 0 chi-square value"+ propChiSquare+ , testProperty+ "The intersection of an histogram with itself is the sum of its values."+ propIntersec+ , testProperty "Comparing the same histogram returns a 0 EMD value"+ propEMD+ ]++-- | The sum of the values of the histogram is equal to the number of pixels of+-- the image.+propCalcHist :: Grey -> Bool+propCalcHist img =+ let Z :. h :. w = I.shape img+ Histogram _ vec = histogram Nothing img+ in V.sum vec == w * h++-- | Checks the identity @histogram == reduce . histogram2D@.+propReduceHist :: Grey -> Bool+propReduceHist img =+ let hist1 = histogram Nothing img :: Histogram DIM1 Int32+ hist2 = reduce (histogram2D (ix3 256 3 3) img)+ in hist1 == hist2++-- | Checks the resizing of an histogram equals the direct computation of the+-- smallest one.+propResizeHist :: Grey -> Bool+propResizeHist img =+ let hist1 = histogram (Just (ix1 128)) img :: Histogram DIM1 Int32+ hist2 = resize (ix1 128) (histogram (Just (ix1 256)) img)+ in hist1 == hist2++-- | Checks if the last bin of the cumulative histogram equals the sum of the+-- values of the original histogram.+propCumulatHist :: Histogram DIM1 Int32 -> Bool+propCumulatHist hist@(Histogram _ vec) =+ let Histogram _ vec' = cumulative hist+ in V.sum vec == vec' V.! 255++-- | Checks that the sums of an equalized histogram equals the desired value.+propNormalizedHist :: Double -> Histogram DIM1 Int32 -> Bool+propNormalizedHist val hist =+ let Histogram _ vec = normalize val hist+ in round (V.sum vec) == (round val :: Integer)++-- | Checks that the comparison of two identical histograms gives the+-- correlation value 1.+propCorrelation :: Histogram DIM1 Int32 -> Bool+propCorrelation hist = round (compareCorrel hist hist :: Double) == (1 :: Int)++-- | Checks that the comparison of two identical histograms gives the zero+-- Chi-square value.+propChiSquare :: Histogram DIM1 Int32 -> Bool+propChiSquare hist = round (compareChi hist hist :: Double) == (0 :: Int)++-- | Checks that the comparison of two identical histograms gives the sum of the+-- values of the histogram.+propIntersec :: Histogram DIM1 Int32 -> Bool+propIntersec hist@(Histogram _ vec) = compareIntersect hist hist == V.sum vec++-- | Checks that the comparison of two identical histograms gives a zero+-- EMD value.+propEMD :: Histogram DIM1 Int32 -> Bool+propEMD hist = compareEMD hist hist == 0
+ test/Test/Vision/Image.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE CPP+ , FlexibleContexts+ , FlexibleInstances+ , TypeFamilies+ , UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Vision.Image (tests) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<*>), (<$>))+#endif++import Data.Vector.Storable (Storable, replicateM)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary (..), choose, Property)+import Test.Utils (propStorableRoundtrip)++import Vision.Image (+ MaskedImage (..), Image (..), Interpolable, FromFunction (..)+ , ImageChannel, Manifest (..), Delayed (..)+ , Grey, GreyPixel (..), HSVPixel (..)+ , RGBA, RGBAPixel (..), RGBADelayed+ , RGB, RGBPixel (..), InterpolMethod (..)+ , convert, resize, horizontalFlip, verticalFlip+ )+import Vision.Primitive (Z (..), (:.) (..), Size)++maxImageSize :: Int+maxImageSize = 100++instance (Arbitrary p, Storable p) => Arbitrary (Manifest p) where+ arbitrary = do+ w <- choose (1, maxImageSize)+ h <- choose (1, maxImageSize)+ vec <- replicateM (w * h) arbitrary+ return $ Manifest (Z :. h :. w) vec++instance Arbitrary GreyPixel where+ arbitrary = GreyPixel <$> arbitrary++instance Arbitrary RGBAPixel where+ arbitrary = RGBAPixel <$> arbitrary <*> arbitrary <*> arbitrary+ <*> arbitrary++instance Arbitrary RGBPixel where+ arbitrary = RGBPixel <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary HSVPixel where+ arbitrary = HSVPixel <$> arbitrary <*> arbitrary <*> arbitrary++tests :: [Test]+tests = [+ testGroup "Conversions identities" [+ testProperty "RGB to/from RGBA" $ propRGBRGBA+ , testProperty "RGB to/from HSV" $ propRGBHSV+ ]+ , testGroup "Nearest-neighbor resize" [+ testProperty "Grey" (propImageResize :: Grey -> Bool)+ , testProperty "RGBA" (propImageResize :: RGBA -> Bool)+ , testProperty "RGB" (propImageResize :: RGB -> Bool)+ ]+ , testGroup "Horizontal flip is symetric" [+ testProperty "Grey" (propHorizontalFlip :: Grey -> Bool)+ , testProperty "RGBA" (propHorizontalFlip :: RGBA -> Bool)+ , testProperty "RGB" (propHorizontalFlip :: RGB -> Bool)+ ]+ , testGroup "Vertical flip is symetric" [+ testProperty "Grey" (propVerticalFlip :: Grey -> Bool)+ , testProperty "RGBA" (propVerticalFlip :: RGBA -> Bool)+ , testProperty "RGB" (propVerticalFlip :: RGB -> Bool)+ ]+ , testGroup "Storable can roundtrip" [+ testProperty "HSVPixel" $ (propStorableRoundtrip :: HSVPixel -> Property)+ , testProperty "RGBPixel" $ (propStorableRoundtrip :: RGBPixel -> Property)+ , testProperty "RGBAPixel" $ (propStorableRoundtrip :: RGBAPixel -> Property)+ ]+ ]++-- | Tests if the conversions between RGB and RGBA images give the same images.+propRGBRGBA :: RGB -> Bool+propRGBRGBA img =+ let img' = convert (convert img :: RGBADelayed) :: RGB+ in img == img'++-- | Tests if the conversions between RGB and HSV images give the same images.+propRGBHSV :: RGBPixel -> Bool+propRGBHSV pix =+ same pix pix'+ where+ pix' = convert (convert pix :: HSVPixel) :: RGBPixel++ err = 9++ same (RGBPixel r g b) (RGBPixel r' g' b') =+ abs (r - r') + abs (g - g') + abs (b - b') <= err++-- | Tests if by increasing the size of the image by a factor of two and then+-- reducing by a factor of two give the original image.+propImageResize :: (Image i, FromFunction i, FromFunctionPixel i ~ ImagePixel i+ , Interpolable (ImagePixel i), Integral (ImageChannel i)+ , Eq i)+ => i -> Bool+propImageResize img =+ img == resize' size (resize' (Z :. (h * 2) :. (w * 2)) img)+ where+ size@(Z :. h :. w) = shape img++ resize' :: (Image i, FromFunction i, FromFunctionPixel i ~ ImagePixel i+ , Interpolable (ImagePixel i), Integral (ImageChannel i))+ => Size -> i -> i+ resize' size' = resize NearestNeighbor size'++-- | Tests if applying the horizontal flip twice gives the original image.+propHorizontalFlip :: (Image i, FromFunction i+ , FromFunctionPixel i ~ ImagePixel i, Eq i) => i -> Bool+propHorizontalFlip img =+ img == horizontalFlip (delayedFlip img)+ where+ delayedFlip :: (Image i, ImagePixel i ~ p) => i -> Delayed p+ delayedFlip = horizontalFlip++-- | Tests if applying the vertical flip twice gives the original image.+propVerticalFlip :: (Image i, FromFunction i+ , FromFunctionPixel i ~ ImagePixel i, Eq i) => i -> Bool+propVerticalFlip img =+ img == verticalFlip (delayedFlip img)+ where+ delayedFlip :: (Image i, ImagePixel i ~ p) => i -> Delayed p+ delayedFlip = verticalFlip
+ test/Test/Vision/Primitive.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Vision.Primitive+( tests+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<*>), (<$>))+#endif++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary (..), Property)+import Test.Utils (propStorableRoundtrip)++import Vision.Primitive++instance Arbitrary Z where+ arbitrary = return Z++instance (Arbitrary t, Arbitrary h) => Arbitrary (t :. h) where+ arbitrary = (:.) <$> arbitrary <*> arbitrary++tests :: [Test]+tests =+ [ testGroup "Storable can roundtrip"+ [ testProperty "DIM0" $ (propStorableRoundtrip :: DIM0 -> Property)+ , testProperty "DIM1" $ (propStorableRoundtrip :: DIM1 -> Property)+ , testProperty "DIM2" $ (propStorableRoundtrip :: DIM2 -> Property)+ , testProperty "DIM3" $ (propStorableRoundtrip :: DIM3 -> Property)+ , testProperty "DIM4" $ (propStorableRoundtrip :: DIM4 -> Property)+ , testProperty "DIM5" $ (propStorableRoundtrip :: DIM5 -> Property)+ , testProperty "DIM6" $ (propStorableRoundtrip :: DIM6 -> Property)+ , testProperty "DIM7" $ (propStorableRoundtrip :: DIM7 -> Property)+ , testProperty "DIM8" $ (propStorableRoundtrip :: DIM8 -> Property)+ , testProperty "DIM9" $ (propStorableRoundtrip :: DIM9 -> Property)+ ]+ ]+