diff --git a/CV.cabal b/CV.cabal --- a/CV.cabal +++ b/CV.cabal @@ -1,5 +1,5 @@ Name: CV -Version: 0.3.5.3 +Version: 0.3.5.4 Description: OpenCV Bindings License: GPL License-file: LICENSE @@ -18,6 +18,8 @@ . Changelog. + 0.3.5.4 - Bug fixes and preliminary compatability with opencv 2.4 + . 0.3.5 - Many new wrappers, clean ups and other fixes. . 0.3.4 - Pixelwise operations, bug fixes and additional documentation @@ -47,8 +49,11 @@ examples/elaine.jpg Flag opencv23 Description: Compatability for opencv 2.3.1 - Default: False + Default: True +Flag opencv24 + Description: Compatability for opencv 2.4 + Default: False Library Build-Tools: c2hs >= 0.16.3 @@ -71,6 +76,9 @@ if flag(opencv23) cpp-options: -DOpenCV23 cc-options: -DOpenCV23 + if flag(opencv24) + cpp-options: -DOpenCV24 + cc-options: -DOpenCV24 cc-options: --std=c99 -U__BLOCKS__ extra-libraries: opencv_calib3d, opencv_contrib, @@ -100,7 +108,10 @@ bindings-DSL >= 1.0.14 && < 1.1, vector >= 0.7.0.1 && < 1.1, lazysmallcheck >= 0.5 && < 1, - storable-tuple >= 0.0.2 && <= 1 + parallel-io >= 0.3.2 && < 0.3.3, + storable-tuple >= 0.0.2 && <= 1, + filepath >= 1.3.0.0 && < 1.4 + Exposed-modules: CV.Image ,CV.Arbitrary ,CV.Binary diff --git a/CV/Bindings/Features.hsc b/CV/Bindings/Features.hsc --- a/CV/Bindings/Features.hsc +++ b/CV/Bindings/Features.hsc @@ -30,7 +30,9 @@ #field edgeBlurSize, Int #stoptype +#ifndef OpenCV24 #ccall wrapExtractMSER, Ptr -> Ptr -> Ptr (Ptr ) -> Ptr -> Ptr -> IO () +#endif #ccall cvMoments , Ptr -> Ptr -> Int -> IO () #ccall cvGetSpatialMoment, Ptr -> CInt -> CInt -> IO CDouble diff --git a/CV/Bindings/ImgProc.hsc b/CV/Bindings/ImgProc.hsc --- a/CV/Bindings/ImgProc.hsc +++ b/CV/Bindings/ImgProc.hsc @@ -53,6 +53,52 @@ (cBorderType border) (realToFrac value) +-- moments + +-- | Calculates all spatial and central moments up to the 3rd order +-- @ +-- CVAPI(void) cvMoments( +-- const CvArr* arr, +-- CvMoments* moments, +-- int binary CV_DEFAULT(0));@ + +#ccall cvMoments , Ptr -> Ptr -> CInt -> IO () + +-- | Retrieve particular spatial moment (m_xy) +-- @ +-- CVAPI(double) cvGetSpatialMoment( +-- CvMoments* moments, +-- int x_order, +-- int y_order );@ + +#ccall cvGetSpatialMoment , Ptr -> CInt -> CInt -> IO (CDouble) + +-- | Retrieve particular central moment (mu_xy) +-- @ +-- CVAPI(double) cvGetCentralMoment( +-- CvMoments* moments, +-- int x_order, +-- int y_order );@ + +#ccall cvGetCentralMoment , Ptr -> CInt -> CInt -> IO (CDouble) + +-- | Retrieve particular normalized central moment (eta_xy) +-- @ +-- CVAPI(double) cvGetNormalizedCentralMoment( +-- CvMoments* moments, +-- int x_order, +-- int y_order );@ + +#ccall cvGetNormalizedCentralMoment , Ptr -> CInt -> CInt -> IO (CDouble) + +-- | Calculates 7 Hu's invariants from precalculated spatial and central moments +-- @ +-- CVAPI(void) cvGetHuMoments( +-- CvMoments* moments, +-- CvHuMoments* hu_moments );@ + +#ccall cvGetHuMoments , Ptr -> Ptr -> IO () + -- CVAPI(void) cvCornerHarris( -- const CvArr* image, -- CvArr* harris_responce, @@ -73,6 +119,18 @@ -- double param1 CV_DEFAULT(0), -- double param2 CV_DEFAULT(0) -- ); +-- +-- CvSeq* cvHoughCircles( +-- CvArr* image, +-- void* circle_storage, +-- int method, +-- double dp, +-- double min_dist, +-- double param1=100, +-- double param2=100, +-- int min_radius=0, +-- int max_radius=0 +-- ); #num CV_HOUGH_STANDARD #num CV_HOUGH_PROBABILISTIC @@ -80,6 +138,7 @@ #num CV_HOUGH_GRADIENT #ccall cvHoughLines2, Ptr -> Ptr () -> Int -> Double -> Double -> Int -> Double -> Double -> IO () +#ccall cvHoughCircles, Ptr -> Ptr () -> Int -> Double -> Double -> Double -> Double -> Int -> Int -> IO () #ccall wrapFilter2, Ptr -> Ptr -> Ptr -> Ptr -> IO () @@ -101,3 +160,94 @@ emptyUniformHistogramND dims = withArray dims $ \c_sizes -> c'cvCreateHist 1 c_sizes c'CV_HIST_ARRAY nullPtr 1 + +-- #ccall cvFindContours, Ptr -> Ptr -> Ptr (Ptr ) -> Cint -> CInt -> CInt-> Ptr +-- thresholding types + +-- | value = value > threshold ? max_value : 0 +#num CV_THRESH_BINARY +-- | value = value > threshold ? 0 : max_value +#num CV_THRESH_BINARY_INV +-- | value = value > threshold ? threshold : value +#num CV_THRESH_TRUNC +-- | value = value > threshold ? value : 0 +#num CV_THRESH_TOZERO +-- | value = value > threshold ? 0 : value +#num CV_THRESH_TOZERO_INV +#num CV_THRESH_MASK +-- | Use Otsu algorithm to choose the optimal threshold value; +-- combine the flag with one of the above CV_THRESH_* values. +-- Note: when using this, the threshold value is ignored. +#num CV_THRESH_OTSU + +-- | CV_THRESH_OTSU | CV_THRESH_BINARY +#num CV_THRESH_OTSU_BINARY +-- | CV_THRESH_OTSU | CV_THRESH_BINARY_INV +#num CV_THRESH_OTSU_BINARY_INV +-- | CV_THRESH_OTSU | CV_THRESH_TRUNC +#num CV_THRESH_OTSU_TRUNC +-- | CV_THRESH_OTSU | CV_THRESH_TOZERO +#num CV_THRESH_OTSU_TOZERO +-- | CV_THRESH_OTSU | CV_THRESH_TOZERO +#num CV_THRESH_OTSU_TOZERO_INV + +-- | Applies fixed-level threshold to grayscale image. +-- This is a basic operation applied before retrieving contours. +-- @ +-- CVAPI(double) cvThreshold( +-- const CvArr* src, +-- CvArr* dst, +-- double threshold, +-- double max_value, +-- int threshold_type);@ + +#ccall cvThreshold , Ptr -> Ptr -> CDouble -> CDouble -> CInt -> IO (CDouble) + +-- | Threshold for each pixel is the mean calculated from /block_size/ +-- neighborhood, minus /param1/. +#num CV_ADAPTIVE_THRESH_MEAN_C +-- | Threshold for each pixel is the gaussian mean calculated from /block_size/ +-- neighborhood, minus /param1/ +#num CV_ADAPTIVE_THRESH_GAUSSIAN_C + +-- | Applies adaptive threshold to grayscale image. +-- The two parameters for methods CV_ADAPTIVE_THRESH_MEAN_C and +-- CV_ADAPTIVE_THRESH_GAUSSIAN_C are: +-- neighborhood size (3, 5, 7 etc.), +-- and a constant subtracted from mean (...,-3,-2,-1,0,1,2,3,...) +-- @ +-- CVAPI(void) cvAdaptiveThreshold( +-- const CvArr* src, +-- CvArr* dst, +-- double max_value, +-- int adaptive_method CV_DEFAULT(CV_ADAPTIVE_THRESH_MEAN_C), +-- int threshold_type CV_DEFAULT(CV_THRESH_BINARY), +-- int block_size CV_DEFAULT(3), +-- double param1 CV_DEFAULT(5));@ + +#ccall cvAdaptiveThreshold , Ptr -> Ptr -> CDouble -> CInt -> CInt -> CInt -> CDouble -> IO () + +-- | Fills the connected component until the color difference gets large enough +-- @ +-- CVAPI(void) cvFloodFill( +-- CvArr* image, +-- CvPoint seed_point, +-- CvScalar new_val, +-- CvScalar lo_diff CV_DEFAULT(cvScalarAll(0)), +-- CvScalar up_diff CV_DEFAULT(cvScalarAll(0)), +-- CvConnectedComp* comp CV_DEFAULT(NULL), +-- int flags CV_DEFAULT(4), +-- CvArr* mask CV_DEFAULT(NULL));@ + +-- | Labels connected components by flood filling each with a different value. +-- @ +-- void fillConnectedComponents(const IplImage* img, int *count)@ + +#ccall fillConnectedComponents , Ptr -> Ptr CInt -> IO () + +-- | Masks a connected component by filling it with white, and filling all +-- other pixels with black. +-- @ +-- void maskConnectedComponent(const IplImage *src, IplImage *mask, int id)@ + +#ccall maskConnectedComponent , Ptr -> Ptr -> CInt -> IO () diff --git a/CV/Bindings/Types.hsc b/CV/Bindings/Types.hsc --- a/CV/Bindings/Types.hsc +++ b/CV/Bindings/Types.hsc @@ -36,6 +36,27 @@ #opaque_t CvHistogram +#starttype CvContour +#field flags, CInt +#field header_size, CInt +#field h_prev, Ptr +#field h_next, Ptr +#field v_prev, Ptr +#field v_next, Ptr +#field total, CInt +#field elem_size, CInt +#field block_max, Ptr Char +#field ptr, Ptr Char +#field delta_elems, CInt +#field free_blocks, Ptr +#field first, Ptr +#field rect, +#field color, CInt +#field reserved[0], CInt +#field reserved[1], CInt +#field reserved[2], CInt +#stoptype + #starttype CvSeq #field flags, CInt #field header_size, CInt @@ -174,8 +195,9 @@ -- #endtype - +-- | /Spatial and central moments #starttype CvMoments +-- | spatial moments #field m00, CDouble #field m10, CDouble #field m01, CDouble @@ -186,7 +208,7 @@ #field m21, CDouble #field m12, CDouble #field m03, CDouble - +-- | central moments #field mu20, CDouble #field mu11, CDouble #field mu02, CDouble @@ -194,8 +216,19 @@ #field mu21, CDouble #field mu12, CDouble #field mu03, CDouble - +-- | @m00 != 0 ? 1/sqrt(m00) : 0@ #field inv_sqrt_m00, CDouble +#stoptype + +-- | Hu invariants +#starttype CvHuMoments +#field hu1 , CDouble +#field hu2 , CDouble +#field hu3 , CDouble +#field hu4 , CDouble +#field hu5 , CDouble +#field hu6 , CDouble +#field hu7 , CDouble #stoptype #starttype CvTermCriteria diff --git a/CV/ConnectedComponents.chs b/CV/ConnectedComponents.chs --- a/CV/ConnectedComponents.chs +++ b/CV/ConnectedComponents.chs @@ -4,12 +4,16 @@ module CV.ConnectedComponents ( -- * Working with connected components - selectSizedComponents + fillConnectedComponents + ,maskConnectedComponent + ,selectSizedComponents ,countBlobs -- * Working with Image moments -- |Note that these functions should probably go to a different module, since -- they deal with entire moments of entire images. + ,spatialMoments ,centralMoments + ,normalizedCentralMoments ,huMoments -- * Working with component contours aka. object boundaries. -- |This part is really old code and probably could be improved a lot. @@ -23,19 +27,40 @@ where #include "cvWrapLEO.h" +import CV.Bindings.ImgProc +import CV.Bindings.Types import Control.Monad ((>=>)) import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Array +import Foreign.Marshal.Utils (with) import Foreign.Ptr +import Foreign.Storable import System.IO.Unsafe - {#import CV.Image#} import CV.ImageOp +fillConnectedComponents :: Image GrayScale D8 -> (Image GrayScale D8, Int) +fillConnectedComponents image = unsafePerformIO $ do + let + count :: CInt + count = 0 + withCloneValue image $ \clone -> + withImage clone $ \pclone -> + with count $ \pcount -> do + c'fillConnectedComponents (castPtr pclone) pcount + c <- peek pcount + return (clone, fromIntegral c) +maskConnectedComponent :: Image GrayScale D8 -> Int -> Image GrayScale D8 +maskConnectedComponent image index = unsafePerformIO $ + withCloneValue image $ \clone -> + withImage image $ \pimage -> + withImage clone $ \pclone -> do + c'maskConnectedComponent (castPtr pimage) (castPtr pclone) (fromIntegral index) + return clone -- |Count the number of connected components in the image countBlobs :: Image GrayScale D8 -> Int @@ -51,24 +76,59 @@ -- * Working with Image moments. +-- Utility function for getting the moments +getMoments :: (Ptr C'CvMoments -> CInt -> CInt -> IO (CDouble)) -> Image GrayScale D32 -> Bool -> [Double] +getMoments f image binary = unsafePerformIO $ do + withImage image $ \pimage -> do + let + moments :: C'CvMoments + moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + with moments $ \pmoments -> do + c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0) + ms <- sequence [ f pmoments i j + | i <- [0..3], j <- [0..3], i+j <= 3 ] + return (map realToFrac ms) --- |Extract central moments of the image. These are useful for describing the object shape --- for a classifier system. -centralMoments :: Image GrayScale D32 -> Bool -> [Double] +-- | Extract raw spatial moments of the image. +spatialMoments = getMoments c'cvGetSpatialMoment + +-- | Extract central moments of the image. These are useful for describing the +-- object shape for a classifier system. +centralMoments = getMoments c'cvGetCentralMoment + +-- | Extract normalized central moments of the image. +normalizedCentralMoments = getMoments c'cvGetNormalizedCentralMoment + +{- centralMoments image binary = unsafePerformIO $ do moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0) ms <- sequence [{#call cvGetCentralMoment#} moments i j | i <- [0..3], j<-[0..3], i+j <= 3] {#call freeCvMoments#} moments return (map realToFrac ms) +-} -- |Extract Hu-moments of the image. These features are rotation invariant. huMoments :: Image GrayScale D32 -> Bool -> [Double] huMoments image binary = unsafePerformIO $ do + withImage image $ \pimage -> do + let + moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + hu = C'CvHuMoments 0 0 0 0 0 0 0 + with moments $ \pmoments -> do + with hu $ \phu -> do + c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0) + c'cvGetHuMoments pmoments phu + (C'CvHuMoments hu1 hu2 hu3 hu4 hu5 hu6 hu7) <- peek phu + return (map realToFrac [hu1,hu2,hu3,hu4,hu5,hu6,hu7]) + +{- +huMoments image binary = unsafePerformIO $ do moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0) hu <- readHu moments {#call freeCvMoments#} moments return (map realToFrac hu) +-} -- read stuff out of hu-moments structure.. This could be done way better. readHu m = do diff --git a/CV/DFT.hs b/CV/DFT.hs --- a/CV/DFT.hs +++ b/CV/DFT.hs @@ -15,8 +15,11 @@ type Idft32 = Image DFT D32 data Ipolar32 = Ipolar32 (Complex D32) -dft :: Image GrayScale d -> Image DFT D32 -dft i = unsafePerformIO $ do +data Swap = SwapQuadrants | DontSwapQuadrants deriving (Eq,Show) + +dft = dft' SwapQuadrants +dft' :: Swap -> Image GrayScale d -> Image DFT D32 +dft' swap i = unsafePerformIO $ do --n::(Image GrayScale D32) <- create (w', h') --n <- copyMakeBorder i 0 (h'-h) 0 (w'-w) BorderReplicate 0 z::(Image GrayScale D32) <- create (w, h) @@ -26,26 +29,37 @@ withImage d $ \d_ptr -> do c'cvMerge (castPtr i_ptr) (castPtr z_ptr) nullPtr nullPtr (castPtr d_ptr) c'cvDFT (castPtr d_ptr) (castPtr d_ptr) c'CV_DXT_FORWARD (fromIntegral 0) - c'swapQuadrants (castPtr d_ptr) + case swap of + SwapQuadrants -> c'swapQuadrants (castPtr d_ptr) + DontSwapQuadrants -> return () return d where (w,h) = getSize i --w' = fromIntegral $ c'cvGetOptimalDFTSize (fromIntegral w) --h' = fromIntegral $ c'cvGetOptimalDFTSize (fromIntegral h) -idft :: Image DFT D32 -> Image GrayScale D32 -idft d = unsafePerformIO $ do +idft = idft' SwapQuadrants +idft' :: Swap -> Image DFT D32 -> Image GrayScale D32 +idft' swap d = unsafePerformIO $ do n::(Image GrayScale D32) <- create s --z::(Image GrayScale D32) <- create s withImage d $ \d_ptr -> withImage n $ \n_ptr -> do --withImage z $ \z_ptr -> do - c'swapQuadrants (castPtr d_ptr) + case swap of + SwapQuadrants -> c'swapQuadrants (castPtr d_ptr) + DontSwapQuadrants -> return () + --c'swapQuadrants (castPtr d_ptr) c'cvDFT (castPtr d_ptr) (castPtr n_ptr) c'CV_DXT_INV_SCALE (fromIntegral 0) --c'cvSplit (castPtr d_ptr) (castPtr n_ptr) (castPtr z_ptr) nullPtr nullPtr return n where s = getSize d + +swapQuadrants img = unsafePerformIO $ do + e <- cloneImage img + withImage e (c'swapQuadrants . castPtr) + return e dftSplit :: Image DFT D32 -> (Image GrayScale D32, Image GrayScale D32) dftSplit d = unsafePerformIO $ do diff --git a/CV/Drawing.chs b/CV/Drawing.chs --- a/CV/Drawing.chs +++ b/CV/Drawing.chs @@ -1,5 +1,5 @@ {-#LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, TypeSynonymInstances, - ViewPatterns, FlexibleContexts, ConstraintKinds#-} + ViewPatterns, FlexibleContexts #-} #include "cvWrapLEO.h" -- | Module for exposing opencv drawing functions. These are meant for quick and dirty marking -- and not for anything presentable. For any real drawing @@ -63,7 +63,7 @@ -- | Draw a Circle circleOp :: (Color a b) -> (Int,Int) -> Int -> ShapeStyle -> ImageOperation a b -- | Draw a Rectangle by supplying two corners - rectOp :: (IntBounded bb) => (Color a b) -> Int -> bb -> ImageOperation a b + rectOp :: (BoundingBox bb, Integral (ELBB bb)) => (Color a b) -> Int -> bb -> ImageOperation a b -- | Draw a filled polygon fillPolyOp :: (Color a b) -> [(Int,Int)] -> ImageOperation a b ellipseBoxOp :: (Color a b) -> C'CvBox2D -> Int -> Int -> ImageOperation a b diff --git a/CV/Features.hs b/CV/Features.hs --- a/CV/Features.hs +++ b/CV/Features.hs @@ -1,6 +1,8 @@ {-#LANGUAGE RecordWildCards, ScopedTypeVariables, TypeFamilies#-} module CV.Features (SURFParams, defaultSURFParams, getSURF +#ifndef OpenCV24 ,getMSER, MSERParams, mkMSERParams, defaultMSERParams +#endif ,moments,Moments,getSpatialMoment,getCentralMoment,getNormalizedCentralMoment) where import CV.Image import CV.Bindings.Types @@ -13,6 +15,7 @@ import Utils.GeometryClass import System.IO.Unsafe +#ifndef OpenCV24 newtype MSERParams = MP C'CvMSERParams deriving (Show) -- | Create parameters for getMSER. @@ -49,6 +52,7 @@ pts :: [C'CvPoint] <- cvSeqToList ctr return (map convertPt pts) +#endif -- TODO: Move this to some utility module withMask :: Maybe (Image GrayScale D8) -> (Ptr C'CvArr -> IO α) -> IO α @@ -106,7 +110,7 @@ ptr_keypoints <- peek ptr_ptr_keypoints ptr_descriptors <- peek ptr_ptr_descriptors a <- cvSeqToList ptr_keypoints - b <- if c'CvSURFParams'extended params /= 1 + b <- if c'CvSURFParams'extended params == 1 then do es :: [FloatBlock128] <- cvSeqToList ptr_descriptors return (map (\(FP128 e) -> e) es) diff --git a/CV/Filters.chs b/CV/Filters.chs --- a/CV/Filters.chs +++ b/CV/Filters.chs @@ -3,8 +3,10 @@ {-#OPTIONS_GHC -fwarn-unused-imports#-} -- | This module is a collection of various image filters -module CV.Filters(gaussian,gaussianOp +module CV.Filters( + gaussian,gaussianOp ,blurOp,blur,blurNS + ,bilateral ,HasMedianFiltering,median ,susan,getCentralMoment,getAbsCentralMoment ,getMoment,secondMomentBinarize,secondMomentBinarizeOp @@ -77,10 +79,16 @@ (\i-> {#call smab#} i w h t) secondMomentAdaptiveBinarize w h t i = unsafeOperate (secondMomentAdaptiveBinarizeOp w h t) i -data SmoothType = BlurNoScale | Blur - | Gaussian | Median - | Bilateral - deriving(Enum) +#c +enum SmoothType { + BlurNoScale = CV_BLUR_NO_SCALE, + Blur = CV_BLUR, + Gaussian = CV_GAUSSIAN, + Median = CV_MEDIAN , + Bilateral = CV_BILATERAL +}; +#endc +{#enum SmoothType {}#} {#fun cvSmooth as smooth' {withGenImage* `Image GrayScale D32' @@ -88,39 +96,35 @@ ,`Int',`Int',`Int',`Float',`Float'} -> `()'#} -gaussianOp (w,h) - | maskIsOk (w,h) = ImgOp $ \img -> - smooth' img img (fromEnum Gaussian) w h 0 0 - | otherwise = error "One of aperture dimensions is incorrect (should be >=1 and odd))" -gaussian = unsafeOperate.gaussianOp +-- | Image operation which applies gaussian or unifarm smoothing with a given window size to the image. +gaussianOp,blurOp,blurNSOp :: (Int, Int) -> ImageOperation GrayScale D32 +gaussianOp m = withMask m $ \(w,h) img -> smooth' img img (fromEnum Gaussian) w h 0 0 +blurOp m = withMask m $ \(w,h) img -> smooth' img img (fromEnum Blur) w h 0 0 +blurNSOp m = withMask m $ \(w,h) img -> smooth' img img (fromEnum BlurNoScale) w h 0 0 -blurOp (w,h) - | maskIsOk (w,h) = ImgOp $ \img -> - smooth' img img (fromEnum Blur) w h 0 0 - | otherwise = error "One of aperture dimensions is incorrect (should be >=1 and odd))" +-- | Create a new image by applying gaussian, or uniform smoothing. +gaussian,blur,blurNS :: (Int, Int) -> Image GrayScale D32 -> Image GrayScale D32 +gaussian = unsafeOperate . gaussianOp +blur = unsafeOperate . blurOp +blurNS = unsafeOperate . blurNSOp -blurNSOp (w,h) - | maskIsOk (w,h) = ImgOp $ \img -> - smooth' img img (fromEnum BlurNoScale) w h 0 0 +withMask (w,h) op + | maskIsOk (w,h) = ImgOp $ op (w,h) | otherwise = error "One of aperture dimensions is incorrect (should be >=1 and odd))" -blur size image = let r = unsafeOperate (blurOp size) image - in r -blurNS size image = let r = unsafeOperate (blurNSOp size) image - in r --- | TODO: This doesn't give a reasonable result. Investigate -bilateral :: Int -> Int -> Image GrayScale D8 -> Image GrayScale D8 -bilateral colorS spaceS img = unsafePerformIO $ + +-- | Apply bilateral filtering +bilateral :: (Int,Int) -> (Int,Int) -> Image a D8 -> Image a D8 +bilateral (w,h) (s1,s2) img = unsafePerformIO $ withClone img $ \clone -> withGenImage img $ \cimg -> withGenImage clone $ \ccln -> do {#call cvSmooth#} cimg ccln (fromIntegral $ fromEnum Bilateral) - (fromIntegral colorS) (fromIntegral spaceS) 0 0 - + (fromIntegral w) (fromIntegral h) + (realToFrac s1) (realToFrac s2) --- TODO: The type is not exactly correct class HasMedianFiltering a where median :: (Int,Int) -> a -> a diff --git a/CV/HoughTransform.hs b/CV/HoughTransform.hs --- a/CV/HoughTransform.hs +++ b/CV/HoughTransform.hs @@ -89,3 +89,11 @@ withImage img $ \c_img -> c'cvHoughLines2 (castPtr c_img) (castPtr c_m) c'CV_HOUGH_MULTI_SCALE ρ θ t distDiv angleDiv return $ toList m + +houghCirclesGradient :: Image GrayScale D8 -> Int -> Double -> Double -> Double -> Double -> Int -> Int -> [(CFloat, CFloat, CFloat)] +houghCirclesGradient img n dp minDist cannyThresh accumThresh minRad maxRad = unsafePerformIO $ do + let m :: Matrix (CFloat,CFloat,CFloat) = create (1,n) + withMatPtr m $ \c_m -> + withImage img $ \c_img -> + c'cvHoughCircles (castPtr c_img) (castPtr c_m) c'CV_HOUGH_GRADIENT dp minDist cannyThresh accumThresh minRad maxRad + return $ toList m diff --git a/CV/Image.chs b/CV/Image.chs --- a/CV/Image.chs +++ b/CV/Image.chs @@ -1,4 +1,4 @@ -{-#LANGUAGE ForeignFunctionInterface, ViewPatterns,ParallelListComp, FlexibleInstances, FlexibleContexts, TypeFamilies, EmptyDataDecls, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable #-} +{-#LANGUAGE ForeignFunctionInterface, ViewPatterns,ParallelListComp, FlexibleInstances, FlexibleContexts, TypeFamilies, EmptyDataDecls, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable, UndecidableInstances #-} #include "cvWrapLEO.h" module CV.Image ( -- * Basic types @@ -27,6 +27,7 @@ , lab , rgba , rgb +, compose , composeMultichannelImage -- * IO operations @@ -97,6 +98,7 @@ import System.Mem import System.Directory +import System.FilePath import Foreign.C.Types import Foreign.C.String @@ -201,10 +203,32 @@ rgba = undefined :: Tag RGBA lab = undefined :: Tag LAB +-- | Typeclass for elements that are build from component elements. For example, +-- RGB images can be constructed from three grayscale images. +class Composes a where + type Source a :: * + compose :: Source a -> a +instance (CreateImage (Image RGBA a)) => Composes (Image RGBA a) where + type Source (Image RGBA a) = (Image GrayScale a, Image GrayScale a + ,Image GrayScale a, Image GrayScale a) + compose (r,g,b,a) = composeMultichannelImage (Just b) (Just g) (Just r) (Just a) rgba + +instance (CreateImage (Image RGB a)) => Composes (Image RGB a) where + type Source (Image RGB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a) + compose (r,g,b) = composeMultichannelImage (Just b) (Just g) (Just r) Nothing rgb + +instance (CreateImage (Image LAB a)) => Composes (Image LAB a) where + type Source (Image LAB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a) + compose (l,a,b) = composeMultichannelImage (Just l) (Just a) (Just b) Nothing lab + +{-# DEPRECATED composeMultichannelImage "This is unsafe. Use compose instead" #-} composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a -composeMultichannelImage (c1) - (c2) +composeMultichannelImage = composeMultichannel + +composeMultichannel :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a +composeMultichannel (c2) + (c1) (c3) (c4) totag @@ -222,6 +246,7 @@ size = getSize . head . catMaybes $ [c1,c2,c3,c4] +-- | Typeclass for CV items that can be read from file. Mainly images at this point. class Loadable a where readFromFile :: FilePath -> IO a @@ -231,28 +256,28 @@ e <- loadImage fp case e of Just i -> return i - Nothing -> fail $ "Could not load "++fp + Nothing -> throw $ CvIOError $ "Could not load "++fp instance Loadable ((Image RGB D32)) where readFromFile fp = do e <- loadColorImage8 fp case e of Just i -> return $ unsafeImageTo32F $ bgrToRgb i - Nothing -> fail $ "Could not load "++fp + Nothing -> throw $ CvIOError $ "Could not load "++fp instance Loadable ((Image RGB D8)) where readFromFile fp = do e <- loadColorImage8 fp case e of Just i -> return $ bgrToRgb i - Nothing -> fail $ "Could not load "++fp + Nothing -> throw $ CvIOError $ "Could not load "++fp instance Loadable ((Image GrayScale D8)) where readFromFile fp = do e <- loadImage8 fp case e of Just i -> return i - Nothing -> fail $ "Could not load "++fp + Nothing -> throw $ CvIOError $ "Could not load "++fp -- | This function loads and converts image to an arbitrary format. Notice that it is @@ -276,6 +301,7 @@ loadColorImage8 :: FilePath -> IO (Maybe (Image BGR D8)) loadColorImage8 = unsafeloadUsing imageTo8Bit 1 +-- | Typeclass for elements with a size, such as images and matrices. class Sized a where type Size a :: * getSize :: a -> Size a @@ -452,10 +478,10 @@ grayToRGB = S . convertTo (fromIntegral . fromEnum $ CV_GRAY2BGR) 3 . unS -bgrToRgb :: Image BGR depth -> Image RGB depth +bgrToRgb :: Image BGR D8 -> Image RGB D8 bgrToRgb = S . swapRB . unS -rgbToBgr :: Image BGR depth -> Image RGB depth +rgbToBgr :: Image RGB D8 -> Image BGR D8 rgbToBgr = S . swapRB . unS swapRB :: BareImage -> BareImage @@ -481,6 +507,15 @@ s <- {#get IplImage->widthStep#} c_i peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Float))):: Ptr Float) +instance GetPixel (Image GrayScale D8) where + type P (Image GrayScale D8) = D8 + {-#INLINE getPixel#-} + getPixel (x,y) i = unsafePerformIO $ + withGenImage i $ \c_i -> do + d <- {#get IplImage->imageData#} c_i + s <- {#get IplImage->widthStep#} c_i + peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Word8))):: Ptr Word8) + instance GetPixel (Image DFT D32) where type P (Image DFT D32) = Complex D32 {-#INLINE getPixel#-} @@ -504,19 +539,65 @@ s <- {#get IplImage->widthStep#} c_i let cs = fromIntegral s fs = sizeOf (undefined :: Float) - r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) + b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) - b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) + r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) return (r,g,b) +instance GetPixel (Image BGR D32) where + type P (Image BGR D32) = (D32,D32,D32) + {-#INLINE getPixel#-} + getPixel (x,y) i = unsafePerformIO $ + withGenImage i $ \c_i -> do + d <- {#get IplImage->imageData#} c_i + s <- {#get IplImage->widthStep#} c_i + let cs = fromIntegral s + fs = sizeOf (undefined :: Float) + b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) + g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) + r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) + return (r,g,b) +instance GetPixel (Image BGR D8) where + type P (Image BGR D8) = (D8,D8,D8) + {-#INLINE getPixel#-} + getPixel (x,y) i = unsafePerformIO $ + withGenImage i $ \c_i -> do + d <- {#get IplImage->imageData#} c_i + s <- {#get IplImage->widthStep#} c_i + let cs = fromIntegral s + fs = sizeOf (undefined :: D8) + b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) + g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) + r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) + return (r,g,b) -getPixelOldRGB (fromIntegral -> x, fromIntegral -> y) image - = unsafePerformIO $ do - withGenImage image $ \img -> do - r <- {#call wrapGet32F2DC#} img y x 0 - g <- {#call wrapGet32F2DC#} img y x 1 - b <- {#call wrapGet32F2DC#} img y x 2 - return (realToFrac r,realToFrac g, realToFrac b) +instance GetPixel (Image RGB D8) where + type P (Image RGB D8) = (D8,D8,D8) + {-#INLINE getPixel#-} + getPixel (x,y) i = unsafePerformIO $ + withGenImage i $ \c_i -> do + d <- {#get IplImage->imageData#} c_i + s <- {#get IplImage->widthStep#} c_i + let cs = fromIntegral s + fs = sizeOf (undefined :: D8) + b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) + g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) + r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) + return (r,g,b) +instance GetPixel (Image LAB D32) where + type P (Image LAB D32) = (D32,D32,D32) + {-#INLINE getPixel#-} + getPixel (x,y) i = unsafePerformIO $ + withGenImage i $ \c_i -> do + d <- {#get IplImage->imageData#} c_i + s <- {#get IplImage->widthStep#} c_i + let cs = fromIntegral s + fs = sizeOf (undefined :: Float) + l <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) + a <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) + b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) + return (l,a,b) + -- | Perform (a destructive) inplace map of the image. This should be wrapped inside -- withClone or an image operation mapImageInplace :: (P (Image GrayScale D32) -> P (Image GrayScale D32)) @@ -533,19 +614,6 @@ poke (castPtr (d `plusPtr` (y*cs+x*fs))) (f v) -instance GetPixel (Image RGB D8) where - type P (Image RGB D8) = (D8,D8,D8) - {-#INLINE getPixel#-} - getPixel (x,y) i = unsafePerformIO $ - withGenImage i $ \c_i -> do - d <- {#get IplImage->imageData#} c_i - s <- {#get IplImage->widthStep#} c_i - let cs = fromIntegral s - fs = sizeOf (undefined :: D8) - r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs))) - g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) - b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) - return (r,g,b) convertTo :: CInt -> CInt -> BareImage -> BareImage @@ -603,14 +671,35 @@ emptyCopy img = unsafePerformIO $ create (getSize img) -- | Save image. This will convert the image to 8 bit one before saving -saveImage :: FilePath -> Image c d -> IO () -saveImage filename image = do - fpi <- imageTo8Bit $ unS image - withCString filename $ \name -> - withGenBareImage fpi $ \cvArr -> - alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ()) +class Save a where + save :: FilePath -> a -> IO () +instance Save (Image BGR D32) where + save filename image = primitiveSave filename (unS . unsafeImageTo8Bit $ image) +instance Save (Image RGB D32) where + save filename image = primitiveSave filename (swapRB . unS . unsafeImageTo8Bit $ image) + +instance Save (Image RGB D8) where + save filename image = primitiveSave filename (swapRB . unS $ image) + +instance Save (Image GrayScale D8) where + save filename image = primitiveSave filename (unS $ image) + +instance Save (Image GrayScale D32) where + save filename image = primitiveSave filename (unS . unsafeImageTo8Bit $ image) + +primitiveSave :: FilePath -> BareImage -> IO () +primitiveSave filename fpi = do + exists <- doesDirectoryExist (takeDirectory filename) + when (not exists) $ throw (CvIOError $ "Directory does not exist: " ++ (takeDirectory filename)) + withCString filename $ \name -> + withGenBareImage fpi $ \cvArr -> + alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ()) + +saveImage :: (Save (Image c d)) => FilePath -> Image c d -> IO () +saveImage = save + getArea :: (Sized a,Num b, Size a ~ (b,b)) => a -> b getArea = uncurry (*).getSize @@ -637,6 +726,7 @@ i1 i2 x y) -- | Blit image2 onto image1. blitFix = blit +blit :: Image GrayScale D32 -> Image GrayScale D32 -> (Int,Int) -> IO () blit image1 image2 (x,y) | badSizes = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y) | otherwise = withImage image1 $ \i1 -> @@ -646,7 +736,7 @@ ((w1,h1),(w2,h2)) = (getSize image1,getSize image2) badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0 -blitM :: (CreateImage (Image c d)) => (Int,Int) -> [((Int,Int),Image c d)] -> Image c d +-- blitM :: (CreateImage (Image c d)) => (Int,Int) -> [((Int,Int),Image c d)] -> Image c d blitM (rw,rh) imgs = resultPic where resultPic = unsafePerformIO $ do @@ -681,7 +771,7 @@ withImage image1Alpha $ \i1a -> withImage image2Alpha $ \i2a -> withImage image2 $ \i2 -> - ({#call alphaBlit#} i1 i1a i2 i2a x y) + ({#call alphaBlit#} i1 i1a i2 i2a y x) -- | Create a copy of an image @@ -826,6 +916,18 @@ + x*sizeOf (0::Word8))):: Ptr Word8) v +instance SetPixel (Image RGB D32) where + type SP (Image RGB D32) = (D32,D32,D32) + {-#INLINE setPixel#-} + setPixel (x,y) (r,g,b) image = withGenImage image $ \c_i -> do + d <- {#get IplImage->imageData#} c_i + s <- {#get IplImage->widthStep#} c_i + let cs = fromIntegral s + fs = sizeOf (undefined :: Float) + poke (castPtr (d`plusPtr` (y*cs +x*3*fs))) b + poke (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) g + poke (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) r + instance SetPixel (Image DFT D32) where type SP (Image DFT D32) = Complex D32 {-#INLINE setPixel#-} @@ -854,7 +956,7 @@ -- |Create a montage form given images (u,v) determines the layout and space the spacing -- between images. Images are assumed to be the same size (determined by the first image) -montage :: (CreateImage (Image c d)) => (Int,Int) -> Int -> [Image c d] -> Image c d +montage :: (CreateImage (Image GrayScale D32)) => (Int,Int) -> Int -> [Image GrayScale D32] -> Image GrayScale D32 montage (u',v') space' imgs | u'*v' /= (length imgs) = error ("Montage mismatch: "++show (u,v, length imgs)) | otherwise = resultPic @@ -875,7 +977,10 @@ data CvException = CvException Int String String String Int deriving (Show, Typeable) +data CvIOError = CvIOError String deriving (Show,Typeable) + instance Exception CvException +instance Exception CvIOError setCatch = do let catch i cstr1 cstr2 cstr3 j = do diff --git a/CV/ImageMath.chs b/CV/ImageMath.chs --- a/CV/ImageMath.chs +++ b/CV/ImageMath.chs @@ -1,6 +1,64 @@ {-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, FlexibleContexts#-} #include "cvWrapLEO.h" -module CV.ImageMath where + +-- | Mathematical and statistical operations for images. See also module +-- "CV.ImageMathOp" which contains handy operators for some of these. +module CV.ImageMath( + -- * Operations for two images + add +, sub +, absDiff +, mul +, CV.ImageMath.div +, CV.ImageMath.min +, CV.ImageMath.max +, maskedMerge +, averageImages +, CV.ImageMath.atan2 + -- * Operations for one image +, subMean +, subMeanAbs +, CV.ImageMath.sqrt +, CV.ImageMath.log +, CV.ImageMath.abs +, CV.ImageMath.atan +, invert + -- * Operations for a scalar and an image +, addS +, subS +, subRS +, mulS +-- TODO: divS is missing, is it needed? +-- , divS +, minS +, maxS + -- * Comparison operations +, lessThan +, moreThan +, less2Than +, more2Than + -- * Image statistics +, CV.ImageMath.sum +, average +, averageMask +, stdDeviation +, stdDeviationMask +, findMinMax +, findMinMaxLoc +, findMinMaxMask +, imageMinMax -- TODO: merge with findMinMax / replace binding? +, minValue +, maxValue +, imageAvgSdv -- TODO: merge with average and stdDeviation / replace binding? + -- * Misc (to be moved?) +, gaussianImage -- TODO: move to other module? +, fadedEdgeImage -- TODO: move to other module? +, fadeToCenter -- TODO: move to other module? +, maximalCoveringCircle -- TODO: move to other module? +, limitToOp -- TODO: remove? needed in Morphology; export operations at end? +-- TODO: add section "Image operations" and add the bare operations there for combining with others? +) where + import Foreign.C.Types import Foreign.C.String import Foreign.ForeignPtr @@ -45,13 +103,18 @@ -- I just can't think of a proper name for this -- Friday Evening abcNullPtr f = \a b c -> f a b c nullPtr + addOp imageToBeAdded = ImgOp $ \target -> withGenImage target $ \ctarget -> withGenImage imageToBeAdded $ \cadd -> {#call cvAdd#} ctarget cadd ctarget nullPtr +-- | Calculates the per-pixel sum of two images. add = mkBinaryImageOp $ abcNullPtr {#call cvAdd#} + +-- | Calculates the per-pixel difference of two images. sub = mkBinaryImageOp $ abcNullPtr {#call cvSub#} + subFrom what = ImgOp $ \from -> withGenImage from $ \ifrom -> withGenImage what $ \iwhat -> @@ -59,30 +122,43 @@ logOp :: ImageOperation GrayScale D32 logOp = ImgOp $ \i -> withGenImage i (\img -> {#call cvLog#} img img) + +-- | Calculates the natural logarithm of every pixel. log = unsafeOperate logOp +sqrtOp :: ImageOperation GrayScale D32 sqrtOp = ImgOp $ \i -> withGenImage i (\img -> {#call sqrtImage#} img img) + +-- | Calculates the square root of every pixel. sqrt = unsafeOperate sqrtOp +-- | Operation to limit image with another image; same as 'ImageMath.min'. limitToOp what = ImgOp $ \from -> withGenImage from $ \ifrom -> withGenImage what $ \iwhat -> {#call cvMin#} ifrom iwhat ifrom +-- | Limit image with another image; same as 'ImageMath.min'. limitTo x y = unsafeOperate (limitToOp x) y +-- | Calculates the per-pixel product of two images. mul = mkBinaryImageOp (\a b c -> {#call cvMul#} a b c 1) +-- | Calculates the per-pixel division of two images. div = mkBinaryImageOp (\a b c -> {#call cvDiv#} a b c 1) +-- | Calculates the per-pixel minimum of two images. min = mkBinaryImageOp {#call cvMin#} +-- | Calculates the per-pixel maximum of two images. max = mkBinaryImageOp {#call cvMax#} +-- | Calculates the per-pixel absolute difference of two images. absDiff = mkBinaryImageOp {#call cvAbsDiff#} +-- | Calculates the atan of every pixel. atan :: Image GrayScale D32 -> Image GrayScale D32 atan i = unsafePerformIO $ do let (w,h) = getSize i @@ -92,6 +168,8 @@ {#call calculateAtan#} s r return res +-- | Calculates the atan2 of pixel values in two images. +atan2 :: Image GrayScale D32 -> Image GrayScale D32 -> Image GrayScale D32 atan2 a b = unsafePerformIO $ do res <- create (getSize a) withImage a $ \c_a -> @@ -107,13 +185,19 @@ withGenImage image $ \i -> {#call wrapAbsDiffS#} i (realToFrac av) i -- TODO: check C datatype sizes --- Logical inversion of image (Ie. invert, but stay on [0..1] range) +-- | Calculates the absolute difference of every pixel to image mean. +-- See also 'ImageMath.subMean'. +subMeanAbs = unsafeOperate subtractMeanAbsOp + +-- | Logical inversion of image (ie. invert, but stay on [0..1] range; +-- multiply by @-1@ and add @1@). invert i = addS 1 $ mulS (-1) i absOp = ImgOp $ \image -> do withGenImage image $ \i -> {#call wrapAbsDiffS#} i 0 i +-- | Calculates the absolute value of every pixel. abs = unsafeOperate absOp subtractMeanOp :: ImageOperation GrayScale D32 @@ -123,17 +207,23 @@ let (ImgOp subop) = subRSOp (realToFrac mean) subop image +-- | Calculates the (non-absolute) difference of every pixel to image mean. +-- See also 'ImageMath.subMeanAbs'. +subMean = unsafeOperate subtractMeanOp + subRSOp :: D32 -> ImageOperation GrayScale D32 subRSOp scalar = ImgOp $ \a -> withGenImage a $ \ia -> do {#call wrapSubRS#} ia (realToFrac scalar) ia +-- | Subtracts a scalar from every pixel, scalar on right. subRS s a= unsafeOperate (subRSOp s) a subSOp scalar = ImgOp $ \a -> withGenImage a $ \ia -> do {#call wrapSubS#} ia (realToFrac scalar) ia +-- | Subtracts a scalar from every pixel, scalar on left. subS a s = unsafeOperate (subSOp s) a -- Multiply the image with scalar @@ -144,6 +234,8 @@ return () where s = realToFrac scalar -- I've heard this will lose information + +-- | Multiplies every pixel by a scalar. mulS s = unsafeOperate $ mulSOp s mkImgScalarOp op scalar = ImgOp $ \a -> @@ -154,12 +246,20 @@ -- TODO: Relax the addition so it works on multiple image depths addSOp :: D32 -> ImageOperation GrayScale D32 addSOp = mkImgScalarOp $ {#call wrapAddS#} + +-- | Adds a scalar to every pixel. addS s = unsafeOperate $ addSOp s minSOp = mkImgScalarOp $ {#call cvMinS#} + +-- | Calculates the per-pixel minimum between an image and a scalar. +minS :: Float -> Image c d -> Image c d minS s = unsafeOperate $ minSOp s maxSOp = mkImgScalarOp $ {#call cvMaxS#} + +-- | Calculates the per-pixel maximum between an image and a scalar. +maxS :: Float -> Image c d -> Image c d maxS s = unsafeOperate $ maxSOp s @@ -193,54 +293,76 @@ return new --imageTo32F new --- Compare Image to Scalar -lessThan, moreThan :: D32 -> Image GrayScale D32 ->Image GrayScale D8 - +-- | Compares each pixel to a scalar, and produces a binary image where the +-- pixel value is less than the scalar. For example, @(lessThan s I)@ has +-- white pixels where value of I is less than s. Notice that the order of +-- operands is opposite to the intuitive interpretation of @s ``lessThan`` I@. +lessThan :: D32 -> Image GrayScale D32 -> Image GrayScale D8 lessThan = mkCmpOp cmpLT + +-- | Compares each pixel to a scalar, and produces a binary image where the +-- pixel value is greater than the scalar. For example, @(moreThan s I)@ has +-- white pixels where value of I is greater than s. Notice that the order of +-- operands is opposite to the intuitive interpretation of @s ``moreThan`` I@. +moreThan :: D32 -> Image GrayScale D32 -> Image GrayScale D8 moreThan = mkCmpOp cmpGT +-- | Compares two images and produces a binary image that has white pixels in +-- those positions where the comparison is true. For example, +-- @(less2Than A B)@ has white pixels where value of A is less than value of +-- B. Notice that these functions follow the intuitive order of operands, +-- unlike 'lessThan' and 'moreThan'. less2Than,lessEq2Than,more2Than :: (CreateImage (Image GrayScale d)) => Image GrayScale d -> Image GrayScale d -> Image GrayScale D8 + less2Than = mkCmp2Op cmpLT lessEq2Than = mkCmp2Op cmpLE more2Than = mkCmp2Op cmpGT -- Statistics -averageMask :: Image GrayScale D32 -> Image GrayScale D8 -> D32 -averageMask img mask = unsafePerformIO $ - withGenImage img $ \c_image -> - withGenImage mask $ \c_mask -> - {#call wrapAvg#} c_image c_mask >>= return . realToFrac average' :: Image GrayScale D32 -> IO D32 average' img = withGenImage img $ \image -> {#call wrapAvg#} image nullPtr >>= return . realToFrac +-- | Calculates the average pixel value in whole image. average :: Image GrayScale D32 -> D32 average = realToFrac.unsafePerformIO.average' --- | Sum the pixels in the image. Notice that OpenCV automatically casts the --- result to double sum :: Image GrayScale D32 -> D32 +-- | Calculates the average value for pixels that have non-zero mask value. +averageMask :: Image GrayScale D32 -> Image GrayScale D8 -> D32 +averageMask img mask = unsafePerformIO $ + withGenImage img $ \c_image -> + withGenImage mask $ \c_mask -> + {#call wrapAvg#} c_image c_mask >>= return . realToFrac + +-- | Calculates the sum of pixel values in whole image +-- (notice that OpenCV automatically casts the result to double). sum :: Image GrayScale D32 -> D32 sum img = realToFrac $ unsafePerformIO $ withGenImage img $ \image -> {#call wrapSum#} image +-- | Calculates the average of multiple images by adding the pixel values and +-- dividing the resulting values by number of images. averageImages is = ( (1/(fromIntegral $ length is)) `mulS`) (foldl1 add is) -- sum img = unsafePerformIO $ withGenImage img $ \image -> -- {#call wrapSum#} image stdDeviation' img = withGenImage img {#call wrapStdDev#} + +-- | Calculates the standard deviation of pixel values in whole image. stdDeviation :: Image GrayScale D32 -> D32 stdDeviation = realToFrac . unsafePerformIO . stdDeviation' +-- | Calculates the standard deviation of values for pixels that have non-zero +-- mask value. stdDeviationMask img mask = unsafePerformIO $ withGenImage img $ \i -> withGenImage mask $ \m -> {#call wrapStdDevMask#} i m - peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b peekFloatConv a = fmap realToFrac (peek a) @@ -252,6 +374,8 @@ , alloca- `D32' peekFloatConv*} -- TODO: Check datatype sizes used in C! -> `()'#} +-- | Finds the minimum and maximum pixel value in the image and the locations +-- where these values were found. findMinMaxLoc img = unsafePerformIO $ alloca $ \(ptrintmaxx :: Ptr CInt)-> alloca $ \(ptrintmaxy :: Ptr CInt)-> @@ -269,20 +393,60 @@ minval <- realToFrac <$> peek ptrintmin; return (((minx,miny),minval),((maxx,maxy),maxval));} -imageMinMax i = unsafePerformIO $ do - withImage i $ \i_ptr -> do +-- TODO: create one function findMinMaxLoc' which takes also mask and base +-- findMinMax, findMinMaxLoc and findMinMaxMask (findMinMaxLocMask?) on it + +-- findMinMax and findMinMaxLoc using the new bindings of cvMinMaxLoc... +-- do these really work also with D8 images? depends on fractional instance? +-- maybe create a new class or add a function to some existing class that +-- allows to get a pixel value from float.. + +-- | Finds the minimum and maximum pixel value in the image. +imageMinMax :: (Fractional d) => Image GrayScale d -> (d,d) +imageMinMax image = unsafePerformIO $ do + withImage image $ \pimage -> do let minval :: CDouble minval = 0 maxval :: CDouble maxval = 0 - with minval $ \cminval -> - with maxval $ \cmaxval -> do - c'cvMinMaxLoc (castPtr i_ptr) cminval cmaxval nullPtr nullPtr nullPtr - imin <- peek cminval - imax <- peek cmaxval - return ((realToFrac imin), (realToFrac imax)) + with minval $ \pminval -> + with maxval $ \pmaxval -> do + c'cvMinMaxLoc (castPtr pimage) pminval pmaxval nullPtr nullPtr nullPtr + minv <- peek pminval + maxv <- peek pmaxval + return ((realToFrac minv), (realToFrac maxv)) +-- | Finds the minimum and maximum pixel value in the image. +imageMinMaxLoc :: (Fractional d) => Image GrayScale d -> (((Int,Int),d), ((Int,Int),d)) +imageMinMaxLoc image = unsafePerformIO $ do + withImage image $ \pimage -> do + let + minval :: CDouble + minval = 0 + maxval :: CDouble + maxval = 0 + minloc :: C'CvPoint + minloc = C'CvPoint 0 0 + maxloc :: C'CvPoint + maxloc = C'CvPoint 0 0 + with minval $ \pminval -> + with maxval $ \pmaxval -> + with minloc $ \pminloc -> + with maxloc $ \pmaxloc -> do + c'cvMinMaxLoc (castPtr pimage) pminval pmaxval pminloc pmaxloc nullPtr + minv <- peek pminval + (C'CvPoint minx miny) <- peek pminloc + maxv <- peek pmaxval + (C'CvPoint maxx maxy) <- peek pmaxloc + return $ + (((fromIntegral minx, fromIntegral miny), realToFrac minv), + ((fromIntegral maxx, fromIntegral maxy), realToFrac maxv)) + +-- TODO: enable using a mask +-- | Calculates the average and standard deviation of pixel values in the image +-- in one operation. +imageAvgSdv :: (Fractional d) => Image GrayScale d -> (d,d) imageAvgSdv i = unsafePerformIO $ do withImage i $ \i_ptr -> do let @@ -291,25 +455,28 @@ with avg $ \avg_ptr -> with sdv $ \sdv_ptr -> do c'cvAvgSdv (castPtr i_ptr) avg_ptr sdv_ptr nullPtr - (C'CvScalar a1 a2 a3 a4) <- peek avg_ptr - (C'CvScalar s1 s2 s3 s4) <- peek sdv_ptr - return ((realToFrac a1, realToFrac a2, realToFrac a3, realToFrac a4), - (realToFrac s1, realToFrac s2, realToFrac s3, realToFrac s4)) + (C'CvScalar a1 _ _ _) <- peek avg_ptr + (C'CvScalar s1 _ _ _) <- peek sdv_ptr + return (realToFrac a1, realToFrac s1) +-- | Finds the minimum and maximum pixel value in the image. findMinMax i = unsafePerformIO $ do nullp <- newForeignPtr_ nullPtr (findMinMax' (unS i) (BareImage nullp)) --- |Find minimum and maximum value of image i in area specified by the mask. +-- | Finds the minimum and maximum value for pixels with non-zero mask value. findMinMaxMask i mask = unsafePerformIO (findMinMax' i mask) + -- let a = getAllPixels i in (minimum a,maximum a) +-- | Utility functions for getting the maximum or minimum pixel value of the +-- image; equal to @snd . findMinMax@ and @fst . findMinMax@. maxValue,minValue :: Image GrayScale D32 -> D32 maxValue = snd.findMinMax minValue = fst.findMinMax --- | Render image of 2D gaussian curve with standard deviation of (stdX,stdY) to image size (w,h) --- The origin/center of curve is in center of the image +-- | Render image of 2D gaussian curve with standard deviation of (stdX,stdY) to image size (w,h) +-- The origin/center of curve is in center of the image. gaussianImage :: (Int,Int) -> (Double,Double) -> Image GrayScale D32 gaussianImage (w,h) (stdX,stdY) = unsafePerformIO $ do dst <- create (w,h) -- 32F_C1 @@ -317,14 +484,14 @@ {#call render_gaussian#} d (realToFrac stdX) (realToFrac stdY) return dst --- | Produce white image with 'edgeW' amount of edges fading to black +-- | Produce white image with 'edgeW' amount of edges fading to black. fadedEdgeImage (w,h) edgeW = unsafePerformIO $ creatingImage ({#call fadedEdges#} w h edgeW) --- | Produce image where pixel is coloured according to distance from the edge +-- | Produce image where pixel is coloured according to distance from the edge. fadeToCenter (w,h) = unsafePerformIO $ creatingImage ({#call rectangularDistance#} w h ) --- | Merge two images according to a mask. Result R is R = A*m+B*(m-1) . -- TODO: Fix C-code of masked_merge to accept D8 input for the mask +-- | Merge two images according to a mask. Result is @R = A*m + B*(m-1)@. maskedMerge :: Image GrayScale D8 -> Image GrayScale D32 -> Image GrayScale D32 -> Image GrayScale D32 maskedMerge mask img img2 = unsafePerformIO $ do res <- create (getSize img) -- 32FC1 @@ -335,11 +502,8 @@ {#call masked_merge#} cimg cmask cimg2 cres return res - - -- | Given a distance map and a circle, return the biggest circle with radius less --- than given in the distance map that fully covers the previous one - +-- than given in the distance map that fully covers the previous one. maximalCoveringCircle distMap (x,y,r) = unsafePerformIO $ withImage distMap $ \c_distmap -> @@ -352,7 +516,3 @@ max_y <- fromIntegral <$> peek ptr_int_max_y max_r <- realToFrac <$> peek ptr_double_max_r return (max_x,max_y,max_r) - - - - diff --git a/CV/ImageMathOp.hs b/CV/ImageMathOp.hs --- a/CV/ImageMathOp.hs +++ b/CV/ImageMathOp.hs @@ -1,28 +1,62 @@ {-#LANGUAGE FlexibleContexts#-} -module CV.ImageMathOp where +-- | Mathematical operators for images; see also module "ImageMath" for the +-- functions these operators are based on. +module CV.ImageMathOp( + -- * Operators for two images + (#+) +, (#-) +, (#*) +, (#<) +, (#>) + -- * Operators for an image and a scalar +, (|*) +, (|+) +, (-|) +, (|-) +, (|>) +, (|<) +) where + import CV.Image import CV.ImageMath as IM import Data.List(iterate) +-- | Image addition, subtraction, and multiplication operator; same as +-- 'ImageMath.add', 'ImageMath.sub', and 'ImageMath.mul'. (#+), (#-), (#*) :: (CreateImage (Image c d)) => Image c d -> Image c d -> Image c d + (#+) = IM.add (#-) = IM.sub (#*) = IM.mul +-- | Image comparison operators; same as 'ImageMath.less2Than' and +-- 'ImageMath.more2Than'. Example: @A #< B@ produces a binary image that has +-- white pixels in those positions where value of A is less than value of B. (#<), (#>) :: (CreateImage (Image GrayScale d)) => Image GrayScale d -> Image GrayScale d -> Image GrayScale D8 + (#<) = IM.less2Than (#>) = IM.more2Than +-- | Scalar multiplication, addition, and subtraction (scalar on left) operators; +-- same as 'ImageMath.mulS', 'ImageMath.addS', and 'ImageMath.subRS'. (|*), (|+), (-|) :: D32 -> Image GrayScale D32 -> Image GrayScale D32 + (|*) = IM.mulS (|+) = IM.addS (-|) = IM.subRS +-- | Scalar comparison operators; same as 'ImageMath.moreThan' and +-- 'ImageMath.lessThan'. Example: @s |> I@ produces a binary image that has +-- white pixels in those positions where the value of I is larger than s. +-- Notice that this is opposite to the intuitive interpretation. (|>), (|<) :: D32 -> Image GrayScale D32 -> Image GrayScale D8 + (|>) = IM.moreThan (|<) = IM.lessThan + -- (|^) i n = (iterate (#* i) i) !! (n-1) +-- | Scalar subtraction operator (scalar on right); same as 'ImageMath.subS'. (|-) :: Image GrayScale D32 -> D32 -> Image GrayScale D32 (|-) = IM.subS diff --git a/CV/Matrix.hs b/CV/Matrix.hs --- a/CV/Matrix.hs +++ b/CV/Matrix.hs @@ -5,10 +5,9 @@ ( Exists(..), Matrix, emptyMatrix, fromFunction, fromList,toList,toRows,toCols,get,put,withMatPtr - , transpose, mxm, rodrigues2 + , transpose, mxm, rodrigues2, identity )where -{-#OPTIONS_GHC -fwarn-unused-imports#-} import System.Mem @@ -79,6 +78,10 @@ type Args (Matrix (Float,Float,Float)) = (Int,Int) create (r,c) = unsafePerformIO $ creatingMat (c'cvCreateMat r c c'CV_32FC3) +instance Exists (Matrix (CFloat,CFloat,CFloat)) where + type Args (Matrix (CFloat,CFloat,CFloat)) = (Int,Int) + create (r,c) = unsafePerformIO $ creatingMat (c'cvCreateMat r c c'CV_32FC3) + instance Exists (Matrix (Int,Int,Int,Int)) where type Args (Matrix (Int,Int,Int,Int)) = (Int,Int) create (r,c) = unsafePerformIO $ creatingMat (c'cvCreateMat r c c'CV_32SC4) @@ -91,6 +94,10 @@ type Args (Matrix Double) = (Int,Int) create (r,c) = unsafePerformIO $ creatingMat (c'cvCreateMat r c c'CV_64FC1) +instance Exists (Matrix (Double,Double)) where + type Args (Matrix (Double,Double)) = (Int,Int) + create (r,c) = unsafePerformIO $ creatingMat (c'cvCreateMat r c c'CV_64FC2) + instance Sized (Matrix a) where type Size (Matrix a) = (Int,Int) getSize (Matrix e) = unsafePerformIO $ withForeignPtr e $ \mat -> do @@ -102,6 +109,7 @@ emptyMatrix :: Exists (Matrix a) => Args (Matrix a) -> Matrix a emptyMatrix a = create a +-- | Create an identity matrix identity :: (Num a, Sized (Matrix a), Args (Matrix a) ~ (Int,Int), Size (Matrix a) ~ (Int,Int), Storable a, Exists (Matrix a)) => (Matrix a) -> Matrix a identity a = unsafePerformIO $ do @@ -236,4 +244,3 @@ putRaw :: forall t. (Storable t) => Ptr t -> CInt -> Int -> Int -> Int -> t -> IO () putRaw d step eltSize col row v = poke (castPtr (d `plusPtr` (col*(fromIntegral step)+row*eltSize))) v - diff --git a/CV/Pixelwise.hs b/CV/Pixelwise.hs --- a/CV/Pixelwise.hs +++ b/CV/Pixelwise.hs @@ -6,17 +6,19 @@ ,fromImage ,fromFunction ,toImage + ,toImagePar ,remap ,remapImage ,mapImage ,mapPixels ,imageFromFunction + ,imageToFunction ,(<$$>) ,(<+>)) where import Control.Applicative import CV.Image import System.IO.Unsafe -import Control.Parallel.Strategies +import Control.Concurrent.ParallelIO.Local -- | A wrapper for allowing functor and applicative instances for non-polymorphic image types. data Pixelwise x = MkP {sizeOf :: (Int,Int) @@ -60,11 +62,31 @@ remap :: (((Int,Int) -> b) -> ((Int,Int) -> x)) -> Pixelwise b -> Pixelwise x remap f (MkP s e) = MkP s (f e) --- | Convert a pixelwise construct into an image. -fromImage :: (GetPixel b, Sized b, Size b ~ Size (Pixelwise (P b))) => b -> Pixelwise (P b) -fromImage i = MkP (getSize i) (flip getPixel $ i) --- --- | Convert an image to pixelwise construct. +-- | Convert image to a function, which returns pixel values in the domain of +-- the image and zero elsewhere +imageToFunction :: (GetPixel (Image a b), Num (P (Image a b))) + => Image a b -> ((Int,Int) -> P (Image a b)) +imageToFunction img (x,y) | x>= 0 && y>= 0 && x < w && y < h = getPixel (x,y) img + | otherwise = 0 + where (w,h) = getSize img + +fromImage :: (Num (P b), GetPixel b, Sized b, Size b ~ Size (Pixelwise (P b))) => b -> Pixelwise (P b) +fromImage i = MkP size getP + where + size@(w,h) = getSize i + getP (x,y) | x>=0 && x=0 && y Int -> Pixelwise (SP (Image a b)) -> Image a b +toImagePar n (MkP (w,h) e) = unsafePerformIO $ withPool n $ \pool -> do + img <- create (w,h) + parallel_ pool [sequence_ [setPixel (i,j) (e (i,j)) img | i <- [0..w-1]] + |j <- [0..h-1]] + return img + +-- | Convert a pixelwise construct to image. toImage :: (SetPixel (Image a b), CreateImage (Image a b)) => Pixelwise (SP (Image a b)) -> Image a b toImage (MkP (w,h) e) = unsafePerformIO $ do @@ -78,6 +100,7 @@ remapImage :: (CreateImage (Image a b), SetPixel (Image a b), + Num (P (Image a b)), GetPixel (Image a b)) => (((Int, Int) -> P (Image a b)) -> (Int, Int) -> SP (Image a b)) -> Image a b -> Image a b @@ -88,14 +111,14 @@ mapPixels f (MkP s e) = MkP s (\(i,j) -> f $ e (i,j)) mapImage :: - (CreateImage (Image a b), - SetPixel (Image a b), + (CreateImage (Image c d), + SetPixel (Image c d), + Num (P (Image a b)), GetPixel (Image a b)) => - (P (Image a b) -> SP (Image a b)) -> Image a b -> Image a b + (P (Image a b) -> SP (Image c d)) -> Image a b -> Image c d mapImage f = toImage . mapPixels f . fromImage - -- | Convert a function into construct into a Pixelwise construct fromFunction :: (Int, Int) -> ((Int, Int) -> x) -> Pixelwise x fromFunction size f = MkP size f @@ -105,19 +128,10 @@ imageFromFunction size = toImage . fromFunction size --- toImageP :: Pixelwise D32 -> Image GrayScale D32 --- toImageP (MkP (w,h) e) = unsafePerformIO $ do --- img <- create (w,h) --- let rs = parMap rdeepseq (\j -> unsafePerformIO ( --- sequence_ [setPixel (i,j) (e (i,j)) img | i <- [0..w-1]] --- >> return True)) --- [0..h-1] --- all (==True) rs `seq` return img - -- | Shorthand for `a <$> fromImage b` -(<$$>) :: (Size b1 ~ (Int, Int), Sized b1, GetPixel b1) => (P b1 -> b) -> b1 -> Pixelwise b +(<$$>) :: (Num (P b1), Size b1 ~ (Int, Int), Sized b1, GetPixel b1) => (P b1 -> b) -> b1 -> Pixelwise b a <$$> b = a <$> fromImage b -- | Shorthand for `a <*> fromImage b` -(<+>) :: (Size b1 ~ (Int, Int), Sized b1, GetPixel b1) => Pixelwise (P b1 -> b) -> b1 -> Pixelwise b +(<+>) :: (Num (P b1),Size b1 ~ (Int, Int), Sized b1, GetPixel b1) => Pixelwise (P b1 -> b) -> b1 -> Pixelwise b a <+> b = a <*> fromImage b diff --git a/CV/Thresholding.hs b/CV/Thresholding.hs --- a/CV/Thresholding.hs +++ b/CV/Thresholding.hs @@ -1,5 +1,21 @@ -module CV.Thresholding -where + {-#LANGUAGE TypeSynonymInstances#-} + -- | Image thresholding operations +module CV.Thresholding( + -- * Interfaces to OpenCV functions + ThresholdType(..) +, threshold +, thresholdOtsu +, AdaptiveType(..) +, adaptiveThreshold + -- * Other methods +, bernsen +, nibbly +, nibblyr +, kittler +, kittlerMeasure +, betweenClassVariance +) where + import CV.Image import CV.Filters import qualified CV.ImageMath as IM @@ -10,7 +26,103 @@ import Utils.List import Data.List import CV.Histogram +import CV.Bindings.ImgProc +import Foreign.Ptr (nullPtr,castPtr) +-- | A type class for selecting the maximum value for each image type, used in +-- creating the thresholded image +class MaxVal a where + maxval :: (Image GrayScale a) -> Double + +instance MaxVal D32 where + maxval _ = 1 + +instance MaxVal D8 where + maxval _ = 255 + +-- | Thresholding behavior for values larger and smaller than threshold +data ThresholdType + -- | Values larger than threshold are set to max, smaller to zero + = MaxAndZero + -- | Values larger than threshold are set to zero, smaller to max + | ZeroAndMax + -- | Values larger than threshold are truncated to threshold, smaller are not touched + | ThreshAndValue + -- | Values larger than threshold are not touched, smaller are set to zero + | ValueAndZero + -- | Values larger than threshold are set to zero, smaller are not touched + | ZeroAndValue + +-- | Utility function for converting ThresholdType to c values +cThresholdType t = + case t of + MaxAndZero -> c'CV_THRESH_BINARY + ZeroAndMax -> c'CV_THRESH_BINARY_INV + ThreshAndValue -> c'CV_THRESH_TRUNC + ValueAndZero -> c'CV_THRESH_TOZERO + ZeroAndValue -> c'CV_THRESH_TOZERO_INV + +-- | Utility function for converting otsu ThresholdType to c values +cOtsuThresholdType t = + case t of + MaxAndZero -> c'CV_THRESH_OTSU_BINARY + ZeroAndMax -> c'CV_THRESH_OTSU_BINARY_INV + ThreshAndValue -> c'CV_THRESH_OTSU_TRUNC + ValueAndZero -> c'CV_THRESH_OTSU_TOZERO + ZeroAndValue -> c'CV_THRESH_OTSU_TOZERO_INV + +-- | Method used for selecting the adaptive threshold value +data AdaptiveType + -- | Threshold using the arithmetic mean of pixel neighborhood + = ByMean + -- | Threshold using the gaussian weighted mean of pixel neighborhood + | ByGaussian + +-- | Utility function for converting AdaptiveType to c value +cAdaptiveType t = + case t of + ByMean -> c'CV_ADAPTIVE_THRESH_MEAN_C + ByGaussian -> c'CV_ADAPTIVE_THRESH_GAUSSIAN_C + +-- | Thresholds a grayscale image according to the selected type, using the +-- given threshold value. +threshold :: (MaxVal d) => ThresholdType -> Double -> Image GrayScale d -> Image GrayScale d +threshold ttype tval image = + unsafePerformIO $ + withCloneValue image $ \result -> + withImage image $ \pimage -> + withImage result $ \presult -> do + c'cvThreshold (castPtr pimage) (castPtr presult) (realToFrac tval) + (realToFrac (maxval image)) (cThresholdType ttype) + return result + +-- | Thresholds a grayscale image using the otsu method according to the +-- selected type. Threshold value is selected automatically, and only 8-bit +-- images are supported. +thresholdOtsu :: ThresholdType -> Image GrayScale D8 -> Image GrayScale D8 +thresholdOtsu ttype image = + unsafePerformIO $ + withCloneValue image $ \result -> + withImage image $ \pimage -> + withImage result $ \presult -> do + c'cvThreshold (castPtr pimage) (castPtr presult) 0 + (realToFrac 255) (cOtsuThresholdType ttype) + return result + +-- | Applies adaptive thresholding by selecting the optimal threshold value for +-- each pixel. The threshold is selected by calculating the arithmetic or +-- gaussian-weighted mean of a pixel neighborhood, and applying a bias term to +-- the obtained value. +adaptiveThreshold :: (MaxVal d) => AdaptiveType -> ThresholdType -> Int -> Double + -> Image GrayScale d -> Image GrayScale d +adaptiveThreshold a t neighborhood bias image = + unsafePerformIO $ + withCloneValue image $ \result -> + withImage image $ \pimage -> + withImage result $ \presult -> do + c'cvAdaptiveThreshold (castPtr pimage) (castPtr presult) (realToFrac (maxval image)) + (cAdaptiveType a) (cThresholdType t) (fromIntegral neighborhood) (realToFrac bias) + return result bernsen (w,h) c i = goodContrast #* (i #< surface) where diff --git a/CV/Tracking.hs b/CV/Tracking.hs --- a/CV/Tracking.hs +++ b/CV/Tracking.hs @@ -1,4 +1,4 @@ -{-#LANGUAGE ConstraintKinds, FlexibleContexts, TypeFamilies#-} +{-#LANGUAGE FlexibleContexts, TypeFamilies#-} module CV.Tracking where import CV.Bindings.Tracking import CV.Bindings.Types @@ -12,7 +12,7 @@ import Foreign.Marshal.Utils import System.IO.Unsafe -meanShift :: (IntBounded a, ELBB a~Int) => Image GrayScale D32 -> a -> TermCriteria +meanShift :: (BoundingBox a, Integral (ELBB a), ELBB a~Int) => Image GrayScale D32 -> a -> TermCriteria -> (Double,Rectangle Int) meanShift image window crit = unsafePerformIO $ withGenImage image $ \c_img -> diff --git a/CV/Transforms.chs b/CV/Transforms.chs --- a/CV/Transforms.chs +++ b/CV/Transforms.chs @@ -124,7 +124,7 @@ {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg peekArray (3*3) c_hmg where - flatten = concatMap (\(a,b) -> [a,b]) + flatten = map realToFrac . concatMap (\(a,b) -> [a,b]) src = flatten srcPts dst = flatten dstPts @@ -243,6 +243,16 @@ #endc {#enum DistanceType {}#} +#ifdef OpenCV24 +#c +enum LabelType { + DIST_LABEL_CCOMP = CV_DIST_LABEL_CCOMP + ,DIST_LABEL_PIXEL = CV_DIST_LABEL_PIXEL +}; +#endc +{#enum LabelType {}#} +#endif + -- |Mask sizes accepted by distanceTransform data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show) @@ -256,6 +266,9 @@ (fromIntegral . fromEnum $ dtype) (fromIntegral . fromEnum $ maskSize) nullPtr nullPtr +#ifdef OpenCV24 + (fromIntegral . fromEnum $ DIST_LABEL_CCOMP) +#endif return result -- TODO: Add handling for labels -- TODO: Add handling for custom masks diff --git a/CV/Video.chs b/CV/Video.chs --- a/CV/Video.chs +++ b/CV/Video.chs @@ -77,7 +77,7 @@ , CAP_PROP_GAIN = CV_CAP_PROP_GAIN , CAP_PROP_EXPOSURE = CV_CAP_PROP_EXPOSURE , CAP_PROP_CONVERT_RGB = CV_CAP_PROP_CONVERT_RGB -#ifdef OpenCV23 +#if defined OpenCV23 || defined OpenCV24 , CAP_PROP_WHITE_BALANCE_BLUE_U = CV_CAP_PROP_WHITE_BALANCE_BLUE_U , CAP_PROP_WHITE_BALANCE_RED_V = CV_CAP_PROP_WHITE_BALANCE_RED_V #else diff --git a/Utils/GeometryClass.hs b/Utils/GeometryClass.hs --- a/Utils/GeometryClass.hs +++ b/Utils/GeometryClass.hs @@ -1,4 +1,4 @@ -{-#LANGUAGE TypeFamilies,FlexibleInstances, ConstraintKinds #-} +{-#LANGUAGE TypeFamilies,FlexibleInstances#-} module Utils.GeometryClass where import Utils.Rectangle @@ -41,7 +41,7 @@ convertBounds :: (BoundingBox a, FromBounds b, ELBB a ~ ELFB b) => a -> b convertBounds = fromBounds . bounds -type IntBounded a = (BoundingBox a,Integral (ELBB a)) +-- type IntBounded a = (BoundingBox a,Integral (ELBB a)) class Line2D a where type ELL a :: * diff --git a/Utils/Rectangle.hs b/Utils/Rectangle.hs --- a/Utils/Rectangle.hs +++ b/Utils/Rectangle.hs @@ -24,6 +24,9 @@ rSize (Rectangle x y w h) = (w,h) rArea r = let (w,h) = rSize r in (w*h) +center (Rectangle x y w h) = (x+w/2,y+h/2) +centerI (Rectangle x y w h) = (x+w`div`2,y+h`div`2) + -- TODO: Add documentation #Cleanup instance (Num a, Ord a , Serial a) => Serial (Rectangle a) where @@ -116,7 +119,11 @@ (round (a*fromIntegral s1),round (b*fromIntegral s2)) -toInt (Rectangle a b c d) +fromInt (Rectangle a b c d) = Rectangle (f a) (f b) (f c) (f d) where f = fromIntegral + +roundR (Rectangle a b c d) + = Rectangle (f a) (f b) (f c) (f d) + where f = round diff --git a/cbits/cvWrapLEO.c b/cbits/cvWrapLEO.c --- a/cbits/cvWrapLEO.c +++ b/cbits/cvWrapLEO.c @@ -447,11 +447,11 @@ ,bSize.height); // Blit the images b into a using cvCopy - printf("Doing a blit\n"); fflush(stdout); +// printf("Doing a blit\n"); fflush(stdout); cvSetImageROI(a,pos); cvCopy(b,a,NULL); cvResetImageROI(a); - printf("Done!\n"); fflush(stdout); +// printf("Done!\n"); fflush(stdout); } IplImage* makeEvenDown(IplImage *src) @@ -2348,7 +2348,11 @@ double wrapCalibrateCamera2(const CvMat* objectPoints, const CvMat* imagePoints, const CvMat* pointCounts, CvSize *imageSize, CvMat* cameraMatrix, CvMat* distCoeffs, CvMat* rvecs, CvMat* tvecs, int flags) { +#ifdef OpenCV24 +return cvCalibrateCamera2(objectPoints, imagePoints, pointCounts, *imageSize, cameraMatrix, distCoeffs, rvecs, tvecs, flags, cvTermCriteria(CV_TERMCRIT_ITER+CV_TERMCRIT_EPS,30,DBL_EPSILON)); +#else return cvCalibrateCamera2(objectPoints, imagePoints, pointCounts, *imageSize, cameraMatrix, distCoeffs, rvecs, tvecs, flags); +#endif }; void wrapFindCornerSubPix(const CvArr* image, CvPoint2D32f* corners, int count, int winW, int winH, int zeroW, int zeroH, int tType, int maxIter, double epsilon) { diff --git a/cbits/cvWrapLEO.h b/cbits/cvWrapLEO.h --- a/cbits/cvWrapLEO.h +++ b/cbits/cvWrapLEO.h @@ -292,9 +292,11 @@ return cvExtractSURF(image, mask, keypoints, descriptors, storage, *param, useProvidedKeyPts); }; +#ifndef OpenCV24 void wrapExtractMSER( CvArr* _img, CvArr* _mask, CvSeq** contours, CvMemStorage* storage, CvMSERParams *params ){ cvExtractMSER( _img, _mask, contours, storage, *params ); }; +#endif void wrapEllipseBox(CvArr* img, CvBox2D *box, CvScalar *color ,int thickness, int lineType, int shift) diff --git a/cbits/wrapImgProc.c b/cbits/wrapImgProc.c --- a/cbits/wrapImgProc.c +++ b/cbits/wrapImgProc.c @@ -4,3 +4,67 @@ void wrapFilter2(const CvArr* src, CvArr* dst, const CvMat* kernel, CvPoint *anchor) {cvFilter2D(src, dst, kernel, *anchor);}; +void fillConnectedComponents(IplImage* img, int *count) +{ + unsigned char *data, value; + unsigned int x, y, w, h, pos, step, index; + CvPoint point; + CvSize size; + + size = cvGetSize(img); + w = size.width; + h = size.height; + data = (unsigned char *)img->imageData; + step = (unsigned int)(img->widthStep / sizeof(unsigned char)); + + index = 0; + for (y = 0; y < h; y++) { + pos = y * step; + for (x = 0; x < w; x++, pos++) { + value = data[pos]; + if (value > index) { + index++; + point.x = x; + point.y = y; + cvFloodFill(img, point, cvRealScalar(index), cvScalarAll(0), cvScalarAll(0), NULL, 4, NULL); + } + } + } + *count = index; +} + +void maskConnectedComponent(const IplImage *src, IplImage *mask, int id) +{ + unsigned char *data, value, index; + unsigned int x, y, w, h, pos, step; + CvPoint point; + CvSize size; + + size = cvGetSize(mask); + w = size.width; + h = size.height; + data = (unsigned char *)mask->imageData; + step = (unsigned int)(mask->widthStep / sizeof(unsigned char)); + + if (id > 0 && id < 256) { + cvCopy(src, mask, NULL); + index = (unsigned char)id; + for (y = 0; y < h; y++) { + pos = y * step; + for (x = 0; x < w; x++, pos++) { + value = data[pos]; + if (value > 0) { + if (value == index) { + data[pos] = 255; + } + else { + data[pos] = 0; + } + } + } + } + } + else { + cvSetZero(mask); + } +} diff --git a/cbits/wrapImgProc.h b/cbits/wrapImgProc.h --- a/cbits/wrapImgProc.h +++ b/cbits/wrapImgProc.h @@ -3,6 +3,16 @@ #include +#define CV_THRESH_OTSU_BINARY CV_THRESH_OTSU | CV_THRESH_BINARY +#define CV_THRESH_OTSU_BINARY_INV CV_THRESH_OTSU | CV_THRESH_BINARY_INV +#define CV_THRESH_OTSU_TRUNC CV_THRESH_OTSU | CV_THRESH_TRUNC +#define CV_THRESH_OTSU_TOZERO CV_THRESH_OTSU | CV_THRESH_TOZERO +#define CV_THRESH_OTSU_TOZERO_INV CV_THRESH_OTSU | CV_THRESH_TOZERO_INV + void wrapFilter2(const CvArr* src, CvArr* dst, const CvMat* kernel, CvPoint *anchor); + +void fillConnectedComponents(IplImage* src, int *count); + +void maskConnectedComponent(const IplImage *src, IplImage *mask, int id); #endif diff --git a/examples/ConnectedComponents.hs b/examples/ConnectedComponents.hs new file mode 100644 --- /dev/null +++ b/examples/ConnectedComponents.hs @@ -0,0 +1,21 @@ +module Main where +import CV.Fitting +import CV.Image +import CV.Drawing +import CV.Matrix +import CV.ImageOp + +main = do + let res :: Image GrayScale D32 + res = empty (400,400) + testPts = [(200+100*sin x-80*cos x,200+60*cos x) | x <- [0,0.1..pi]] + mat = fromList (1,length testPts) testPts + ell = fitEllipse mat + bb = minAreaRect mat + br = boundingRect mat + pts = res <## [circleOp 1 (round x, round y) 3 Filled | (x,y) <- testPts] + <# drawBox2Dop 1 bb + saveImage "bb_result.png" pts + print ell + print bb + print br diff --git a/examples/TreeTop.hs b/examples/TreeTop.hs new file mode 100644 --- /dev/null +++ b/examples/TreeTop.hs @@ -0,0 +1,66 @@ +{-#LANGUAGE ParallelListComp, RecordWildCards, DeriveGeneric#-} +module Main where + +import CV.Image +import CV.Tracking +import CV.Bindings.Types +import CV.Drawing +import CV.ImageOp +import Utils.Rectangle +import Text.Printf +import CV.ImageMathOp hiding ((#>)) +import CV.Filters +import CV.ColourUtils +import Utils.Rectangle +import Data.List +import Data.Function + +import Graphics.Tools.DefaultGUI + +data Parameters = P {x :: IntRange Zero Hundred + ,y :: IntRange Zero Hundred + ,scale :: IntRange One Fifty } deriving (Generic) + +instance Default Parameters +instance Persist Parameters +instance Tangible Parameters + +main = defaultGUI "Treetop_params" "dsm.tif" f + +f P{..} img = resultI + where + prec :: Image GrayScale D32 + prec = gaussian (11,11) img + (w,h) = getSize img + resultPts = [ (val,res) | x <- [0,15..w-10], y <- [0,15..h-10] + , let (val,res) = hillClimber (indfun prec) (-1,(x,y)) + ] + groups = group2 (\a b -> abs (a-b) < value scale) (snd.snd) (fst.snd) $ resultPts + resultI = img-- <## [ lineOp 0.8 1 s (res) #> + -- circleOp 2 (res) 1 Filled + -- | (s,res) <- resultPts + -- ] + <## [circleOp 0 m 10 (Stroked 1) | rs <- groups, let (v,m) = maximumBy (compare`on`fst) rs] + + -- (val,res) = -- meanShift prec s1 (EPS 1) + +group2 equal a b = concatMap (f a) . f b + where + f a = groupBy (equal `on` a) . sortBy (compare `on` a) + + +indfun :: Image GrayScale D32 -> ((Int,Int) -> D32) +indfun img c@(x,y) | x<0 = 0 + | y<0 = 0 + | x>=w = 0 + | y>=h = 0 + | otherwise = getPixel c img + where (w,h) = getSize img + +hillClimber :: ((Int,Int) -> D32) -> (D32, (Int,Int)) -> (D32, (Int,Int)) +hillClimber f (o,init) + | (o+0.001) >= v = (o,init) + | otherwise = hillClimber f (v,next) + where + (v,next) = maximumBy (compare`on` fst) $ [(f n, n) | n <- neighbours init ] + neighbours (x,y) = [(x+i,y+j) | i<-[-5,-4..5], j <- [-5,-4..5], (i,j) /= (0,0)] diff --git a/examples/dftPattern.hs b/examples/dftPattern.hs deleted file mode 100644 --- a/examples/dftPattern.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-#LANGUAGE ScopedTypeVariables#-} -module Main where - -import CV.ColourUtils -import CV.DFT -import CV.Drawing -import CV.Edges -import CV.Filters -import CV.Image -import CV.ImageOp -import CV.Pixelwise -import Control.Applicative hiding ((<**>),empty) -import qualified CV.ImageMath as IM -import qualified CV.Transforms as T -import Data.Complex -import CV.ImageMathOp -import CV.Thresholding - -fi = fromIntegral - -main = do - Just x <- loadImage "d2.png" - let d = dft x - c (x,y) = circleOp (0:+0) (x,y) 23 Filled - d2 = d <# c (155,215) - <# c (400,205) - <# c (180,365) - <# c (425,370) - <# c (40,370) - <# c (540,215) - <# c (200,150) - <# c (375,432) - <# c (260,130) - <# c (315,450) - <# c (262,520) - <# c (315,66) - <# c (375,44) - <# c (202,540) - mag = fst $ dftSplit $ d - pat = gaussian (3,3) $ unsafeImageTo32F $ nibbly 0.01 0.001 $ gaussian (31,31) mag #- gaussian (9,9) mag - saveImage "target.png" $ logarithmicCompression $ fst $ dftSplit $ d2 - saveImage "dftmanip.png" $ montage (3,1) 0 - [ - x - ,logarithmicCompression $ fst $ dftSplit $ (d #* dftMerge (pat,empty (getSize pat))) - ,idft (d #* dftMerge (pat,empty (getSize pat))) - ] diff --git a/examples/glcm.hs b/examples/glcm.hs new file mode 100644 --- /dev/null +++ b/examples/glcm.hs @@ -0,0 +1,23 @@ +module Main where + +import CV.Image +import qualified Data.Vector as V +import CV.Pixelwise +import CV.ColourUtils + + +main = do + Just x <- loadImage "smallLena.jpg" >>= return . fmap unsafeImageTo8Bit + let + -- Avustimet + get (i,j) = fromIntegral $ getPixel (i,j) x -- Lyhennemerkintä. + (w,h) = getSize x --koko + + (dx,dy) = (2,2) -- DX/DY on aina positiivinen, sillä talletetaan vain alakolmio. + toIdx (i,j) = (max i j*(max i j+1)) `div` 2 + min i j -- Talletetaan vain alakolmiomatriisi + + hist = V.accum (+) (V.replicate (toIdx (255,255)) 0) $ -- Raaka-akkumulaatio + [(toIdx (get (i,j), get (i+dx,j+dy)),1) + | i <- [0..w-1-dx] + , j <- [0..h-1-dy]] + saveImage "GLCM.png" . logarithmicCompression $ imageFromFunction (255,255) ((V.!) hist . toIdx)