friday (empty) → 0.1
raw patch · 34 files changed
+4096/−0 lines, 34 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, convertible, criterion, friday, primitive, ratio-int, test-framework, test-framework-quickcheck2, transformers, vector
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- bench/Benchmark.hs +186/−0
- example/Canny.hs +39/−0
- example/Delayed.hs +44/−0
- example/GaussianBlur.hs +35/−0
- example/Histogram.hs +46/−0
- example/ResizeImage.hs +28/−0
- friday.cabal +175/−0
- src/Vision/Detector/Edge.hs +150/−0
- src/Vision/Histogram.hs +438/−0
- src/Vision/Image.hs +39/−0
- src/Vision/Image/Filter.hs +690/−0
- src/Vision/Image/Grey.hs +6/−0
- src/Vision/Image/Grey/Conversion.hs +47/−0
- src/Vision/Image/Grey/Type.hs +42/−0
- src/Vision/Image/HSV.hs +6/−0
- src/Vision/Image/HSV/Conversion.hs +91/−0
- src/Vision/Image/HSV/Type.hs +81/−0
- src/Vision/Image/Interpolate.hs +130/−0
- src/Vision/Image/Mutable.hs +120/−0
- src/Vision/Image/RGB.hs +6/−0
- src/Vision/Image/RGB/Conversion.hs +34/−0
- src/Vision/Image/RGB/Type.hs +72/−0
- src/Vision/Image/RGBA.hs +6/−0
- src/Vision/Image/RGBA/Conversion.hs +22/−0
- src/Vision/Image/RGBA/Type.hs +74/−0
- src/Vision/Image/Storage.hsc +381/−0
- src/Vision/Image/Threshold.hs +73/−0
- src/Vision/Image/Transform.hs +184/−0
- src/Vision/Image/Type.hs +436/−0
- src/Vision/Primitive.hs +24/−0
- src/Vision/Primitive/Shape.hs +214/−0
- test/Test.hs +10/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Benchmark.hs view
@@ -0,0 +1,186 @@+{-# 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+ ]+++ , 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++ 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)
+ example/Canny.hs view
@@ -0,0 +1,39 @@+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 view
@@ -0,0 +1,44 @@+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 view
@@ -0,0 +1,35 @@+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 view
@@ -0,0 +1,46 @@+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 view
@@ -0,0 +1,28 @@+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 ()
+ friday.cabal view
@@ -0,0 +1,175 @@+name: friday+version: 0.1+synopsis: A functionnal image processing library for Haskell.+homepage: https://github.com/RaphaelJ/friday+license: LGPL-3+license-file: LICENSE+author: Raphael Javaux <raphaeljavaux[at]gmail.com>+maintainer: Raphael Javaux <raphaeljavaux[at]gmail.com>++description: Friday provides functions to manipulate images in a+ functional way.+ 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+ 'Vector's ;+ .+ * the 'Delayed' representation uses functions to produce+ images pixels. These images can be combined to produce+ complex transformations. By some inlining, Haskell+ compilers are able to produce fast algorithms by+ removing intermediate structures.+ .+ The library currently support four color spaces: RGB,+ RGBA, HSV and gray-scale images.+ .+ Please read our+ <https://github.com/RaphaelJ/friday/blob/master/README.md README>+ to get a detailed usage and some examples.++category: Graphics+stability: Experimental+build-type: Simple+cabal-version: >= 1.10++Flag examples+ Description: Compiles examples from the example/ directory.+ Default: False++library+ exposed-modules: Vision.Detector.Edge+ Vision.Histogram+ Vision.Image+ Vision.Image.Grey+ Vision.Image.Grey.Conversion+ Vision.Image.Grey.Type+ Vision.Image.Filter+ Vision.Image.HSV+ Vision.Image.HSV.Conversion+ Vision.Image.HSV.Type+ Vision.Image.Interpolate+ Vision.Image.Mutable+ Vision.Image.RGBA+ Vision.Image.RGBA.Conversion+ Vision.Image.RGBA.Type+ Vision.Image.RGB+ Vision.Image.RGB.Conversion+ Vision.Image.RGB.Type+ Vision.Image.Storage+ Vision.Image.Threshold+ Vision.Image.Transform+ Vision.Image.Type+ Vision.Primitive+ Vision.Primitive.Shape++ ghc-options: -Wall -O2+ hs-source-dirs: src/+ default-language: Haskell2010++ build-depends: base >= 4 && < 5+ , bytestring >= 0.10 && < 1.0+ , convertible >= 1 && < 2+ , primitive >= 0.5.2.1 && < 0.6+ , ratio-int >= 0.1.2 && < 0.2+ , vector >= 0.10.0.1 && < 1.0+ , transformers >= 0.3 && < 0.4++ 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+++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++Test-Suite test+ type: exitcode-stdio-1.0++ main-is: Test.hs+ ghc-options: -Wall -O2 -rtsopts+ hs-source-dirs: test/+ default-language: Haskell2010++ build-depends: base >= 4 && < 5+ , QuickCheck >= 2.6 && < 3+ , friday+ , test-framework >= 0.8 && < 0.9+ , test-framework-quickcheck2 >= 0.3.0.2 && < 0.4+ , vector >= 0.10.0.1 && < 1.0
+ src/Vision/Detector/Edge.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, MultiWayIf #-}++module Vision.Detector.Edge (canny) where++import Control.Monad (when)+import Control.Monad.ST.Safe (ST)+import Data.Int+import Data.Vector.Storable (enumFromN, forM_)++import Vision.Image (+ Image, Pixel, ImagePixel, Manifest, MutableManifest, Grey, Derivative (..)+ , shape, index, linearIndex, fromFunction+ , create, new', linearRead, linearWrite+ , apply, sobel+ )+import Vision.Primitive (Z (..), (:.) (..), inShape, ix2)++data EdgeDirection = NorthSouth -- ^ |+ | WestEast -- ^ ―+ | NorthEastSouthWest -- ^ /+ | NorthWestSouthEast -- ^ \++-- | Detects edges using the Canny's algorithm. Edges are given the value+-- 'maxBound' while non-edges are given the value 'minBound'.+--+-- This implementation doesn't perform any noise erasing (as blurring) before+-- edge detection. Noisy images might need to be pre-processed using a Gaussian+-- blur.+--+-- The bidirectional derivative (gradient magnitude) is computed from @x@ and+-- @y@ derivatives using @sqrt(dx² + dy²)@.+--+-- See <http://en.wikipedia.org/wiki/Canny_edge_detector> for details.+--+-- 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)+ => Int+ -- ^ Radius of the Sobel's filter.+ -> Int32+ -- ^ Low threshold. Pixels for which the bidirectional derivative is+ -- greater than this value and which are connected to another pixel which+ -- is part of an edge will be part of this edge.+ -> Int32+ -- ^ High threshold. Pixels for which the bidirectional derivative is+ -- greater than this value will be part of an edge.+ -> src+ -> Manifest res+canny !derivSize !lowThres !highThres !img =+ create $ do+ edges <- newManifest+ forM_ (enumFromN 0 h) $ \y -> do+ let !lineOffset = y * w+ forM_ (enumFromN 0 w) $ \x -> do+ visitPoint edges x y (lineOffset + x) highThres'+ return edges+ where+ !size@(Z :. h :. w) = shape img++ -- Squares both thresholds as they will be compared to 'dxy' which contains+ -- squared gradient magnitudes.+ (!lowThres', !highThres') = (square lowThres, square highThres)++ dx, dy :: Manifest Int16+ !dx = sobel derivSize DerivativeX `apply` img+ !dy = sobel derivSize DerivativeY `apply` img++ -- Gradient magnitude, squared.+ dxy :: Manifest Int32+ !dxy = fromFunction size $ \pt ->+ square (fromIntegral $ dx `index` pt)+ + square (fromIntegral $ dy `index` pt)++ newManifest :: (Pixel p, Bounded p) => ST s (MutableManifest p s)+ newManifest = new' size minBound++ -- Visits a point and compares its gradient magnitude to the given+ -- threshold, visits neighbor if the point is perceived an an edge.+ visitPoint !edges !x !y !linearIX !thres = do+ val <- linearRead edges linearIX++ when (val == minBound) $ do+ let !ptDxy = dxy `linearIndex` linearIX+ ptDx = dx `linearIndex` linearIX+ ptDy = dy `linearIndex` linearIX+ direction = edgeDirection ptDx ptDy++ -- When the current pixel has a greater magnitude than the threshold+ -- and is a local maximum, considers it as a new starting point of+ -- an edge. Tries to draw the remaining of the edge using the low+ -- threshold and by following the edge direction.++ when (ptDxy > thres && isMaximum x y ptDxy direction) $ do+ linearWrite edges linearIX maxBound+ visitNeighbour edges x y direction++ visitNeighbour !edges !x !y !direction = do+ let (!x1, !y1, !x2, !y2) =+ case direction of+ NorthSouth -> (x, y - 1, x, y + 1)+ WestEast -> (x - 1, y, x + 1, y )+ NorthEastSouthWest -> (x - 1, y - 1, x + 1, y + 1)+ NorthWestSouthEast -> (x + 1, y - 1, x - 1, y + 1)++ when (inShape size (ix2 y1 x1)) $+ visitPoint edges x1 y1 (y1 * w + x1) lowThres'++ when (inShape size (ix2 y2 x2)) $+ visitPoint edges x2 y2 (y2 * w + x2) lowThres'++ isMaximum !x !y !ptDxy !direction =+ let (!x1, !y1, !x2, !y2) =+ case direction of+ NorthSouth -> (x - 1, y, x + 1, y )+ WestEast -> (x, y - 1, x, y + 1)+ NorthEastSouthWest -> (x + 1, y - 1, x - 1, y + 1)+ NorthWestSouthEast -> (x - 1, y - 1, x + 1, y + 1)+ 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)+ | otherwise = True++ -- Returns the direction of the edge, not to be confused with the direction+ -- of the gradient which is the perpendicular of this value.+ edgeDirection ptDx ptDy =+ let !angle = atan2 (double ptDy) (double ptDx)+ in if angle >= 0 then if | angle > pi8x7 -> NorthSouth+ | angle > pi8x5 -> NorthEastSouthWest+ | angle > pi8x3 -> WestEast+ | angle > pi8 -> NorthWestSouthEast+ | otherwise -> NorthSouth+ else if | angle < -pi8x7 -> NorthSouth+ | angle < -pi8x5 -> NorthWestSouthEast+ | angle < -pi8x3 -> WestEast+ | angle < -pi8 -> NorthEastSouthWest+ | otherwise -> NorthSouth++ !pi8 = pi / 8+ !pi8x3 = pi8 * 3+ !pi8x5 = pi8 * 5+ !pi8x7 = pi8 * 7+{-# INLINABLE canny #-}+{-# SPECIALIZE canny :: Int -> Int32 -> Int32 -> Grey -> Grey #-}++square :: Num a => a -> a+square a = a * a++double :: Integral a => a -> Double+double = fromIntegral
+ src/Vision/Histogram.hs view
@@ -0,0 +1,438 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances+ , ParallelListComp, TypeFamilies, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Contains functions to compute and manipulate histograms as well as some+-- images transformations which are histogram-based.+--+-- Every polymorphic function is specialised for histograms of 'Int32', 'Double'+-- and 'Float'. Other types can be specialized as every polymorphic function is+-- declared @INLINABLE@.+module Vision.Histogram (+ -- * Types & helpers+ Histogram (..), HistogramShape (..), ToHistogram (..)+ , index, linearIndex, map, assocs+ -- * Histogram computations+ , histogram, histogram2D, reduce, resize, cumulative, normalize+ -- * Images processing+ , equalizeImage+ -- * Histogram comparisons+ , compareCorrel, compareChi, compareIntersect, compareEMD+ ) where++import Data.Int+import Data.Vector.Storable (Vector, (!))+import qualified Data.Vector.Storable as V+import Foreign.Storable (Storable)+import Prelude hiding (map)++import Vision.Image (+ Pixel, MaskedImage, Image, ImagePixel, FunctorImage+ , Grey, GreyPixel (..), HSV, HSVPixel (..), RGBA, RGBAPixel (..)+ , RGB, RGBPixel (..)+ )+import qualified Vision.Image as I+import Vision.Primitive (+ Z (..), (:.) (..), Shape (..), DIM1, DIM3, DIM4, DIM5, DIM6+ , ix1, ix3, ix4+ )++-- 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.++{-# RULES+"realToFrac/Int32->Double" realToFrac = fromIntegral :: Int32 -> Double+"realToFrac/Int32->Float" realToFrac = fromIntegral :: Int32 -> Float+ #-}++-- Types -----------------------------------------------------------------------++data Histogram sh a = Histogram {+ shape :: !sh+ , vector :: !(Vector a) -- ^ Values of the histogram in row-major order.+ } deriving (Eq, Ord, Show)++-- | Subclass of 'Shape' which defines how to resize a shape so it will fit+-- inside a resized histogram.+class Shape sh => HistogramShape sh where+ -- | Given a number of bins, reduces an index so it will be mapped to a bin.+ toBin :: sh -- ^ The number of bins we are mapping to.+ -> sh -- ^ The number of possible values of the original index.+ -> sh -- ^ The original index.+ -> sh -- ^ The index of the bin in the histogram.++instance HistogramShape Z where+ toBin _ _ _ = Z+ {-# INLINE toBin #-}++instance HistogramShape sh => HistogramShape (sh :. Int) where+ toBin !(shBins :. bins) !(shMaxBins :. maxBins) !(shIx :. ix)+ | bins == maxBins = inner :. ix+ | otherwise = inner :. (ix * bins `quot` maxBins)+ where+ inner = toBin shBins shMaxBins shIx+ {-# INLINE toBin #-}++-- | This class defines how many dimensions a histogram will have and what will+-- be the default number of bins.+class (Pixel p, Shape (PixelValueSpace p)) => ToHistogram p where+ -- | Gives the value space of a pixel. Single-channel pixels will be 'DIM1'+ -- whereas three-channels pixels will be 'DIM3'.+ -- This is used to determine the rank of the generated histogram.+ type PixelValueSpace p++ -- | Converts a pixel to an index.+ pixToIndex :: p -> PixelValueSpace p++ -- | Returns the maximum number of different values an index can take for+ -- each dimension of the histogram (aka. the maximum index returned by+ -- 'pixToIndex' plus one).+ domainSize :: p -> PixelValueSpace p++instance ToHistogram GreyPixel where+ type PixelValueSpace GreyPixel = DIM1++ pixToIndex !(GreyPixel val) = ix1 $ int val+ {-# INLINE pixToIndex #-}++ domainSize _ = ix1 256++instance ToHistogram RGBAPixel where+ type PixelValueSpace RGBAPixel = DIM4++ pixToIndex !(RGBAPixel r g b a) = ix4 (int r) (int g) (int b) (int a)+ {-# INLINE pixToIndex #-}++ domainSize _ = ix4 256 256 256 256++instance ToHistogram RGBPixel where+ type PixelValueSpace RGBPixel = DIM3++ pixToIndex !(RGBPixel r g b) = ix3 (int r) (int g) (int b)+ {-# INLINE pixToIndex #-}++ domainSize _ = ix3 256 256 256++instance ToHistogram HSVPixel where+ type PixelValueSpace HSVPixel = DIM3++ pixToIndex !(HSVPixel h s v) = ix3 (int h) (int s) (int v)+ {-# INLINE pixToIndex #-}++ domainSize _ = ix3 180 256 256++-- Functions -------------------------------------------------------------------++index :: (Shape sh, Storable a) => Histogram sh a -> sh -> a+index !hist = linearIndex hist . toLinearIndex (shape hist)+{-# INLINE index #-}++-- | 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)+{-# INLINE linearIndex #-}++map :: (Storable a, Storable b) => (a -> b) -> Histogram sh a -> Histogram sh b+map f !(Histogram sh vec) = Histogram sh (V.map f vec)+{-# INLINE map #-}++-- | Returns all index/value pairs from the histogram.+assocs :: (Shape sh, Storable a) => Histogram sh a -> [(sh, a)]+assocs !(Histogram sh vec) = [ (ix, v) | ix <- shapeList sh+ | v <- V.toList vec ]+{-# INLINE assocs #-}++-- | Computes an histogram from a (possibly) multi-channel image.+--+-- If the size of the histogram is not given, there will be as many bins as the+-- range of values of pixels of the original image (see 'domainSize').+--+-- If the size of the histogram is specified, every bin of a given dimension+-- will be of the same size (uniform histogram).+histogram :: (MaskedImage i, ToHistogram (ImagePixel i), Storable a, Num a+ , HistogramShape (PixelValueSpace (ImagePixel i)))+ => Maybe (PixelValueSpace (ImagePixel i)) -> i+ -> Histogram (PixelValueSpace (ImagePixel i)) a+histogram mSize img =+ let initial = V.replicate nBins 0+ ones = V.replicate nPixs 1+ ixs = V.map toIndex (I.values img)+ in Histogram size (V.accumulate_ (+) initial ixs ones)+ where+ !size = case mSize of Just s -> s+ Nothing -> maxSize+ !maxSize = domainSize (I.pixel img)+ !nChans = I.nChannels img+ !nPixs = shapeLength (I.shape img) * nChans+ !nBins = shapeLength size++ toIndex !p = toLinearIndex size $!+ case mSize of Just _ -> toBin size maxSize $! pixToIndex p+ Nothing -> pixToIndex p+ {-# INLINE toIndex #-}+{-# SPECIALIZE histogram :: Maybe DIM1 -> Grey -> Histogram DIM1 Int32+ , Maybe DIM1 -> Grey -> Histogram DIM1 Double+ , Maybe DIM1 -> Grey -> Histogram DIM1 Float+ , Maybe DIM3 -> HSV -> Histogram DIM3 Int32+ , Maybe DIM3 -> HSV -> Histogram DIM3 Double+ , Maybe DIM3 -> HSV -> Histogram DIM3 Float+ , Maybe DIM4 -> RGBA -> Histogram DIM4 Int32+ , Maybe DIM4 -> RGBA -> Histogram DIM4 Double+ , Maybe DIM4 -> RGBA -> Histogram DIM4 Float+ , Maybe DIM3 -> RGB -> Histogram DIM3 Int32+ , Maybe DIM3 -> RGB -> Histogram DIM3 Double+ , Maybe DIM3 -> RGB -> Histogram DIM3 Float #-}+{-# INLINABLE histogram #-}++-- | Similar to 'histogram' but adds two dimensions for the y and x-coordinates+-- of the sampled points. This way, the histogram will map different regions of+-- the original image.+--+-- For example, an 'RGB' image will be mapped as+-- @'Z' ':.' red channel ':.' green channel ':.' blue channel ':.' y region+-- ':.' x region@.+--+-- As there is no reason to create an histogram as large as the number of pixels+-- of the image, a size is always needed.+histogram2D :: (Image i, ToHistogram (ImagePixel i), Storable a, Num a+ , HistogramShape (PixelValueSpace (ImagePixel i)))+ => (PixelValueSpace (ImagePixel i)) :. Int :. Int -> i+ -> Histogram ((PixelValueSpace (ImagePixel i)) :. Int :. Int) a+histogram2D size img =+ let initial = V.replicate nBins 0+ ones = V.replicate nPixs 1+ imgIxs = V.iterateN nPixs (shapeSucc imgSize) shapeZero+ ixs = V.zipWith toIndex imgIxs (I.vector img)+ in Histogram size (V.accumulate_ (+) initial ixs ones)+ where+ !imgSize@(Z :. h :. w) = I.shape img+ !maxSize = domainSize (I.pixel img) :. h :. w+ !nChans = I.nChannels img+ !nPixs = shapeLength (I.shape img) * nChans+ !nBins = shapeLength size++ toIndex !(Z :. y :. x) !p =+ let !ix = (pixToIndex p) :. y :. x+ in toLinearIndex size $! toBin size maxSize ix+ {-# INLINE toIndex #-}+{-# SPECIALIZE histogram2D :: DIM3 -> Grey -> Histogram DIM3 Int32+ , DIM3 -> Grey -> Histogram DIM3 Double+ , DIM3 -> Grey -> Histogram DIM3 Float+ , DIM5 -> HSV -> Histogram DIM5 Int32+ , DIM5 -> HSV -> Histogram DIM5 Double+ , DIM5 -> HSV -> Histogram DIM5 Float+ , DIM6 -> RGBA -> Histogram DIM6 Int32+ , DIM6 -> RGBA -> Histogram DIM6 Double+ , DIM6 -> RGBA -> Histogram DIM6 Float+ , DIM5 -> RGB -> Histogram DIM5 Int32+ , DIM5 -> RGB -> Histogram DIM5 Double+ , DIM5 -> RGB -> Histogram DIM5 Float #-}+{-# INLINABLE histogram2D #-}++-- Reshaping -------------------------------------------------------------------++-- | Reduces a 2D histogram to its linear representation. See 'resize' for a+-- reduction of the number of bins of an histogram.+--+-- @'histogram' == 'reduce' . 'histogram2D'@+reduce :: (HistogramShape sh, Storable a, Num a)+ => Histogram (sh :. Int :. Int) a -> Histogram sh a+reduce !(Histogram sh vec) =+ let !(sh' :. h :. w) = sh+ !len2D = h * w+ !vec' = V.unfoldrN (shapeLength sh') step vec+ step !rest = let (!channels, !rest') = V.splitAt len2D rest+ in Just (V.sum channels, rest')+ in Histogram sh' vec'+{-# SPECIALIZE reduce :: Histogram DIM5 Int32 -> Histogram DIM3 Int32+ , Histogram DIM5 Double -> Histogram DIM3 Double+ , Histogram DIM5 Float -> Histogram DIM3 Float+ , Histogram DIM3 Int32 -> Histogram DIM1 Int32+ , Histogram DIM3 Double -> Histogram DIM1 Double+ , Histogram DIM3 Float -> Histogram DIM1 Float #-}+{-# INLINABLE reduce #-}++-- | Resizes an histogram to another index shape. See 'reduce' for a reduction+-- of the number of dimensions of an histogram.+resize :: (HistogramShape sh, Storable a, Num a)+ => sh -> Histogram sh a -> Histogram sh a+resize !sh' (Histogram sh vec) =+ let initial = V.replicate (shapeLength sh') 0+ -- TODO: In this scheme, indexes are computed for each bin of the+ -- original histogram. It's sub-optimal as some parts of those indexes+ -- (lower dimensions) don't change at each bin.+ reIndex = toLinearIndex sh' . toBin sh' sh . fromLinearIndex sh+ ixs = V.map reIndex $ V.enumFromN 0 (shapeLength sh)+ in Histogram sh' (V.accumulate_ (+) initial ixs vec)++-- Normalisation ---------------------------------------------------------------++-- | Computes the cumulative histogram of another single dimension histogram.+--+-- @C(i) = SUM H(j)@ for each @j@ in @[0..i]@ where @C@ is the cumulative+-- histogram, and @H@ the original histogram.+cumulative :: (Storable a, Num a) => Histogram DIM1 a -> Histogram DIM1 a+cumulative (Histogram sh vec) = Histogram sh (V.scanl1' (+) vec)+{-# SPECIALIZE cumulative :: Histogram DIM1 Int32 -> Histogram DIM1 Int32+ , Histogram DIM1 Double -> Histogram DIM1 Double+ , Histogram DIM1 Float -> Histogram DIM1 Float #-}+{-# INLINABLE cumulative #-}++-- | Normalizes the histogram so that the sum of the histogram bins is equal to+-- the given value (normalisation by the @L1@ norm).+--+-- This is useful to compare two histograms which have been computed from images+-- with a different number of pixels.+normalize :: (Storable a, Real a, Storable b, Fractional b)+ => b -> Histogram sh a -> Histogram sh b+normalize norm !hist@(Histogram _ vec) =+ let !ratio = norm / realToFrac (V.sum vec)+ equalizeVal !val = realToFrac val * ratio+ {-# INLINE equalizeVal #-}+ in map equalizeVal hist+{-# SPECIALIZE normalize :: Double -> Histogram sh Int32 -> Histogram sh Double+ , Float -> Histogram sh Int32 -> Histogram sh Float+ , Double -> Histogram sh Double -> Histogram sh Double+ , Float -> Histogram sh Double -> Histogram sh Float+ , Double -> Histogram sh Float -> Histogram sh Double+ , Float -> Histogram sh Float -> Histogram sh Float+ #-}+{-# INLINABLE normalize #-}++-- | Equalizes a single channel image by equalising its histogram.+--+-- The algorithm equalizes the brightness and increases the contrast of the+-- image by mapping each pixel values to the value at the index of the+-- cumulative @L1@-normalized histogram :+--+-- @N(x, y) = H(I(x, y))@ where @N@ is the equalized image, @I@ is the image and+-- @H@ the cumulative of the histogram normalized over an @L1@ norm.+--+-- See <https://en.wikipedia.org/wiki/Histogram_equalization>.+equalizeImage :: (FunctorImage i i, Integral (ImagePixel i)+ , ToHistogram (ImagePixel i)+ , PixelValueSpace (ImagePixel i) ~ DIM1) => i -> i+equalizeImage img =+ I.map equalizePixel img+ where+ hist = histogram Nothing img :: Histogram DIM1 Int32+ 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)+ {-# INLINE equalizePixel #-}+-- FIXME: GHC 7.8.2 fails to specialize+{-# SPECIALIZE equalizeImage :: Grey -> Grey #-}+{-# INLINABLE equalizeImage #-}++-- Comparisons -----------------------------------------------------------------++-- | Computes the /Pearson\'s correlation coefficient/ between each+-- corresponding bins of the two histograms.+--+-- A value of 1 implies a perfect correlation, a value of -1 a perfect+-- opposition and a value of 0 no correlation at all.+--+-- @'compareCorrel' = SUM [ (H1(i) - µ(H1)) (H1(2) - µ(H2)) ]+-- / ( SQRT [ SUM [ (H1(i) - µ(H1))^2 ] ]+-- * SQRT [ SUM [ (H2(i) - µ(H2))^2 ] ] )@+--+-- Where @µ(H)@ is the average value of the histogram @H@.+--+-- See <http://en.wikipedia.org/wiki/Pearson_correlation_coefficient>.+compareCorrel :: (Shape sh, Storable a, Real a, Storable b, Eq b, Floating b)+ => Histogram sh a -> Histogram sh a -> b+compareCorrel (Histogram sh1 vec1) (Histogram sh2 vec2)+ | sh1 /= sh2 = error "Histograms are not of equal size."+ | denominat == 0 = 1+ | otherwise = numerat / denominat+ where+ numerat = V.sum $ V.zipWith (*) diff1 diff2+ denominat = sqrt (V.sum (V.map square diff1))+ * sqrt (V.sum (V.map square diff2))++ diff1 = V.map (\v1 -> realToFrac v1 - avg1) vec1+ diff2 = V.map (\v2 -> realToFrac v2 - avg2) vec2++ (avg1, avg2) = (avg vec1, avg vec2)+ avg !vec = realToFrac (V.sum vec) / realToFrac (V.length vec)+{-# SPECIALIZE compareCorrel+ :: Shape sh => Histogram sh Int32 -> Histogram sh Int32 -> Double+ , Shape sh => Histogram sh Int32 -> Histogram sh Int32 -> Float+ , Shape sh => Histogram sh Double -> Histogram sh Double -> Double+ , Shape sh => Histogram sh Double -> Histogram sh Double -> Float+ , Shape sh => Histogram sh Float -> Histogram sh Float -> Double+ , Shape sh => Histogram sh Float -> Histogram sh Float -> Float #-}+{-# INLINABLE compareCorrel #-}++-- | Computes the Chi-squared distance between two histograms.+--+-- A value of 0 indicates a perfect match.+--+-- @'compareChi' = SUM (d(i))@ for each indice @i@ of the histograms where+-- @d(i) = 2 * ((H1(i) - H2(i))^2 / (H1(i) + H2(i)))@.+compareChi :: (Shape sh, Storable a, Real a, Storable b, Fractional b)+ => Histogram sh a -> Histogram sh a -> b+compareChi (Histogram sh1 vec1) (Histogram sh2 vec2)+ | sh1 /= sh2 = error "Histograms are not of equal size."+ | otherwise = (V.sum $ V.zipWith step vec1 vec2) * 2+ where+ step !v1 !v2 = let !denom = v1 + v2+ in if denom == 0+ then 0+ else realToFrac (square (v1 - v2)) / realToFrac denom+ {-# INLINE step #-}+{-# SPECIALIZE compareChi+ :: Shape sh => Histogram sh Int32 -> Histogram sh Int32 -> Double+ , Shape sh => Histogram sh Int32 -> Histogram sh Int32 -> Float+ , Shape sh => Histogram sh Double -> Histogram sh Double -> Double+ , Shape sh => Histogram sh Double -> Histogram sh Double -> Float+ , Shape sh => Histogram sh Float -> Histogram sh Float -> Double+ , Shape sh => Histogram sh Float -> Histogram sh Float -> Float #-}+{-# INLINABLE compareChi #-}++-- | Computes the intersection of the two histograms.+--+-- The higher the score is, the best the match is.+--+-- @'compareIntersect' = SUM (min(H1(i), H2(i))@ for each indice @i@ of the+-- histograms.+compareIntersect :: (Shape sh, Storable a, Num a, Ord a)+ => Histogram sh a -> Histogram sh a -> a+compareIntersect (Histogram sh1 vec1) (Histogram sh2 vec2)+ | sh1 /= sh2 = error "Histograms are not of equal size."+ | otherwise = V.sum $ V.zipWith min vec1 vec2+{-# SPECIALIZE compareIntersect+ :: Shape sh => Histogram sh Int32 -> Histogram sh Int32 -> Int32+ , Shape sh => Histogram sh Double -> Histogram sh Double -> Double+ , Shape sh => Histogram sh Float -> Histogram sh Float -> Float #-}+{-# INLINABLE compareIntersect #-}++-- | Computed the /Earth mover's distance/ between two histograms.+--+-- Current algorithm only supports histograms of one dimension.+--+-- See <https://en.wikipedia.org/wiki/Earth_mover's_distance>.+compareEMD :: (Num a, Storable a)+ => Histogram DIM1 a -> Histogram DIM1 a -> a+compareEMD hist1@(Histogram sh1 _) hist2@(Histogram sh2 _)+ | sh1 /= sh2 = error "Histograms are not of equal size."+ | otherwise = let Histogram _ vec1 = cumulative hist1+ Histogram _ vec2 = cumulative hist2+ in V.sum $ V.zipWith (\v1 v2 -> abs (v1 - v2)) vec1 vec2+{-# SPECIALIZE compareEMD+ :: Histogram DIM1 Int32 -> Histogram DIM1 Int32 -> Int32+ , Histogram DIM1 Double -> Histogram DIM1 Double -> Double+ , Histogram DIM1 Float -> Histogram DIM1 Float -> Float #-}+{-# INLINABLE compareEMD #-}++square :: Num a => a -> a+square a = a * a++double :: Integral a => a -> Double+double= fromIntegral++int :: Integral a => a -> Int+int = fromIntegral
+ src/Vision/Image.hs view
@@ -0,0 +1,39 @@+-- | Images are manipulated by their 'Image' and 'MaskedImage' type-class+-- instances.+--+-- The 'Manifest' representation uses an internal 'Vector' to represent the+-- image whereas the 'Delayed' representation uses a function to generate+-- pixels. Most transformation functions are generic to both representations in+-- the way they apply to any type which implements the type-classes.+--+-- The 'Delayed' image should be used as intermediate representations of+-- complex image transformations.+--+-- Please refer to our+-- <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.Filter+ , module Vision.Image.HSV+ , module Vision.Image.Interpolate+ , module Vision.Image.Mutable+ , 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.Grey+import Vision.Image.Filter+import Vision.Image.HSV+import Vision.Image.Interpolate+import Vision.Image.Mutable+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/Filter.hs view
@@ -0,0 +1,690 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, GADTs+ , MultiParamTypeClasses, TypeFamilies #-}++-- | 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.+--+-- See <http://en.wikipedia.org/wiki/Kernel_(image_processing)> for details.+--+-- 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+-- @+module Vision.Image.Filter (+ -- * Types+ Filterable (..), Filter (..)+ , BoxFilter, BoxFilter1, SeparableFilter, SeparableFilter1+ , KernelAnchor (..)+ , Kernel (..)+ , SeparableKernel (..), SeparatelyFiltrable (..)+ , FilterFold (..), FilterFold1 (..)+ , BorderInterpolate (..)+ -- * Functions+ , kernelAnchor, borderInterpolate+ -- * Filters+ -- ** Morphological operators+ , dilate, erode+ -- ** Blur+ , blur, gaussianBlur+ -- ** Derivation+ , Derivative (..), scharr, sobel+ ) where++import Data.List+import Data.Ratio+import qualified Data.Vector.Storable as V+import Data.Word+import Foreign.Storable (Storable)++import Vision.Image.Type (+ MaskedImage (..), Image (..), FromFunction (..)+ , Manifest, Delayed+ )+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)++-- | 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 -----------------------------------------------------++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 #-}++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++ kernel _ = min+{-# INLINE 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 #-}++-- | 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.+ -> 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 #-}++-- Derivation ------------------------------------------------------------------++data Derivative = 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)+ => 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 #-}++-- | 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 #-}++square :: Num a => a -> a+square a = a * a++word :: Integral a => a -> Word+word = fromIntegral
+ src/Vision/Image/Grey.hs view
@@ -0,0 +1,6 @@+module Vision.Image.Grey (+ module Vision.Image.Grey.Type+ ) where++import Vision.Image.Grey.Type+import Vision.Image.Grey.Conversion ()
+ src/Vision/Image/Grey/Conversion.hs view
@@ -0,0 +1,47 @@+{-# 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/Type.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TypeFamilies #-}++module Vision.Image.Grey.Type (+ Grey, GreyPixel (..), GreyDelayed+ ) where++import Data.Bits+import Data.Word+import Foreign.Storable (Storable)++import Vision.Image.Interpolate (Interpolable (..))+import Vision.Image.Transform (+ InterpolMethod, crop, resize, horizontalFlip, verticalFlip+ )+import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Primitive (Rect, Size)++newtype GreyPixel = GreyPixel Word8+ deriving (Bits, Bounded, Enum, Eq, FiniteBits, Integral, Num, Ord, Real+ , Read, Show, Storable)++type Grey = Manifest GreyPixel++type GreyDelayed = Delayed GreyPixel++instance Pixel GreyPixel where+ type PixelChannel GreyPixel = Word8++ pixNChannels _ = 1+ {-# INLINE pixNChannels #-}++ pixIndex !(GreyPixel v) _ = v+ {-# INLINE pixIndex #-}++instance Interpolable GreyPixel where+ interpol f (GreyPixel a) (GreyPixel b) = GreyPixel $ f a b+ {-# INLINE interpol #-}++{-# SPECIALIZE crop :: Rect -> Grey -> Grey #-}+{-# SPECIALIZE resize :: InterpolMethod -> Size -> Grey -> Grey #-}+{-# SPECIALIZE horizontalFlip :: Grey -> Grey #-}+{-# SPECIALIZE verticalFlip :: Grey -> Grey #-}
+ src/Vision/Image/HSV.hs view
@@ -0,0 +1,6 @@+module Vision.Image.HSV (+ module Vision.Image.HSV.Type+ ) where++import Vision.Image.HSV.Type+import Vision.Image.HSV.Conversion ()
+ src/Vision/Image/HSV/Conversion.hs view
@@ -0,0 +1,91 @@+{-# 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
@@ -0,0 +1,81 @@+{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-}++module Vision.Image.HSV.Type (+ HSV, HSVPixel (..), HSVDelayed+ ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word+import Foreign.Storable (Storable (..))+import Foreign.Ptr (castPtr, plusPtr)++import Vision.Image.Interpolate (Interpolable (..))+import Vision.Image.Transform (+ InterpolMethod, crop, resize, horizontalFlip, verticalFlip+ )+import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Primitive (Rect, Size)++data HSVPixel = HSVPixel {+ hsvHue :: {-# UNPACK #-} !Word8, hsvSat :: {-# UNPACK #-} !Word8+ , hsvValue :: {-# UNPACK #-} !Word8+ } deriving (Eq, Show)++-- | 24 bits (3 * 8 bits) HSV image.+--+-- The Hue value is in [0..179], Saturation in [0..255] and Value in [0..255].+--+-- This image type is more respectful to human eye perception of colors and can+-- be converted (using 'convert') from 'RGB' images.+--+-- Uses <http://en.wikipedia.org/wiki/HSL_and_HSV> equations to convert from and+-- to RGB.+type HSV = Manifest HSVPixel++type HSVDelayed = Delayed HSVPixel++instance Storable HSVPixel where+ sizeOf _ = 3 * sizeOf (undefined :: Word8)+ {-# INLINE sizeOf #-}++ alignment _ = alignment (undefined :: Word8)+ {-# INLINE alignment #-}++ peek !ptr =+ let !ptr' = castPtr ptr+ in HSVPixel <$> peek ptr' <*> peek (ptr' `plusPtr` 1)+ <*> peek (ptr' `plusPtr` 2)+ {-# INLINE peek #-}++ poke !ptr HSVPixel { .. } =+ let !ptr' = castPtr ptr+ in poke ptr' hsvHue >>+ poke (ptr' `plusPtr` 1) hsvSat >>+ poke (ptr' `plusPtr` 2) hsvValue+ {-# INLINE poke #-}++instance Pixel HSVPixel where+ type PixelChannel HSVPixel = Word8++ pixNChannels _ = 3+ {-# INLINE pixNChannels #-}++ pixIndex !(HSVPixel h _ _) 0 = h+ pixIndex !(HSVPixel _ s _) 1 = s+ pixIndex !(HSVPixel _ _ v) _ = v+ {-# INLINE pixIndex #-}++instance Interpolable HSVPixel where+ interpol f a b =+ let HSVPixel aHue aSat aVal = a+ HSVPixel bHue bSat bVal = b+ in HSVPixel {+ hsvHue = f aHue bHue, hsvSat = f aSat bSat+ , hsvValue = f aVal bVal+ }+ {-# INLINE interpol #-}++{-# SPECIALIZE crop :: Rect -> HSV -> HSV #-}+{-# SPECIALIZE resize :: InterpolMethod -> Size -> HSV -> HSV #-}+{-# SPECIALIZE horizontalFlip :: HSV -> HSV #-}+{-# SPECIALIZE verticalFlip :: HSV -> HSV #-}
+ src/Vision/Image/Interpolate.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE BangPatterns, FlexibleContexts #-}++-- | Provides a way to estimate the value of a pixel at rational coordinates+-- using a linear interpolation.+module Vision.Image.Interpolate (+ Interpolable (..), bilinearInterpol+ ) where++import Data.Int+import Data.RatioInt (denominator, numerator)+import Data.Word++import Vision.Image.Type (Pixel (..), Image (..), ImagePixel, ImageChannel)+import Vision.Primitive (RPoint (..), ix2)++-- | Provides a way to apply the interpolation to every component of a pixel.+class Interpolable p where+ -- | Given a function which interpolates two points over a single channel,+ -- returns a function which interpolates two points over every channel of+ -- two pixels.+ interpol :: (PixelChannel p -> PixelChannel p -> PixelChannel p)+ -> p -> p -> p++instance Interpolable Int16 where+ interpol = id++instance Interpolable Int32 where+ interpol = id++instance Interpolable Int where+ interpol = id++instance Interpolable Word8 where+ interpol = id++instance Interpolable Word16 where+ interpol = id++instance Interpolable Word32 where+ interpol = id++instance Interpolable Word where+ interpol = id++instance Interpolable Float where+ interpol = id++instance Interpolable Double where+ interpol = id++instance Interpolable Bool where+ interpol = id++-- | Uses a bilinear interpolation to find the value of the pixel at the+-- rational coordinates.+--+-- Estimates the value of a rational point @p@ using @a@, @b@, @c@ and @d@ :+--+-- @+-- x1 x2+--+-- y1 a ------ b+-- - -+-- - p -+-- - -+-- y2 c ------ d+-- @+bilinearInterpol :: (Image i, Interpolable (ImagePixel i)+ , Integral (ImageChannel i))+ => i -> RPoint -> ImagePixel i+img `bilinearInterpol` RPoint x y+ | not integralX && not integralY =+ let (!x1, !deltaX1) = properFraction x+ (!y1, !deltaY1) = properFraction y+ !x2 = x1 + 1+ !y2 = y1 + 1+ !a = img `index` ix2 y1 x1+ !b = img `index` ix2 y1 x2+ !c = img `index` ix2 y2 x1+ !d = img `index` ix2 y2 x2++ -- Computes the relative distance to the four points.+ !deltaX2 = compl deltaX1+ !deltaY2 = compl deltaY1++ !interpolX1 = interpol (interpolChannel deltaX1 deltaX2) a b+ !interpolX2 = interpol (interpolChannel deltaX1 deltaX2) c d+ in interpol (interpolChannel deltaY1 deltaY2) interpolX1 interpolX2+ | not integralX =+ let (!x1, !deltaX1) = properFraction x+ !y1 = truncate y+ !x2 = x1 + 1+ !a = img `index` ix2 y1 x1+ !b = img `index` ix2 y1 x2+ !deltaX2 = compl deltaX1+ in interpol (interpolChannel deltaX1 deltaX2) a b+ | not integralY =+ let !x1 = truncate x+ (!y1, !deltaY1) = properFraction y+ !y2 = y1 + 1+ !a = img `index` ix2 y1 x1+ !c = img `index` ix2 y2 x1+ !deltaY2 = compl deltaY1+ in interpol (interpolChannel deltaY1 deltaY2) a c+ | otherwise = img `index` ix2 (numerator y) (numerator x)+ where+ integralX = denominator x == 1+ integralY = denominator y == 1++ -- compl delta = 1 - delta+ compl delta = delta {+ numerator = denominator delta - numerator delta+ }+ {-# INLINE compl #-}++ -- Interpolates the value of a single channel given its two surrounding+ -- points.+ interpolChannel deltaA deltaB chanA chanB = truncate $+ -- (fromIntegral chanA) * deltaB + (fromIntegral chanB) * deltaA+ -- deltaB { numerator = int chanA * numerator deltaB }+ -- + deltaA { numerator = int chanB * numerator deltaA }+ deltaA {+ numerator = int chanA * numerator deltaB+ + int chanB * numerator deltaA+ }+ {-# INLINE interpolChannel #-}+{-# INLINE bilinearInterpol #-}++int :: Integral a => a -> Int+int = fromIntegral
+ src/Vision/Image/Mutable.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes, TypeFamilies #-}++module Vision.Image.Mutable (+ MutableImage (..), create+ , MutableManifest (..)+ ) where++import Control.Monad.Primitive (PrimMonad (..))+import Control.Monad.ST.Safe (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 Vision.Primitive (+ DIM2, 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++ -- | 'mShape' doesn't run in a monad as the size of a mutable image is+ -- constant.+ mShape :: i s -> Size++ -- | Creates a new mutable image of the given size. Pixels are initialized+ -- with an unknown value.+ new :: PrimMonad m => Size -> m (i (PrimState m))++ -- | Creates a new mutable image of the given size and fill it with the+ -- given value.+ 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 !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 !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)+ -> m ()+ write !img !ix !val = linearWrite img (toLinearIndex (mShape img) ix) val+ {-# INLINE write #-}++ -- | Overrides the value of the pixel at the given index as if the image was+ -- a single dimension vector (row-major representation).+ linearWrite :: PrimMonad m => i (PrimState m) -> Int+ -> ImagePixel (Freezed i) -> m ()+ linearWrite !img !ix !val = write img (fromLinearIndex (mShape img) ix) val++ -- | Returns an immutable copy of the mutable image.+ freeze :: PrimMonad m => i (PrimState m) -> m (Freezed i)++ -- | Returns the immutable version of the mutable image. The mutable image+ -- should not be modified thereafter.+ unsafeFreeze :: PrimMonad m => i (PrimState m) -> m (Freezed i)+ unsafeFreeze = freeze++ -- | Returns a mutable copy of the immutable image.+ thaw :: PrimMonad m => Freezed i -> m (i (PrimState m))++ {-# MINIMAL mShape, new, new', (read | linearRead)+ , (write | linearWrite), freeze, thaw #-}++-- | Creates an immutable image from an 'ST' action creating a mutable image.+create :: (MutableImage i) => (forall s. ST s (i s)) -> Freezed i+create action =+ runST $ do+ img <- action+ unsafeFreeze img++-- Instances -------------------------------------------------------------------++data Storable p => MutableManifest p s = MutableManifest {+ mmSize :: !Size+ , mmVector :: !(MVector s p)+ }++instance (Pixel p, Storable p) => MutableImage (MutableManifest p) where+ type Freezed (MutableManifest p) = Manifest p++ mShape = mmSize++ new !size = do+ mvec <- MV.new (shapeLength size)+ return $! MutableManifest size mvec++ new' !size !val = do+ mvec <- MV.replicate (shapeLength size) val+ return $! MutableManifest size mvec++ linearRead !img = MV.read (mmVector img)+ {-# INLINE linearRead #-}++ linearWrite !img = MV.write (mmVector img)+ {-# INLINE linearWrite #-}++ freeze !(MutableManifest size mvec) = do+ vec <- V.freeze mvec+ return $! Manifest size vec++ unsafeFreeze !(MutableManifest size mvec) = do+ vec <- V.unsafeFreeze mvec+ return $! Manifest size vec++ thaw !(Manifest size vec) = do+ mvec <- V.thaw vec+ return $! MutableManifest size mvec
+ src/Vision/Image/RGB.hs view
@@ -0,0 +1,6 @@+module Vision.Image.RGB (+ module Vision.Image.RGB.Type+ ) where++import Vision.Image.RGB.Type+import Vision.Image.RGB.Conversion ()
+ src/Vision/Image/RGB/Conversion.hs view
@@ -0,0 +1,34 @@+{-# 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
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-}++module Vision.Image.RGB.Type (+ RGB, RGBPixel (..), RGBDelayed+ ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word+import Foreign.Storable (Storable (..))+import Foreign.Ptr (castPtr, plusPtr)++import Vision.Image.Interpolate (Interpolable (..))+import Vision.Image.Transform (+ InterpolMethod, crop, resize, horizontalFlip, verticalFlip+ )+import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Primitive (Rect, Size)++data RGBPixel = RGBPixel {+ rgbRed :: {-# UNPACK #-} !Word8, rgbGreen :: {-# UNPACK #-} !Word8+ , rgbBlue :: {-# UNPACK #-} !Word8+ } deriving (Eq, Show)++type RGB = Manifest RGBPixel++type RGBDelayed = Delayed RGBPixel++instance Storable RGBPixel where+ sizeOf _ = 3 * sizeOf (undefined :: Word8)+ {-# INLINE sizeOf #-}++ alignment _ = alignment (undefined :: Word8)+ {-# INLINE alignment #-}++ peek !ptr =+ let !ptr' = castPtr ptr+ in RGBPixel <$> peek ptr' <*> peek (ptr' `plusPtr` 1)+ <*> peek (ptr' `plusPtr` 2)+ {-# INLINE peek #-}++ poke !ptr RGBPixel { .. } =+ let !ptr' = castPtr ptr+ in poke ptr' rgbRed >>+ poke (ptr' `plusPtr` 1) rgbGreen >>+ poke (ptr' `plusPtr` 2) rgbBlue+ {-# INLINE poke #-}++instance Pixel RGBPixel where+ type PixelChannel RGBPixel = Word8++ pixNChannels _ = 3+ {-# INLINE pixNChannels #-}++ pixIndex !(RGBPixel r _ _) 0 = r+ pixIndex !(RGBPixel _ g _) 1 = g+ pixIndex !(RGBPixel _ _ b) _ = b+ {-# INLINE pixIndex #-}++instance Interpolable RGBPixel where+ interpol f a b =+ let RGBPixel aRed aGreen aBlue = a+ RGBPixel bRed bGreen bBlue = b+ in RGBPixel {+ rgbRed = f aRed bRed, rgbGreen = f aGreen bGreen+ , rgbBlue = f aBlue bBlue+ }+ {-# INLINE interpol #-}++{-# SPECIALIZE crop :: Rect -> RGB -> RGB #-}+{-# SPECIALIZE resize :: InterpolMethod -> Size -> RGB -> RGB #-}+{-# SPECIALIZE horizontalFlip :: RGB -> RGB #-}+{-# SPECIALIZE verticalFlip :: RGB -> RGB #-}
+ src/Vision/Image/RGBA.hs view
@@ -0,0 +1,6 @@+module Vision.Image.RGBA (+ module Vision.Image.RGBA.Type+ ) where++import Vision.Image.RGBA.Type+import Vision.Image.RGBA.Conversion ()
+ src/Vision/Image/RGBA/Conversion.hs view
@@ -0,0 +1,22 @@+{-# 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
@@ -0,0 +1,74 @@+{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-}++module Vision.Image.RGBA.Type (+ RGBA, RGBAPixel (..), RGBADelayed+ ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word+import Foreign.Storable (Storable (..))+import Foreign.Ptr (castPtr, plusPtr)++import Vision.Image.Interpolate (Interpolable (..))+import Vision.Image.Transform (+ InterpolMethod, crop, resize, horizontalFlip, verticalFlip+ )+import Vision.Image.Type (Pixel (..), Manifest, Delayed)+import Vision.Primitive (Rect, Size)++data RGBAPixel = RGBAPixel {+ rgbaRed :: {-# UNPACK #-} !Word8, rgbaGreen :: {-# UNPACK #-} !Word8+ , rgbaBlue :: {-# UNPACK #-} !Word8, rgbaAlpha :: {-# UNPACK #-} !Word8+ } deriving (Eq, Show)++type RGBA = Manifest RGBAPixel++type RGBADelayed = Delayed RGBAPixel++instance Storable RGBAPixel where+ sizeOf _ = 4 * sizeOf (undefined :: Word8)+ {-# INLINE sizeOf #-}++ alignment _ = alignment (undefined :: Word8)+ {-# INLINE alignment #-}++ peek !ptr =+ let !ptr' = castPtr ptr+ in RGBAPixel <$> peek ptr' <*> peek (ptr' `plusPtr` 1)+ <*> peek (ptr' `plusPtr` 2) <*> peek (ptr' `plusPtr` 3)+ {-# INLINE peek #-}++ poke !ptr RGBAPixel { .. } =+ let !ptr' = castPtr ptr+ in poke ptr' rgbaRed >>+ poke (ptr' `plusPtr` 1) rgbaGreen >>+ poke (ptr' `plusPtr` 2) rgbaBlue >>+ poke (ptr' `plusPtr` 3) rgbaAlpha+ {-# INLINE poke #-}++instance Pixel RGBAPixel where+ type PixelChannel RGBAPixel = Word8++ pixNChannels _ = 4+ {-# INLINE pixNChannels #-}++ pixIndex !(RGBAPixel r _ _ _) 0 = r+ pixIndex !(RGBAPixel _ g _ _) 1 = g+ pixIndex !(RGBAPixel _ _ b _) 2 = b+ pixIndex !(RGBAPixel _ _ _ a) _ = a+ {-# INLINE pixIndex #-}++instance Interpolable RGBAPixel where+ interpol f a b =+ let RGBAPixel aRed aGreen aBlue aAlpha = a+ RGBAPixel bRed bGreen bBlue bAlpha = b+ in RGBAPixel {+ rgbaRed = f aRed bRed, rgbaGreen = f aGreen bGreen+ , rgbaBlue = f aBlue bBlue, rgbaAlpha = f aAlpha bAlpha+ }+ {-# INLINE interpol #-}++{-# SPECIALIZE crop :: Rect -> RGBA -> RGBA #-}+{-# SPECIALIZE resize :: InterpolMethod -> Size -> RGBA -> RGBA #-}+{-# SPECIALIZE horizontalFlip :: RGBA -> RGBA #-}+{-# SPECIALIZE verticalFlip :: RGBA -> RGBA #-}
+ src/Vision/Image/Storage.hsc view
@@ -0,0 +1,381 @@+{-# 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
@@ -0,0 +1,73 @@+{-# LANGUAGE BangPatterns, GADTs #-}++module Vision.Image.Threshold (+ ThresholdType (..)+ , threshold+ , AdaptiveThresholdKernel (..), adaptiveThreshold+ ) where++import Foreign.Storable (Storable)++import Vision.Image.Filter (Filter (..), SeparableFilter, blur, gaussianBlur)+import Vision.Image.Type (ImagePixel, FunctorImage)+import qualified Vision.Image.Type 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@.+data ThresholdType src res where+ BinaryThreshold :: res -> res -> ThresholdType src res+ Truncate :: src -> ThresholdType src src++-- | 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+{-# INLINE threshold #-}++-- | Defines how pixels of the kernel of the adaptive threshold will be+-- weighted.+--+-- With 'MeanKernel', pixels of the kernel have the same weight.+--+-- With @'GaussianKernel' sigma@, pixels are weighted according to their distance+-- from the thresholded pixel using a Gaussian function parametred by @sigma@.+-- See 'gaussianBlur' for details.+data AdaptiveThresholdKernel acc where+ MeanKernel :: Integral acc => AdaptiveThresholdKernel acc+ 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 :: (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 =+ 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+ !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 #-}
+ src/Vision/Image/Transform.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, TypeFamilies #-}++-- | Provides high level functions to do geometric transformations on images.+--+-- Every transformation is been declared @INLINABLE@ so new image types could be+-- specialized.+module Vision.Image.Transform (+ InterpolMethod (..), crop, resize, horizontalFlip, verticalFlip, floodFill+ ) where++import Control.Monad (when)+import Control.Monad.Primitive (PrimMonad (..))+import Data.RatioInt (RatioInt, (%))++import Vision.Image.Interpolate (Interpolable, bilinearInterpol)+import Vision.Image.Mutable (+ MutableImage (Freezed, mShape, linearRead, linearWrite)+ )+import Vision.Image.Type (+ MaskedImage (..), Image (..), ImageChannel, FromFunction (..)+ )+import Vision.Primitive (+ Z (..), (:.) (..), Point, RPoint (..), Rect (..), Size, ix2, toLinearIndex+ )++-- | Defines the set of possible methods for pixel interpolations when looking+-- for a pixel at floating point coordinates.+data InterpolMethod =+ TruncateInteger -- ^ Selects the top left pixel (fastest).+ | NearestNeighbor -- ^ Selects the nearest pixel (fast).+ | Bilinear -- ^ Does a double linear interpolation over the four+ -- surrounding points (slow).++-- | Maps the content of the image\'s rectangle in a new image.+crop :: (Image i1, FromFunction i2, ImagePixel i1 ~ FromFunctionPixel i2)+ => Rect -> i1 -> i2+crop !(Rect rx ry rw rh) !img =+ fromFunction (Z :. rh :. rw) $ \(Z :. y :. x) ->+ img `index` ix2 (ry + y) (rx + x)+{-# INLINABLE crop #-}++-- | Resizes the 'Image' using the given interpolation method.+resize :: (Image i1, Interpolable (ImagePixel i1), FromFunction i2+ , ImagePixel i1 ~ FromFunctionPixel i2, Integral (ImageChannel i1))+ => InterpolMethod -> Size -> i1 -> i2+resize !method !size'@(Z :. h' :. w') !img =+ case method of+ TruncateInteger ->+ let !widthRatio = double w / double w'+ !widthMiddle = (widthRatio - 1) / 2+ !heightRatio = double h / double h'+ !heightMiddle = (heightRatio - 1) / 2+ line !y' = truncate $ double y' * heightRatio + heightMiddle+ {-# INLINE line #-}+ col !x' = truncate $ double x' * widthRatio + widthMiddle+ {-# INLINE col #-}+ f !y !(Z :. _ :. x') = let !x = col x'+ in img `index` ix2 y x+ {-# INLINE f #-}+ in fromFunctionLine size' line f+ NearestNeighbor ->+ let !widthRatio = double w / double w'+ !widthMiddle = (widthRatio - 1) / 2+ !heightRatio = double h / double h'+ !heightMiddle = (heightRatio - 1) / 2+ line !y' = round $ double y' * heightRatio + heightMiddle+ {-# INLINE line #-}+ col !x' = round $ double x' * widthRatio + widthMiddle+ {-# INLINE col #-}+ f !y !(Z :. _ :. x') = let !x = col x'+ in img `index` ix2 y x+ {-# INLINE f #-}+ in fromFunctionLine size' line f+ Bilinear ->+ let !widthRatio = w % w'+ !widthMiddle = (widthRatio - 1) / 2+ !maxWidth = ratio (w - 1)+ !heightRatio = (h - 1) % (h' - 1)+ !heightMiddle = (heightRatio - 1) / 2+ !maxHeight = ratio (h - 1)+ -- Limits the interpolation to inner pixel as first and last+ -- pixels can have out of bound coordinates.+ bound !limit = min limit . max 0+ {-# INLINE bound #-}+ line !y' = bound maxHeight $ ratio y' * heightRatio+ + heightMiddle+ {-# INLINE line #-}+ col !x' = bound maxWidth $ ratio x' * widthRatio+ + widthMiddle+ {-# INLINE col #-}+ f !y !x _ = img `bilinearInterpol` RPoint x y+ {-# INLINE f #-}+ in fromFunctionCached size' line col f+ where+ !(Z :. h :. w) = shape img+{-# INLINABLE resize #-}++-- | Reverses the image horizontally.+horizontalFlip :: (Image i1, FromFunction i2+ , ImagePixel i1 ~ FromFunctionPixel i2)+ => i1 -> i2+horizontalFlip !img =+ let f !(Z :. y :. x') = let !x = maxX - x'+ in img `index` ix2 y x+ {-# INLINE f #-}+ in fromFunction size f+ where+ !size@(Z :. _ :. w) = shape img+ !maxX = w - 1+{-# INLINABLE horizontalFlip #-}++-- | Reverses the image vertically.+verticalFlip :: (Image i1, FromFunction i2+ , ImagePixel i1 ~ FromFunctionPixel i2)+ => i1 -> i2+verticalFlip !img =+ let line !y' = maxY - y'+ {-# INLINE line #-}+ f !y !(Z :. _ :. x) = img `index` ix2 y x+ {-# INLINE f #-}+ in fromFunctionLine size line f+ where+ !size@(Z :. h :. _) = shape img+ !maxY = h - 1+{-# INLINABLE verticalFlip #-}++-- | Paints with a new value the pixels surrounding the given point of the image+-- which have the same value as the starting point.+floodFill :: (PrimMonad m, MutableImage i, Eq (ImagePixel (Freezed i)))+ => Point -> ImagePixel (Freezed i) -> i (PrimState m) -> m ()+floodFill !start !newVal !img = do+ let !linearIX = toLinearIndex size start+ val <- linearRead img linearIX+ when (val /= newVal) $ -- No reason to repaint using the same color.+ go val start linearIX+ where+ !size@(Z :. h :. w) = mShape img++ -- Runs the flood-fill algorithm from the starting point then checks the+ -- pixels at the left and at the right of the point until their value+ -- change (scanLine). Then visits the upper and lower line of neighboring+ -- pixels (visitLine).++ go !val !(Z :. y :. x) !linearIX = do+ pix <- linearRead img linearIX++ when (pix == val) $ do+ let !minLineLinearIX = linearIX - x+ !maxLineLinearIX = minLineLinearIX + w - 1++ linearWrite img linearIX newVal++ stopLeft <- scanLine val (< minLineLinearIX) pred (linearIX - 1)+ stopRight <- scanLine val (> maxLineLinearIX) succ (linearIX + 1)++ let !from = stopLeft + 1+ !to = stopRight - 1+ !xFrom = from - minLineLinearIX++ when (y > 0) $+ visitLine val (to - w) (ix2 (y - 1) xFrom) (from - w)+ when ((y + 1) < h) $+ visitLine val (to + w) (ix2 (y + 1) xFrom) (from + w)++ scanLine !val !stop !next !linearIX+ | stop linearIX = return linearIX+ | otherwise = do+ pix <- linearRead img linearIX+ if pix == val then do linearWrite img linearIX newVal+ scanLine val stop next (next linearIX)+ else return linearIX++ visitLine !val !maxLinearIX !pt@(y :. x) !linearIX+ | linearIX > maxLinearIX = return ()+ | otherwise = do+ go val pt linearIX+ visitLine val maxLinearIX (y :. (x + 1)) (linearIX + 1)+{-# INLINABLE floodFill #-}++double :: Integral a => a -> Double+double = fromIntegral++ratio :: Integral a => a -> RatioInt+ratio = fromIntegral
+ src/Vision/Image/Type.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE BangPatterns, 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 (..)+ -- * Delayed images+ , Delayed (..)+ -- * Delayed masked images+ , DelayedMask (..)+ -- * Functions+ , nChannels, pixel+ -- * Conversion+ , Convertible (..), convert, delay, compute+ -- * Types helpers+ , delayed, manifest+ ) where++import Control.Applicative ((<$>))+import Data.Convertible (Convertible (..), convert)+import Data.Int+import Data.Vector.Storable (+ Vector, (!), create, enumFromN, forM_, generate, unfoldr+ )+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 #-}++-- | 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++-- Manifest images -------------------------------------------------------------++-- | Stores the image content in a 'Vector'.+data Storable p => Manifest p = Manifest {+ manifestSize :: !Size+ , manifestVector :: !(Vector p)+ } deriving (Eq, Ord, Show)++instance Pixel p => MaskedImage (Manifest p) where+ type ImagePixel (Manifest p) = p++ shape = manifestSize+ {-# INLINE shape #-}++ Manifest _ vec `maskedLinearIndex` ix = Just $! vec ! ix+ {-# INLINE maskedLinearIndex #-}++ values = manifestVector+ {-# INLINE values #-}++instance Pixel p => Image (Manifest p) where+ Manifest _ vec `linearIndex` ix = vec ! ix+ {-# INLINE linearIndex #-}++ vector = manifestVector+ {-# INLINE vector #-}++instance Storable p => FromFunction (Manifest p) where+ type FromFunctionPixel (Manifest p) = p++ fromFunction !size@(Z :. h :. w) f =+ Manifest size $ create $ do+ arr <- new (h * w)++ forM_ (enumFromN 0 h) $ \y -> do+ let !lineOffset = y * w+ forM_ (enumFromN 0 w) $ \x -> do+ let !offset = lineOffset + x+ !val = f (ix2 y x)+ write arr offset val++ return arr+ {-# INLINE fromFunction #-}++ fromFunctionLine !size@(Z :. h :. w) line f =+ Manifest size $ create $ do+ -- Note: create is faster than unfoldrN.+ arr <- new (h * w)++ forM_ (enumFromN 0 h) $ \y -> do+ let !lineVal = line y+ !lineOffset = y * w+ forM_ (enumFromN 0 w) $ \x -> do+ let !offset = lineOffset + x+ !val = f lineVal (ix2 y x)+ write arr offset val++ return arr+ {-# INLINE fromFunctionLine #-}++ fromFunctionCol !size@(Z :. h :. w) col f =+ Manifest size $ create $ do+ -- Note: create is faster than unfoldrN.+ arr <- new (h * w)++ forM_ (enumFromN 0 h) $ \y -> do+ let !lineOffset = y * w+ forM_ (enumFromN 0 w) $ \x -> do+ let !offset = lineOffset + x+ !val = f (cols ! x) (ix2 y x)+ write arr offset val++ return arr+ where+ !cols = generate w col+ {-# INLINE fromFunctionCol #-}++ fromFunctionCached !size@(Z :. h :. w) line col f =+ Manifest size $ create $ do+ -- Note: create is faster than unfoldrN.+ arr <- new (h * w)++ forM_ (enumFromN 0 h) $ \y -> do+ let !lineVal = line y+ !lineOffset = y * w+ forM_ (enumFromN 0 w) $ \x -> do+ let !offset = lineOffset + x+ !val = f lineVal (cols ! x) (ix2 y x)+ write arr offset val++ return arr+ where+ !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`))+ {-# INLINE map #-}++-- Delayed images --------------------------------------------------------------++-- | A delayed image is an image which is constructed using a function.+--+-- Usually, a delayed image maps each of its pixels over another image.+-- Delayed images are useful by avoiding intermediate images in a+-- transformation pipeline of images or by avoiding the computation of the whole+-- resulting image when only a portion of its pixels will be accessed.+data Delayed p = Delayed {+ delayedSize :: !Size+ , delayedFun :: !(Point -> p)+ }++instance Pixel p => MaskedImage (Delayed p) where+ type ImagePixel (Delayed p) = p++ shape = delayedSize+ {-# INLINE shape #-}++ maskedIndex img = Just . delayedFun img+ {-# INLINE maskedIndex #-}++instance Pixel p => Image (Delayed p) where+ index = delayedFun+ {-# INLINE index #-}++instance FromFunction (Delayed p) where+ type FromFunctionPixel (Delayed p) = p++ fromFunction = Delayed+ {-# INLINE fromFunction #-}++instance (Image src, Pixel p) => FunctorImage src (Delayed p) where+ map f img = fromFunction (shape img) (f . (img `index`))+ {-# INLINE map #-}++-- Masked delayed images -------------------------------------------------------++data DelayedMask p = DelayedMask {+ delayedMaskSize :: !Size+ , delayedMaskFun :: !(Point -> Maybe p)+ }++instance Pixel p => MaskedImage (DelayedMask p) where+ type ImagePixel (DelayedMask p) = p++ shape = delayedMaskSize+ {-# INLINE shape #-}++ maskedIndex = delayedMaskFun+ {-# INLINE maskedIndex #-}++instance Pixel 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+ 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 ------------------------------------------------------------------++-- | Delays an image in its delayed representation.+delay :: Image i => i -> Delayed (ImagePixel i)+delay = map id+{-# INLINE delay #-}++-- | Computes the value of an image into a manifest representation.+compute :: (Image i, Storable (ImagePixel i)) => i -> Manifest (ImagePixel i)+compute = map id+{-# INLINE compute #-}++instance (Pixel p1, Pixel p2, 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)+ => Convertible (Delayed p1) (Delayed p2) where+ safeConvert = Right . map convert+ {-# INLINE safeConvert #-}++instance (Pixel p1, Pixel p2, 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)+ => 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.+delayed :: Delayed p -> Delayed p+delayed = id++-- | Forces an image to be in its delayed represenation. Does nothing.+manifest :: Manifest p -> Manifest p+manifest = id
+ src/Vision/Primitive.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE BangPatterns #-}++module Vision.Primitive (+ module Vision.Primitive.Shape+ , Point, Size, Rect (..), RPoint (..)+ ) where++import Data.RatioInt (RatioInt)++import Vision.Primitive.Shape++type Point = DIM2++type Size = DIM2++data Rect = Rect {+ rX :: {-# UNPACK #-} !Int, rY :: {-# UNPACK #-} !Int+ , rWidth :: {-# UNPACK #-} !Int, rHeight :: {-# UNPACK #-} !Int+ } deriving (Show, Read, Eq, Ord)++-- | Rational coordinates used for interpolations.+data RPoint = RPoint {+ rpX :: {-# UNPACK #-} !RatioInt, rpY :: {-# UNPACK #-} !RatioInt+ } deriving (Show, Read, Eq, Ord)
+ src/Vision/Primitive/Shape.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, TypeOperators #-}++-- | 'Shape's are similar to what you could found in @repa@. 'Shape' are used+-- both for indexes and shapes.+--+-- To create a shape/index, use the 'ix1', 'ix2', 'ix3' ... helpers :+--+-- > size = ix2 200 100+--+-- To pull values from a shape, use the 'Z' and ':.' constructors :+--+-- > Z :. h :. w = size+module Vision.Primitive.Shape (+ Shape (..), Z (..), (:.) (..)+ -- * Common dimensions.+ , DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9+ -- * Helpers+ , ix1, ix2, ix3, ix4, ix5, ix6, ix7, ix8, ix9+) where++import Control.Applicative+import Data.Word++import Foreign.Storable (Storable (..))+import Foreign.Ptr (castPtr, plusPtr)++-- | Class of types that can be used as array shapes and indices.+class Eq sh => Shape sh where+ -- | Gets the number of dimensions in a shape.+ shapeRank :: sh -> Int++ -- | Gets the total number of elements in an array of this shape.+ shapeLength :: sh -> Int++ -- | Gives the first index of an array.+ shapeZero :: sh++ -- | Gives the successor of an index, given the shape of the array.+ shapeSucc :: sh -- ^ Shape of the array.+ -> sh -- ^ Index.+ -> sh++ -- | Convert an index into its equivalent flat, linear, row-major version.+ toLinearIndex :: sh -- ^ Shape of the array.+ -> sh -- ^ Index into the array.+ -> Int++ -- | Inverse of `toLinearIndex`.+ fromLinearIndex :: sh -- ^ Shape of the array.+ -> Int -- ^ Index into linear representation.+ -> sh++ -- | Return the ascending list of indexes for the given shape.+ shapeList :: sh -> [sh]++ -- | Check whether an index is within a given shape.+ inShape :: sh -- ^ Shape of the array.+ -> sh -- ^ Index to check for.+ -> Bool++-- | An index of dimension zero.+data Z = Z deriving (Show, Read, Eq, Ord)++-- | Our index type, used for both shapes and indices.+infixl 3 :.+data tail :. head = !tail :. !head+ deriving (Show, Read, Eq, Ord)++-- Common dimensions.+type DIM0 = Z+type DIM1 = DIM0 :. Int+type DIM2 = DIM1 :. Int+type DIM3 = DIM2 :. Int+type DIM4 = DIM3 :. Int+type DIM5 = DIM4 :. Int+type DIM6 = DIM5 :. Int+type DIM7 = DIM6 :. Int+type DIM8 = DIM7 :. Int+type DIM9 = DIM8 :. Int++instance Shape Z where+ shapeRank Z = 0+ {-# INLINE shapeRank #-}++ shapeLength Z = 1+ {-# INLINE shapeLength #-}++ shapeZero = Z+ {-# INLINE shapeZero #-}++ shapeSucc _ _= Z+ {-# INLINE shapeSucc #-}++ toLinearIndex Z _ = 0+ {-# INLINE toLinearIndex #-}++ fromLinearIndex Z _ = Z+ {-# INLINE fromLinearIndex #-}++ -- | Returns every shape in ascending order+ --+ -- > shapeList sh = map fromLinearIndex [1..shapeLength sh - 1]+ shapeList Z = [Z]+ {-# INLINE shapeList #-}++ inShape Z Z = True+ {-# INLINE inShape #-}++instance Storable Z where+ sizeOf _ = 0+ {-# INLINE sizeOf #-}++ alignment _ = 0+ {-# INLINE alignment #-}++ peek _ = return Z+ {-# INLINE peek #-}++ poke _ _ = return ()+ {-# INLINE poke #-}++instance Shape sh => Shape (sh :. Int) where+ shapeRank (sh :. _) = shapeRank sh + 1+ {-# INLINE shapeRank #-}++ shapeLength (sh :. n) = shapeLength sh * n+ {-# INLINE shapeLength #-}++ shapeZero = shapeZero :. 0+ {-# INLINE shapeZero #-}++ shapeSucc (sh :. n) (sh' :. ix)+ | ix' >= n = shapeSucc sh sh' :. 0+ | otherwise = sh' :. ix'+ where+ !ix' = ix + 1+ {-# INLINE shapeSucc #-}++ toLinearIndex (sh :. n) (sh' :. ix) = toLinearIndex sh sh' * n+ + ix+ {-# INLINE toLinearIndex #-}++ fromLinearIndex (sh :. n) ix+ | shapeRank sh == 0 = fromLinearIndex sh 0 :. ix+ | otherwise = let (q, r) = ix `quotRem` n+ in fromLinearIndex sh q :. r+ {-# INLINE fromLinearIndex #-}++ shapeList (sh :. n) = [ sh' :. i | sh' <- shapeList sh, i <- [0..n-1] ]+ {-# INLINE shapeList #-}++ inShape (sh :. n) (sh' :. ix) = word ix < word n && inShape sh sh'+ {-# INLINE inShape #-}++instance Storable sh => Storable (sh :. Int) where+ sizeOf ~(sh :. _) = sizeOf (undefined :: Int) + sizeOf sh+ {-# INLINE sizeOf #-}++ alignment _ = alignment (undefined :: Int)+ {-# INLINE alignment #-}++ peek !ptr = do+ let !ptr' = castPtr ptr+ (:.) <$> peek (castPtr $! ptr' `plusPtr` 1) <*> peek ptr'+ {-# INLINE peek #-}++ poke !ptr (sh :. n) = do+ let !ptr' = castPtr ptr+ poke (castPtr $! ptr' `plusPtr` 1) sh >> poke ptr' n+ {-# INLINE poke #-}++-- | Helper for index construction.+--+-- Use this instead of explicit constructors like @(Z :. (x :: Int))@+-- The this is sometimes needed to ensure that 'x' is constrained to+-- be in @Int@.+ix1 :: Int -> DIM1+ix1 x = Z :. x+{-# INLINE ix1 #-}++ix2 :: Int -> Int -> DIM2+ix2 y x = Z :. y :. x+{-# INLINE ix2 #-}++ix3 :: Int -> Int -> Int -> DIM3+ix3 z y x = Z :. z :. y :. x+{-# INLINE ix3 #-}++ix4 :: Int -> Int -> Int -> Int -> DIM4+ix4 a z y x = Z :. a :. z :. y :. x+{-# INLINE ix4 #-}++ix5 :: Int -> Int -> Int -> Int -> Int -> DIM5+ix5 b a z y x = Z :. b :. a :. z :. y :. x+{-# INLINE ix5 #-}++ix6 :: Int -> Int -> Int -> Int -> Int -> Int -> DIM6+ix6 c b a z y x = Z :. c :. b :. a :. z :. y :. x+{-# INLINE ix6 #-}++ix7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> DIM7+ix7 d c b a z y x = Z :. d :. c :. b :. a :. z :. y :. x+{-# INLINE ix7 #-}++ix8 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> DIM8+ix8 e d c b a z y x = Z :. e :. d :. c :. b :. a :. z :. y :. x+{-# INLINE ix8 #-}++ix9 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> DIM9+ix9 f e d c b a z y x = Z :. f :. e :. d :. c :. b :. a :. z :. y :. x+{-# INLINE ix9 #-}++word :: Integral a => a -> Word+word = fromIntegral
+ test/Test.hs view
@@ -0,0 +1,10 @@+import Test.Framework (defaultMain, testGroup)++import qualified Test.Vision.Image as I+import qualified Test.Vision.Histogram as H++main :: IO ()+main = defaultMain [+ testGroup "Images" I.tests+ , testGroup "Histograms" H.tests+ ]