never executed always true always false
    1 {-# LANGUAGE QuasiQuotes #-}
    2 {-# LANGUAGE TemplateHaskell #-}
    3 
    4 module OpenCV.ImgProc.StructuralAnalysis
    5     ( contourArea
    6     , pointPolygonTest
    7     , findContours
    8     , Contour(..)
    9     , ContourAreaOriented(..)
   10     , ContourRetrievalMode(..)
   11     , ContourApproximationMethod(..)
   12     , approxPolyDP
   13     , arcLength
   14     , minAreaRect
   15     ) where
   16 
   17 import "primitive" Control.Monad.Primitive ( PrimMonad, PrimState, unsafePrimToPrim )
   18 import "base" Control.Exception ( mask_ )
   19 import "base" Control.Monad (guard)
   20 import "base" Data.Functor (($>))
   21 import "base" Data.Int
   22 import "base" Data.Maybe (mapMaybe)
   23 import "base" Data.Traversable (for)
   24 import qualified "vector" Data.Vector as V
   25 import "base" Data.Word
   26 import "base" Foreign.C.Types
   27 import "base" Foreign.Marshal.Alloc ( alloca )
   28 import "base" Foreign.Marshal.Array ( peekArray )
   29 import "base" Foreign.Marshal.Utils ( fromBool )
   30 import "base" Foreign.Ptr ( Ptr )
   31 import "base" Foreign.Storable ( peek )
   32 import "base" System.IO.Unsafe ( unsafePerformIO )
   33 import qualified "inline-c" Language.C.Inline as C
   34 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
   35 import qualified "inline-c" Language.C.Inline.Unsafe as CU
   36 import "linear" Linear.V4 ( V4(..) )
   37 import "this" OpenCV.Core.Types ( Mut )
   38 import "this" OpenCV.Core.Types.Point
   39 import "this" OpenCV.Core.Types.Vec ( fromVec )
   40 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
   41 import "this" OpenCV.Internal.C.Types
   42 import "this" OpenCV.Internal.Core.Types
   43 import "this" OpenCV.Internal.Core.Types.Mat
   44 import "this" OpenCV.Internal.Exception
   45 import "this" OpenCV.TypeLevel
   46 
   47 --------------------------------------------------------------------------------
   48 
   49 #include <bindings.dsl.h>
   50 #include "opencv2/imgproc.hpp"
   51 
   52 C.context openCvCtx
   53 
   54 C.include "opencv2/core.hpp"
   55 C.include "opencv2/imgproc.hpp"
   56 C.using "namespace cv"
   57 
   58 --------------------------------------------------------------------------------
   59 -- Structural Analysis and Shape Descriptors
   60 --------------------------------------------------------------------------------
   61 
   62 {- | Calculates a contour area.
   63 
   64 The function computes a contour area. Similarly to `moments`, the area is
   65 computed using the <https://en.wikipedia.org/wiki/Green%27s_theorem Green formula>.
   66 Thus, the returned area and the number of non-zero pixels, if you draw the
   67 contour using `drawContours` or `fillPoly`, can be different. Also, the function
   68 will most certainly give a wrong results for contours with self-intersections.
   69 
   70 <http://docs.opencv.org/3.0-last-rst/modules/imgproc/doc/structural_analysis_and_shape_descriptors.html?highlight=contourarea#cv2.contourArea OpenCV Sphinx doc>
   71 -}
   72 contourArea
   73     :: (IsPoint2 point2 CFloat)
   74     => V.Vector (point2 CFloat)
   75        -- ^ Input vector of 2D points (contour vertices).
   76     -> ContourAreaOriented
   77        -- ^ Signed or unsigned area
   78     -> CvExcept Double
   79 contourArea contour areaOriented = unsafeWrapException $
   80     withArrayPtr (V.map toPoint contour) $ \contourPtr ->
   81     alloca $ \c'area ->
   82     handleCvException (realToFrac <$> peek c'area) $
   83       [cvExcept|
   84         cv::_InputArray contour =
   85           cv::_InputArray( $(Point2f * contourPtr)
   86                          , $(int32_t c'numPoints)
   87                          );
   88         *$(double * c'area) = cv::contourArea(contour, $(bool c'oriented));
   89       |]
   90   where
   91     oriented =
   92       case areaOriented of
   93         ContourAreaOriented -> True
   94         ContourAreaAbsoluteValue -> False
   95     c'numPoints = fromIntegral $ V.length contour
   96     c'oriented = fromBool oriented
   97 
   98 -- | Performs a point-in-contour test.
   99 --
  100 -- The function determines whether the point is inside a contour, outside, or
  101 -- lies on an edge (or coincides with a vertex). It returns positive (inside),
  102 -- negative (outside), or zero (on an edge) value, correspondingly. When
  103 -- measureDist=false , the return value is +1, -1, and 0,
  104 -- respectively. Otherwise, the return value is a signed distance between the
  105 -- point and the nearest contour edge.
  106 --
  107 -- <http://docs.opencv.org/3.0-last-rst/modules/imgproc/doc/structural_analysis_and_shape_descriptors.html#pointpolygontest OpenCV Sphinx doc>
  108 pointPolygonTest
  109     :: ( IsPoint2 contourPoint2 CFloat
  110        , IsPoint2 testPoint2    CFloat
  111        )
  112     => V.Vector (contourPoint2 CFloat) -- ^ Contour.
  113     -> testPoint2 CFloat -- ^ Point tested against the contour.
  114     -> Bool
  115        -- ^ If true, the function estimates the signed distance from the point
  116        -- to the nearest contour edge. Otherwise, the function only checks if
  117        -- the point is inside a contour or not.
  118     -> CvExcept Double
  119 pointPolygonTest contour pt measureDist = unsafeWrapException $
  120     withArrayPtr (V.map toPoint contour) $ \contourPtr ->
  121     withPtr (toPoint pt) $ \ptPtr ->
  122     alloca $ \c'resultPtr ->
  123     handleCvException (realToFrac <$> peek c'resultPtr) $
  124       [cvExcept|
  125         cv::_InputArray contour =
  126           cv::_InputArray( $(Point2f * contourPtr)
  127                          , $(int32_t c'numPoints)
  128                          );
  129         *$(double * c'resultPtr) =
  130           cv::pointPolygonTest( contour
  131                               , *$(Point2f * ptPtr)
  132                               , $(bool c'measureDist)
  133                               );
  134       |]
  135   where
  136     c'numPoints = fromIntegral $ V.length contour
  137     c'measureDist = fromBool measureDist
  138 
  139 -- | Oriented area flag.
  140 data ContourAreaOriented
  141   = ContourAreaOriented
  142     -- ^ Return a signed area value, depending on the contour orientation (clockwise or
  143     -- counter-clockwise). Using this feature you can determine orientation
  144     -- of a contour by taking the sign of an area.
  145   | ContourAreaAbsoluteValue
  146     -- ^ Return the area as an absolute value.
  147 
  148 data ContourRetrievalMode
  149   = ContourRetrievalExternal
  150     -- ^ Retrieves only the extreme outer contours.
  151   | ContourRetrievalList
  152     -- ^ Retrieves all of the contours without establishing any hierarchical relationships.
  153   | ContourRetrievalCComp
  154     -- ^ Retrieves all of the contours and organizes them into a two-level hierarchy. At the top level, there are external boundaries of the components. At the second level, there are boundaries of the holes. If there is another contour inside a hole of a connected component, it is still put at the top level.
  155   | ContourRetrievalTree
  156     -- ^ Retrieves all of the contours and reconstructs a full hierarchy of nested contours.
  157 
  158 data ContourApproximationMethod
  159   = ContourApproximationNone
  160     -- ^ Stores absolutely all the contour points. That is, any 2 subsequent points @(x1,y1)@ and @(x2,y2)@ of the contour will be either horizontal, vertical or diagonal neighbors, that is, @max(abs(x1-x2),abs(y2-y1)) == 1@.
  161   | ContourApproximationSimple
  162     -- ^ Compresses horizontal, vertical, and diagonal segments and leaves only their end points. For example, an up-right rectangular contour is encoded with 4 points.
  163   | ContourApproximationTC89L1
  164   | ContourApproximationTC89KCOS
  165 
  166 #num CV_RETR_EXTERNAL
  167 #num CV_RETR_LIST
  168 #num CV_RETR_CCOMP
  169 #num CV_RETR_TREE
  170 #num CV_CHAIN_APPROX_NONE
  171 #num CV_CHAIN_APPROX_SIMPLE
  172 #num CV_CHAIN_APPROX_TC89_L1
  173 #num CV_CHAIN_APPROX_TC89_KCOS
  174 
  175 marshalContourRetrievalMode
  176   :: ContourRetrievalMode -> Int32
  177 marshalContourRetrievalMode = \case
  178   ContourRetrievalExternal -> c'CV_RETR_EXTERNAL
  179   ContourRetrievalList     -> c'CV_RETR_LIST
  180   ContourRetrievalCComp    -> c'CV_RETR_CCOMP
  181   ContourRetrievalTree     -> c'CV_RETR_TREE
  182 
  183 marshalContourApproximationMethod
  184   :: ContourApproximationMethod -> Int32
  185 marshalContourApproximationMethod = \case
  186   ContourApproximationNone     -> c'CV_CHAIN_APPROX_NONE
  187   ContourApproximationSimple   -> c'CV_CHAIN_APPROX_SIMPLE
  188   ContourApproximationTC89L1   -> c'CV_CHAIN_APPROX_TC89_L1
  189   ContourApproximationTC89KCOS -> c'CV_CHAIN_APPROX_TC89_KCOS
  190 
  191 data Contour =
  192      Contour
  193      { contourPoints   :: !(V.Vector Point2i)
  194      , contourChildren :: !(V.Vector Contour)
  195      } deriving Show
  196 
  197 findContours
  198   :: (PrimMonad m)
  199   => ContourRetrievalMode
  200   -> ContourApproximationMethod
  201   -> Mut (Mat ('S [h, w]) ('S 1) ('S Word8)) (PrimState m)
  202   -> m (V.Vector Contour)
  203 findContours mode method src = unsafePrimToPrim $
  204   withPtr src $ \srcPtr ->
  205   alloca $ \(contourLengthsPtrPtr :: Ptr (Ptr Int32)) ->
  206   alloca $ \(contoursPtrPtr :: Ptr (Ptr (Ptr (Ptr C'Point2i)))) ->
  207   alloca $ \(hierarchyPtrPtr :: Ptr (Ptr (Ptr C'Vec4i))) ->
  208   alloca $ \(numContoursPtr :: Ptr Int32) -> mask_ $ do
  209     [C.block| void {
  210       std::vector< std::vector<cv::Point> > contours;
  211       std::vector<cv::Vec4i> hierarchy;
  212       cv::findContours(
  213         *$(Mat * srcPtr),
  214         contours,
  215         hierarchy,
  216         $(int32_t c'mode),
  217         $(int32_t c'method)
  218       );
  219 
  220       *$(int32_t * numContoursPtr) = contours.size();
  221 
  222       cv::Point * * * * contoursPtrPtr = $(Point2i * * * * contoursPtrPtr);
  223       cv::Point * * * contoursPtr = new cv::Point * * [contours.size()];
  224       *contoursPtrPtr = contoursPtr;
  225 
  226       cv::Vec4i * * * hierarchyPtrPtr = $(Vec4i * * * hierarchyPtrPtr);
  227       cv::Vec4i * * hierarchyPtr = new cv::Vec4i * [contours.size()];
  228       *hierarchyPtrPtr = hierarchyPtr;
  229 
  230       int32_t * * contourLengthsPtrPtr = $(int32_t * * contourLengthsPtrPtr);
  231       int32_t * contourLengthsPtr = new int32_t [contours.size()];
  232       *contourLengthsPtrPtr = contourLengthsPtr;
  233 
  234       for (std::vector< std::vector<cv::Point> >::size_type i = 0; i < contours.size(); i++) {
  235         std::vector<cv::Point> & contourPoints = contours[i];
  236         cv::Vec4i hierarchyInfo = hierarchy[i];
  237 
  238         contourLengthsPtr[i] = contourPoints.size();
  239 
  240         cv::Point * * newContourPoints = new cv::Point * [contourPoints.size()];
  241         for (std::vector<cv::Point>::size_type j = 0; j < contourPoints.size(); j++) {
  242           cv::Point & orig = contourPoints[j];
  243           cv::Point * newPt = new cv::Point(orig.x, orig.y);
  244           newContourPoints[j] = newPt;
  245         }
  246         contoursPtr[i] = newContourPoints;
  247 
  248         hierarchyPtr[i] = new cv::Vec4i(
  249           hierarchyInfo[0],
  250           hierarchyInfo[1],
  251           hierarchyInfo[2],
  252           hierarchyInfo[3]
  253         );
  254       }
  255     }|]
  256 
  257     numContours <- fromIntegral <$> peek numContoursPtr
  258 
  259     contourLengthsPtr <- peek contourLengthsPtrPtr
  260     contourLengths <- peekArray numContours contourLengthsPtr
  261 
  262     contoursPtr <- peek contoursPtrPtr
  263     unmarshalledContours <- peekArray numContours contoursPtr
  264 
  265     allContours <- for (zip unmarshalledContours contourLengths) $ \(contourPointsPtr,n) ->
  266       fmap V.fromList
  267            (peekArray (fromIntegral n) contourPointsPtr >>= mapM (fromPtr . pure))
  268 
  269     hierarchyPtr <- peek hierarchyPtrPtr
  270     (hierarchy :: [V4 Int32]) <-
  271         peekArray numContours hierarchyPtr >>=
  272         mapM (fmap fromVec . fromPtr . pure)
  273 
  274     let treeHierarchy :: V.Vector ([Contour], Bool)
  275         treeHierarchy = V.fromList $
  276           zipWith
  277             (\(V4 nextSibling previousSibling firstChild parent) points ->
  278               ( Contour { contourPoints = points
  279                         , contourChildren =
  280                             if firstChild < 0
  281                             then mempty
  282                             else V.fromList $ fst $ treeHierarchy V.! fromIntegral firstChild
  283                         } : if nextSibling < 0
  284                             then []
  285                             else fst $ treeHierarchy V.! fromIntegral nextSibling
  286               , parent < 0 && previousSibling < 0
  287               )
  288             )
  289             hierarchy
  290             allContours
  291 
  292     [CU.block| void {
  293       delete [] *$(Point2i * * * * contoursPtrPtr);
  294       delete [] *$(Vec4i * * * hierarchyPtrPtr);
  295       delete [] *$(int32_t * * contourLengthsPtrPtr);
  296     } |]
  297 
  298     return $ V.fromList $ concat
  299            $ mapMaybe (\(contours,isRoot) -> guard isRoot $> contours)
  300            $ V.toList treeHierarchy
  301   where
  302     c'mode = marshalContourRetrievalMode mode
  303     c'method = marshalContourApproximationMethod method
  304 
  305 {- | Approximates a polygonal curve(s) with the specified precision.
  306 
  307 The functions approxPolyDP approximate a curve or a polygon with another
  308 curve/polygon with less vertices so that the distance between them is less or
  309 equal to the specified precision. It uses the
  310 <http://en.wikipedia.org/wiki/Ramer-Douglas-Peucker_algorithm Douglas-Peucker algorithm>
  311 
  312 <http://docs.opencv.org/3.0-last-rst/modules/imgproc/doc/structural_analysis_and_shape_descriptors.html?highlight=contourarea#approxpolydp>
  313 -}
  314 approxPolyDP
  315     :: (IsPoint2 point2 Int32)
  316     => V.Vector (point2 Int32)
  317     -> Double -- ^ epsilon
  318     -> Bool   -- ^ is closed
  319     -> V.Vector Point2i -- vector of points
  320 approxPolyDP curve epsilon isClosed = unsafePerformIO $
  321     withArrayPtr (V.map toPoint curve) $ \curvePtr ->
  322     alloca $ \(pointsResPtrPtr ::Ptr (Ptr (Ptr C'Point2i))) ->
  323     alloca $ \(numPointsResPtr :: Ptr Int32) -> mask_ $ do
  324       [C.block| void {
  325         std::vector<cv::Point> points_res;
  326         cv::_InputArray curve = cv::_InputArray ($(Point2i * curvePtr), $(int32_t c'numPoints));
  327         cv::approxPolyDP
  328         (  curve
  329         ,  points_res
  330         ,  $(double c'epsilon)
  331         ,  $(bool c'isClosed)
  332         );
  333 
  334         *$(int32_t * numPointsResPtr) = points_res.size();
  335 
  336         cv::Point * * * pointsResPtrPtr = $(Point2i * * * pointsResPtrPtr);
  337         cv::Point * * pointsResPtr = new cv::Point * [points_res.size()];
  338         *pointsResPtrPtr = pointsResPtr;
  339 
  340         for (std::vector<cv::Point>::size_type i = 0; i < points_res.size(); i++) {
  341             cv::Point & ptAddress = points_res[i];
  342             cv::Point * newPt = new cv::Point(ptAddress.x, ptAddress.y);
  343             pointsResPtr[i] = newPt;
  344         }
  345       }|]
  346 
  347       numPoints <- fromIntegral <$> peek numPointsResPtr
  348 
  349       pointsResPtr <- peek pointsResPtrPtr
  350       (pointsResList :: [Point2i]) <- peekArray numPoints pointsResPtr >>= mapM (fromPtr . pure) --CHECK THIS
  351       let pointsRes :: V.Vector (Point2i)
  352           pointsRes = V.fromList pointsResList
  353 
  354       [CU.block| void {
  355         delete [] *$(Point2i * * * pointsResPtrPtr);
  356       } |]
  357 
  358       return pointsRes
  359   where
  360     c'numPoints = fromIntegral $ V.length curve
  361     c'isClosed  = fromBool isClosed
  362     c'epsilon   = realToFrac epsilon
  363 
  364 arcLength
  365     :: (IsPoint2 point2 Int32)
  366     => V.Vector (point2 Int32)
  367     -> Bool -- ^ is closed
  368     -> CvExcept Double
  369 arcLength curve isClosed = unsafeWrapException $
  370     withArrayPtr (V.map toPoint curve) $ \curvePtr ->
  371     alloca $ \c'resultPtr ->
  372     handleCvException (realToFrac <$> peek c'resultPtr) $
  373         [cvExcept|
  374             cv::_InputArray curve =
  375               cv::_InputArray ( $(Point2i * curvePtr)
  376                               , $(int32_t c'numPoints)
  377                               );
  378             *$(double * c'resultPtr) =
  379                cv::arcLength( curve
  380                               , $(bool c'isClosed)
  381                             );
  382         |]
  383     where
  384       c'isClosed = fromBool isClosed
  385       c'numPoints = fromIntegral $ V.length curve
  386 
  387 minAreaRect :: (IsPoint2 point2 Int32)
  388             => V.Vector (point2 Int32) -> RotatedRect
  389 minAreaRect points =
  390     unsafePerformIO $ fromPtr $
  391     withArrayPtr (V.map toPoint points) $ \pointsPtr ->
  392       [CU.exp|
  393         RotatedRect * {
  394           new RotatedRect(
  395             cv::minAreaRect(
  396                 cv::_InputArray( $(Point2i * pointsPtr)
  397                                , $(int32_t c'numPoints))))
  398         }
  399       |]
  400   where
  401     c'numPoints = fromIntegral $ V.length points