diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs deleted file mode 100644 --- a/bench/Benchmark.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts #-} -import Control.Monad.ST.Safe (ST) -import Criterion.Main -import Data.Int -import Data.Word - -import Vision.Image ( - Grey, HSV, RGBA, RGB, RGBDelayed, InterpolMethod - ) -import qualified Vision.Detector.Edge as D (canny) -import qualified Vision.Image as I -import Vision.Histogram (Histogram) -import qualified Vision.Histogram as H -import Vision.Primitive - -path :: FilePath -path = "bench/image.jpg" - -main :: IO () -main = do - Right io <- I.load Nothing path - let !(Z :. h :. w) = I.shape rgb - !halfSize = Rect (w `quot` 2) (h `quot` 2) - (w `quot` 2) (h `quot` 2) - !rgb = I.convert io :: RGB - !rgba = I.convert rgb :: RGBA - !grey = I.convert rgb :: Grey - !edges = canny' grey - !hsv = I.convert rgb :: HSV - !hist = H.histogram Nothing grey :: H.Histogram DIM1 Int32 - !hist2D = H.histogram2D (ix3 256 3 3) grey - :: H.Histogram DIM3 Int32 - - defaultMain [ - bgroup "IO" [ - bench "load" $ whnfIO $ I.load Nothing path - ] - , bgroup "conversion" [ - bench "RGB to grey" $ whnf (I.convert :: RGB -> Grey) rgb - , bench "RGBA to grey" $ whnf (I.convert :: RGBA -> Grey) rgba - , bench "RGBA to RGB" $ whnf (I.convert :: RGBA -> RGB) rgba - , bench "RGB to RGBA" $ whnf (I.convert :: RGB -> RGBA) rgb - , bench "RGB to HSV" $ whnf (I.convert :: RGB -> HSV) rgb - , bench "HSV to RGB" $ whnf (I.convert :: HSV -> RGB) hsv - ] - , bgroup "crop" [ - bench "RGB" $ whnf (I.crop halfSize :: RGB -> RGB) rgb - ] - , bgroup "detector" [ - bench "Canny's edge detector" $ whnf canny' grey - ] - , bgroup "filter" [ - bench "erode" $ whnf erode' grey - , bench "blur" $ whnf blur' grey - , bench "gaussian blur" $ whnf gaussianBlur' grey - , bench "scharr" $ whnf scharr' grey - , bench "sobel" $ whnf sobel' grey - ] - , bgroup "flip" [ - bench "horizontal" $ whnf (I.horizontalFlip :: RGB -> RGB) rgb - , bench "vertical" $ whnf (I.verticalFlip :: RGB -> RGB) rgb - ] - , bench "flood-fill" $ whnf floodFill' edges - , bgroup "histogram" [ - bench "calculate 1D histogram of a grey image" $ - whnf (H.histogram Nothing :: Grey -> Histogram DIM1 Int32) grey - , bench "calculate 3D histogram of a RGB image" $ - whnf (H.histogram Nothing :: RGB -> Histogram DIM3 Int32) rgb - , bench "calculate 3D histogram (9 regions) of a grey image" $ - whnf (H.histogram2D (ix3 256 3 3) - :: Grey -> Histogram DIM3 Int32) - grey - - , bench "reduce an Int32 histogram" $ whnf H.reduce hist2D - , bench "resize an Int32 histogram" $ whnf (H.resize (ix1 128)) - hist - - , bench "cumulative Int32 histogram" $ whnf H.cumulative hist - - , bench "normalize histogram" $ - whnf (H.normalize 1 - :: Histogram DIM1 Int32 -> Histogram DIM1 Double) - hist - , bench "equalize grey image" $ - whnf (H.equalizeImage :: Grey -> Grey) grey - - , bench "correlation comparison" $ - whnf (H.compareCorrel hist :: Histogram DIM1 Int32 -> Double) - hist - , bench "chi-square comparison" $ - whnf (H.compareChi hist :: Histogram DIM1 Int32 -> Double) hist - , bench "intersection comparison" $ - whnf (H.compareIntersect hist :: Histogram DIM1 Int32 -> Int32) - hist - , bench "EMD comparison" $ whnf (H.compareEMD hist) hist - - , bench "2D correlation comparison" $ - whnf (H.compareCorrel hist2D :: Histogram DIM3 Int32 -> Double) - hist2D - , bench "2D chi-square comparison 2D" $ - whnf (H.compareChi hist2D :: Histogram DIM3 Int32 -> Double) - hist2D - , bench "2D intersection comparison 2D" $ - whnf (H.compareIntersect hist2D - :: Histogram DIM3 Int32 -> Int32) - hist2D - ] - , bgroup "resize" [ - bench "truncate-integer 50%" $ - whnf (resize' I.TruncateInteger (ix2 (h `quot` 2) (w `quot` 2))) - rgb - , bench "truncate-integer 200%" $ - whnf (resize' I.TruncateInteger (ix2 (h * 2) (w * 2))) rgb - , bench "nearest-neighbor 50%" $ - whnf (resize' I.NearestNeighbor (ix2 (h `quot` 2) (w `quot` 2))) - rgb - , bench "nearest-neighbor 200%" $ - whnf (resize' I.NearestNeighbor (ix2 (h * 2) (w * 2))) rgb - , bench "bilinear 50%" $ - whnf (resize' I.Bilinear (ix2 (h `quot` 2) (w `quot` 2))) rgb - , bench "bilinear 200%" $ - whnf (resize' I.Bilinear (ix2 (h * 2) (w * 2))) rgb - ] - , bgroup "threshold" [ - bench "simple threshold" $ whnf threshold' grey - , bench "adaptive threshold" $ whnf adaptiveThreshold' grey - , bench "Otsu's method" $ whnf otsu' grey - ] - - - , bgroup "application" [ - bench "miniature 150x150" $ whnf miniature rgb - ] - ] - where - canny' :: Grey -> Grey - canny' !img = D.canny 2 256 1024 img - - erode' :: Grey -> Grey - erode' !img = I.erode 1 `I.apply` img - - blur' :: Grey -> Grey - blur' !img = - let filt = I.blur 1 :: I.SeparableFilter I.GreyPixel Word32 I.GreyPixel - in filt `I.apply` img - - gaussianBlur' :: Grey -> Grey - gaussianBlur' !img = - let filt = I.gaussianBlur 1 Nothing :: I.SeparableFilter I.GreyPixel - Float - I.GreyPixel - in filt `I.apply` img - - sobel' :: Grey -> I.Manifest Int16 - sobel' !img = I.sobel 1 I.DerivativeX `I.apply` img - - scharr' :: Grey -> I.Manifest Int16 - scharr' !img = I.scharr I.DerivativeX `I.apply` img - - floodFill' :: Grey -> I.Grey - floodFill' img = - I.create $ do - mut <- I.thaw img :: ST s (I.MutableManifest I.GreyPixel s) - I.floodFill (ix2 5 5) 255 mut - return mut - - resize' :: InterpolMethod -> Size -> RGB -> RGB - resize' = I.resize - - threshold' :: Grey -> Grey - threshold' !img = I.threshold (> 127) (I.BinaryThreshold 0 255) img - - adaptiveThreshold' :: Grey -> Grey - adaptiveThreshold' !img = - let filt :: I.SeparableFilter I.GreyPixel Float I.GreyPixel - filt = I.adaptiveThreshold (I.GaussianKernel Nothing) 1 0 - (I.BinaryThreshold 0 255) - in filt `I.apply` img - - otsu' :: Grey -> Grey - otsu' !img = I.otsu (I.BinaryThreshold 0 255) img - - miniature !rgb = - let Z :. h :. w = I.shape rgb - in if w > h - then resizeSquare $ I.crop (Rect ((w - h) `quot` 2) 0 h h) rgb - else resizeSquare $ I.crop (Rect 0 ((h - w) `quot` 2) w w) rgb - - resizeSquare :: RGBDelayed -> RGB - resizeSquare = I.resize I.Bilinear (Z :. 150 :. 150) diff --git a/example/Canny.hs b/example/Canny.hs deleted file mode 100644 --- a/example/Canny.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Prelude hiding (filter) -import System.Environment (getArgs) - -import Vision.Detector.Edge (canny) -import Vision.Image - --- Detects the edge of the image with the Canny's edge detector. --- --- usage: ./canny input.png output.png -main :: IO () -main = do - [input, output] <- getArgs - - -- Loads the image. Automatically infers the format. - io <- load Nothing input - - case io of - Left _err -> putStrLn "Error while reading the image." - Right img -> do - let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to - -- a Grey image (edges are detected on greyscale images). - grey = convert img :: Grey - - -- Creates a Gaussian filter with a 3x3 kernel to remove small - -- noises. - filter = gaussianBlur 1 Nothing :: SeparableFilter GreyPixel - Float - GreyPixel - - -- Applies the Gaussian filter to the grey-scale image. - blurred = apply filter grey :: Grey - - -- Applies the Canny's algorithm with a 5x5 Sobel kernel (radius - -- = 2). - edges = canny 2 256 1024 blurred :: Grey - - -- Saves the edges image. Ignores any runtime error. - _ <- save output edges - return () diff --git a/example/Delayed.hs b/example/Delayed.hs deleted file mode 100644 --- a/example/Delayed.hs +++ /dev/null @@ -1,44 +0,0 @@ -import System.Environment (getArgs) - -import Vision.Image -import Vision.Primitive (Z (..), (:.) (..), Rect (..), ix2) - --- Reads an image from a file, applies a composition of transformations to --- create a centred and squared miniature and then writes the result to a file: --- --- usage: ./delayed input.png output.png -main :: IO () -main = do - [input, output] <- getArgs - - -- Loads the image. Automatically infers the format. - io <- load Nothing input - - case io of - Left _err -> putStrLn "Error while reading the image." - Right img -> do - let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to - -- an RGB image. - rgb = convert img :: RGB - - -- Gets the size of the image. - Z :. h :. w = shape rgb - - -- Creates a Rect object which will be used to define how we - -- will crop our image. The rectangle is centered on the largest - -- side of the image. - rect | w > h = Rect ((w - h) `quot` 2) 0 h h - | otherwise = Rect 0 ((h - w) `quot` 2) w w - - -- Crops the image. Doesn't compute the image into a "real" - -- image: by using a delayed representation, this intermediate - -- image will not exist in the computer memory as a large array. - cropped = delayed $ crop rect rgb - - -- Resizes the image. By using the delayed representation of the - -- cropped image, our compiler should be able to fuse these two - -- transformations into a single loop. - resized = manifest $ resize Bilinear (ix2 250 250) cropped - - _ <- save output resized - return () diff --git a/example/GaussianBlur.hs b/example/GaussianBlur.hs deleted file mode 100644 --- a/example/GaussianBlur.hs +++ /dev/null @@ -1,35 +0,0 @@ -import Prelude hiding (filter) -import System.Environment (getArgs) - -import Vision.Image - --- Applies a Gaussian blur to an image. --- --- usage: ./gaussian_blur input.png output.png -main :: IO () -main = do - [input, output] <- getArgs - - -- Loads the image. Automatically infers the format. - io <- load Nothing input - - case io of - Left _err -> putStrLn "Error while reading the image." - Right img -> do - let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to - -- a Grey image (filters are currently only supported on single - -- channel images). - grey = convert img :: Grey - - -- Creates a Gaussian filter with a 21x21 kernel (kernel radius - -- of 10px). - filter = gaussianBlur 10 Nothing :: SeparableFilter GreyPixel - Float - GreyPixel - - -- Applies the filter to the grey-scale image. - blurred = apply filter grey :: Grey - - -- Saves the blurred image. Ignores any runtime error. - _ <- save output blurred - return () diff --git a/example/Histogram.hs b/example/Histogram.hs deleted file mode 100644 --- a/example/Histogram.hs +++ /dev/null @@ -1,46 +0,0 @@ -import Data.Int -import System.Environment (getArgs) -import Text.Printf - -import Vision.Histogram -import Vision.Image -import Vision.Primitive - --- Compares two images by their HSV histograms. --- --- usage: ./histogram input1.png input2.png -main :: IO () -main = do - [input1, input2] <- getArgs - - -- Loads the images. Automatically infers the format. - io1 <- load Nothing input1 - io2 <- load Nothing input2 - - case (io1, io2) of - (Right img1, Right img2) -> do - let rgb1 = convert img1 :: RGB - rgb2 = convert img2 :: RGB - - -- Converts both images to the HSV color space as it gives - -- better results when comparing colors. - hsv1 = convert rgb1 :: HSV - hsv2 = convert rgb2 :: HSV - - -- Computes a small histogram so two colors which are similar - -- will be in the same bin. - histSize = Just $ ix3 10 5 5 - - hist1 = histogram histSize hsv1 :: Histogram DIM3 Int32 - hist2 = histogram histSize hsv2 :: Histogram DIM3 Int32 - - -- Normalizes both histograms as the number of pixels in the two - -- images could be different. - hist1' = normalize 100 hist1 :: Histogram DIM3 Double - hist2' = normalize 100 hist2 :: Histogram DIM3 Double - - intersec = compareIntersect hist1' hist2' - - printf "The two images share %.2f%% of their colors.\n" intersec - - _ -> putStrLn "Error while reading the images." diff --git a/example/ResizeImage.hs b/example/ResizeImage.hs deleted file mode 100644 --- a/example/ResizeImage.hs +++ /dev/null @@ -1,28 +0,0 @@ -import System.Environment (getArgs) - -import Vision.Image -import Vision.Primitive (ix2) - --- Resizes the input image to a square of 250x250 pixels. --- --- usage: ./resize_image input.png output.png -main :: IO () -main = do - [input, output] <- getArgs - - -- Loads the image. Automatically infers the format. - io <- load Nothing input - - case io of - Left _err -> putStrLn "Error while reading the image." - Right img -> do - let -- Convert the StorageImage (which can be Grey, RGB or RGBA) to - -- an RGB image. - rgb = convert img :: RGB - - -- Resizes the RGB image to 250x250 pixels. - miniature = resize Bilinear (ix2 250 250) rgb :: RGB - - -- Saves the miniature. Ignores any runtime error. - _ <- save output miniature - return () diff --git a/example/Threshold.hs b/example/Threshold.hs deleted file mode 100644 --- a/example/Threshold.hs +++ /dev/null @@ -1,18 +0,0 @@ -import System.Environment (getArgs) - -import Vision.Image - --- Thresholds an image by applying the Otsu's method. --- --- usage: ./threshold .png output.png -main :: IO () -main = do - [input, output] <- getArgs - io <- either (\x -> error $ "Load failed: " ++ show x) return - =<< load Nothing input - - let grey = convert io :: Grey - thresholded = otsu (BinaryThreshold 0 255) grey :: Grey - - _ <- save output thresholded - return () diff --git a/friday.cabal b/friday.cabal --- a/friday.cabal +++ b/friday.cabal @@ -1,6 +1,9 @@ name: friday -version: 0.1.5 -synopsis: A functionnal image processing library for Haskell. +-- +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.2.0.1 +synopsis: A functional image processing library for Haskell. homepage: https://github.com/RaphaelJ/friday license: LGPL-3 license-file: LICENSE @@ -12,11 +15,6 @@ The library is designed to be fast, generic and type-safe. . - The library uses FFI calls to the DevIL image library to - read images from a wide variety of formats, including - BMP, JPG, PNG, GIF, ICO and PSD. Except for I/Os, friday - is entirely written in Haskell. - . Images can be represented in two representations: . * the 'Manifest' representation stores images in Haskell @@ -40,19 +38,21 @@ build-type: Simple cabal-version: >= 1.10 -Flag examples - Description: Compiles examples from the example/ directory. - Default: False +source-repository head + type: git + location: https://github.com/RaphaelJ/friday library exposed-modules: Vision.Detector.Edge Vision.Histogram Vision.Image + Vision.Image.Class Vision.Image.Grey Vision.Image.Grey.Conversion Vision.Image.Grey.Specialize Vision.Image.Grey.Type Vision.Image.Filter + Vision.Image.Filter.Internal Vision.Image.HSV Vision.Image.HSV.Conversion Vision.Image.HSV.Specialize @@ -67,7 +67,6 @@ Vision.Image.RGB.Conversion Vision.Image.RGB.Specialize Vision.Image.RGB.Type - Vision.Image.Storage Vision.Image.Threshold Vision.Image.Transform Vision.Image.Type @@ -79,101 +78,14 @@ default-language: Haskell2010 build-depends: base >= 4 && < 5 - , bytestring >= 0.10 && < 1.0 + , bytestring >= 0.10 && < 1 , convertible >= 1 && < 2 + , deepseq >= 1.3 && < 2 , primitive >= 0.5.2.1 && < 0.6 , ratio-int >= 0.1.2 && < 0.2 - , vector >= 0.10.0.1 && < 1.0 + , vector >= 0.10.0.1 && < 1 , transformers >= 0.3 && < 0.5 - Build-tools: hsc2hs - - Extra-Libraries: IL - -executable delayed - if !flag(examples) - Buildable: False - - main-is: Delayed.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: example/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , friday - -executable canny - if !flag(examples) - Buildable: False - - main-is: Canny.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: example/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , friday - -executable gaussian_blur - if !flag(examples) - Buildable: False - - main-is: GaussianBlur.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: example/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , friday - -executable histogram - if !flag(examples) - Buildable: False - - main-is: Histogram.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: example/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , friday - -executable resize_image - if !flag(examples) - Buildable: False - - main-is: ResizeImage.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: example/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , friday - -executable threshold - if !flag(examples) - Buildable: False - - main-is: Threshold.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: example/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , friday - -Benchmark benchmark - type: exitcode-stdio-1.0 - - main-is: Benchmark.hs - ghc-options: -Wall -O2 -rtsopts - hs-source-dirs: bench/ - default-language: Haskell2010 - - build-depends: base >= 4 && < 5 - , criterion >= 1.0 && < 2.0 - , friday - Test-Suite test type: exitcode-stdio-1.0 @@ -187,4 +99,4 @@ , friday , test-framework >= 0.8 && < 0.9 , test-framework-quickcheck2 >= 0.3.0.2 && < 0.4 - , vector >= 0.10.0.1 && < 1.0 + , vector >= 0.10.0.1 && < 1 diff --git a/src/Vision/Detector/Edge.hs b/src/Vision/Detector/Edge.hs --- a/src/Vision/Detector/Edge.hs +++ b/src/Vision/Detector/Edge.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, MultiWayIf #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts + , MultiWayIf #-} module Vision.Detector.Edge (canny) where @@ -6,12 +8,13 @@ import Control.Monad.ST.Safe (ST) import Data.Int import Data.Vector.Storable (enumFromN, forM_) +import Foreign.Storable (Storable) import Vision.Image ( - Image, Pixel, ImagePixel, Manifest, MutableManifest, Grey, Derivative (..) - , shape, index, linearIndex, fromFunction + Image, ImagePixel, Manifest, MutableManifest, Grey, DerivativeType (..) + , (!), shape, linearIndex, fromFunction , create, new', linearRead, linearWrite - , apply, sobel + , sobel ) import Vision.Primitive (Z (..), (:.) (..), inShape, ix2) @@ -34,7 +37,8 @@ -- -- This function is specialized for 'Grey' images but is declared @INLINABLE@ -- to be further specialized for new image types. -canny :: (Image src, Integral (ImagePixel src), Bounded res, Eq res, Pixel res) +canny :: ( Image src, Integral (ImagePixel src), Bounded res, Eq res + , Storable res) => Int -- ^ Radius of the Sobel's filter. -> Int32 @@ -62,16 +66,16 @@ (!lowThres', !highThres') = (square lowThres, square highThres) dx, dy :: Manifest Int16 - !dx = sobel derivSize DerivativeX `apply` img - !dy = sobel derivSize DerivativeY `apply` img + !dx = sobel derivSize DerivativeX img + !dy = sobel derivSize DerivativeY img -- Gradient magnitude, squared. dxy :: Manifest Int32 !dxy = fromFunction size $ \pt -> - square (fromIntegral $ dx `index` pt) - + square (fromIntegral $ dy `index` pt) + square (fromIntegral $ dx ! pt) + + square (fromIntegral $ dy ! pt) - newManifest :: (Pixel p, Bounded p) => ST s (MutableManifest p s) + newManifest :: (Storable p, Bounded p) => ST s (MutableManifest p s) newManifest = new' size minBound -- Visits a point and compares its gradient magnitude to the given @@ -118,7 +122,7 @@ in tryCompare ptDxy (>) (x1, y1) && tryCompare ptDxy (>=) (x2, y2) tryCompare !ptDxy op !(x, y) - | inShape size (ix2 y x) = ptDxy `op` fromIntegral (dxy `index` ix2 y x) + | inShape size (ix2 y x) = ptDxy `op` fromIntegral (dxy ! ix2 y x) | otherwise = True -- Returns the direction of the edge, not to be confused with the direction diff --git a/src/Vision/Histogram.hs b/src/Vision/Histogram.hs --- a/src/Vision/Histogram.hs +++ b/src/Vision/Histogram.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances - , ParallelListComp, TypeFamilies, TypeOperators #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts + , FlexibleInstances + , ParallelListComp + , TypeFamilies + , TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Contains functions to compute and manipulate histograms as well as some @@ -11,7 +15,7 @@ module Vision.Histogram ( -- * Types & helpers Histogram (..), HistogramShape (..), ToHistogram (..) - , index, linearIndex, map, assocs, pixToBin + , index, (!), linearIndex, map, assocs, pixToBin -- * Histogram computations , histogram, histogram2D, reduce, resize, cumulative, normalize -- * Images processing @@ -21,21 +25,23 @@ ) where import Data.Int -import Data.Vector.Storable (Vector, (!)) -import qualified Data.Vector.Storable as V +import Data.Vector.Storable (Vector) import Foreign.Storable (Storable) import Prelude hiding (map) +import qualified Data.Vector.Storable as V + +import Vision.Image.Class (Pixel, MaskedImage, Image, ImagePixel, FunctorImage) import Vision.Image.Grey.Type (GreyPixel (..)) import Vision.Image.HSV.Type (HSVPixel (..)) import Vision.Image.RGBA.Type (RGBAPixel (..)) import Vision.Image.RGB.Type (RGBPixel (..)) -import Vision.Image.Type (Pixel, MaskedImage, Image, ImagePixel, FunctorImage) -import qualified Vision.Image.Type as I import Vision.Primitive ( Z (..), (:.) (..), Shape (..), DIM1, DIM3, DIM4, DIM5, ix1, ix3, ix4 ) +import qualified Vision.Image.Class as I + -- There is no rule to simplify the conversion from Int32 to Double and Float -- when using realToFrac. Both conversions are using a temporary yet useless -- Rational value. @@ -128,10 +134,15 @@ index !hist = linearIndex hist . toLinearIndex (shape hist) {-# INLINE index #-} +-- | Alias of 'index'. +(!) :: (Shape sh, Storable a) => Histogram sh a -> sh -> a +(!) = index +{-# INLINE (!) #-} + -- | Returns the value at the index as if the histogram was a single dimension -- vector (row-major representation). linearIndex :: (Shape sh, Storable a) => Histogram sh a -> Int -> a -linearIndex !hist = (!) (vector hist) +linearIndex !hist = (V.!) (vector hist) {-# INLINE linearIndex #-} map :: (Storable a, Storable b) => (a -> b) -> Histogram sh a -> Histogram sh b @@ -306,7 +317,7 @@ Z :. nBins = shape hist cumNormalized = cumulative $ normalize (double nBins) hist !cumNormalized' = map round cumNormalized :: Histogram DIM1 Int32 - equalizePixel !val = fromIntegral $ cumNormalized' `index` ix1 (int val) + equalizePixel !val = fromIntegral $ cumNormalized' ! ix1 (int val) {-# INLINE equalizePixel #-} {-# INLINABLE equalizeImage #-} diff --git a/src/Vision/Image.hs b/src/Vision/Image.hs --- a/src/Vision/Image.hs +++ b/src/Vision/Image.hs @@ -13,19 +13,20 @@ -- for a -- detailed usage and examples. module Vision.Image ( - module Vision.Image.Grey + module Vision.Image.Class + , 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.Class import Vision.Image.Grey import Vision.Image.Filter import Vision.Image.HSV @@ -33,7 +34,6 @@ 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/Class.hs b/src/Vision/Image/Class.hs new file mode 100644 --- /dev/null +++ b/src/Vision/Image/Class.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses + , TypeFamilies #-} + +module Vision.Image.Class ( + -- * Classes + Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..) + , FunctorImage (..) + -- * Functions + , (!), (!?), nChannels, pixel + -- * Conversion + , Convertible (..), convert + ) where + +import Data.Convertible (Convertible (..), convert) +import Data.Int +import Data.Vector.Storable (Vector, generate, unfoldr) +import Data.Word +import Foreign.Storable (Storable) +import Prelude hiding (map, read) + +import Vision.Primitive ( + Z (..), (:.) (..), Point, Size + , fromLinearIndex, toLinearIndex, shapeLength + ) + +-- Classes --------------------------------------------------------------------- + +-- | Determines the number of channels and the type of each pixel of the image +-- and how images are represented. +class Pixel p where + type PixelChannel p + + -- | Returns the number of channels of the pixel. + -- Must not consume 'p' (could be 'undefined'). + pixNChannels :: p -> Int + + pixIndex :: p -> Int -> PixelChannel p + +instance Pixel Int16 where + type PixelChannel Int16 = Int16 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Int32 where + type PixelChannel Int32 = Int32 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Int where + type PixelChannel Int = Int + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word8 where + type PixelChannel Word8 = Word8 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word16 where + type PixelChannel Word16 = Word16 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word32 where + type PixelChannel Word32 = Word32 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word where + type PixelChannel Word = Word + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Float where + type PixelChannel Float = Float + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Double where + type PixelChannel Double = Double + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Bool where + type PixelChannel Bool = Bool + pixNChannels _ = 1 + pixIndex p _ = p + +-- | Provides an abstraction for images which are not defined for each of their +-- pixels. The interface is similar to 'Image' except that indexing functions +-- don't always return. +-- +-- Image origin (@'ix2' 0 0@) is located in the upper left corner. +class Storable (ImagePixel i) => MaskedImage i where + type ImagePixel i + + shape :: i -> Size + + -- | Returns the pixel\'s value at 'Z :. y, :. x'. + maskedIndex :: i -> Point -> Maybe (ImagePixel i) + maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img) + {-# INLINE maskedIndex #-} + + -- | Returns the pixel\'s value as if the image was a single dimension + -- vector (row-major representation). + maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i) + maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img) + {-# INLINE maskedLinearIndex #-} + + -- | Returns the non-masked values of the image. + values :: i -> Vector (ImagePixel i) + values !img = + unfoldr step 0 + where + !n = shapeLength (shape img) + + step !i | i >= n = Nothing + | Just p <- img `maskedLinearIndex` i = Just (p, i + 1) + | otherwise = step (i + 1) + {-# INLINE values #-} + + {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} + +type ImageChannel i = PixelChannel (ImagePixel i) + +-- | Provides an abstraction over the internal representation of an image. +-- Image origin 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 + +-- Functions ------------------------------------------------------------------- + +-- | Alias of 'maskedIndex'. +(!?) :: MaskedImage i => i -> Point -> Maybe (ImagePixel i) +(!?) = maskedIndex +{-# INLINE (!?) #-} + +-- | Alias of 'index'. +(!) :: Image i => i -> Point -> ImagePixel i +(!) = index +{-# INLINE (!) #-} + +-- | Returns the number of channels of an image. +nChannels :: (Pixel (ImagePixel i), MaskedImage i) => i -> Int +nChannels img = pixNChannels (pixel img) +{-# INLINE nChannels #-} + +-- | Returns an 'undefined' instance of a pixel of the image. This is sometime +-- useful to satisfy the type checker as in a call to 'pixNChannels' : +-- +-- > nChannels img = pixNChannels (pixel img) +pixel :: MaskedImage i => i -> ImagePixel i +pixel _ = undefined diff --git a/src/Vision/Image/Filter.hs b/src/Vision/Image/Filter.hs --- a/src/Vision/Image/Filter.hs +++ b/src/Vision/Image/Filter.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, GADTs - , MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts + , TypeFamilies #-} --- | Provides high level functions to define and apply filters on images. +-- | Provides high level filtering functions for images. -- +-- Use 'Vision.Image.Filter.Internal' if you want to create new image filters. +-- -- Filters are operations on images on which the surrounding of each processed -- pixel is considered according to a kernel. -- @@ -11,607 +14,86 @@ -- The @radius@ argument of some filters is used to determine the kernel size. -- A radius as of 1 means a kernel of size 3, 2 a kernel of size 5 and so on. -- --- The @acc@ type argument of some filters defines the type which will be used --- to store the accumulated value of the kernel (e.g. by setting @acc@ to --- 'Double' in the computation of a Gaussian blur, the kernel average will be --- computed using a 'Double'). --- --- To apply a filter to an image, use the 'apply' method: --- --- @ --- let filter :: 'SeparableFilter' GreyPixel Double GreyPixel --- filter = 'gaussianBlur' 2 Nothing --- in 'apply' filter img :: Grey --- @ +-- /Note:/ filters are currently not supported on multi-channel images (RGB, +-- RGBA ...) are currently not supported. module Vision.Image.Filter ( - -- * Types - Filterable (..), Filter (..) - , BoxFilter, BoxFilter1, SeparableFilter, SeparableFilter1 - , KernelAnchor (..) - , Kernel (..) - , SeparableKernel (..), SeparatelyFiltrable (..) - , FilterFold (..), FilterFold1 (..) - , BorderInterpolate (..) - -- * Functions - , kernelAnchor, borderInterpolate - -- * Filters - -- ** Morphological operators + -- * Classes and type + Filterable, Filter, SeparatelyFiltrable + -- * Morphological operators , dilate, erode - -- ** Blur + -- * Blur , blur, gaussianBlur - -- ** Derivation - , Derivative (..), scharr, sobel + -- * Derivation + , DerivativeType (..), scharr, sobel + -- * Others + , mean ) where -import Data.List -import Data.Ratio -import qualified Data.Vector.Storable as V -import Data.Word +import Data.Int import Foreign.Storable (Storable) -import Vision.Image.Type ( - MaskedImage (..), Image (..), FromFunction (..) - , Manifest, Delayed +import Vision.Image.Class (MaskedImage (..), Image (..), FromFunction (..)) +import Vision.Image.Filter.Internal ( + Filterable, Filter, SeparatelyFiltrable (..) + , DerivativeType ) -import Vision.Primitive (Z (..), (:.) (..), DIM1, DIM2, Size, ix1, ix2) - --- Types ----------------------------------------------------------------------- - --- | Provides an implementation to execute a type of filter. --- --- 'src' is the original image, 'res' the resulting image and 'f' the filter. -class Filterable src res f where - -- | Applies the given filter on the given image. - apply :: f -> src -> res - -data Filter src kernel init acc res = Filter { - fKernelSize :: !Size - , fKernelCenter :: !KernelAnchor - -- | See 'Kernel' and 'SeparableKernel'. - , fKernel :: !kernel - -- | Defines how the accumulated value is initialized. - -- - -- See 'FilterFold' and 'FilterFold1'. - , fInit :: !init - , fPost :: !(src -> acc -> res) - , fInterpol :: !(BorderInterpolate src) - } - --- | 2D filters which are initialized with a value. -type BoxFilter src acc res = Filter src (Kernel src acc) (FilterFold acc) - acc res - --- | 2D filters which are not initialized with a value. -type BoxFilter1 src res = Filter src (Kernel src src) FilterFold1 src - res - --- | Separable 2D filters which are initialized with a value. -type SeparableFilter src acc res = Filter src (SeparableKernel src acc) - (FilterFold acc) acc res - --- | Separable 2D filters which are not initialized with a value. -type SeparableFilter1 src res = Filter src (SeparableKernel src src) - FilterFold1 src res - --- | Defines how the center of the kernel will be determined. -data KernelAnchor = KernelAnchor !DIM2 | KernelAnchorCenter - --- | A simple 2D kernel. --- --- The kernel function accepts the coordinates in the kernel, the value of the --- pixel at these coordinates ('src'), the current accumulated value and returns --- a new accumulated value. --- --- Non-separable filters computational complexity grows quadratically according --- to the size of the sides of the kernel. -newtype Kernel src acc = Kernel (DIM2 -> src -> acc -> acc) - --- | Some kernels can be factorized in two uni-dimensional kernels (horizontal --- and vertical). --- --- Separable filters computational complexity grows linearly according to the --- size of the sides of the kernel. --- --- See . -data SeparableKernel src acc = SeparableKernel { - -- | Vertical (column) kernel. - skVertical :: !(DIM1 -> src -> acc -> acc) - -- | Horizontal (row) kernel. - , skHorizontal :: !(DIM1 -> acc -> acc -> acc) - } - --- | Used to determine the type of the accumulator image used when computing --- separable filters. --- --- 'src' and 'res' are respectively the source and the result image types while --- 'acc' is the pixel type of the accumulator. -class SeparatelyFiltrable src res acc where - type SeparableFilterAccumulator src res acc - -instance SeparatelyFiltrable src (Manifest p) acc where - type SeparableFilterAccumulator src (Manifest p) acc = Manifest acc - -instance SeparatelyFiltrable src (Delayed p) acc where - type SeparableFilterAccumulator src (Delayed p) acc = Delayed acc - --- | Uses an initial value to initialize the filter. -data FilterFold acc = FilterFold acc - --- | Uses the first pixel in the kernel as initial value. The kernel must not be --- empty and the accumulator type must be the same as the source pixel type. --- --- This kind of initialization is needed by morphological filters. -data FilterFold1 = FilterFold1 - --- | Defines how image boundaries are extrapolated by the algorithms. --- --- '|' characters in examples are image borders. -data BorderInterpolate a = - -- | Replicates the first and last pixels of the image. - -- - -- > aaaaaa|abcdefgh|hhhhhhh - BorderReplicate - -- | Reflects the border of the image. - -- - -- > fedcba|abcdefgh|hgfedcb - | BorderReflect - -- | Considers that the last pixel of the image is before the first one. - -- - -- > cdefgh|abcdefgh|abcdefg - | BorderWrap - -- | Assigns a constant value to out of image pixels. - -- - -- > iiiiii|abcdefgh|iiiiiii with some specified 'i' - | BorderConstant !a - --- Instances ------------------------------------------------------------------- - --- Following implementations share a lot of similar processing. However, GHC --- fails to specialise and optimise correctly when goXXX functions are top-level --- functions, even with static argument transformations. - --- | Box filters initialized with a given value. -instance (Image src, FromFunction res, src_p ~ ImagePixel src - , res_p ~ FromFunctionPixel res) - => Filterable src res (BoxFilter src_p acc res_p) where - apply !(Filter ksize anchor (Kernel kernel) ini post interpol) !img = - let !(FilterFold acc) = ini - in fromFunction size $ \(!pt@(Z :. iy :. ix)) -> - let !iy0 = iy - kcy - !ix0 = ix - kcx - !safe = iy0 >= 0 && iy0 + kh <= ih - && ix0 >= 0 && ix0 + kw <= iw - !pix = img `index` pt - in post pix $! if safe then goColumnSafe (iy0 * iw) ix0 0 acc - else goColumn iy0 ix0 0 acc - where - !size@(Z :. ih :. iw) = shape img - - !(Z :. kh :. kw) = ksize - !(Z :. kcy :. kcx) = kernelAnchor anchor ksize - - goColumn !iy !ix !ky !acc - | ky < kh = case borderInterpolate interpol ih iy of - Left iy' -> goLine iy (iy' * iw) ix ix ky 0 acc - Right val -> goLineConst iy ix ky 0 val acc - | otherwise = acc - - goColumnSafe !linearIY !ix !ky !acc - | ky < kh = goLineSafe linearIY ix ix ky 0 acc - | otherwise = acc - - goLine !iy !linearIY !ix0 !ix !ky !kx !acc - | kx < kw = - let !val = case borderInterpolate interpol iw ix of - Left ix' -> img `linearIndex` (linearIY + ix') - Right val' -> val' - !acc' = kernel (ix2 ky kx) val acc - in goLine iy linearIY ix0 (ix + 1) ky (kx + 1) acc' - | otherwise = goColumn (iy + 1) ix0 (ky + 1) acc - - goLineSafe !linearIY !ix0 !ix !ky !kx !acc - | kx < kw = - let !val = img `linearIndex` (linearIY + ix) - !acc' = kernel (ix2 ky kx) val acc - in goLineSafe linearIY ix0 (ix + 1) ky (kx + 1) acc' - | otherwise = goColumnSafe (linearIY + iw) ix0 (ky + 1) acc - - goLineConst !iy !ix !ky !kx !val !acc - | kx < kw = let !acc' = kernel (ix2 ky kx) val acc - in goLineConst iy ix ky (kx + 1) val acc' - | otherwise = goColumn (iy + 1) ix (ky + 1) acc - {-# INLINE apply #-} - --- | Box filters initialized using the first pixel of the kernel. -instance (Image src, FromFunction res, src_p ~ ImagePixel src - , res_p ~ FromFunctionPixel res) - => Filterable src res (BoxFilter1 src_p res_p) where - apply !(Filter ksize anchor (Kernel kernel) _ post interpol) !img - | kh == 0 || kw == 0 = - error "Using FilterFold1 with an empty kernel." - | otherwise = - fromFunction size $ \(!pt@(Z :. iy :. ix)) -> - let !iy0 = iy - kcy - !ix0 = ix - kcx - !safe = iy0 >= 0 && iy0 + kh <= ih - && ix0 >= 0 && ix0 + kw <= iw - !pix = img `index` pt - in post pix $! if safe then goColumn1Safe iy0 ix0 - else goColumn1 iy0 ix0 - where - !size@(Z :. ih :. iw) = shape img - - !(Z :. kh :. kw) = ksize - !(Z :. kcy :. kcx) = kernelAnchor anchor ksize - - goColumn1 !iy !ix = - case borderInterpolate interpol ih iy of - Left iy' -> - let !linearIY = iy' * iw - !acc = safeIndex linearIY ix - in goLine iy linearIY ix (ix + 1) 0 1 acc - Right val -> goLineConst iy ix 0 1 val val - - goColumn1Safe !iy !ix = - let !linearIY = iy * iw - !acc = img `linearIndex` (linearIY + ix) - in goLineSafe linearIY ix (ix + 1) 0 1 acc - - goColumn !iy !ix !ky !acc - | ky < kh = case borderInterpolate interpol ih iy of - Left iy' -> goLine iy (iy' * iw) ix ix ky 0 acc - Right val -> goLineConst iy ix ky 0 val acc - | otherwise = acc - - goColumnSafe !linearIY !ix !ky !acc - | ky < kh = goLineSafe linearIY ix ix ky 0 acc - | otherwise = acc - - goLine !iy !linearIY !ix0 !ix !ky !kx !acc - | kx < kw = - let !val = safeIndex linearIY ix - !acc' = kernel (ix2 ky kx) val acc - in goLine iy linearIY ix0 (ix + 1) ky (kx + 1) acc' - | otherwise = goColumn (iy + 1) ix0 (ky + 1) acc - - goLineSafe !linearIY !ix0 !ix !ky !kx !acc - | kx < kw = - let !val = img `linearIndex` (linearIY + ix) - !acc' = kernel (ix2 ky kx) val acc - in goLineSafe linearIY ix0 (ix + 1) ky (kx + 1) acc' - | otherwise = goColumnSafe (linearIY + iw) ix0 (ky + 1) acc - - goLineConst !iy !ix !ky !kx !val !acc - | kx < kw = let !acc' = kernel (ix2 ky kx) val acc - in goLineConst iy ix ky (kx + 1) val acc' - | otherwise = goColumn (iy + 1) ix (ky + 1) acc - - safeIndex !linearIY !ix = - case borderInterpolate interpol iw ix of - Left ix' -> img `linearIndex` (linearIY + ix') - Right val -> val - {-# INLINE apply #-} - --- | Separable filters initialized with a given value. -instance (Image src, FromFunction res, SeparatelyFiltrable src res acc - , src_p ~ ImagePixel src, res_p ~ FromFunctionPixel res - , FromFunction (SeparableFilterAccumulator src res acc) - , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc - , Image (SeparableFilterAccumulator src res acc) - , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc) - => Filterable src res (SeparableFilter src_p acc res_p) - where - apply !f !img = - fst $! wrapper img f - where - wrapper :: (Image src, FromFunction res - , FromFunction (SeparableFilterAccumulator src res acc) - , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc - , Image (SeparableFilterAccumulator src res acc) - , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc) - => src - -> SeparableFilter (ImagePixel src) acc (FromFunctionPixel res) - -> (res, SeparableFilterAccumulator src res acc) - wrapper !src !(Filter ksize anchor kernel ini post interpol) = - (res, tmp) - where - !size@(Z :. ih :. iw) = shape src - - !(Z :. kh :. kw) = ksize - !(Z :. kcy :. kcx) = kernelAnchor anchor ksize - - !(SeparableKernel vert horiz) = kernel - !(FilterFold acc0) = ini - - !tmp = fromFunction size $ \(!(Z :. iy :. ix)) -> - let !iy0 = iy - kcy - in if iy0 >= 0 && iy0 + kh <= ih - then goColumnSafe iy0 ix 0 acc0 - else goColumn iy0 ix 0 acc0 - - !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) -> - let !ix0 = ix - kcx - !pix = src `index` pt - in post pix $! if ix0 >= 0 && ix0 + kw <= iw - then goLineSafe (iy * iw) ix0 0 acc0 - else goLine (iy * iw) ix0 0 acc0 - - goColumn !iy !ix !ky !acc - | ky < kh = - let !val = case borderInterpolate interpol ih iy of - Left iy' -> src `index` ix2 iy' ix - Right val' -> val' - !acc' = vert (ix1 ky) val acc - in goColumn (iy + 1) ix (ky + 1) acc' - | otherwise = acc - - goColumnSafe !iy !ix !ky !acc - | ky < kh = - let !val = src `index` ix2 iy ix - !acc' = vert (ix1 ky) val acc - in goColumnSafe (iy + 1) ix (ky + 1) acc' - | otherwise = acc - - goLine !linearIY !ix !kx !acc - | kx < kw = - let !val = - case borderInterpolate interpol iw ix of - Left ix'-> tmp `linearIndex` (linearIY + ix') - Right _ -> constLine - !acc' = horiz (ix1 kx) val acc - in goLine linearIY (ix + 1) (kx + 1) acc' - | otherwise = acc - - goLineSafe !linearIY !ix !kx !acc - | kx < kw = - let !val = tmp `linearIndex` (linearIY + ix) - !acc' = horiz (ix1 kx) val acc - in goLineSafe linearIY (ix + 1) (kx + 1) acc' - | otherwise = acc - - constLine | BorderConstant val <- interpol = - foldl' (\acc ky -> vert (ix1 ky) val acc) acc0 [0..kh-1] - | otherwise = undefined - {-# INLINE wrapper #-} - {-# INLINE apply #-} - --- | Separable filters initialized using the first pixel of the kernel. -instance (Image src, FromFunction res, SeparatelyFiltrable src res src_p - , src_p ~ ImagePixel src, res_p ~ FromFunctionPixel res - , FromFunction (SeparableFilterAccumulator src res src_p) - , FromFunctionPixel (SeparableFilterAccumulator src res src_p) ~ src_p - , Image (SeparableFilterAccumulator src res src_p) - , ImagePixel (SeparableFilterAccumulator src res src_p) ~ src_p) - => Filterable src res (SeparableFilter1 src_p res_p) - where - apply !f !img = - fst $! wrapper img f - where - wrapper :: (Image src, FromFunction res, acc ~ ImagePixel src - , FromFunction (SeparableFilterAccumulator src res acc) - , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc - , Image (SeparableFilterAccumulator src res acc) - , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc) - => src - -> SeparableFilter1 (ImagePixel src) (FromFunctionPixel res) - -> (res, SeparableFilterAccumulator src res acc) - wrapper !src !(Filter ksize anchor kernel _ post interpol) - | kh == 0 || kw == 0 = - error "Using FilterFold1 with an empty kernel." - | otherwise = - (res, tmp) - where - !size@(Z :. ih :. iw) = shape src - - !(Z :. kh :. kw) = ksize - !(Z :. kcy :. kcx) = kernelAnchor anchor ksize - - !(SeparableKernel vert horiz) = kernel - - !tmp = fromFunction size $ \(!(Z :. iy :. ix)) -> - let !iy0 = iy - kcy - in if iy0 >= 0 && iy0 + kh <= ih - then goColumn1Safe iy0 ix - else goColumn1 iy0 ix - - !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) -> - let !ix0 = ix - kcx - !pix = src `index` pt - in post pix $! if ix0 >= 0 && ix0 + kw <= iw - then goLine1Safe (iy * iw) ix0 - else goLine1 (iy * iw) ix0 - - goColumn1 !iy !ix = - case borderInterpolate interpol ih iy of - Left iy' -> - let !acc = src `index` ix2 iy' ix - in goColumn (iy + 1) ix 1 acc - Right val -> - goColumn (iy + 1) ix 1 val - - goColumn1Safe !iy !ix = - let !linearIY = iy * iw - !acc = src `linearIndex` (linearIY + ix) - in goColumnSafe (linearIY + iw) ix 1 acc - - goColumn !iy !ix !ky !acc - | ky < kh = - let !val = case borderInterpolate interpol ih iy of - Left iy' -> src `index` ix2 iy' ix - Right val' -> val' - !acc' = vert (ix1 ky) val acc - in goColumn (iy + 1) ix (ky + 1) acc' - | otherwise = acc - - goColumnSafe !linearIY !ix !ky !acc - | ky < kh = - let !val = src `linearIndex` (linearIY + ix) - !acc' = vert (ix1 ky) val acc - in goColumnSafe (linearIY + iw) ix (ky + 1) acc' - | otherwise = acc - - goLine1 !linearIY !ix = - let !acc = - case borderInterpolate interpol iw ix of - Left ix' -> tmp `linearIndex` (linearIY + ix') - Right _ -> columnConst - in goLine linearIY (ix + 1) 1 acc - - goLine1Safe !linearIY !ix = - let !linearIX = linearIY + ix - !acc = tmp `linearIndex` linearIX - in goLineSafe (linearIX + 1) 1 acc - - goLine !linearIY !ix !kx !acc - | kx < kw = - let !val = - case borderInterpolate interpol iw ix of - Left ix'-> tmp `linearIndex` (linearIY + ix') - Right _ -> columnConst - !acc' = horiz (ix1 kx) val acc - in goLine linearIY (ix + 1) (kx + 1) acc' - | otherwise = acc - - goLineSafe !linearIX !kx !acc - | kx < kw = - let !val = tmp `linearIndex` linearIX - !acc' = horiz (ix1 kx) val acc - in goLineSafe (linearIX + 1) (kx + 1) acc' - | otherwise = acc - - columnConst - | BorderConstant val <- interpol = goColumnConst 1 val val - | otherwise = undefined - - goColumnConst !ky !val !acc - | ky < kh = goColumnConst (ky + 1) val (vert (ix1 ky) acc val) - | otherwise = acc - {-# INLINE wrapper #-} - {-# INLINE apply #-} - --- Functions ------------------------------------------------------------------- - --- | Given a method to compute the kernel anchor and the size of the kernel, --- returns the anchor of the kernel as coordinates. -kernelAnchor :: KernelAnchor -> Size -> DIM2 -kernelAnchor (KernelAnchor ix) _ = ix -kernelAnchor (KernelAnchorCenter) (Z :. kh :. kw) = ix2 (round $ (kh - 1) % 2) - (round $ (kw - 1) % 2) +import Vision.Primitive (Size) --- | Given a method of interpolation, the number of pixel in the dimension and --- an index in this dimension, returns either the index of the interpolated --- pixel or a constant value. -borderInterpolate :: BorderInterpolate a - -> Int -- ^ The size of the dimension. - -> Int -- ^ The index in the dimension. - -> Either Int a -borderInterpolate !interpol !len !ix - | word ix < word len = Left ix - | otherwise = - case interpol of - BorderReplicate | ix < 0 -> Left 0 - | otherwise -> Left $! len - 1 - BorderReflect -> Left $! goReflect ix - BorderWrap -> Left $! ix `mod` len - BorderConstant i -> Right i - where - goReflect !ix' | ix' < 0 = goReflect (-ix' - 1) - | ix' >= len = goReflect ((len - 1) - (ix' - len)) - | otherwise = ix' -{-# INLINE borderInterpolate #-} +import qualified Vision.Image.Filter.Internal as Internal -- Morphological operators ----------------------------------------------------- -dilate :: Ord src => Int -> SeparableFilter1 src src -dilate radius = - Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel) - FilterFold1 (\_ acc -> acc) BorderReplicate - where - !size = radius * 2 + 1 - - kernel _ = max -{-# INLINE dilate #-} +dilate, erode :: ( Image src, Ord (ImagePixel src) + , FromFunction res, FromFunctionPixel res ~ ImagePixel src + , SeparatelyFiltrable src res (ImagePixel src)) + => Int -- ^ Kernel radius. + -> src + -> res -erode :: Ord src => Int -> SeparableFilter1 src src -erode radius = - Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel) - FilterFold1 (\_ acc -> acc) BorderReplicate - where - !size = radius * 2 + 1 +dilate radius img = Internal.dilate radius `Internal.apply` img +{-# INLINABLE dilate #-} - kernel _ = min -{-# INLINE erode #-} +erode radius img = Internal.erode radius `Internal.apply` img +{-# INLINABLE erode #-} -- Blur ------------------------------------------------------------------------ -- | Blurs the image by averaging the pixel inside the kernel. -- --- Considers using a type for 'acc' with --- @maxBound acc >= maxBound src * (kernel size)²@. -blur :: (Integral src, Integral acc, Num res) - => Int -- ^ Blur radius. - -> SeparableFilter src acc res -blur radius = - Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) - (FilterFold 0) post BorderReplicate - where - !size = radius * 2 + 1 - !nPixs = fromIntegral $ square size - - vert _ !val !acc = acc + fromIntegral val - - horiz _ !acc' !acc = acc + acc' - - post _ acc = fromIntegral $ acc `div` nPixs -{-# INLINE blur #-} +-- Uses an 'Int32' as accumulator during the averaging operation. +blur :: ( Image src, Integral (ImagePixel src) + , FromFunction res, Num (FromFunctionPixel res) + , SeparatelyFiltrable src res Int32) + => Int -- ^ Blur radius. + -> src + -> res +blur radius img = + let filt :: (Integral src, Num res) => Internal.Blur src Int32 res + filt = Internal.blur radius + in filt `Internal.apply` img +{-# INLINABLE blur #-} -- | Blurs the image by averaging the pixel inside the kernel using a Gaussian -- function. -- -- See -gaussianBlur :: (Integral src, Floating acc, RealFrac acc, Storable acc - , Integral res) - => Int -- ^ Blur radius. +gaussianBlur :: ( Image src, Integral (ImagePixel src) + , FromFunction res, Integral (FromFunctionPixel res) + , Floating acc, RealFrac acc, Storable acc + , SeparatelyFiltrable src res acc) + => Int -- ^ Blur radius. -> Maybe acc -- ^ Sigma value of the Gaussian function. If not given, will be -- automatically computed from the radius so that the kernel -- fits 3σ of the distribution. - -> SeparableFilter src acc res -gaussianBlur !radius !mSig = - Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) - (FilterFold 0) (\_ !acc -> round acc) BorderReplicate - where - !size = radius * 2 + 1 - - -- If σ is not provided, tries to fit 3σ in the kernel. - !sig = case mSig of Just s -> s - Nothing -> (0.5 + fromIntegral radius) / 3 - - vert !(Z :. y) !val !acc = let !coeff = kernelVec V.! y - in acc + fromIntegral val * coeff - - horiz !(Z :. x) !val !acc = let !coeff = kernelVec V.! x - in acc + val * coeff - - !kernelVec = - -- Creates a vector of Gaussian values and normalizes it so its sum - -- equals 1. - let !unormalized = V.generate size $ \x -> - gaussian $! fromIntegral $! abs $! x - radius - !kernelSum = V.sum unormalized - in V.map (/ kernelSum) unormalized - - gaussian !x = invSigSqrt2Pi * exp (inv2xSig2 * square x) - - -- Pre-computed terms of the Gaussian function. - !invSigSqrt2Pi = 1 / (sig * sqrt (2 * pi)) - !inv2xSig2 = -1 / (2 * square sig) -{-# INLINE gaussianBlur #-} + -> src + -> res +gaussianBlur radius mSig img = + Internal.gaussianBlur radius mSig `Internal.apply` img +{-# INLINABLE gaussianBlur #-} -- Derivation ------------------------------------------------------------------ -data Derivative = DerivativeX | DerivativeY - -- | Estimates the first derivative using the Scharr's 3x3 kernel. -- -- Convolves the following kernel for the X derivative: @@ -630,61 +112,46 @@ -- 3 10 3 -- @ -- --- Considers using a signed integer type for 'res' with --- @maxBound res >= 16 * maxBound src@. -scharr :: (Integral src, Integral res) - => Derivative -> SeparableFilter src res res -scharr der = - let !kernel = - case der of - DerivativeX -> SeparableKernel kernel1 kernel2 - DerivativeY -> SeparableKernel kernel2 kernel1 - in Filter (ix2 3 3) KernelAnchorCenter kernel (FilterFold 0) (\_ acc -> acc) - BorderReplicate - where - kernel1 !(Z :. 1) !val !acc = acc + 10 * fromIntegral val - kernel1 !(Z :. _) !val !acc = acc + 3 * fromIntegral val - - kernel2 !(Z :. 0) !val !acc = acc - fromIntegral val - kernel2 !(Z :. 1) !_ !acc = acc - kernel2 !(Z :. ~2) !val !acc = acc + fromIntegral val -{-# INLINE scharr #-} +-- Uses an 'Int32' as accumulator during kernel application. +scharr :: ( Image src, Integral (ImagePixel src) + , FromFunction res, Integral (FromFunctionPixel res) + , Storable (FromFunctionPixel res) + , SeparatelyFiltrable src res (FromFunctionPixel res)) + => DerivativeType -> src -> res +scharr der img = Internal.scharr der `Internal.apply` img +{-# INLINABLE scharr #-} -- | Estimates the first derivative using a Sobel's kernel. -- -- Prefer 'scharr' when radius equals @1@ as Scharr's kernel is more accurate -- and is implemented faster. -- --- Considers using a signed integer type for 'res' which is significantly larger --- than 'src', especially for large kernels. -sobel :: (Integral src, Integral res, Storable res) - => Int -- ^ Kernel radius. - -> Derivative - -> SeparableFilter src res res -sobel radius der = - Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) - (FilterFold 0) (\_ acc -> acc) BorderReplicate - where - !size = radius * 2 + 1 - - vert !(Z :. x) !val !acc = let !coeff = vec1 V.! x - in acc + fromIntegral val * coeff - - horiz !(Z :. x) !val !acc = let !coeff = vec2 V.! x - in acc + fromIntegral val * coeff - - !radius' = fromIntegral radius - - (!vec1, !vec2) = case der of DerivativeX -> (vec1', vec2') - DerivativeY -> (vec2', vec1') - - !vec1' = let pows = [ 2^i | i <- [0..radius'] ] - in V.fromList $ pows ++ (tail (reverse pows)) - !vec2' = V.fromList $ map negate [1..radius'] ++ [0] ++ [1..radius'] -{-# INLINE sobel #-} +-- Uses an 'Int32' as accumulator during kernel application. +sobel :: ( Image src, Integral (ImagePixel src) + , FromFunction res, Integral (FromFunctionPixel res) + , Storable (FromFunctionPixel res) + , SeparatelyFiltrable src res (FromFunctionPixel res)) + => Int -- ^ Kernel radius. + -> DerivativeType + -> src + -> res +sobel radius der img = Internal.sobel radius der `Internal.apply` img +{-# INLINABLE sobel #-} -square :: Num a => a -> a -square a = a * a +-- Others ---------------------------------------------------------------------- -word :: Integral a => a -> Word -word = fromIntegral +-- | Computes the average of a kernel of the given size. +-- +-- This is similar to 'blur' but with a rectangular kernel and a 'Fractional' +-- result. +-- +-- Uses an 'Int32' as accumulator during the averaging operation. +mean :: ( Image src, Integral (ImagePixel src) + , FromFunction res, Fractional (FromFunctionPixel res) + , SeparatelyFiltrable src res Int32) + => Size -> src -> res +mean size img = + let filt :: (Integral src, Fractional res) => Internal.Mean src Int32 res + filt = Internal.mean size + in filt `Internal.apply` img +{-# INLINABLE mean #-} diff --git a/src/Vision/Image/Filter/Internal.hs b/src/Vision/Image/Filter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vision/Image/Filter/Internal.hs @@ -0,0 +1,758 @@ +{-# LANGUAGE BangPatterns + , FlexibleContexts + , FlexibleInstances + , GADTs + , MultiParamTypeClasses + , TypeFamilies + , TupleSections + , ScopedTypeVariables #-} + +-- | Provides high level functions to define and apply filters on images. +-- +-- Filters are operations on images on which the surrounding of each processed +-- pixel is considered according to a kernel. +-- +-- Please use 'Vision.Image.Filter' if you only want to apply filter to images. +-- +-- To apply a filter to an image, use the 'apply' method: +-- +-- @ +-- let -- Creates a filter which will blur the image. Uses a 'Double' as +-- -- accumulator of the Gaussian kernel. +-- filter :: 'Blur' GreyPixel Double GreyPixel +-- filter = 'gaussianBlur' 2 Nothing +-- in 'apply' filter img :: Grey +-- @ +-- +-- The @radius@ argument of some filters is used to determine the kernel size. +-- A radius as of 1 means a kernel of size 3, 2 a kernel of size 5 and so on. +-- +-- The @acc@ type argument of some filters defines the type which will be used +-- to store the accumulated value of the kernel (e.g. by setting @acc@ to +-- 'Double' in the computation of a Gaussian blur, the kernel average will be +-- computed using a 'Double'). +module Vision.Image.Filter.Internal ( + -- * Types + Filterable (..), Filter (..) + , BoxFilter, BoxFilter1, SeparableFilter, SeparableFilter1 + , KernelAnchor (..) + , Kernel (..) + , SeparableKernel (..), SeparatelyFiltrable (..) + , FilterFold (..), FilterFold1 (..) + , BorderInterpolate (..) + -- * Functions + , kernelAnchor, borderInterpolate + -- * Filters + -- ** Morphological operators + , Morphological, dilate, erode + -- ** Blur + , Blur, blur, gaussianBlur + -- ** Derivation + , Derivative, DerivativeType (..), scharr, sobel + -- ** Others + , Mean, mean + ) where + +import Data.List +import Data.Ratio +import Data.Word +import Foreign.Storable (Storable) + +import qualified Data.Vector.Storable as V + +import Vision.Image.Class (MaskedImage (..), Image (..), FromFunction (..), (!)) +import Vision.Image.Type (Manifest, Delayed) +import Vision.Primitive (Z (..), (:.) (..), DIM1, Point, Size, ix1, ix2) + +-- Types ----------------------------------------------------------------------- + +-- | Provides an implementation to execute a type of filter. +-- +-- 'src' is the original image, 'res' the resulting image and 'f' the filter. +class Filterable src res f where + -- | Applies the given filter on the given image. + apply :: f -> src -> res + +data Filter src kernel init fold acc res = Filter { + fKernelSize :: !Size + , fKernelCenter :: !KernelAnchor + -- | See 'Kernel' and 'SeparableKernel'. + , fKernel :: !kernel + -- | Computes a constant value for each pixel before applying the kernel. + -- + -- This value will be passed to 'fKernel' functions and to the 'fPost' + -- function. + -- For most filters, @fInit@ will be @\_ _ -> ()@. + , fInit :: !(Point -> src -> init) + -- | Defines how the accumulated value is initialized. + -- + -- See 'FilterFold' and 'FilterFold1'. + , fFold :: !fold + -- | This function will be executed after the iteration of the kernel on a + -- given point. + -- + -- Can be used to normalize the accumulated value, for example. + , fPost :: !(Point -> src -> init -> acc -> res) + , fInterpol :: !(BorderInterpolate src) + } + +-- | 2D filters which are initialized with a value. +type BoxFilter src init acc res = Filter src (Kernel src init acc) init + (FilterFold acc) acc res + +-- | 2D filters which are not initialized with a value. +type BoxFilter1 src init res = Filter src (Kernel src init src) init + FilterFold1 src res + +-- | Separable 2D filters which are initialized with a value. +type SeparableFilter src init acc res = Filter src + (SeparableKernel src init acc) + init (FilterFold acc) acc res + +-- | Separable 2D filters which are not initialized with a value. +type SeparableFilter1 src init res = Filter src + (SeparableKernel src init src) + init FilterFold1 src res + +-- | Defines how the center of the kernel will be determined. +data KernelAnchor = KernelAnchor !Point | KernelAnchorCenter + +-- | A simple 2D kernel. +-- +-- The kernel function accepts the coordinates in the kernel, the value of the +-- pixel at these coordinates ('src'), the current accumulated value and returns +-- a new accumulated value. +-- +-- Non-separable filters computational complexity grows quadratically according +-- to the size of the sides of the kernel. +newtype Kernel src init acc = Kernel (init -> Point -> src -> acc -> acc) + +-- | Some kernels can be factorized in two uni-dimensional kernels (horizontal +-- and vertical). +-- +-- Separable filters computational complexity grows linearly according to the +-- size of the sides of the kernel. +-- +-- See . +data SeparableKernel src init acc = SeparableKernel { + -- | Vertical (column) kernel. + skVertical :: !(init -> DIM1 -> src -> acc -> acc) + -- | Horizontal (row) kernel. + , skHorizontal :: !(init -> DIM1 -> acc -> acc -> acc) + } + +-- | Used to determine the type of the accumulator image used when computing +-- separable filters. +-- +-- 'src' and 'res' are respectively the source and the result image types while +-- 'acc' is the pixel type of the accumulator. +class ( Image (SeparableFilterAccumulator src res acc) + , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc + , FromFunction (SeparableFilterAccumulator src res acc) + , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc) + => SeparatelyFiltrable src res acc where + type SeparableFilterAccumulator src res acc + +instance Storable acc => SeparatelyFiltrable src (Manifest p) acc where + type SeparableFilterAccumulator src (Manifest p) acc = Manifest acc + +instance Storable acc => SeparatelyFiltrable src (Delayed p) acc where + type SeparableFilterAccumulator src (Delayed p) acc = Delayed acc + +-- | Uses the result of the provided function as the initial value of the +-- kernel's accumulator, depending on the center coordinates in the image. +-- +-- For most filters, the function will always return the same value (i.e. +-- defined as @const 0@), but this kind of initialization could be required for +-- some filters. +data FilterFold acc = FilterFold (Point -> acc) + +-- | Uses the first pixel in the kernel as initial value. The kernel must not be +-- empty and the accumulator type must be the same as the source pixel type. +-- +-- This kind of initialization is needed by morphological filters. +data FilterFold1 = FilterFold1 + +-- | Defines how image boundaries are extrapolated by the algorithms. +-- +-- '|' characters in examples are image borders. +data BorderInterpolate a = + -- | Replicates the first and last pixels of the image. + -- + -- > aaaaaa|abcdefgh|hhhhhhh + BorderReplicate + -- | Reflects the border of the image. + -- + -- > fedcba|abcdefgh|hgfedcb + | BorderReflect + -- | Considers that the last pixel of the image is before the first one. + -- + -- > cdefgh|abcdefgh|abcdefg + | BorderWrap + -- | Assigns a constant value to out of image pixels. + -- + -- > iiiiii|abcdefgh|iiiiiii with some specified 'i' + | BorderConstant !a + +-- Instances ------------------------------------------------------------------- + +-- Following implementations share a lot of similar processing. However, GHC +-- fails to specialise and optimise correctly when goXXX functions are top-level +-- functions, even with static argument transformations. + +-- | Box filters initialized with a given value. +instance (Image src, FromFunction res, src_pix ~ ImagePixel src + , res_pix ~ FromFunctionPixel res) + => Filterable src res (BoxFilter src_pix init acc res_pix) where + apply !(Filter ksize anchor (Kernel kernel) initF fold post interpol) !img = + let !(FilterFold fAcc) = fold + in fromFunction size $ \(!pt@(Z :. iy :. ix)) -> + let pix = img ! pt + !ini = initF pt pix + !acc = fAcc pt + !iy0 = iy - kcy + !ix0 = ix - kcx + !safe = iy0 >= 0 && iy0 + kh <= ih + && ix0 >= 0 && ix0 + kw <= iw + in post pt pix ini $! + if safe then goColumnSafe ini (iy0 * iw) ix0 0 acc + else goColumn ini iy0 ix0 0 acc + where + !size@(Z :. ih :. iw) = shape img + + !(Z :. kh :. kw) = ksize + !(Z :. kcy :. kcx) = kernelAnchor anchor ksize + + goColumn !ini !iy !ix !ky !acc + | ky < kh = case borderInterpolate interpol ih iy of + Left iy' -> goLine ini iy (iy' * iw) ix ix ky 0 acc + Right val -> goLineConst ini iy ix ky 0 val acc + | otherwise = acc + + goColumnSafe !ini !linearIY !ix !ky !acc + | ky < kh = goLineSafe ini linearIY ix ix ky 0 acc + | otherwise = acc + + goLine !ini !iy !linearIY !ix0 !ix !ky !kx !acc + | kx < kw = + let !val = case borderInterpolate interpol iw ix of + Left ix' -> img `linearIndex` (linearIY + ix') + Right val' -> val' + !acc' = kernel ini (ix2 ky kx) val acc + in goLine ini iy linearIY ix0 (ix + 1) ky (kx + 1) acc' + | otherwise = goColumn ini (iy + 1) ix0 (ky + 1) acc + + goLineSafe !ini !linearIY !ix0 !ix !ky !kx !acc + | kx < kw = + let !val = img `linearIndex` (linearIY + ix) + !acc' = kernel ini (ix2 ky kx) val acc + in goLineSafe ini linearIY ix0 (ix + 1) ky (kx + 1) acc' + | otherwise = goColumnSafe ini (linearIY + iw) ix0 (ky + 1) acc + + goLineConst !ini !iy !ix !ky !kx !val !acc + | kx < kw = let !acc' = kernel ini (ix2 ky kx) val acc + in goLineConst ini iy ix ky (kx + 1) val acc' + | otherwise = goColumn ini (iy + 1) ix (ky + 1) acc + {-# INLINE apply #-} + +-- | Box filters initialized using the first pixel of the kernel. +instance (Image src, FromFunction res, src_pix ~ ImagePixel src + , res_pix ~ FromFunctionPixel res) + => Filterable src res (BoxFilter1 src_pix init res_pix) where + apply !(Filter ksize anchor (Kernel kernel) initF _ post interpol) !img + | kh == 0 || kw == 0 = + error "Using FilterFold1 with an empty kernel." + | otherwise = + fromFunction size $ \(!pt@(Z :. iy :. ix)) -> + let pix = img ! pt + !ini = initF pt pix + !iy0 = iy - kcy + !ix0 = ix - kcx + !safe = iy0 >= 0 && iy0 + kh <= ih + && ix0 >= 0 && ix0 + kw <= iw + in post pt pix ini $! if safe then goColumn1Safe ini iy0 ix0 + else goColumn1 ini iy0 ix0 + where + !size@(Z :. ih :. iw) = shape img + + !(Z :. kh :. kw) = ksize + !(Z :. kcy :. kcx) = kernelAnchor anchor ksize + + goColumn1 !ini !iy !ix = + case borderInterpolate interpol ih iy of + Left iy' -> + let !linearIY = iy' * iw + !acc = safeIndex linearIY ix + in goLine ini iy linearIY ix (ix + 1) 0 1 acc + Right val -> goLineConst ini iy ix 0 1 val val + + goColumn1Safe !ini !iy !ix = + let !linearIY = iy * iw + !acc = img `linearIndex` (linearIY + ix) + in goLineSafe ini linearIY ix (ix + 1) 0 1 acc + + goColumn !ini !iy !ix !ky !acc + | ky < kh = case borderInterpolate interpol ih iy of + Left iy' -> goLine ini iy (iy' * iw) ix ix ky 0 acc + Right val -> goLineConst ini iy ix ky 0 val acc + | otherwise = acc + + goColumnSafe !ini !linearIY !ix !ky !acc + | ky < kh = goLineSafe ini linearIY ix ix ky 0 acc + | otherwise = acc + + goLine !ini !iy !linearIY !ix0 !ix !ky !kx !acc + | kx < kw = + let !val = safeIndex linearIY ix + !acc' = kernel ini (ix2 ky kx) val acc + in goLine ini iy linearIY ix0 (ix + 1) ky (kx + 1) acc' + | otherwise = goColumn ini (iy + 1) ix0 (ky + 1) acc + + goLineSafe !ini !linearIY !ix0 !ix !ky !kx !acc + | kx < kw = + let !val = img `linearIndex` (linearIY + ix) + !acc' = kernel ini (ix2 ky kx) val acc + in goLineSafe ini linearIY ix0 (ix + 1) ky (kx + 1) acc' + | otherwise = goColumnSafe ini (linearIY + iw) ix0 (ky + 1) acc + + goLineConst !ini !iy !ix !ky !kx !val !acc + | kx < kw = let !acc' = kernel ini (ix2 ky kx) val acc + in goLineConst ini iy ix ky (kx + 1) val acc' + | otherwise = goColumn ini (iy + 1) ix (ky + 1) acc + + safeIndex !linearIY !ix = + case borderInterpolate interpol iw ix of + Left ix' -> img `linearIndex` (linearIY + ix') + Right val -> val + {-# INLINE apply #-} + +-- | Separable filters initialized with a given value. +instance ( Image src, FromFunction res + , src_pix ~ ImagePixel src + , res_pix ~ FromFunctionPixel res + , SeparatelyFiltrable src res acc) + => Filterable src res (SeparableFilter src_pix init acc res_pix) + where + apply !f !img = + fst $! wrapper img f + where + wrapper :: (Image src, FromFunction res) + => src + -> SeparableFilter (ImagePixel src) init acc (FromFunctionPixel res) + -> (res, SeparableFilterAccumulator src res acc) + wrapper !src !(Filter ksize anchor kernel initF fold post interpol) = + (res, tmp) + where + !size@(Z :. ih :. iw) = shape src + + !(Z :. kh :. kw) = ksize + !(Z :. kcy :. kcx) = kernelAnchor anchor ksize + + !(SeparableKernel vert horiz) = kernel + !(FilterFold fAcc) = fold + + !tmp = fromFunction size $ \(!pt@(Z :. iy :. ix)) -> + let pix = src ! pt + !ini = initF pt pix + !acc0 = fAcc pt + !iy0 = iy - kcy + in if iy0 >= 0 && iy0 + kh <= ih + then goColumnSafe ini iy0 ix 0 acc0 + else goColumn ini iy0 ix 0 acc0 + + !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) -> + let pix = src ! pt + !ini = initF pt pix + !acc0 = fAcc pt + !ix0 = ix - kcx + in post pt pix ini $! + if ix0 >= 0 && ix0 + kw <= iw + then goLineSafe ini (iy * iw) ix0 0 acc0 + else goLine ini acc0 (iy * iw) ix0 0 + acc0 + + goColumn !ini !iy !ix !ky !acc + | ky < kh = + let !val = case borderInterpolate interpol ih iy of + Left iy' -> src ! ix2 iy' ix + Right val' -> val' + !acc' = vert ini (ix1 ky) val acc + in goColumn ini (iy + 1) ix (ky + 1) acc' + | otherwise = acc + + goColumnSafe !ini !iy !ix !ky !acc + | ky < kh = + let !val = src ! ix2 iy ix + !acc' = vert ini (ix1 ky) val acc + in goColumnSafe ini (iy + 1) ix (ky + 1) acc' + | otherwise = acc + + goLine !ini !acc0 !linearIY !ix !kx !acc + | kx < kw = + let !val = + case borderInterpolate interpol iw ix of + Left ix' -> tmp `linearIndex` (linearIY + ix') + Right val' -> constCol ini acc0 val' + !acc' = horiz ini (ix1 kx) val acc + in goLine ini acc0 linearIY (ix + 1) (kx + 1) acc' + | otherwise = acc + + goLineSafe !ini !linearIY !ix !kx !acc + | kx < kw = + let !val = tmp `linearIndex` (linearIY + ix) + !acc' = horiz ini (ix1 kx) val acc + in goLineSafe ini linearIY (ix + 1) (kx + 1) acc' + | otherwise = acc + + -- Computes the value of an out of image column when the + -- interpolation method is BorderConstant. + constCol !ini !acc0 !constVal = + foldl' (\acc ky -> vert ini (ix1 ky) constVal acc) acc0 + [0..kh-1] + {-# INLINE wrapper #-} + {-# INLINE apply #-} + +-- | Separable filters initialized using the first pixel of the kernel. +instance ( Image src, FromFunction res + , src_pix ~ ImagePixel src + , res_pix ~ FromFunctionPixel res + , SeparatelyFiltrable src res src_pix) + => Filterable src res (SeparableFilter1 src_pix init res_pix) + where + apply !f !img = + fst $! wrapper img f + where + wrapper :: (Image src, FromFunction res, acc ~ ImagePixel src + , FromFunction (SeparableFilterAccumulator src res acc) + , FromFunctionPixel (SeparableFilterAccumulator src res acc) ~ acc + , Image (SeparableFilterAccumulator src res acc) + , ImagePixel (SeparableFilterAccumulator src res acc) ~ acc) + => src + -> SeparableFilter1 (ImagePixel src) init (FromFunctionPixel res) + -> (res, SeparableFilterAccumulator src res acc) + wrapper !src !(Filter ksize anchor kernel initF _ post interpol) + | kh == 0 || kw == 0 = + error "Using FilterFold1 with an empty kernel." + | otherwise = + (res, tmp) + where + !size@(Z :. ih :. iw) = shape src + + !(Z :. kh :. kw) = ksize + !(Z :. kcy :. kcx) = kernelAnchor anchor ksize + + !(SeparableKernel vert horiz) = kernel + + !tmp = fromFunction size $ \(!pt@(Z :. iy :. ix)) -> + let pix = src ! pt + !ini = initF pt pix + !iy0 = iy - kcy + in if iy0 >= 0 && iy0 + kh <= ih + then goColumn1Safe ini iy0 ix + else goColumn1 ini iy0 ix + + !res = fromFunction size $ \(!pt@(Z :. iy :. ix)) -> + let pix = src ! pt + !ini = initF pt pix + !ix0 = ix - kcx + in post pt pix ini $! + if ix0 >= 0 && ix0 + kw <= iw + then goLine1Safe ini (iy * iw) ix0 + else goLine1 ini (iy * iw) ix0 + + goColumn1 !ini !iy !ix = + case borderInterpolate interpol ih iy of + Left iy' -> + let !acc = src ! ix2 iy' ix + in goColumn ini (iy + 1) ix 1 acc + Right val -> + goColumn ini (iy + 1) ix 1 val + + goColumn1Safe !ini !iy !ix = + let !linearIY = iy * iw + !acc = src `linearIndex` (linearIY + ix) + in goColumnSafe ini (linearIY + iw) ix 1 acc + + goColumn !ini !iy !ix !ky !acc + | ky < kh = + let !val = case borderInterpolate interpol ih iy of + Left iy' -> src ! ix2 iy' ix + Right val' -> val' + !acc' = vert ini (ix1 ky) val acc + in goColumn ini (iy + 1) ix (ky + 1) acc' + | otherwise = acc + + goColumnSafe !ini !linearIY !ix !ky !acc + | ky < kh = + let !val = src `linearIndex` (linearIY + ix) + !acc' = vert ini (ix1 ky) val acc + in goColumnSafe ini (linearIY + iw) ix (ky + 1) acc' + | otherwise = acc + + goLine1 !ini !linearIY !ix = + let !acc = + case borderInterpolate interpol iw ix of + Left ix' -> tmp `linearIndex` (linearIY + ix') + Right val -> columnConst ini val + in goLine ini linearIY (ix + 1) 1 acc + + goLine1Safe !ini !linearIY !ix = + let !linearIX = linearIY + ix + !acc = tmp `linearIndex` linearIX + in goLineSafe ini (linearIX + 1) 1 acc + + goLine !ini !linearIY !ix !kx !acc + | kx < kw = + let !val = + case borderInterpolate interpol iw ix of + Left ix' -> tmp `linearIndex` (linearIY + ix') + Right val' -> columnConst ini val' + !acc' = horiz ini (ix1 kx) val acc + in goLine ini linearIY (ix + 1) (kx + 1) acc' + | otherwise = acc + + goLineSafe !ini !linearIX !kx !acc + | kx < kw = + let !val = tmp `linearIndex` linearIX + !acc' = horiz ini (ix1 kx) val acc + in goLineSafe ini (linearIX + 1) (kx + 1) acc' + | otherwise = acc + + columnConst !ini !constVal = goColumnConst ini 1 constVal constVal + + goColumnConst !ini !ky !constVal !acc + | ky < kh = goColumnConst ini (ky + 1) constVal + (vert ini (ix1 ky) acc constVal) + | otherwise = acc + {-# INLINE wrapper #-} + {-# INLINE apply #-} + +-- Functions ------------------------------------------------------------------- + +-- | Given a method to compute the kernel anchor and the size of the kernel, +-- returns the anchor of the kernel as coordinates. +kernelAnchor :: KernelAnchor -> Size -> Point +kernelAnchor (KernelAnchor ix) _ = ix +kernelAnchor (KernelAnchorCenter) (Z :. kh :. kw) = ix2 (round $ (kh - 1) % 2) + (round $ (kw - 1) % 2) + +-- | Given a method of interpolation, the number of pixel in the dimension and +-- an index in this dimension, returns either the index of the interpolated +-- pixel or a constant value. +borderInterpolate :: BorderInterpolate a + -> Int -- ^ The size of the dimension. + -> Int -- ^ The index in the dimension. + -> Either Int a +borderInterpolate !interpol !len !ix + | word ix < word len = Left ix + | otherwise = + case interpol of + BorderReplicate | ix < 0 -> Left 0 + | otherwise -> Left $! len - 1 + BorderReflect -> Left $! goReflect ix + BorderWrap -> Left $! ix `mod` len + BorderConstant i -> Right i + where + goReflect !ix' | ix' < 0 = goReflect (-ix' - 1) + | ix' >= len = goReflect ((len - 1) - (ix' - len)) + | otherwise = ix' +{-# INLINE borderInterpolate #-} + +-- Morphological operators ----------------------------------------------------- + +type Morphological pix = SeparableFilter1 pix () pix + +dilate :: Ord pix => Int -> Morphological pix +dilate radius = + Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel) + (\_ _ -> ()) FilterFold1 (\_ _ _ !acc -> acc) BorderReplicate + where + !size = radius * 2 + 1 + + kernel _ _ = max +{-# INLINE dilate #-} + +erode :: Ord pix => Int -> Morphological pix +erode radius = + Filter (ix2 size size) KernelAnchorCenter (SeparableKernel kernel kernel) + (\_ _ -> ()) FilterFold1 (\_ _ _ !acc -> acc) BorderReplicate + where + !size = radius * 2 + 1 + + kernel _ _ = min +{-# INLINE erode #-} + +-- Blur ------------------------------------------------------------------------ + +type Blur src acc res = SeparableFilter src () acc res + +-- | Blurs the image by averaging the pixel inside the kernel. +-- +-- Considers using a type for 'acc' with +-- @maxBound acc >= maxBound src * (kernel size)²@. +blur :: (Integral src, Integral acc, Num res) + => Int -- ^ Blur radius. + -> Blur src acc res +blur radius = + Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) + (\_ _ -> ()) (FilterFold (const 0)) post BorderReplicate + where + !size = radius * 2 + 1 + !nPixs = fromIntegral $ square size + + vert _ _ !val !acc = acc + fromIntegral val + horiz _ _ !acc' !acc = acc + acc' + + post _ _ _ !acc = fromIntegral $ acc `div` nPixs +{-# INLINE blur #-} + +-- | Blurs the image by averaging the pixel inside the kernel using a Gaussian +-- function. +-- +-- See +gaussianBlur :: (Integral src, Floating acc, RealFrac acc, Storable acc + , Integral res) + => Int -- ^ Blur radius. + -> Maybe acc + -- ^ Sigma value of the Gaussian function. If not given, will be + -- automatically computed from the radius so that the kernel + -- fits 3σ of the distribution. + -> Blur src acc res +gaussianBlur !radius !mSig = + Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) + (\_ _ -> ()) (FilterFold (const 0)) (\_ _ _ !acc -> round acc) + BorderReplicate + where + !size = radius * 2 + 1 + + -- If σ is not provided, tries to fit 3σ in the kernel. + !sig = case mSig of Just s -> s + Nothing -> (0.5 + fromIntegral radius) / 3 + + vert _ !(Z :. y) !val !acc = let !coeff = kernelVec V.! y + in acc + fromIntegral val * coeff + + horiz _ !(Z :. x) !val !acc = let !coeff = kernelVec V.! x + in acc + val * coeff + + !kernelVec = + -- Creates a vector of Gaussian values and normalizes it so its sum + -- equals 1. + let !unormalized = V.generate size $ \x -> + gaussian $! fromIntegral $! abs $! x - radius + !kernelSum = V.sum unormalized + in V.map (/ kernelSum) unormalized + + gaussian !x = invSigSqrt2Pi * exp (inv2xSig2 * square x) + + -- Pre-computed terms of the Gaussian function. + !invSigSqrt2Pi = 1 / (sig * sqrt (2 * pi)) + !inv2xSig2 = -1 / (2 * square sig) +{-# INLINE gaussianBlur #-} + +-- Derivation ------------------------------------------------------------------ + +type Derivative src res = SeparableFilter src () res res + +data DerivativeType = DerivativeX | DerivativeY + +-- | Estimates the first derivative using the Scharr's 3x3 kernel. +-- +-- Convolves the following kernel for the X derivative: +-- +-- @ +-- -3 0 3 +-- -10 0 10 +-- -3 0 3 +-- @ +-- +-- And this kernel for the Y derivative: +-- +-- @ +-- -3 -10 -3 +-- 0 0 0 +-- 3 10 3 +-- @ +-- +-- Considers using a signed integer type for 'res' with +-- @maxBound res >= 16 * maxBound src@. +scharr :: (Integral src, Integral res) + => DerivativeType -> Derivative src res +scharr der = + let !kernel = + case der of + DerivativeX -> SeparableKernel kernel1 kernel2 + DerivativeY -> SeparableKernel kernel2 kernel1 + in Filter (ix2 3 3) KernelAnchorCenter kernel (\_ _ -> ()) + (FilterFold (const 0)) (\_ _ _ !acc -> acc) BorderReplicate + where + kernel1 _ !(Z :. 1) !val !acc = acc + 10 * fromIntegral val + kernel1 _ !(Z :. _) !val !acc = acc + 3 * fromIntegral val + + kernel2 _ !(Z :. 0) !val !acc = acc - fromIntegral val + kernel2 _ !(Z :. 1) !_ !acc = acc + kernel2 _ !(Z :. ~2) !val !acc = acc + fromIntegral val +{-# INLINE scharr #-} + +-- | Estimates the first derivative using a Sobel's kernel. +-- +-- Prefer 'scharr' when radius equals @1@ as Scharr's kernel is more accurate +-- and is implemented faster. +-- +-- Considers using a signed integer type for 'res' which is significantly larger +-- than 'src', especially for large kernels. +sobel :: (Integral src, Integral res, Storable res) + => Int -- ^ Kernel radius. + -> DerivativeType + -> Derivative src res +sobel radius der = + Filter (ix2 size size) KernelAnchorCenter (SeparableKernel vert horiz) + (\_ _ -> ()) (FilterFold (const 0)) (\_ _ _ !acc -> acc) + BorderReplicate + where + !size = radius * 2 + 1 + + vert _ !(Z :. x) !val !acc = let !coeff = vec1 V.! x + in acc + fromIntegral val * coeff + + horiz _ !(Z :. x) !val !acc = let !coeff = vec2 V.! x + in acc + fromIntegral val * coeff + + !radius' = fromIntegral radius + + (!vec1, !vec2) = case der of DerivativeX -> (vec1', vec2') + DerivativeY -> (vec2', vec1') + + !vec1' = let pows = [ 2^i | i <- [0..radius'] ] + in V.fromList $ pows ++ (tail (reverse pows)) + !vec2' = V.fromList $ map negate [1..radius'] ++ [0] ++ [1..radius'] +{-# INLINE sobel #-} + +-- Others ---------------------------------------------------------------------- + +type Mean src acc res = SeparableFilter src () acc res + +-- | Computes the average of a kernel of the given size. +-- +-- This is similar to 'blur' but with a rectangular kernel and a 'Fractional' +-- result. +mean :: (Integral src, Integral acc, Fractional res) + => Size -> SeparableFilter src () acc res +mean size@(Z :. h :. w) = + Filter size KernelAnchorCenter (SeparableKernel vert horiz) (\_ _ -> ()) + (FilterFold (const 0)) post BorderReplicate + where + vert _ _ !val !acc = acc + fromIntegral val + horiz _ _ !acc' !acc = acc + acc' + + !nPixsFactor = 1 / (fromIntegral $! h * w) + post _ _ _ !acc = fromIntegral acc * nPixsFactor +{-# INLINE mean #-} + +-- ----------------------------------------------------------------------------- + +square :: Num a => a -> a +square a = a * a + +word :: Integral a => a -> Word +word = fromIntegral diff --git a/src/Vision/Image/Grey/Conversion.hs b/src/Vision/Image/Grey/Conversion.hs --- a/src/Vision/Image/Grey/Conversion.hs +++ b/src/Vision/Image/Grey/Conversion.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE BangPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns + , MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Vision.Image.Grey.Conversion () where diff --git a/src/Vision/Image/Grey/Specialize.hs b/src/Vision/Image/Grey/Specialize.hs --- a/src/Vision/Image/Grey/Specialize.hs +++ b/src/Vision/Image/Grey/Specialize.hs @@ -6,11 +6,17 @@ import Data.Int import Vision.Histogram (Histogram, histogram, histogram2D, equalizeImage) +import Vision.Image.Filter ( + DerivativeType, dilate, erode, blur, gaussianBlur, scharr, sobel, mean + ) import Vision.Image.Grey.Type (Grey, GreyPixel) -import Vision.Image.Threshold (ThresholdType, otsu) +import Vision.Image.Threshold ( + ThresholdType, AdaptiveThresholdKernel, adaptiveThreshold, otsu, scw + ) import Vision.Image.Transform ( InterpolMethod, crop, resize, horizontalFlip, verticalFlip ) +import Vision.Image.Type (Manifest) import Vision.Primitive (DIM1, DIM3, Rect, Size) {-# SPECIALIZE histogram :: Maybe DIM1 -> Grey -> Histogram DIM1 Int32 @@ -24,10 +30,55 @@ -- FIXME: GHC 7.8.2 fails to specialize {-# SPECIALIZE equalizeImage :: Grey -> Grey #-} +{-# SPECIALIZE dilate :: Int -> Grey -> Grey #-} +{-# SPECIALIZE erode :: Int -> Grey -> Grey #-} +{-# SPECIALIZE blur :: Int -> Grey -> Grey #-} +{-# SPECIALIZE gaussianBlur :: Int -> Maybe Double -> Grey -> Grey #-} +{-# SPECIALIZE gaussianBlur :: Int -> Maybe Float -> Grey -> Grey #-} +{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Grey #-} +{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Manifest Int16 #-} +{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Manifest Int32 #-} +{-# SPECIALIZE scharr :: DerivativeType -> Grey -> Manifest Int #-} +{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey -> Grey #-} +{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey + -> Manifest Int16 #-} +{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey + -> Manifest Int32 #-} +{-# SPECIALIZE sobel :: Int -> DerivativeType -> Grey + -> Manifest Int #-} +{-# SPECIALIZE mean :: Size -> Grey -> Manifest Double #-} +{-# SPECIALIZE mean :: Size -> Grey -> Manifest Float #-} + +{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Int -> Int + -> GreyPixel + -> ThresholdType GreyPixel GreyPixel + -> Grey -> Grey #-} +{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Int16 -> Int + -> GreyPixel + -> ThresholdType GreyPixel GreyPixel + -> Grey -> Grey #-} +{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Int32 -> Int + -> GreyPixel + -> ThresholdType GreyPixel GreyPixel + -> Grey -> Grey #-} +{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Double -> Int + -> GreyPixel + -> ThresholdType GreyPixel GreyPixel + -> Grey -> Grey #-} +{-# SPECIALIZE adaptiveThreshold :: AdaptiveThresholdKernel Float -> Int + -> GreyPixel + -> ThresholdType GreyPixel GreyPixel + -> Grey -> Grey #-} +{-# SPECIALIZE otsu :: ThresholdType GreyPixel GreyPixel -> Grey + -> Grey #-} +{-# SPECIALIZE scw :: Size -> Size -> Double + -> ThresholdType GreyPixel GreyPixel -> Grey + -> Grey #-} +{-# SPECIALIZE scw :: Size -> Size -> Float + -> ThresholdType GreyPixel GreyPixel -> Grey + -> Grey #-} + {-# SPECIALIZE crop :: Rect -> Grey -> Grey #-} {-# SPECIALIZE resize :: InterpolMethod -> Size -> Grey -> Grey #-} {-# SPECIALIZE horizontalFlip :: Grey -> Grey #-} {-# SPECIALIZE verticalFlip :: Grey -> Grey #-} - -{-# SPECIALIZE otsu :: ThresholdType GreyPixel GreyPixel -> Grey - -> Grey #-} diff --git a/src/Vision/Image/Grey/Type.hs b/src/Vision/Image/Grey/Type.hs --- a/src/Vision/Image/Grey/Type.hs +++ b/src/Vision/Image/Grey/Type.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TypeFamilies #-} +{-# LANGUAGE BangPatterns + , GeneralizedNewtypeDeriving + , TypeFamilies #-} module Vision.Image.Grey.Type ( Grey, GreyPixel (..), GreyDelayed @@ -8,8 +10,9 @@ import Data.Word import Foreign.Storable (Storable) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..)) -import Vision.Image.Type (Pixel (..), Manifest, Delayed) +import Vision.Image.Type (Manifest, Delayed) newtype GreyPixel = GreyPixel Word8 deriving (Bits, Bounded, Enum, Eq, Integral, Num, Ord, Real, Read, Show diff --git a/src/Vision/Image/HSV/Conversion.hs b/src/Vision/Image/HSV/Conversion.hs --- a/src/Vision/Image/HSV/Conversion.hs +++ b/src/Vision/Image/HSV/Conversion.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns, MultiParamTypeClasses, PatternGuards #-} +{-# LANGUAGE BangPatterns + , MultiParamTypeClasses + , PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Vision.Image.HSV.Conversion () where diff --git a/src/Vision/Image/HSV/Type.hs b/src/Vision/Image/HSV/Type.hs --- a/src/Vision/Image/HSV/Type.hs +++ b/src/Vision/Image/HSV/Type.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-} +{-# LANGUAGE BangPatterns + , RecordWildCards + , TypeFamilies + , TypeOperators #-} module Vision.Image.HSV.Type ( HSV, HSVPixel (..), HSVDelayed @@ -9,8 +12,9 @@ import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..)) -import Vision.Image.Type (Pixel (..), Manifest, Delayed) +import Vision.Image.Type (Manifest, Delayed) data HSVPixel = HSVPixel { hsvHue :: {-# UNPACK #-} !Word8, hsvSat :: {-# UNPACK #-} !Word8 diff --git a/src/Vision/Image/Interpolate.hs b/src/Vision/Image/Interpolate.hs --- a/src/Vision/Image/Interpolate.hs +++ b/src/Vision/Image/Interpolate.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts #-} -- | Provides a way to estimate the value of a pixel at rational coordinates -- using a linear interpolation. @@ -10,7 +11,7 @@ import Data.RatioInt (denominator, numerator) import Data.Word -import Vision.Image.Type (Pixel (..), Image (..), ImagePixel, ImageChannel) +import Vision.Image.Class (Pixel (..), Image (..), ImagePixel, ImageChannel) import Vision.Primitive (RPoint (..), ix2) -- | Provides a way to apply the interpolation to every component of a pixel. diff --git a/src/Vision/Image/Mutable.hs b/src/Vision/Image/Mutable.hs --- a/src/Vision/Image/Mutable.hs +++ b/src/Vision/Image/Mutable.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes, TypeFamilies #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts + , RankNTypes + , TypeFamilies #-} +-- | Contains an stateful image type which can be modified inside a 'ST' monad. module Vision.Image.Mutable ( MutableImage (..), create , MutableManifest (..) @@ -8,18 +12,19 @@ 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 qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as MV + +import Vision.Image.Class (Image, ImagePixel) +import Vision.Image.Type (Manifest (..)) import Vision.Primitive ( - DIM2, Size, fromLinearIndex, toLinearIndex, shapeLength + Point, Size, fromLinearIndex, toLinearIndex, shapeLength ) -- | Class for images which can be constructed from a mutable image. - class Image (Freezed i) => MutableImage i where -- | The type of the immutable version of the mutable image 'i'. type Freezed i @@ -37,19 +42,20 @@ new' :: PrimMonad m => Size -> ImagePixel (Freezed i) -> m (i (PrimState m)) -- | Returns the pixel value at @Z :. y :. x@. - read :: PrimMonad m => i (PrimState m) -> DIM2 -> m (ImagePixel (Freezed i)) + read :: PrimMonad m => i (PrimState m) -> Point + -> m (ImagePixel (Freezed i)) read !img !ix = img `linearRead` toLinearIndex (mShape img) ix {-# INLINE read #-} -- | Returns the pixel value as if the image was a single dimension vector -- (row-major representation). - linearRead :: PrimMonad m => i (PrimState m) -> Int - -> m (ImagePixel (Freezed i)) + linearRead :: PrimMonad m + => i (PrimState m) -> Int -> m (ImagePixel (Freezed i)) linearRead !img !ix = img `read` fromLinearIndex (mShape img) ix {-# INLINE linearRead #-} -- | Overrides the value of the pixel at @Z :. y :. x@. - write :: PrimMonad m => i (PrimState m) -> DIM2 -> ImagePixel (Freezed i) + write :: PrimMonad m => i (PrimState m) -> Point -> ImagePixel (Freezed i) -> m () write !img !ix !val = linearWrite img (toLinearIndex (mShape img) ix) val {-# INLINE write #-} @@ -83,12 +89,12 @@ -- Instances ------------------------------------------------------------------- -data Storable p => MutableManifest p s = MutableManifest { +data MutableManifest p s = MutableManifest { mmSize :: !Size , mmVector :: !(MVector s p) } -instance (Pixel p, Storable p) => MutableImage (MutableManifest p) where +instance Storable p => MutableImage (MutableManifest p) where type Freezed (MutableManifest p) = Manifest p mShape = mmSize diff --git a/src/Vision/Image/RGB/Conversion.hs b/src/Vision/Image/RGB/Conversion.hs --- a/src/Vision/Image/RGB/Conversion.hs +++ b/src/Vision/Image/RGB/Conversion.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE BangPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns + , MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Vision.Image.RGB.Conversion () where diff --git a/src/Vision/Image/RGB/Type.hs b/src/Vision/Image/RGB/Type.hs --- a/src/Vision/Image/RGB/Type.hs +++ b/src/Vision/Image/RGB/Type.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-} +{-# LANGUAGE BangPatterns + , RecordWildCards + , TypeFamilies + , TypeOperators #-} module Vision.Image.RGB.Type ( RGB, RGBPixel (..), RGBDelayed @@ -9,8 +12,9 @@ import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..)) -import Vision.Image.Type (Pixel (..), Manifest, Delayed) +import Vision.Image.Type (Manifest, Delayed) data RGBPixel = RGBPixel { rgbRed :: {-# UNPACK #-} !Word8, rgbGreen :: {-# UNPACK #-} !Word8 diff --git a/src/Vision/Image/RGBA/Conversion.hs b/src/Vision/Image/RGBA/Conversion.hs --- a/src/Vision/Image/RGBA/Conversion.hs +++ b/src/Vision/Image/RGBA/Conversion.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE BangPatterns, MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns + , MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Vision.Image.RGBA.Conversion () where diff --git a/src/Vision/Image/RGBA/Type.hs b/src/Vision/Image/RGBA/Type.hs --- a/src/Vision/Image/RGBA/Type.hs +++ b/src/Vision/Image/RGBA/Type.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, TypeFamilies, TypeOperators #-} +{-# LANGUAGE BangPatterns + , RecordWildCards + , TypeFamilies + , TypeOperators #-} module Vision.Image.RGBA.Type ( RGBA, RGBAPixel (..), RGBADelayed @@ -9,8 +12,9 @@ import Foreign.Storable (Storable (..)) import Foreign.Ptr (castPtr, plusPtr) +import Vision.Image.Class (Pixel (..)) import Vision.Image.Interpolate (Interpolable (..)) -import Vision.Image.Type (Pixel (..), Manifest, Delayed) +import Vision.Image.Type (Manifest, Delayed) data RGBAPixel = RGBAPixel { rgbaRed :: {-# UNPACK #-} !Word8, rgbaGreen :: {-# UNPACK #-} !Word8 diff --git a/src/Vision/Image/Storage.hsc b/src/Vision/Image/Storage.hsc deleted file mode 100644 --- a/src/Vision/Image/Storage.hsc +++ /dev/null @@ -1,381 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances - , ForeignFunctionInterface, MultiParamTypeClasses #-} - --- | Uses the DevIL C library to read and write images from and to files. --- --- /Note:/ As the underlier DevIL library is *not* tread-safe, there is a global --- lock which will prevent two load/save calls to be performed at the same time. -module Vision.Image.Storage ( - ImageType (..), StorageImage (..), StorageError (..), load, loadBS, save - ) where - -import Control.Applicative ((<$>)) -import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar) -import Control.Monad (when) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (Error (..), ErrorT, runErrorT, throwError) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS -import Data.Convertible (Convertible (..), convert) -import Data.Int -import Data.Vector.Storable (unsafeFromForeignPtr0, unsafeWith) -import Data.Word -import Foreign.C.String (CString, withCString) -import Foreign.Concurrent (newForeignPtr) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (peek) -import System.IO.Unsafe (unsafePerformIO) - -import Vision.Image.Grey (Grey, GreyPixel) -import Vision.Image.RGBA (RGBA, RGBAPixel) -import Vision.Image.RGB (RGB, RGBPixel) -import Vision.Image.Type (Manifest (..), Delayed (..), delay, nChannels) -import Vision.Primitive (Z (..), (:.) (..), ix2) - -data StorageImage = GreyStorage Grey | RGBAStorage RGBA | RGBStorage RGB - -data ImageType = BMP | CUT - | DDS -- ^ DirectDraw Surface (.dds). - | Doom -- ^ Doom texture. - | DoomFlat -- ^ Doom flat texture (floor). - | GIF | ICO | JPG - | LIF -- ^ Homeworld (.lif). - | MNG | PCD | PCX | PIC | PNG - | PNM -- ^ Portable AnyMap (.pbm, .pgm or .ppm). - | PSD | PSP | SGI | TGA | TIFF - | RAW -- Raw data with a 13-byte header. - deriving (Eq, Show) - -data StorageError = FailedToInit -- ^ Failed to initialise the library. - | FailedToOpenFile -- ^ Failed to open the given file. - | InvalidType -- ^ The file could not be loaded based - -- on extension or header. - | OutOfMemory -- ^ Could not allocate memory for the new - -- image data. - | FailedToLoad -- ^ Failed to load the image, invalid - -- format. - | FailedToHaskell -- ^ Failed to convert the loaded image to - -- its Haskell representation. - | FailedToDevil -- ^ Failed to write the image content - -- through the inner DevIL library. - | FailedToSave -- ^ Could not open the file for writing. - | UnknownError (Maybe String) - deriving (Eq) - -type StorageMonad = ErrorT StorageError IO - -instance Convertible StorageImage StorageImage where - safeConvert = Right - -instance Convertible (Manifest GreyPixel) StorageImage where - safeConvert = Right . GreyStorage - -instance Convertible (Manifest RGBAPixel) StorageImage where - safeConvert = Right . RGBAStorage - -instance Convertible (Manifest RGBPixel) StorageImage where - safeConvert = Right . RGBStorage - -instance Convertible StorageImage (Manifest GreyPixel) where - safeConvert (GreyStorage img) = Right img - safeConvert (RGBAStorage img) = Right $ convert img - safeConvert (RGBStorage img) = Right $ convert img - -instance Convertible StorageImage (Manifest RGBAPixel) where - safeConvert (GreyStorage img) = Right $ convert img - safeConvert (RGBAStorage img) = Right img - safeConvert (RGBStorage img) = Right $ convert img - -instance Convertible StorageImage (Manifest RGBPixel) where - safeConvert (GreyStorage img) = Right $ convert img - safeConvert (RGBAStorage img) = Right $ convert img - safeConvert (RGBStorage img) = Right img - -instance Convertible StorageImage (Delayed GreyPixel) where - safeConvert (GreyStorage img) = Right $ delay img - safeConvert (RGBAStorage img) = Right $ convert img - safeConvert (RGBStorage img) = Right $ convert img - -instance Convertible StorageImage (Delayed RGBAPixel) where - safeConvert (GreyStorage img) = Right $ convert img - safeConvert (RGBAStorage img) = Right $ delay img - safeConvert (RGBStorage img) = Right $ convert img - -instance Convertible StorageImage (Delayed RGBPixel) where - safeConvert (GreyStorage img) = Right $ convert img - safeConvert (RGBAStorage img) = Right $ convert img - safeConvert (RGBStorage img) = Right $ delay img - -instance Error StorageError where - noMsg = UnknownError Nothing - strMsg = UnknownError . Just - -instance Show StorageError where - show FailedToInit = "Failed to initialise the DevIL library." - show FailedToOpenFile = "Failed to open the given file." - show InvalidType = - "The file could not be loaded based on extension or header." - show OutOfMemory = "Could not allocate memory for the new image data." - show FailedToLoad = "Failed to load the image." - show FailedToHaskell = - "Failed to convert the loaded image to its Haskell representation." - show FailedToDevil = - "Failed to write the image content through the inner DevIL library." - show FailedToSave = "Could not open the file for writing." - show (UnknownError (Just msg)) = msg - show (UnknownError Nothing ) = "Unknown error." - --- | Reads an image into a manifest vector from a file. --- --- If no image type is given, type will be determined automatically. -load :: Maybe ImageType -> FilePath -> IO (Either StorageError StorageImage) -load mType path = - lockDevil $ - bindAndLoad $ - withCString path $ \cPath -> - ilLoadC (toIlType mType) cPath - --- | Reads an image into a manifest vector from a strict 'ByteString'. --- --- If no image type is given, type will be determined automatically. --- TIFF images are not supported. -loadBS :: Maybe ImageType -> BS.ByteString - -> IO (Either StorageError StorageImage) -loadBS (Just TIFF) _ = return $ Left FailedToLoad -loadBS mType bs = - lockDevil $ - bindAndLoad $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - ilLoadLC (toIlType mType) ptr (fromIntegral len) - --- | Saves the image to the given file. --- --- /Note:/ The image type is determined by the filename extension. --- Will fail if the file already exists. -save :: (Convertible i StorageImage) => FilePath -> i -> IO (Maybe StorageError) -save path img = lockDevil $ do - res <- runErrorT $ do - ilInit - name <- ilGenImageName - ilBindImage name - - toDevil $ convert img - ilSaveImage path - - ilDeleteImage name - - return $ case res of Right () -> Nothing - Left err -> Just err - --- C wrappers and helpers ------------------------------------------------------ - -devilLock :: MVar () -devilLock = unsafePerformIO $ newMVar () -{-# NOINLINE devilLock #-} - --- | Uses a global lock ('devilLock') to prevent two threads to call the --- library at the same time. -lockDevil :: IO a -> IO a -lockDevil action = do - takeMVar devilLock - ret <- action - putMVar devilLock () - return ret - --- | Allocates a new image name, executes the given action to load the image --- and then converts it into its Haskell representation. -bindAndLoad :: IO ILboolean -> IO (Either StorageError StorageImage) -bindAndLoad action = runErrorT $ do - ilInit - name <- ilGenImageName - ilBindImage name - - res <- lift action - when (res == 0) $ do - err <- lift ilGetErrorC - throwError $ case err of - (#const IL_COULD_NOT_OPEN_FILE) -> FailedToOpenFile - (#const IL_INVALID_EXTENSION) -> InvalidType - (#const IL_INVALID_FILE_HEADER) -> InvalidType - (#const IL_OUT_OF_MEMORY) -> OutOfMemory - _ -> FailedToLoad - - fromDevil name - -toIlType :: Maybe ImageType -> ILenum -toIlType (Just BMP) = (#const IL_BMP) -toIlType (Just CUT) = (#const IL_CUT) -toIlType (Just DDS) = (#const IL_DDS) -toIlType (Just Doom) = (#const IL_DOOM) -toIlType (Just DoomFlat) = (#const IL_DOOM_FLAT) -toIlType (Just GIF) = (#const IL_GIF) -toIlType (Just ICO) = (#const IL_ICO) -toIlType (Just JPG) = (#const IL_JPG) -toIlType (Just LIF) = (#const IL_LIF) -toIlType (Just MNG) = (#const IL_MNG) -toIlType (Just PCD) = (#const IL_PCD) -toIlType (Just PCX) = (#const IL_PCX) -toIlType (Just PIC) = (#const IL_PIC) -toIlType (Just PNG) = (#const IL_PNG) -toIlType (Just PNM) = (#const IL_PNM) -toIlType (Just PSD) = (#const IL_PSD) -toIlType (Just PSP) = (#const IL_PSP) -toIlType (Just SGI) = (#const IL_SGI) -toIlType (Just TGA) = (#const IL_TGA) -toIlType (Just TIFF) = (#const IL_TIF) -toIlType (Just RAW) = (#const IL_RAW) -toIlType Nothing = (#const IL_TYPE_UNKNOWN) - -#include "IL/il.h" - -type ILuint = #type ILuint -type ILsizei = #type ILsizei -type ILboolean = #type ILboolean -type ILenum = #type ILenum -type ILint = #type ILint -type ILubyte = #type ILubyte - --- DevIL uses unsigned integers as names for each image in processing. -newtype ImageName = ImageName ILuint - deriving (Show) - -foreign import ccall unsafe "ilInit" ilInitC :: IO () -foreign import ccall unsafe "ilGetError" ilGetErrorC :: IO ILenum -foreign import ccall unsafe "ilOriginFunc" ilOriginFuncC - :: ILenum -> IO ILboolean -foreign import ccall unsafe "ilEnable" ilEnableC :: ILenum -> IO ILboolean - -il_RGB, il_RGBA, il_LUMINANCE :: ILenum -il_RGB = (#const IL_RGB) -il_RGBA = (#const IL_RGBA) -il_LUMINANCE = (#const IL_LUMINANCE) - -il_IMAGE_HEIGHT, il_IMAGE_WIDTH :: ILenum -il_IMAGE_FORMAT, il_IMAGE_TYPE :: ILenum -il_IMAGE_HEIGHT = (#const IL_IMAGE_HEIGHT) -il_IMAGE_WIDTH = (#const IL_IMAGE_WIDTH) -il_IMAGE_FORMAT = (#const IL_IMAGE_FORMAT) -il_IMAGE_TYPE = (#const IL_IMAGE_TYPE) - -il_UNSIGNED_BYTE :: ILenum -il_UNSIGNED_BYTE = (#const IL_UNSIGNED_BYTE) - --- | Initialize the library. -ilInit :: StorageMonad () -ilInit = do - lift ilInitC - - -- By default, origin is undefined and depends on the image type - ilOriginFuncC (#const IL_ORIGIN_LOWER_LEFT) FailedToInit - ilEnableC (#const IL_ORIGIN_SET) FailedToInit - -foreign import ccall unsafe "ilGenImages" ilGenImagesC - :: ILsizei -> Ptr ILuint -> IO () - --- | Allocates a new image name. -ilGenImageName :: StorageMonad ImageName -ilGenImageName = lift $ do - alloca $ \pName -> do - ilGenImagesC 1 pName - name <- peek pName - return $! ImageName name - -foreign import ccall unsafe "ilBindImage" ilBindImageC :: ILuint -> IO () - --- | Sets the image name as the current image for processing. -ilBindImage :: ImageName -> StorageMonad () -ilBindImage (ImageName name) = lift $ ilBindImageC name - -foreign import ccall unsafe "ilLoad" ilLoadC :: ILenum -> CString - -> IO ILboolean -foreign import ccall unsafe "ilLoadL" ilLoadLC :: ILenum -> CString -> ILuint - -> IO ILboolean - -foreign import ccall unsafe "ilGetInteger" ilGetIntegerC :: ILenum -> IO ILint -foreign import ccall unsafe "ilConvertImage" ilConvertImageC - :: ILenum -> ILenum -> IO ILboolean -foreign import ccall unsafe "ilGetData" ilGetDataC :: IO (Ptr ILubyte) -foreign import ccall unsafe "ilDeleteImages" ilDeleteImagesC - :: ILsizei -> Ptr ILuint -> IO () - --- | Puts the current image inside a 'Vector'. -fromDevil :: ImageName -> StorageMonad StorageImage -fromDevil (ImageName name) = do - format <- ilGetInteger il_IMAGE_FORMAT - w <- ilGetInteger il_IMAGE_WIDTH - h <- ilGetInteger il_IMAGE_HEIGHT - let !size = ix2 h w - - case format of - _ | format == il_RGB -> do - convertChannels il_RGB - RGBStorage <$> toManifest size - | format == il_RGBA -> do - convertChannels il_RGBA - RGBAStorage <$> toManifest size - | format == il_RGBA -> do - convertChannels il_LUMINANCE - GreyStorage <$> toManifest size - | otherwise -> do -- Unsupported formats are converted to RGBA. - ilConvertImage il_RGBA il_UNSIGNED_BYTE - RGBAStorage <$> toManifest size - where - -- Converts the image to the given format if the pixel type isn't Word8. - convertChannels destFormat = do - pixelType <- ilGetInteger il_IMAGE_TYPE - when (pixelType /= il_UNSIGNED_BYTE) $ - ilConvertImage destFormat il_UNSIGNED_BYTE - - -- Converts the C vector of unsigned bytes to a garbage collected 'Vector' - -- inside a 'Manifest' image. - toManifest size@(Z :. h :. w) = lift $ do - pixels <- castPtr <$> ilGetDataC - managedPixels <- newForeignPtr pixels (with name (ilDeleteImagesC 1)) - return $! Manifest size (unsafeFromForeignPtr0 managedPixels (w * h)) - - ilGetInteger mode = lift $ fromIntegral <$> ilGetIntegerC mode - - ilConvertImage format pixelType = do - ilConvertImageC format pixelType FailedToHaskell - --- | Removes the image and any allocated memory. -ilDeleteImage :: ImageName -> StorageMonad () -ilDeleteImage (ImageName name) = lift $ with name (ilDeleteImagesC 1) - -foreign import ccall unsafe "ilTexImage" ilTexImageC - :: ILuint -> ILuint -> ILuint -- w h depth - -> ILubyte -> ILenum -> ILenum -- numberOfChannels format type - -> Ptr () -- data (copy from this pointer) - -> IO ILboolean - --- | Sets the current DevIL image to the vector's internal array. -toDevil :: StorageImage -> StorageMonad () -toDevil storImg = - case storImg of GreyStorage img -> writeManifest img il_LUMINANCE - RGBAStorage img -> writeManifest img il_RGBA - RGBStorage img -> writeManifest img il_RGB - where - writeManifest img@(Manifest (Z :. h :. w) vec) format = - (unsafeWith vec $ \p -> - ilTexImageC (fromIntegral w) (fromIntegral h) 1 - (fromIntegral $ nChannels img) - format il_UNSIGNED_BYTE (castPtr p) - ) FailedToDevil - -foreign import ccall unsafe "ilSaveImage" ilSaveImageC - :: CString -> IO ILboolean - --- | Saves the current image. -ilSaveImage :: FilePath -> StorageMonad () -ilSaveImage file = withCString file ilSaveImageC FailedToSave - -infix 0 --- | Wraps a breakable DevIL action (which returns 0 on failure) in the --- 'StorageMonad'. Throws the given error in the monad if the action fails. -() :: IO ILboolean -> StorageError -> StorageMonad () -action err = do - res <- lift action - when (res == 0) $ - throwError err diff --git a/src/Vision/Image/Threshold.hs b/src/Vision/Image/Threshold.hs --- a/src/Vision/Image/Threshold.hs +++ b/src/Vision/Image/Threshold.hs @@ -1,44 +1,78 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, GADTs #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts + , GADTs #-} module Vision.Image.Threshold ( - ThresholdType (..) + -- * Simple threshold + ThresholdType (..), thresholdType , threshold - , AdaptiveThresholdKernel (..), adaptiveThreshold - , otsu + -- * Adaptive threshold + , AdaptiveThresholdKernel (..), AdaptiveThreshold + , adaptiveThreshold, adaptiveThresholdFilter + -- * Other methods + , otsu, scw ) where +import Data.Int import Foreign.Storable (Storable) -import Vision.Image.Filter (Filter (..), SeparableFilter, blur, gaussianBlur) -import Vision.Image.Type (ImagePixel, FunctorImage) -import Vision.Histogram -import Vision.Histogram as H -import Vision.Primitive.Shape (shapeLength) -import qualified Vision.Image.Type as I - import qualified Data.Vector.Storable as V import qualified Data.Vector as VU +import Vision.Image.Class ( + Image, ImagePixel, FromFunction (..), FunctorImage, (!), shape + ) +import Vision.Image.Filter.Internal ( + Filter (..), BoxFilter, Kernel (..), SeparableFilter, SeparatelyFiltrable + , KernelAnchor (KernelAnchorCenter), FilterFold (..) + , BorderInterpolate (BorderReplicate) + , apply, blur, gaussianBlur, Mean, mean + ) +import Vision.Image.Type (Manifest, delayed, manifest) +import Vision.Histogram ( + HistogramShape, PixelValueSpace, ToHistogram, histogram + ) +import Vision.Primitive (Z (..), (:.) (..), Size, shapeLength) + +import qualified Vision.Histogram as H +import qualified Vision.Image.Class as I + -- | Specifies what to do with pixels matching the threshold predicate. -- -- @'BinaryThreshold' a b@ will replace matching pixels by @a@ and non-matchings -- pixels by @b@. -- -- @'Truncate' a@ will replace matching pixels by @a@. +-- +-- @'TruncateInv' a@ will replace non-matching pixels by @a@. data ThresholdType src res where BinaryThreshold :: res -> res -> ThresholdType src res Truncate :: src -> ThresholdType src src + TruncateInv :: src -> ThresholdType src src +-- | Given the thresholding method, a boolean indicating if the pixel match the +-- thresholding condition and the pixel, returns the new pixel value. +thresholdType :: ThresholdType src res -> Bool -> src -> res +thresholdType (BinaryThreshold ifTrue ifFalse) match _ | match = ifTrue + | otherwise = ifFalse +thresholdType (Truncate ifTrue) match pix | match = ifTrue + | otherwise = pix +thresholdType (TruncateInv ifFalse) match pix | match = pix + | otherwise = ifFalse +{-# INLINE thresholdType #-} + +-- ----------------------------------------------------------------------------- + -- | Applies the given predicate and threshold policy on the image. threshold :: FunctorImage src res => (ImagePixel src -> Bool) -> ThresholdType (ImagePixel src) (ImagePixel res) -> src -> res -threshold !cond !(BinaryThreshold ifTrue ifFalse) !img = - I.map (\pix -> if cond pix then ifTrue else ifFalse) img -threshold !cond !(Truncate ifTrue) !img = - I.map (\pix -> if cond pix then ifTrue else pix) img +threshold !cond !thresType = + I.map (\pix -> thresholdType thresType (cond pix) pix) {-# INLINE threshold #-} +-- ----------------------------------------------------------------------------- + -- | Defines how pixels of the kernel of the adaptive threshold will be -- weighted. -- @@ -52,34 +86,62 @@ GaussianKernel :: (Floating acc, RealFrac acc) => Maybe acc -> AdaptiveThresholdKernel acc --- | Applies a thresholding adaptively. +-- | Compares every pixel to its surrounding ones in the kernel of the given +-- radius. +adaptiveThreshold :: ( Image src, Integral (ImagePixel src) + , Ord (ImagePixel src) + , FromFunction res, Integral (FromFunctionPixel res) + , Storable acc + , SeparatelyFiltrable src res acc) + => AdaptiveThresholdKernel acc + -> Int + -- ^ Kernel radius. + -> ImagePixel src + -- ^ Minimum difference between the pixel and the kernel + -- average. The pixel is thresholded if + -- @pixel_value - kernel_mean > difference@ where difference + -- is this number. Can be negative. + -> ThresholdType (ImagePixel src) (FromFunctionPixel res) + -> src + -> res +adaptiveThreshold kernelType radius thres thresType img = + adaptiveThresholdFilter kernelType radius thres thresType `apply` img +{-# INLINABLE adaptiveThreshold #-} + +type AdaptiveThreshold src acc res = SeparableFilter src () acc res + +-- | Creates an adaptive thresholding filter to be used with 'apply'. -- +-- Use 'adaptiveThreshold' if you only want to apply the filter on the image. +-- -- Compares every pixel to its surrounding ones in the kernel of the given -- radius. -adaptiveThreshold :: (Integral src, Num src, Ord src, Storable acc) - => AdaptiveThresholdKernel acc - -> Int -- ^ Kernel radius. - -> src -- ^ Minimum difference between the pixel and the - -- kernel average. The pixel is thresholded if - -- @pixel_value - kernel_mean > difference@ where - -- difference if this number. Can be negative. - -> ThresholdType src res -> SeparableFilter src acc res -adaptiveThreshold !kernelType !radius !thres !thresType = +adaptiveThresholdFilter :: (Integral src, Ord src, Storable acc) + => AdaptiveThresholdKernel acc + -> Int + -- ^ Kernel radius. + -> src + -- ^ Minimum difference between the pixel and the kernel + -- average. The pixel is thresholded if + -- @pixel_value - kernel_mean > difference@ where + -- difference is this number. Can be negative. + -> ThresholdType src res + -> AdaptiveThreshold src acc res +adaptiveThresholdFilter !kernelType !radius !thres !thresType = kernelFilter { fPost = post } where !kernelFilter = case kernelType of MeanKernel -> blur radius GaussianKernel sig -> gaussianBlur radius sig - post !pix !acc = - let !acc' = (fPost kernelFilter) pix acc + post ix pix ini acc = + let !acc' = (fPost kernelFilter) ix pix ini acc !cond = (pix - acc') > thres - in case thresType of - BinaryThreshold ifTrue ifFalse -> if cond then ifTrue - else ifFalse - Truncate ifTrue -> if cond then ifTrue else pix -{-# INLINE adaptiveThreshold #-} + in thresholdType thresType cond pix +{-# INLINE adaptiveThresholdFilter #-} +-- ----------------------------------------------------------------------------- + -- | Applies a clustering-based image thresholding using the Otsu's method. -- -- See . @@ -114,6 +176,62 @@ !two = 2 :: Int {-# INLINABLE otsu #-} + +-- ----------------------------------------------------------------------------- + +-- | This is a sliding concentric window filter (SCW) that uses the ratio of the +-- standard deviations of two sliding windows centered on a same point to detect +-- regions of interest (ROI). +-- +-- > scw sizeWindowA sizeWindowB beta thresType img +-- +-- Let @σA@ be the standard deviation of a fist window around a pixel and @σB@ +-- be the standard deviation of another window around the same pixel. +-- Then the pixel will match the threshold if @σB / σA >= beta@, and will be +-- thresholded according to the given 'ThresholdType'. +-- +-- See . +scw :: ( Image src, Integral (ImagePixel src), FromFunction dst + , Floating stdev, Fractional stdev, Ord stdev, Storable stdev) + => Size -> Size -> stdev + -> ThresholdType (ImagePixel src) (FromFunctionPixel dst) -> src -> dst +scw !sizeA !sizeB !beta !thresType !img = + betaThreshold (stdDev sizeA) (stdDev sizeB) + where + betaThreshold a b = + fromFunction (shape img) $ \pt -> + let !cond = (b ! pt) / (a ! pt) < beta + in thresholdType thresType cond (img ! pt) + + stdDev size = + let filt :: (Integral src, Fractional res) => Mean src Int16 res + filt = mean size + !meanImg = manifest $ apply filt img + !varImg = manifest $ apply (variance size meanImg) img + in delayed $ I.map sqrt varImg +{-# INLINABLE scw #-} + +-- | Given a mean image and an original image, computes the variance of the +-- kernel of the given size. +-- +-- @average [ (origPix - mean)^2 | origPix <- kernel pixels on original ]@. +variance :: (Integral src, Fractional res, Storable res) + => Size -> Manifest res -> BoxFilter src res res res +variance !size@(Z :. h :. w) !meanImg = + Filter size KernelAnchorCenter (Kernel kernel) (\pt _ -> meanImg ! pt) + (FilterFold (const 0)) post BorderReplicate + where + kernel !kernelMean _ !val !acc = + acc + square (fromIntegral val - kernelMean) + + !nPixsFactor = 1 / (fromIntegral $! h * w) + post _ _ _ !acc = acc * nPixsFactor +{-# INLINABLE variance #-} + +-- ----------------------------------------------------------------------------- + +square :: Num a => a -> a +square a = a * a double :: Integral a => a -> Double double = fromIntegral diff --git a/src/Vision/Image/Transform.hs b/src/Vision/Image/Transform.hs --- a/src/Vision/Image/Transform.hs +++ b/src/Vision/Image/Transform.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE BangPatterns + , FlexibleContexts + , TypeFamilies #-} -- | Provides high level functions to do geometric transformations on images. -- @@ -12,11 +14,11 @@ import Control.Monad.Primitive (PrimMonad (..)) import Data.RatioInt (RatioInt, (%)) +import Vision.Image.Class ( + MaskedImage (..), Image (..), ImageChannel, FromFunction (..), (!) + ) import Vision.Image.Interpolate (Interpolable, bilinearInterpol) import Vision.Image.Mutable (MutableImage (..)) -import Vision.Image.Type ( - MaskedImage (..), Image (..), ImageChannel, FromFunction (..) - ) import Vision.Primitive ( Z (..), (:.) (..), Point, RPoint (..), Rect (..), Size, ix2, toLinearIndex ) @@ -34,7 +36,7 @@ => Rect -> i1 -> i2 crop !(Rect rx ry rw rh) !img = fromFunction (Z :. rh :. rw) $ \(Z :. y :. x) -> - img `index` ix2 (ry + y) (rx + x) + img ! ix2 (ry + y) (rx + x) {-# INLINABLE crop #-} -- | Resizes the 'Image' using the given interpolation method. @@ -51,7 +53,7 @@ col !x' = truncate $ (double x' + 0.5) * widthRatio - 0.5 {-# INLINE col #-} f !y !(Z :. _ :. x') = let !x = col x' - in img `index` ix2 y x + in img ! ix2 y x {-# INLINE f #-} in fromFunctionLine size' line f NearestNeighbor -> @@ -62,7 +64,7 @@ col !x' = round $ (double x' + 0.5) * widthRatio - 0.5 {-# INLINE col #-} f !y !(Z :. _ :. x') = let !x = col x' - in img `index` ix2 y x + in img ! ix2 y x {-# INLINE f #-} in fromFunctionLine size' line f Bilinear -> @@ -95,7 +97,7 @@ => i1 -> i2 horizontalFlip !img = let f !(Z :. y :. x') = let !x = maxX - x' - in img `index` ix2 y x + in img ! ix2 y x {-# INLINE f #-} in fromFunction size f where @@ -110,7 +112,7 @@ verticalFlip !img = let line !y' = maxY - y' {-# INLINE line #-} - f !y !(Z :. _ :. x) = img `index` ix2 y x + f !y !(Z :. _ :. x) = img ! ix2 y x {-# INLINE f #-} in fromFunctionLine size line f where diff --git a/src/Vision/Image/Type.hs b/src/Vision/Image/Type.hs --- a/src/Vision/Image/Type.hs +++ b/src/Vision/Image/Type.hs @@ -1,245 +1,63 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances - , MultiParamTypeClasses, PatternGuards, TypeFamilies +{-# 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 (..) + Manifest (..) -- * Delayed images , Delayed (..) -- * Delayed masked images , DelayedMask (..) - -- * Functions - , nChannels, pixel - -- * Conversion - , Convertible (..), convert, delay, compute - -- * Types helpers - , delayed, manifest + -- * Conversion and type helpers + , delay, compute, delayed, manifest ) where import Control.Applicative ((<$>)) -import Data.Convertible (Convertible (..), convert) -import Data.Int -import Data.Vector.Storable ( - Vector, (!), create, enumFromN, forM_, generate, unfoldr - ) +import Control.DeepSeq (NFData (..)) +import Data.Vector.Storable (Vector, create, enumFromN, forM_, generate) import Data.Vector.Storable.Mutable (new, write) -import Data.Word import Foreign.Storable (Storable) import Prelude hiding (map, read) -import Vision.Primitive ( - Z (..), (:.) (..), Point, Size - , ix2, fromLinearIndex, toLinearIndex, shapeLength - ) - --- Classes --------------------------------------------------------------------- - --- | Determines the number of channels and the type of each pixel of the image --- and how images are represented. -class Storable p => Pixel p where - type PixelChannel p - - -- | Returns the number of channels of the pixel. - -- Must not consume 'p' (could be 'undefined'). - pixNChannels :: p -> Int - - pixIndex :: p -> Int -> PixelChannel p - -instance Pixel Int16 where - type PixelChannel Int16 = Int16 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Int32 where - type PixelChannel Int32 = Int32 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Int where - type PixelChannel Int = Int - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word8 where - type PixelChannel Word8 = Word8 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word16 where - type PixelChannel Word16 = Word16 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word32 where - type PixelChannel Word32 = Word32 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word where - type PixelChannel Word = Word - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Float where - type PixelChannel Float = Float - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Double where - type PixelChannel Double = Double - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Bool where - type PixelChannel Bool = Bool - pixNChannels _ = 1 - pixIndex p _ = p - --- | Provides an abstraction for images which are not defined for each of their --- pixels. The interface is similar to 'Image' except that indexing functions --- don't always return. --- Image origin is located in the lower left corner. -class Pixel (ImagePixel i) => MaskedImage i where - type ImagePixel i - - shape :: i -> Size - - -- | Returns the pixel\'s value at 'Z :. y, :. x'. - maskedIndex :: i -> Point -> Maybe (ImagePixel i) - maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img) - {-# INLINE maskedIndex #-} - - -- | Returns the pixel\'s value as if the image was a single dimension - -- vector (row-major representation). - maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i) - maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img) - {-# INLINE maskedLinearIndex #-} - - -- | Returns the non-masked values of the image. - values :: i -> Vector (ImagePixel i) - values !img = - unfoldr step 0 - where - !n = shapeLength (shape img) - - step !i | i >= n = Nothing - | Just p <- img `maskedLinearIndex` i = Just (p, i + 1) - | otherwise = step (i + 1) - {-# INLINE values #-} - - {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} - -type ImageChannel i = PixelChannel (ImagePixel i) - --- | Provides an abstraction over the internal representation of an image. --- Image origin is located in the lower left corner. -class MaskedImage i => Image i where - -- | Returns the pixel value at 'Z :. y :. x'. - index :: i -> Point -> ImagePixel i - index img = (img `linearIndex`) . toLinearIndex (shape img) - {-# INLINE index #-} - - -- | Returns the pixel value as if the image was a single dimension vector - -- (row-major representation). - linearIndex :: i -> Int -> ImagePixel i - linearIndex img = (img `index`) . fromLinearIndex (shape img) - {-# INLINE linearIndex #-} - - -- | Returns every pixel values as if the image was a single dimension - -- vector (row-major representation). - vector :: i -> Vector (ImagePixel i) - vector img = generate (shapeLength $ shape img) (img `linearIndex`) - {-# INLINE vector #-} - - {-# MINIMAL index | linearIndex #-} - --- | Provides ways to construct an image from a function. -class FromFunction i where - type FromFunctionPixel i - - -- | Generates an image by calling the given function for each pixel of the - -- constructed image. - fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i - - -- | Generates an image by calling the last function for each pixel of the - -- constructed image. - -- The first function is called for each line, generating a line invariant - -- value. - -- This function is faster for some image representations as some recurring - -- computation can be cached. - fromFunctionLine :: Size -> (Int -> a) - -> (a -> Point -> FromFunctionPixel i) -> i - fromFunctionLine size line f = - fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt) - {-# INLINE fromFunctionLine #-} - - -- | Generates an image by calling the last function for each pixel of the - -- constructed image. - -- The first function is called for each column, generating a column - -- invariant value. - -- This function *can* be faster for some image representations as some - -- recurring computations can be cached. However, it may requires a vector - -- allocation for these values. If the column invariant is cheap to - -- compute, prefer 'fromFunction'. - fromFunctionCol :: Storable b => Size -> (Int -> b) - -> (b -> Point -> FromFunctionPixel i) -> i - fromFunctionCol size col f = - fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt) - {-# INLINE fromFunctionCol #-} - - -- | Generates an image by calling the last function for each pixel of the - -- constructed image. - -- The two first functions are called for each line and for each column, - -- respectively, generating common line and column invariant values. - -- This function is faster for some image representations as some recurring - -- computation can be cached. However, it may requires a vector - -- allocation for column values. If the column invariant is cheap to - -- compute, prefer 'fromFunctionLine'. - fromFunctionCached :: Storable b => Size - -> (Int -> a) -- ^ Line function - -> (Int -> b) -- ^ Column function - -> (a -> b -> Point - -> FromFunctionPixel i) -- ^ Pixel function - -> i - fromFunctionCached size line col f = - fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt) - {-# INLINE fromFunctionCached #-} - - {-# MINIMAL fromFunction #-} +import qualified Data.Vector.Storable as V --- | Defines a class for images on which a function can be applied. The class is --- different from 'Functor' as there could be some constraints and --- transformations the pixel and image types. -class (MaskedImage src, MaskedImage res) => FunctorImage src res where - map :: (ImagePixel src -> ImagePixel res) -> src -> res +import Vision.Image.Class ( + MaskedImage (..), Image (..), FromFunction (..), FunctorImage (..) + , Convertible (..), (!), convert + ) +import Vision.Primitive (Z (..), (:.) (..), Point, Size, ix2) -- Manifest images ------------------------------------------------------------- -- | Stores the image content in a 'Vector'. -data Storable p => Manifest p = Manifest { +data Manifest p = Manifest { manifestSize :: !Size , manifestVector :: !(Vector p) } deriving (Eq, Ord, Show) -instance Pixel p => MaskedImage (Manifest p) where +instance NFData (Manifest p) where + rnf !_ = () + +instance Storable p => MaskedImage (Manifest p) where type ImagePixel (Manifest p) = p shape = manifestSize {-# INLINE shape #-} - Manifest _ vec `maskedLinearIndex` ix = Just $! vec ! ix + Manifest _ vec `maskedLinearIndex` ix = Just $! vec V.! ix {-# INLINE maskedLinearIndex #-} values = manifestVector {-# INLINE values #-} -instance Pixel p => Image (Manifest p) where - Manifest _ vec `linearIndex` ix = vec ! ix +instance Storable p => Image (Manifest p) where + Manifest _ vec `linearIndex` ix = vec V.! ix {-# INLINE linearIndex #-} vector = manifestVector @@ -287,7 +105,7 @@ let !lineOffset = y * w forM_ (enumFromN 0 w) $ \x -> do let !offset = lineOffset + x - !val = f (cols ! x) (ix2 y x) + !val = f (cols V.! x) (ix2 y x) write arr offset val return arr @@ -305,7 +123,7 @@ !lineOffset = y * w forM_ (enumFromN 0 w) $ \x -> do let !offset = lineOffset + x - !val = f lineVal (cols ! x) (ix2 y x) + !val = f lineVal (cols V.! x) (ix2 y x) write arr offset val return arr @@ -313,8 +131,8 @@ !cols = generate w col {-# INLINE fromFunctionCached #-} -instance (Image src, Pixel p) => FunctorImage src (Manifest p) where - map f img = fromFunction (shape img) (f . (img `index`)) +instance (Image src, Storable p) => FunctorImage src (Manifest p) where + map f img = fromFunction (shape img) (f . (img !)) {-# INLINE map #-} -- Delayed images -------------------------------------------------------------- @@ -330,7 +148,7 @@ , delayedFun :: !(Point -> p) } -instance Pixel p => MaskedImage (Delayed p) where +instance Storable p => MaskedImage (Delayed p) where type ImagePixel (Delayed p) = p shape = delayedSize @@ -339,7 +157,7 @@ maskedIndex img = Just . delayedFun img {-# INLINE maskedIndex #-} -instance Pixel p => Image (Delayed p) where +instance Storable p => Image (Delayed p) where index = delayedFun {-# INLINE index #-} @@ -349,8 +167,8 @@ fromFunction = Delayed {-# INLINE fromFunction #-} -instance (Image src, Pixel p) => FunctorImage src (Delayed p) where - map f img = fromFunction (shape img) (f . (img `index`)) +instance (Image src, Storable p) => FunctorImage src (Delayed p) where + map f img = fromFunction (shape img) (f . (img !)) {-# INLINE map #-} -- Masked delayed images ------------------------------------------------------- @@ -360,7 +178,7 @@ , delayedMaskFun :: !(Point -> Maybe p) } -instance Pixel p => MaskedImage (DelayedMask p) where +instance Storable p => MaskedImage (DelayedMask p) where type ImagePixel (DelayedMask p) = p shape = delayedMaskSize @@ -369,31 +187,18 @@ maskedIndex = delayedMaskFun {-# INLINE maskedIndex #-} -instance Pixel p => FromFunction (DelayedMask p) where +instance Storable p => FromFunction (DelayedMask p) where type FromFunctionPixel (DelayedMask p) = Maybe p fromFunction = DelayedMask {-# INLINE fromFunction #-} -instance (MaskedImage src, Pixel p) => FunctorImage src (DelayedMask p) where +instance (MaskedImage src, Storable p) => FunctorImage src (DelayedMask p) where map f img = fromFunction (shape img) (\pt -> f <$> (img `maskedIndex` pt)) {-# INLINE map #-} --- Functions ------------------------------------------------------------------- --- | Returns the number of channels of an image. -nChannels :: MaskedImage i => i -> Int -nChannels img = pixNChannels (pixel img) -{-# INLINE nChannels #-} - --- | Returns an 'undefined' instance of a pixel of the image. This is sometime --- useful to satisfy the type checker as in a call to 'pixNChannels' : --- --- > nChannels img = pixNChannels (pixel img) -pixel :: MaskedImage i => i -> ImagePixel i -pixel _ = undefined - --- Conversion ------------------------------------------------------------------ +-- Conversion and type helpers ------------------------------------------------- -- | Delays an image in its delayed representation. delay :: Image i => i -> Delayed (ImagePixel i) @@ -405,32 +210,30 @@ compute = map id {-# INLINE compute #-} -instance (Pixel p1, Pixel p2, Storable p1, Storable p2, Convertible p1 p2) +instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Manifest p1) (Manifest p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} -instance (Pixel p1, Pixel p2, Convertible p1 p2) +instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Delayed p1) (Delayed p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} -instance (Pixel p1, Pixel p2, Storable p2, Convertible p1 p2) +instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Delayed p1) (Manifest p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} -instance (Pixel p1, Pixel p2, Storable p1, Convertible p1 p2) +instance (Storable p1, Storable p2, Convertible p1 p2) => Convertible (Manifest p1) (Delayed p2) where safeConvert = Right . map convert {-# INLINE safeConvert #-} --- Types helpers --------------------------------------------------------------------- - -- | Forces an image to be in its delayed represenation. Does nothing. delayed :: Delayed p -> Delayed p delayed = id --- | Forces an image to be in its delayed represenation. Does nothing. +-- | Forces an image to be in its manifest represenation. Does nothing. manifest :: Manifest p -> Manifest p manifest = id diff --git a/src/Vision/Primitive.hs b/src/Vision/Primitive.hs --- a/src/Vision/Primitive.hs +++ b/src/Vision/Primitive.hs @@ -9,8 +9,17 @@ import Vision.Primitive.Shape +-- | Coordinates inside the image. +-- +-- Can be constructed using 'ix2'. The first parameter is the y coordinate while +-- the second is the x coordinate (i.e. @'ix2' y x@). Image origin (@'ix2' 0 0@) +-- is located in the upper left corner. type Point = DIM2 +-- | Size of an object. +-- +-- Can be constructed using 'ix2'. The first parameter is the height while the +-- second is the width (i.e. @ix2 h w@). type Size = DIM2 data Rect = Rect { diff --git a/src/Vision/Primitive/Shape.hs b/src/Vision/Primitive/Shape.hs --- a/src/Vision/Primitive/Shape.hs +++ b/src/Vision/Primitive/Shape.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, TypeOperators #-} +{-# LANGUAGE BangPatterns + , FlexibleInstances + , TypeOperators #-} -- | 'Shape's are similar to what you could found in @repa@. 'Shape' are used -- both for indexes and shapes.