working contouring

HOpenCV.cabal

@@ -80,6 +80,10 @@ library
        extra-libraries: cv highgui
      else
        extra-libraries: opencv_core,opencv_imgproc,opencv_highgui,opencv_video
+
+   -- needed to load in ghci-7.8 
+   cc-options: -fPIC
+
    build-depends: base >= 4.6 && <5, 
                   template-haskell,
                   vector-space >= 0.7.2,

src/OpenCV/Contours.hsc

@@ -1,18 +1,140 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 -- |Incomplete support for cvFindContours.
-module OpenCV.Contours (ContourMode(..), ContourMethod(..), 
-                        cvFindContours, followContourList) where
+module OpenCV.Contours (
+
+  -- * contour
+  Contour(..),
+  withContourList,
+  -- ** functions to use with 'withContourList'
+  cvContourArea,
+  cvContourPerimeter,
+  followPoints,
+
+  cvDrawContours,
+  -- * moments
+  cvMoments,
+  CvMoments(..),
+
+  cvGetSpatialMoment,
+  cvGetCentralMoment,
+  cvGetNormalizedCentralMoment,
+  cvGetHuMoments,
+  CvHuMoments(..),
+
+  -- * unused
+  ContourMode(..), ContourMethod(..), 
+  ) where
 import OpenCV.Core.CxCore
-import Foreign.C.Types (CInt)
-import Foreign.Ptr (Ptr, castPtr, nullPtr)
+import OpenCV.Core.ImageUtil
+import Foreign.C.Types (CInt(..))
+import Foreign.Ptr -- (Ptr, castPtr, nullPtr)
 import Foreign.Storable
-import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Alloc -- (alloca)
+import Foreign.ForeignPtr.Safe
+import Foreign.Marshal
+
+import Control.Monad
 
 #include <opencv2/core/types_c.h>
+#include <opencv2/imgproc/types_c.h>
 
 foreign import ccall "HOpenCV_wrap.h c_cvFindContours"
