diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ 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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/bench/Benchmark.hs
@@ -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)
diff --git a/example/Canny.hs b/example/Canny.hs
new file mode 100644
--- /dev/null
+++ b/example/Canny.hs
@@ -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 ()
diff --git a/example/Delayed.hs b/example/Delayed.hs
new file mode 100644
--- /dev/null
+++ b/example/Delayed.hs
@@ -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 ()
diff --git a/example/GaussianBlur.hs b/example/GaussianBlur.hs
new file mode 100644
--- /dev/null
+++ b/example/GaussianBlur.hs
@@ -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 ()
diff --git a/example/Histogram.hs b/example/Histogram.hs
new file mode 100644
--- /dev/null
+++ b/example/Histogram.hs
@@ -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."
diff --git a/example/ResizeImage.hs b/example/ResizeImage.hs
new file mode 100644
--- /dev/null
+++ b/example/ResizeImage.hs
@@ -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 ()
diff --git a/friday.cabal b/friday.cabal
new file mode 100644
--- /dev/null
+++ b/friday.cabal
@@ -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
+maintainer: Raphael Javaux
+
+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
+
+ 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
diff --git a/src/Vision/Detector/Edge.hs b/src/Vision/Detector/Edge.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Detector/Edge.hs
@@ -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 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
diff --git a/src/Vision/Histogram.hs b/src/Vision/Histogram.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Histogram.hs
@@ -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 .
+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 .
+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 .
+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
diff --git a/src/Vision/Image.hs b/src/Vision/Image.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image.hs
@@ -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
+-- 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
diff --git a/src/Vision/Image/Filter.hs b/src/Vision/Image/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Filter.hs
@@ -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 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 .
+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
+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
diff --git a/src/Vision/Image/Grey.hs b/src/Vision/Image/Grey.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Grey.hs
@@ -0,0 +1,6 @@
+module Vision.Image.Grey (
+ module Vision.Image.Grey.Type
+ ) where
+
+import Vision.Image.Grey.Type
+import Vision.Image.Grey.Conversion ()
diff --git a/src/Vision/Image/Grey/Conversion.hs b/src/Vision/Image/Grey/Conversion.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Grey/Conversion.hs
@@ -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
diff --git a/src/Vision/Image/Grey/Type.hs b/src/Vision/Image/Grey/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Grey/Type.hs
@@ -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 #-}
diff --git a/src/Vision/Image/HSV.hs b/src/Vision/Image/HSV.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/HSV.hs
@@ -0,0 +1,6 @@
+module Vision.Image.HSV (
+ module Vision.Image.HSV.Type
+ ) where
+
+import Vision.Image.HSV.Type
+import Vision.Image.HSV.Conversion ()
diff --git a/src/Vision/Image/HSV/Conversion.hs b/src/Vision/Image/HSV/Conversion.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/HSV/Conversion.hs
@@ -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
diff --git a/src/Vision/Image/HSV/Type.hs b/src/Vision/Image/HSV/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/HSV/Type.hs
@@ -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 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 #-}
diff --git a/src/Vision/Image/Interpolate.hs b/src/Vision/Image/Interpolate.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Interpolate.hs
@@ -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
diff --git a/src/Vision/Image/Mutable.hs b/src/Vision/Image/Mutable.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Mutable.hs
@@ -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
diff --git a/src/Vision/Image/RGB.hs b/src/Vision/Image/RGB.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/RGB.hs
@@ -0,0 +1,6 @@
+module Vision.Image.RGB (
+ module Vision.Image.RGB.Type
+ ) where
+
+import Vision.Image.RGB.Type
+import Vision.Image.RGB.Conversion ()
diff --git a/src/Vision/Image/RGB/Conversion.hs b/src/Vision/Image/RGB/Conversion.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/RGB/Conversion.hs
@@ -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
diff --git a/src/Vision/Image/RGB/Type.hs b/src/Vision/Image/RGB/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/RGB/Type.hs
@@ -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 #-}
diff --git a/src/Vision/Image/RGBA.hs b/src/Vision/Image/RGBA.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/RGBA.hs
@@ -0,0 +1,6 @@
+module Vision.Image.RGBA (
+ module Vision.Image.RGBA.Type
+ ) where
+
+import Vision.Image.RGBA.Type
+import Vision.Image.RGBA.Conversion ()
diff --git a/src/Vision/Image/RGBA/Conversion.hs b/src/Vision/Image/RGBA/Conversion.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/RGBA/Conversion.hs
@@ -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 #-}
diff --git a/src/Vision/Image/RGBA/Type.hs b/src/Vision/Image/RGBA/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/RGBA/Type.hs
@@ -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 #-}
diff --git a/src/Vision/Image/Storage.hsc b/src/Vision/Image/Storage.hsc
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Storage.hsc
@@ -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
diff --git a/src/Vision/Image/Threshold.hs b/src/Vision/Image/Threshold.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Threshold.hs
@@ -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 #-}
diff --git a/src/Vision/Image/Transform.hs b/src/Vision/Image/Transform.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Transform.hs
@@ -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
diff --git a/src/Vision/Image/Type.hs b/src/Vision/Image/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Image/Type.hs
@@ -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
diff --git a/src/Vision/Primitive.hs b/src/Vision/Primitive.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Primitive.hs
@@ -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)
diff --git a/src/Vision/Primitive/Shape.hs b/src/Vision/Primitive/Shape.hs
new file mode 100644
--- /dev/null
+++ b/src/Vision/Primitive/Shape.hs
@@ -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
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Test.hs
@@ -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
+ ]