-- GENERATED by C->Haskell Compiler, version 0.16.3 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "./CV/ConnectedComponents.chs" #-}{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables#-}
-- | This module contains functions for extracting features from connected components
--   of black and white images as well as extracting other shape related features. 
module CV.ConnectedComponents
       (
       -- * Working with connected components
        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.
       ,Contours
       ,getContours
       ,contourArea
       ,contourPerimeter
       ,contourPoints
       ,mapContours
       ,contourHuMoments) 
where

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
{-# LINE 41 "./CV/ConnectedComponents.chs" #-}

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 
countBlobs image = fromIntegral $unsafePerformIO $ do
    withGenImage image $ \i ->
     blobCount i

-- |Remove all connected components that fall outside of given size range from the image.
selectSizedComponents :: Double -> Double -> Image GrayScale D8 -> Image GrayScale D8
selectSizedComponents minSize maxSize image = unsafePerformIO $ do
    withGenImage image $ \i ->
     creatingImage (sizeFilter i (realToFrac minSize) (realToFrac maxSize))

-- * 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 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
   hu <- mallocArray 7
   getHuMoments m hu
   hu' <- peekArray 7 hu
   free hu
   return hu'

-- |Structure that contains the opencv sequence holding the contour data.
newtype Contours = Contours (ForeignPtr (Contours))
withContours (Contours fptr) = withForeignPtr fptr
{-# LINE 142 "./CV/ConnectedComponents.chs" #-}
foreign import ccall "& free_found_contours" releaseContours 
    :: FinalizerPtr Contours

-- | This function maps an opencv contour calculation over all
--   contours of the image. 
mapContours :: ContourFunctionUS a -> Contours -> [a]
mapContours (CFUS op) contours = unsafePerformIO $ do
    let loop acc cp = do
        more <- withContours cp more_contours
{-# LINE 151 "./CV/ConnectedComponents.chs" #-}
        if more < 1 
            then return acc 
            else do
                x <- op cp
                (i::CInt) <- withContours cp next_contour
{-# LINE 156 "./CV/ConnectedComponents.chs" #-}
                loop (x:acc) cp
         
    acc <- loop [] contours
    withContours contours (reset_contour)
    return acc

-- |Extract contours of connected components of the image.
getContours :: Image GrayScale D8 -> Contours
getContours img = unsafePerformIO $ do
        withImage img $ \i -> do
          ptr <- get_contours i
          fptr <- newForeignPtr releaseContours ptr
          return $ Contours fptr 

newtype ContourFunctionUS a = CFUS (Contours -> IO a)
newtype ContourFunctionIO a = CFIO (Contours -> IO a)

rawContourOpUS op = CFUS $ \c -> withContours c op
rawContourOp op = CFIO $ \c -> withContours c op

printContour = rawContourOp print_contour
{-# LINE 177 "./CV/ConnectedComponents.chs" #-}

contourArea :: ContourFunctionUS Double
contourArea = rawContourOpUS (contour_area >=> return.realToFrac)
-- ^The area of a contour.

contourPerimeter :: ContourFunctionUS Double
contourPerimeter = rawContourOpUS $ contour_perimeter >=> return.realToFrac
-- ^Get the perimeter of a contour.

-- |Get a list of the points in the contour.
contourPoints :: ContourFunctionUS [(Double,Double)]
contourPoints = rawContourOpUS getContourPoints'
getContourPoints' f = do
     count <- cur_contour_size f
     let count' = fromIntegral count 
     ----print count
     xs <- mallocArray count'     
     ys <- mallocArray count'
     contour_points f xs ys
     xs' <- peekArray count' xs
     ys' <- peekArray count' ys
     free xs
     free ys
     return $ zip (map fromIntegral xs') (map fromIntegral ys')

-- | Operation for extracting Hu-moments from a contour
contourHuMoments :: ContourFunctionUS [Double]
contourHuMoments = rawContourOpUS $ getContourHuMoments' >=> return.map realToFrac
getContourHuMoments' f = do
   m <- contour_moments f     
   hu <- readHu m 
   freeCvMoments m
   return hu


mapContoursIO :: ContourFunctionIO a -> Contours -> IO [a]
mapContoursIO (CFIO op) contours = do
    let loop acc cp = do
        more <- withContours cp more_contours
{-# LINE 216 "./CV/ConnectedComponents.chs" #-}
        if more < 1 
            then return acc 
            else do
                x <- op cp
                (i::CInt) <- withContours cp next_contour
{-# LINE 221 "./CV/ConnectedComponents.chs" #-}
                loop (x:acc) cp
         
    acc <- loop [] contours
    withContours contours (reset_contour)
    return acc

newtype Moments = Moments (ForeignPtr (Moments))
withMoments (Moments fptr) = withForeignPtr fptr
{-# LINE 228 "./CV/ConnectedComponents.chs" #-}

foreign import ccall safe "CV/ConnectedComponents.chs.h blobCount"
  blobCount :: ((Ptr (BareImage)) -> (IO CInt))

foreign import ccall safe "CV/ConnectedComponents.chs.h sizeFilter"
  sizeFilter :: ((Ptr (BareImage)) -> (CDouble -> (CDouble -> (IO (Ptr (BareImage))))))

foreign import ccall safe "CV/ConnectedComponents.chs.h getHuMoments"
  getHuMoments :: ((Ptr ()) -> ((Ptr CDouble) -> (IO ())))

foreign import ccall safe "CV/ConnectedComponents.chs.h more_contours"
  more_contours :: ((Ptr (Contours)) -> (IO CInt))

foreign import ccall safe "CV/ConnectedComponents.chs.h next_contour"
  next_contour :: ((Ptr (Contours)) -> (IO CInt))

foreign import ccall safe "CV/ConnectedComponents.chs.h reset_contour"
  reset_contour :: ((Ptr (Contours)) -> (IO CInt))

foreign import ccall safe "CV/ConnectedComponents.chs.h get_contours"
  get_contours :: ((Ptr (BareImage)) -> (IO (Ptr (Contours))))

foreign import ccall safe "CV/ConnectedComponents.chs.h print_contour"
  print_contour :: ((Ptr (Contours)) -> (IO ()))

foreign import ccall safe "CV/ConnectedComponents.chs.h contour_area"
  contour_area :: ((Ptr (Contours)) -> (IO CDouble))

foreign import ccall safe "CV/ConnectedComponents.chs.h contour_perimeter"
  contour_perimeter :: ((Ptr (Contours)) -> (IO CDouble))

foreign import ccall safe "CV/ConnectedComponents.chs.h cur_contour_size"
  cur_contour_size :: ((Ptr (Contours)) -> (IO CInt))

foreign import ccall safe "CV/ConnectedComponents.chs.h contour_points"
  contour_points :: ((Ptr (Contours)) -> ((Ptr CInt) -> ((Ptr CInt) -> (IO ()))))

foreign import ccall safe "CV/ConnectedComponents.chs.h contour_moments"
  contour_moments :: ((Ptr (Contours)) -> (IO (Ptr ())))

foreign import ccall safe "CV/ConnectedComponents.chs.h freeCvMoments"
  freeCvMoments :: ((Ptr ()) -> (IO ()))