-  c_cvFindContours :: Ptr CvArr -> Ptr CvMemStorage -> Ptr (Ptr (CvSeq a)) -> 
-                      Int -> Int -> Int -> Int -> Int -> IO Int
+  c_cvFindContours :: Ptr CvArr -> Ptr CvMemStorage -> Ptr (Ptr (CvSeq a)) ->
+                      CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt
+
+foreign import ccall "HOpenCV_wrap.h c_cvGetSeqPoint"
+  c_cvGetSeqPoint :: Ptr (CvSeq a) -> CInt -> Ptr CInt -> Ptr CInt -> IO ()
+
+foreign import ccall "HOpenCV_wrap.h c_cvContourArea"
+  cvContourArea :: Contour -> IO Double
+
+foreign import ccall "HOpenCV_wrap.h c_cvContourPerimeter"
+  cvContourPerimeter :: Contour -> IO Double
+
+foreign import ccall "HOpenCV_wrap.h c_cvMoments"
+  c_cvMoments :: Ptr CvArr -> Ptr CvMoments -> IO ()
+
+cvMoments :: IplArrayType a => Ptr a -> IO CvMoments
+cvMoments img = do
+    p <- mallocForeignPtrBytes (# size CvMoments )
+    withForeignPtr p (c_cvMoments (castPtr img))
+    return (CvMoments p)
+
+foreign import ccall "cvGetSpatialMoment" 
+  c_cvGetSpatialMoment :: Ptr CvMoments -> CInt -> CInt -> IO Double
+
+cvGetSpatialMoment, cvGetCentralMoment, cvGetNormalizedCentralMoment
+  ::  CvMoments
+  -> CInt -- ^ x
+  -> CInt -- ^ y
+  -> IO Double
+cvGetSpatialMoment (CvMoments p) xord yord =
+    withForeignPtr p (\ p' -> c_cvGetSpatialMoment p' xord yord )
+
+foreign import ccall "cvGetCentralMoment" 
+  c_cvGetCentralMoment :: Ptr CvMoments -> CInt -> CInt -> IO Double
+
+cvGetCentralMoment (CvMoments p) xord yord =
+    withForeignPtr p (\ p' -> c_cvGetCentralMoment p' xord yord )
+
+foreign import ccall "cvGetNormalizedCentralMoment" 
+  c_cvGetNormalizedCentralMoment :: Ptr CvMoments -> CInt -> CInt -> IO Double
+
+cvGetNormalizedCentralMoment (CvMoments p) xord yord =
+    withForeignPtr p (\ p' -> c_cvGetNormalizedCentralMoment p' xord yord )
+
+foreign import ccall "cvGetHuMoments" 
+  c_cvGetHuMoments :: Ptr CvMoments -> Ptr () -> IO ()
+
+foreign import ccall "c_cvDrawContours"
+  c_cvDrawContours :: Ptr IplImage
+    -> Contour
+    -> Ptr CvScalar -- ^ RGBA external_color
+    -> Ptr CvScalar -- ^ RGBA hole_color
+    -> CInt -- max level
+    -> CInt -- thickness
+    -> CInt -- line-type
+    -> Ptr CvPoint -- offset
+    -> IO ()
+
+cvDrawContours ::
+   Ptr IplImage
+   -> Contour
+   -> CvScalar -- ^ external color
+   -> CvScalar -- ^ hole color
+   -> CInt -- ^ max level
+   -> CInt -- ^ thickness
+   -> CInt -- ^ line type
+   -> CvPoint -- ^ offset
+   -> IO ()
+cvDrawContours img contour external_color hole_color max_level thickness line_type offset =
+    with external_color $ \ec ->
+    with hole_color $ \ hc ->
+    with offset $ \offset' ->
+    c_cvDrawContours img contour ec hc max_level thickness line_type offset'
+
+
+cvGetHuMoments :: CvMoments -> IO CvHuMoments
+cvGetHuMoments (CvMoments m) = allocaBytes (# size CvHuMoments )  $ \p -> do
+    withForeignPtr m $ \m' -> c_cvGetHuMoments m' p
+    h1 <- (#peek CvHuMoments, hu1) p
+    h2 <- (#peek CvHuMoments, hu2) p
+    h3 <- (#peek CvHuMoments, hu3) p
+    h4 <- (#peek CvHuMoments, hu4) p
+    h5 <- (#peek CvHuMoments, hu5) p
+    h6 <- (#peek CvHuMoments, hu6) p
+    h7 <- (#peek CvHuMoments, hu7) p
+    return (CvHuMoments h1 h2 h3 h4 h5 h6 h7)
+
+newtype Contour = Contour (Ptr (CvSeq (CInt, CInt)))
+
+-- | abstract. Use 'cvGetSpatialMoment' etc.
+newtype CvMoments = CvMoments (ForeignPtr CvMoments)
+
+data CvHuMoments = CvHuMoments !Double !Double !Double !Double !Double !Double !Double
+                 deriving Show
 
 -- |Contour extraction mode.
 data ContourMode = CV_RETR_EXTERNAL -- ^retrieves only the extreme
@@ -32,9 +154,11 @@ data ContourMode = CV_RETR_EXTERNAL -- ^retrieves only the extreme
                  | CV_RETR_TREE     -- ^retrieves all of the contours
                                     -- and reconstructs the full
                                     -- hierarchy of nested contours
+                 | CV_RETR_FLOODFILL
                    deriving (Enum, Eq)
 
-data ContourMethod = CV_CHAIN_APPROX_NONE      
+data ContourMethod = CV_CHAIN_CODE -- ^ ??
+                   | CV_CHAIN_APPROX_NONE      
                    -- ^translates all of the points from the chain
                    -- code into points
 
@@ -60,41 +184,40 @@ data ContourMethod = CV_CHAIN_APPROX_NONE
 -- |The function retrieves 'CvContour's from the binary image using the
 -- algorithm Suzuki85. The contours are a useful tool for shape
 -- analysis and object detection and recognition.
-cvFindContours :: IplArrayType a => Ptr a -> ContourMode -> ContourMethod -> IO [CvContour]
-cvFindContours img mode method = 
-    do storage <- cvCreateMemStorage 0
-       let header = case method of
-                      --CV_CHAIN_CODE -> (#size CvChain)
-                      _ -> (#size CvContour)
-           mode' = fromEnum mode
-           method' = case method of 
-                       CV_LINK_RUNS -> if mode == CV_RETR_LIST
-                                       then fromEnum method
-                                       else error $ "CV_LINK_RUNS can only be "++
-                                                    "used with CV_RETR_LIST"
-                       _ -> fromEnum method
-       cs <- alloca $ \cseq ->
-               do _n <- alloca $ \cseq' ->
-                          poke (cseq'::Ptr (Ptr CInt)) cseq >>
-                          c_cvFindContours (fromArr img) storage (castPtr cseq')
-                                           header mode' method' 0 0
-                  putStrLn $ "Found "++show _n++" contours"
-                  followContourList (castPtr cseq)
+--
+-- only does @CV_RETR_LIST CV_CHAIN_APPROX_SIMPLE@
+--
+withContourList :: Image Monochromatic d roi -> (Contour -> IO r) -> IO [r]
+withContourList img fn = withIplImage img $ \imgPtr -> do
+       storage <- cvCreateMemStorage 0
+       cseq <- new nullPtr
+       n <- c_cvFindContours (fromArr imgPtr) storage
+                       cseq
+                       (#size CvContour)
+                       (fromIntegral (fromEnum CV_RETR_LIST))
+                       (fromIntegral (fromEnum CV_CHAIN_APPROX_SIMPLE)) 0 0
+       cs <- mapContours fn n . Contour =<< peek cseq
        cvReleaseMemStorage storage
+       free cseq
        return cs
 
--- FIXME: This is wrong. We're actually getting an array of arrays of
--- Points. Check the cvDrawContours function to see how to interpret
--- the result of c_cvFindContours.
-followContourList :: Ptr (CvSeq CvContour) -> IO [CvContour]
-followContourList = go []
-    where go acc p = if p == nullPtr
-                     then return $ reverse acc
-                     else do putStrLn "Getting element 1"
-                             n <- seqNumElems p
-                             putStrLn $ "Initial seq has "++show n++" elems"
-                             x <- peek =<< cvGetSeqElem p 1
-                             putStrLn $ "Found " ++ show x
-                             p' <- (#peek CvSeq, h_next) p
-                             go (x:acc) p'
+mapContours :: (Contour -> IO b) -> CInt -> Contour -> IO [ b ]
+mapContours fn n (Contour p0) = go [] n p0 where
+  go acc 0 p = return $ reverse acc
+  go acc n p | p == nullPtr = return $ reverse acc
+  go acc n p = do
+        b <- fn (Contour p)
+        p' <- (#peek CvSeq, h_next) p
+        go (b:acc) (n-1) p'
+
+followPoints :: Contour -> IO [(CInt, CInt)]
+followPoints (Contour p) = do
+  m <- (#peek CvSeq, total) p
+  alloca $ \x -> alloca $ \y ->
+    let go (-1) acc = return acc
+        go ni acc = do
+          c_cvGetSeqPoint p ni x y
+          xy <- liftM2 (,) (peek x) (peek y)
+          go (ni-1) (xy : acc)
+    in go ((m::CInt) - 1) []
 

src/OpenCV/Core/HOpenCV_wrap.c

@@ -139,6 +139,12 @@ int seq_total(const CvSeq *seq) {
     return seq->total;
 }
 
+void c_cvGetSeqPoint(const CvSeq *seq, int i, int*x, int*y) {
+  CvPoint* p = CV_GET_SEQ_ELEM( CvPoint, seq, i);
+  *x = p->x;
+  *y = p->y;
+}
+
 /* Commonly used case of CV_GET_SEQ_ELEM is CvRect-typed elements.
    The macro CV_GET_SEQ_ELEM is supposed to be faster in some cases
    than the function cvGetSeqElem. */
@@ -184,6 +190,26 @@ int c_cvFindContours(CvArr *img, CvMemStorage *storage, CvSeq** first_contour,
                           method, cvPoint(offset_x,offset_y));
 }
 
+
+double c_cvContourArea( const CvArr *contour)
+{
+  return cvContourArea( contour, CV_WHOLE_SEQ, 0 );
+}
+
+
+
+void c_cvMoments( const CvArr* arr, CvMoments* moments)
+{
+  cvMoments( arr, moments, 0);
+}
+
+double c_cvContourPerimeter( const void* contour)
+{
+  cvContourPerimeter(contour);
+}
+
+// int c_cvFollowContourList
+
 void c_cvSetRoi(IplImage* img, int x, int y, int width, int height)
 {
   cvSetImageROI(img, cvRect(x,y,width,height));
@@ -205,6 +231,17 @@ void c_cvAvg(const CvArr *img, const CvArr *mask, CvScalar* avg)
 }
 
 
+void c_cvDrawContours( CvArr * img, CvSeq* contour,
+      CvScalar * external_color,
+      CvScalar * hole_color,
+      int max_level, int max_thickness, int line_type, CvPoint * offset )
+{
+  cvDrawContours( img, contour, *external_color, *hole_color,
+        max_level, max_thickness, line_type, *offset);
+}
+
+
+
 /****************************************************************************/
 /*
 CvSeq *c_cvHaarDetectObjects( const CvArr* image,

src/OpenCV/Core/HOpenCV_wrap.h

@@ -31,6 +31,9 @@ void cv_free(void *obj);
 int seq_total(const CvSeq *seq);
 /* CvRect *c_rect_cvGetSeqElem(const CvSeq *seq, int index); */
 
+void c_cvGetSeqPoint(const CvSeq *seq, int i, int*x, int*y);
+
+
 CvVideoWriter* cvCreateVideoWriter(const char* filename, int fourcc, 
         double fps, int frame_x, int frame_y, int is_color);
 
@@ -49,6 +52,9 @@ int c_cvFindContours(CvArr *img, CvMemStorage *storage, CvSeq** first_contour,
                      int header_size, int mode, int method, int offset_x, 
                      int offset_y);
 
+double c_cvContourArea( const CvArr *contour);
+double c_cvContourPerimeter( const void* contour);
+
 void c_cvAvg(const CvArr *img, const CvArr *mask, CvScalar* avg);
 
 CvSeq *c_cvHaarDetectObjects( const CvArr* image,
@@ -57,3 +63,8 @@ CvSeq *c_cvHaarDetectObjects( const CvArr* image,
                               int min_neighbors , int flags,
                               int width, int height);
 
+
+void c_cvDrawContours( CvArr * img, CvSeq* contour,
+      CvScalar * external_color,
+      CvScalar * hole_color,
+      int max_level, int max_thickness, int line_type, CvPoint * offset );

src/OpenCV/Core/Image.hsc

@@ -29,7 +29,8 @@ import Control.Monad (when)
 import Data.Bits (complement, (.&.))
 import Data.Int
 import Data.Proxy
-import Data.Singletons
+import Data.Singletons hiding (Proxy)
+import Data.Singletons.TH
 import Data.Word (Word8, Word16)
 import Foreign.C.Types
 import Foreign.ForeignPtr

src/OpenCV/Drawing.hsc

@@ -138,4 +138,7 @@ fillConvexPoly (r,g,b) lineType pts =
   where lt = fi $ lineTypeEnum lineType
         flatten (x,y) = [fi x, fi y]
         fi = fromIntegral
-        fr = realToFrac
+        fr = realToFrac
+
+
+