never executed always true always false
1 {-# LANGUAGE TemplateHaskell #-}
2 {-# LANGUAGE QuasiQuotes #-}
3 {-# LANGUAGE RecordWildCards #-}
4
5 module OpenCV.Features2d
6 ( -- * ORB
7 Orb
8 , OrbScoreType(..)
9 , WTA_K(..)
10 , OrbParams(..)
11 , defaultOrbParams
12 , mkOrb
13 , orbDetectAndCompute
14
15 -- * BLOB
16 , SimpleBlobDetector
17 , SimpleBlobDetectorParams(..)
18 , BlobFilterByArea(..)
19 , BlobFilterByCircularity(..)
20 , BlobFilterByColor(..)
21 , BlobFilterByConvexity(..)
22 , BlobFilterByInertia(..)
23 , defaultSimpleBlobDetectorParams
24 , mkSimpleBlobDetector
25 , blobDetect
26
27 -- * DescriptorMatcher
28 , DescriptorMatcher(..)
29 , drawMatches
30 -- ** BFMatcher
31 , BFMatcher
32 , newBFMatcher
33 -- ** FlannBasedMatcher
34 , FlannBasedMatcher
35 , FlannIndexParams(..)
36 , FlannSearchParams(..)
37 , FlannBasedMatcherParams(..)
38 , newFlannBasedMatcher
39 ) where
40
41 import "base" Control.Exception ( mask_ )
42 import "base" Data.Int
43 import "base" Data.Word
44 import "base" Data.Maybe
45 import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, castForeignPtr )
46 import "base" Foreign.Marshal.Alloc ( alloca )
47 import "base" Foreign.Marshal.Array ( peekArray )
48 import "base" Foreign.Marshal.Utils ( fromBool )
49 import "base" Foreign.Ptr ( Ptr, nullPtr )
50 import "base" Foreign.Storable ( peek )
51 import "base" System.IO.Unsafe ( unsafePerformIO )
52 import "data-default" Data.Default
53 import "linear" Linear.V4
54 import qualified "inline-c" Language.C.Inline as C
55 import qualified "inline-c" Language.C.Inline.Unsafe as CU
56 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
57 import "this" OpenCV.Core.Types
58 import "this" OpenCV.Internal
59 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
60 import "this" OpenCV.Internal.C.Types
61 import "this" OpenCV.Internal.Core.ArrayOps
62 import "this" OpenCV.Internal.Core.Types ( withArrayPtr, Scalar )
63 import "this" OpenCV.Internal.Core.Types.Mat
64 import "this" OpenCV.Internal.Exception ( cvExcept, unsafeWrapException, handleCvException )
65 import "this" OpenCV.TypeLevel
66 import qualified "vector" Data.Vector as V
67
68 --------------------------------------------------------------------------------
69
70 C.context openCvCtx
71
72 C.include "opencv2/core.hpp"
73 C.include "opencv2/features2d.hpp"
74 C.include "orb.hpp"
75 C.include "simple_blob_detector.hpp"
76
77 C.using "namespace cv"
78 C.using "namespace cv::flann"
79
80 #include <bindings.dsl.h>
81 #include "opencv2/core.hpp"
82 #include "opencv2/features2d.hpp"
83
84 #include "namespace.hpp"
85 #include "orb.hpp"
86 #include "simple_blob_detector.hpp"
87
88 infinity :: Float
89 infinity = 1 / 0
90
91 --------------------------------------------------------------------------------
92 -- ORB - Oriented BRIEF
93 --------------------------------------------------------------------------------
94
95 -- Internally, an Orb is a pointer to a @cv::Ptr<cv::ORB>@, which in turn points
96 -- to an actual @cv::ORB@ object.
97 newtype Orb = Orb {unOrb :: ForeignPtr C'Ptr_ORB}
98
99 type instance C Orb = C'Ptr_ORB
100
101 instance WithPtr Orb where
102 withPtr = withForeignPtr . unOrb
103
104 instance FromPtr Orb where
105 fromPtr = objFromPtr Orb $ \ptr ->
106 [CU.block| void {
107 cv::Ptr<cv::ORB> * orb_ptr_ptr = $(Ptr_ORB * ptr);
108 orb_ptr_ptr->release();
109 delete orb_ptr_ptr;
110 }|]
111
112 --------------------------------------------------------------------------------
113
114 data WTA_K
115 = WTA_K_2
116 | WTA_K_3
117 | WTA_K_4
118
119 marshalWTA_K :: WTA_K -> Int32
120 marshalWTA_K = \case
121 WTA_K_2 -> 2
122 WTA_K_3 -> 3
123 WTA_K_4 -> 4
124
125 data OrbScoreType
126 = HarrisScore
127 | FastScore
128
129 #num HARRIS_SCORE
130 #num FAST_SCORE
131
132 marshalOrbScoreType :: OrbScoreType -> Int32
133 marshalOrbScoreType = \case
134 HarrisScore -> c'HARRIS_SCORE
135 FastScore -> c'FAST_SCORE
136
137 data OrbParams
138 = OrbParams
139 { orb_nfeatures :: !Int32
140 -- ^ The maximum number of features to retain.
141 , orb_scaleFactor :: !Float
142 -- ^ Pyramid decimation ratio, greater than 1. 'orb_scaleFactor' == 2
143 -- means the classical pyramid, where each next level has 4x less pixels
144 -- than the previous, but such a big scale factor will degrade feature
145 -- matching scores dramatically. On the other hand, too close to 1 scale
146 -- factor will mean that to cover certain scale range you will need more
147 -- pyramid levels and so the speed will suffer.
148 , orb_nlevels :: !Int32
149 -- ^ The number of pyramid levels. The smallest level will have linear
150 -- size equal to input_image_linear_size / 'orb_scaleFactor' **
151 -- 'orb_nlevels'.
152 , orb_edgeThreshold :: !Int32
153 -- ^ This is size of the border where the features are not detected. It
154 -- should roughly match the patchSize parameter.
155 , orb_firstLevel :: !Int32
156 -- ^ It should be 0 in the current implementation.
157 , orb_WTA_K :: !WTA_K
158 -- ^ The number of points that produce each element of the oriented BRIEF
159 -- descriptor. The default value 'WTA_K_2' means the BRIEF where we take
160 -- a random point pair and compare their brightnesses, so we get 0/1
161 -- response. Other possible values are 'WTA_K_3' and 'WTA_K_4'. For
162 -- example, 'WTA_K_3' means that we take 3 random points (of course,
163 -- those point coordinates are random, but they are generated from the
164 -- pre-defined seed, so each element of BRIEF descriptor is computed
165 -- deterministically from the pixel rectangle), find point of maximum
166 -- brightness and output index of the winner (0, 1 or 2). Such output
167 -- will occupy 2 bits, and therefore it will need a special variant of
168 -- Hamming distance, denoted as 'Norm_Hamming2' (2 bits per bin). When
169 -- 'WTA_K_4', we take 4 random points to compute each bin (that will also
170 -- occupy 2 bits with possible values 0, 1, 2 or 3).
171 , orb_scoreType :: !OrbScoreType
172 -- ^ The default 'HarrisScore' means that Harris algorithm is used to
173 -- rank features (the score is written to KeyPoint::score and is used to
174 -- retain best nfeatures features); 'FastScore' is alternative value of
175 -- the parameter that produces slightly less stable keypoints, but it is
176 -- a little faster to compute.
177 , orb_patchSize :: !Int32
178 -- ^ Size of the patch used by the oriented BRIEF descriptor. Of course,
179 -- on smaller pyramid layers the perceived image area covered by a
180 -- feature will be larger.
181 , orb_fastThreshold :: !Int32
182 }
183
184 defaultOrbParams :: OrbParams
185 defaultOrbParams =
186 OrbParams
187 { orb_nfeatures = 500
188 , orb_scaleFactor = 1.2
189 , orb_nlevels = 8
190 , orb_edgeThreshold = 31
191 , orb_firstLevel = 0
192 , orb_WTA_K = WTA_K_2
193 , orb_scoreType = HarrisScore
194 , orb_patchSize = 31
195 , orb_fastThreshold = 20
196 }
197
198 --------------------------------------------------------------------------------
199
200 newOrb :: OrbParams -> IO Orb
201 newOrb OrbParams{..} = fromPtr
202 [CU.block|Ptr_ORB * {
203 cv::Ptr<cv::ORB> orbPtr =
204 cv::ORB::create
205 ( $(int32_t orb_nfeatures)
206 , $(float c'scaleFactor)
207 , $(int32_t orb_nlevels)
208 , $(int32_t orb_edgeThreshold)
209 , $(int32_t orb_firstLevel)
210 , $(int32_t c'WTA_K)
211 , $(int32_t c'scoreType)
212 , $(int32_t orb_patchSize)
213 , $(int32_t orb_fastThreshold)
214 );
215 return new cv::Ptr<cv::ORB>(orbPtr);
216 }|]
217 where
218 c'scaleFactor = realToFrac orb_scaleFactor
219 c'WTA_K = marshalWTA_K orb_WTA_K
220 c'scoreType = marshalOrbScoreType orb_scoreType
221
222 mkOrb :: OrbParams -> Orb
223 mkOrb = unsafePerformIO . newOrb
224
225 --------------------------------------------------------------------------------
226
227 {- | Detect keypoints and compute descriptors
228
229 Example:
230
231 @
232 orbDetectAndComputeImg
233 :: forall (width :: Nat)
234 (height :: Nat)
235 (channels :: Nat)
236 (depth :: *)
237 . (Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog)
238 => Mat (ShapeT [height, width]) ('S channels) ('S depth)
239 orbDetectAndComputeImg = exceptError $ do
240 (kpts, _descs) <- orbDetectAndCompute orb frog Nothing
241 withMatM (Proxy :: Proxy [height, width])
242 (Proxy :: Proxy channels)
243 (Proxy :: Proxy depth)
244 white $ \\imgM -> do
245 void $ matCopyToM imgM (V2 0 0) frog Nothing
246 forM_ kpts $ \\kpt -> do
247 let kptRec = keyPointAsRec kpt
248 circle imgM (round \<$> kptPoint kptRec :: V2 Int32) 5 blue 1 LineType_AA 0
249 where
250 orb = mkOrb defaultOrbParams
251 @
252
253 <<doc/generated/examples/orbDetectAndComputeImg.png orbDetectAndComputeImg>>
254 -}
255 orbDetectAndCompute
256 :: Orb
257 -> Mat ('S [height, width]) channels depth -- ^ Image.
258 -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8)) -- ^ Mask.
259 -> CvExcept ( V.Vector KeyPoint
260 , Mat 'D 'D 'D
261 )
262 orbDetectAndCompute orb img mbMask = unsafeWrapException $ do
263 descriptors <- newEmptyMat
264 withPtr orb $ \orbPtr ->
265 withPtr img $ \imgPtr ->
266 withPtr mbMask $ \maskPtr ->
267 withPtr descriptors $ \descPtr ->
268 alloca $ \(numPtsPtr :: Ptr Int32) ->
269 alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'KeyPoint))) -> mask_ $ do
270 ptrException <- [cvExcept|
271 cv::ORB * orb = *$(Ptr_ORB * orbPtr);
272 cv::Mat * maskPtr = $(Mat * maskPtr);
273
274 std::vector<cv::KeyPoint> keypoints = std::vector<cv::KeyPoint>();
275 orb->
276 detectAndCompute
277 ( *$(Mat * imgPtr)
278 , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
279 , keypoints
280 , *$(Mat * descPtr)
281 , false
282 );
283
284 *$(int32_t * numPtsPtr) = keypoints.size();
285
286 cv::KeyPoint * * * arrayPtrPtr = $(KeyPoint * * * arrayPtrPtr);
287 cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()];
288 *arrayPtrPtr = arrayPtr;
289
290 for (std::vector<cv::KeyPoint>::size_type ix = 0; ix != keypoints.size(); ix++)
291 {
292 cv::KeyPoint & org = keypoints[ix];
293 cv::KeyPoint * newPt =
294 new cv::KeyPoint( org.pt
295 , org.size
296 , org.angle
297 , org.response
298 , org.octave
299 , org.class_id
300 );
301 arrayPtr[ix] = newPt;
302 }
303 |]
304 if ptrException /= nullPtr
305 then Left . BindingException <$> fromPtr (pure ptrException)
306 else do
307 numPts <- fromIntegral <$> peek numPtsPtr
308 arrayPtr <- peek arrayPtrPtr
309 keypoints <- mapM (fromPtr . pure) =<< peekArray numPts arrayPtr
310
311 [CU.block| void {
312 delete [] *$(KeyPoint * * * arrayPtrPtr);
313 }|]
314
315 pure $ Right (V.fromList keypoints, relaxMat descriptors)
316
317 --------------------------------------------------------------------------------
318 -- BLOB - Binary Large OBject
319 --------------------------------------------------------------------------------
320
321 -- Internally, a SimpleBlobDetector is a pointer to a @cv::Ptr<cv::SimpleBlobDetector>@, which in turn points
322 -- to an actual @cv::SimpleBlobDetector@ object.
323 newtype SimpleBlobDetector = SimpleBlobDetector {unSimpleBlobDetector :: ForeignPtr C'Ptr_SimpleBlobDetector}
324
325 type instance C SimpleBlobDetector = C'Ptr_SimpleBlobDetector
326
327 instance WithPtr SimpleBlobDetector where
328 withPtr = withForeignPtr . unSimpleBlobDetector
329
330 instance FromPtr SimpleBlobDetector where
331 fromPtr = objFromPtr SimpleBlobDetector $ \ptr ->
332 [CU.block| void {
333 cv::Ptr<cv::SimpleBlobDetector> * simpleBlobDetector_ptr_ptr = $(Ptr_SimpleBlobDetector * ptr);
334 simpleBlobDetector_ptr_ptr->release();
335 delete simpleBlobDetector_ptr_ptr;
336 }|]
337
338 data BlobFilterByArea
339 = BlobFilterByArea
340 { blob_minArea :: !Float
341 , blob_maxArea :: !Float
342 } deriving Eq
343
344 data BlobFilterByCircularity
345 = BlobFilterByCircularity
346 { blob_minCircularity :: !Float
347 , blob_maxCircularity :: !Float
348 } deriving Eq
349
350 data BlobFilterByColor
351 = BlobFilterByColor
352 { blob_blobColor :: !Word8
353 } deriving Eq
354
355 data BlobFilterByConvexity
356 = BlobFilterByConvexity
357 { blob_minConvexity :: !Float
358 , blob_maxConvexity :: !Float
359 } deriving Eq
360
361 data BlobFilterByInertia
362 = BlobFilterByInertia
363 { blob_minInertiaRatio :: !Float
364 , blob_maxInertiaRatio :: !Float
365 } deriving Eq
366
367 data SimpleBlobDetectorParams
368 = SimpleBlobDetectorParams
369 { blob_minThreshold :: !Float
370 , blob_maxThreshold :: !Float
371 , blob_thresholdStep :: !Float
372 , blob_minRepeatability :: !Int32
373 , blob_minDistBetweenBlobs :: !Float
374 , blob_filterByArea :: !(Maybe BlobFilterByArea)
375 -- ^ Extracted blobs have an area between 'minArea' (inclusive) and
376 -- 'maxArea' (exclusive).
377 , blob_filterByCircularity :: !(Maybe BlobFilterByCircularity)
378 -- ^ Extracted blobs have circularity
379 -- @(4 * pi * Area)/(perimeter * perimeter)@ between 'minCircularity'
380 -- (inclusive) and 'maxCircularity' (exclusive).
381 , blob_filterByColor :: !(Maybe BlobFilterByColor)
382 -- ^ This filter compares the intensity of a binary image at the center of
383 -- a blob to 'blobColor'. If they differ, the blob is filtered out. Use
384 -- @blobColor = 0@ to extract dark blobs and @blobColor = 255@ to extract
385 -- light blobs.
386 , blob_filterByConvexity :: !(Maybe BlobFilterByConvexity)
387 -- ^ Extracted blobs have convexity (area / area of blob convex hull) between
388 -- 'minConvexity' (inclusive) and 'maxConvexity' (exclusive).
389 , blob_filterByInertia :: !(Maybe BlobFilterByInertia)
390 -- ^ Extracted blobs have this ratio between 'minInertiaRatio' (inclusive)
391 -- and 'maxInertiaRatio' (exclusive).
392 }
393
394 defaultSimpleBlobDetectorParams :: SimpleBlobDetectorParams
395 defaultSimpleBlobDetectorParams =
396 SimpleBlobDetectorParams
397 { blob_minThreshold = 50
398 , blob_maxThreshold = 220
399 , blob_thresholdStep = 10
400 , blob_minRepeatability = 2
401 , blob_minDistBetweenBlobs = 10
402 , blob_filterByArea = Just (BlobFilterByArea 25 5000)
403 , blob_filterByCircularity = Nothing
404 , blob_filterByColor = Just (BlobFilterByColor 0)
405 , blob_filterByConvexity = Just (BlobFilterByConvexity 0.95 infinity)
406 , blob_filterByInertia = Just (BlobFilterByInertia 0.1 infinity)
407 }
408
409 --------------------------------------------------------------------------------
410
411 newSimpleBlobDetector :: SimpleBlobDetectorParams -> IO SimpleBlobDetector
412 newSimpleBlobDetector SimpleBlobDetectorParams{..} = fromPtr
413 [CU.block|Ptr_SimpleBlobDetector * {
414 cv::SimpleBlobDetector::Params params;
415 params.blobColor = $(unsigned char c'blobColor);
416 params.filterByArea = $(bool c'filterByArea);
417 params.filterByCircularity = $(bool c'filterByCircularity);
418 params.filterByColor = $(bool c'filterByColor);
419 params.filterByConvexity = $(bool c'filterByConvexity);
420 params.filterByInertia = $(bool c'filterByInertia);
421 params.maxArea = $(float c'maxArea);
422 params.maxCircularity = $(float c'maxCircularity);
423 params.maxConvexity = $(float c'maxConvexity);
424 params.maxInertiaRatio = $(float c'maxInertiaRatio);
425 params.maxThreshold = $(float c'maxThreshold);
426 params.minArea = $(float c'minArea);
427 params.minCircularity = $(float c'minCircularity);
428 params.minConvexity = $(float c'minConvexity);
429 params.minDistBetweenBlobs = $(float c'minDistBetweenBlobs);
430 params.minInertiaRatio = $(float c'minInertiaRatio);
431 params.minRepeatability = $(float c'minRepeatability);
432 params.minThreshold = $(float c'minThreshold);
433 params.thresholdStep = $(float c'thresholdStep);
434 cv::Ptr<cv::SimpleBlobDetector> detectorPtr =
435 cv::SimpleBlobDetector::create(params);
436 return new cv::Ptr<cv::SimpleBlobDetector>(detectorPtr);
437 }|]
438 where
439 c'minThreshold = realToFrac blob_minThreshold
440 c'maxThreshold = realToFrac blob_maxThreshold
441 c'thresholdStep = realToFrac blob_thresholdStep
442 c'minRepeatability = realToFrac blob_minRepeatability
443 c'minDistBetweenBlobs = realToFrac blob_minDistBetweenBlobs
444 c'filterByArea = fromBool (isJust blob_filterByArea)
445 c'filterByCircularity = fromBool (isJust blob_filterByCircularity)
446 c'filterByColor = fromBool (isJust blob_filterByColor)
447 c'filterByConvexity = fromBool (isJust blob_filterByConvexity)
448 c'filterByInertia = fromBool (isJust blob_filterByInertia)
449 c'minArea = realToFrac (fromMaybe 25 (fmap blob_minArea blob_filterByArea))
450 c'maxArea = realToFrac (fromMaybe 5000 (fmap blob_maxArea blob_filterByArea))
451 c'minCircularity = realToFrac (fromMaybe 0.8 (fmap blob_minCircularity blob_filterByCircularity))
452 c'maxCircularity = realToFrac (fromMaybe infinity (fmap blob_maxCircularity blob_filterByCircularity))
453 c'blobColor = fromIntegral (fromMaybe 0 (fmap blob_blobColor blob_filterByColor))
454 c'minConvexity = realToFrac (fromMaybe 0.95 (fmap blob_minConvexity blob_filterByConvexity))
455 c'maxConvexity = realToFrac (fromMaybe infinity (fmap blob_maxConvexity blob_filterByConvexity))
456 c'minInertiaRatio = realToFrac (fromMaybe 0.1 (fmap blob_minInertiaRatio blob_filterByInertia))
457 c'maxInertiaRatio = realToFrac (fromMaybe infinity (fmap blob_maxInertiaRatio blob_filterByInertia))
458
459 mkSimpleBlobDetector :: SimpleBlobDetectorParams -> SimpleBlobDetector
460 mkSimpleBlobDetector = unsafePerformIO . newSimpleBlobDetector
461
462 --------------------------------------------------------------------------------
463
464 {- | Detect keypoints and compute descriptors
465 -}
466 blobDetect
467 :: SimpleBlobDetector
468 -> Mat ('S [height, width]) channels depth -- ^ Image.
469 -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8)) -- ^ Mask.
470 -> CvExcept (V.Vector KeyPoint)
471 blobDetect detector img mbMask = unsafeWrapException $ do
472 withPtr detector $ \detectorPtr ->
473 withPtr img $ \imgPtr ->
474 withPtr mbMask $ \maskPtr ->
475 alloca $ \(numPtsPtr :: Ptr Int32) ->
476 alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'KeyPoint))) -> mask_ $ do
477 ptrException <- [cvExcept|
478 cv::SimpleBlobDetector * detector = *$(Ptr_SimpleBlobDetector * detectorPtr);
479 cv::Mat * maskPtr = $(Mat * maskPtr);
480
481 std::vector<cv::KeyPoint> keypoints = std::vector<cv::KeyPoint>();
482 detector->
483 detect
484 ( *$(Mat * imgPtr)
485 , keypoints
486 , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
487 );
488
489 *$(int32_t * numPtsPtr) = keypoints.size();
490
491 cv::KeyPoint * * * arrayPtrPtr = $(KeyPoint * * * arrayPtrPtr);
492 cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()];
493 *arrayPtrPtr = arrayPtr;
494
495 for (std::vector<cv::KeyPoint>::size_type ix = 0; ix != keypoints.size(); ix++)
496 {
497 arrayPtr[ix] = new cv::KeyPoint(keypoints[ix]);
498 }
499 |]
500 if ptrException /= nullPtr
501 then Left . BindingException <$> fromPtr (pure ptrException)
502 else do
503 numPts <- fromIntegral <$> peek numPtsPtr
504 arrayPtr <- peek arrayPtrPtr
505 keypoints <- mapM (fromPtr . pure) =<< peekArray numPts arrayPtr
506
507 [CU.block| void {
508 delete [] *$(KeyPoint * * * arrayPtrPtr);
509 }|]
510
511 pure $ Right (V.fromList keypoints)
512
513 --------------------------------------------------------------------------------
514 -- DescriptorMatcher
515 --------------------------------------------------------------------------------
516
517 class DescriptorMatcher a where
518 upcast :: a -> BaseMatcher
519 add :: a
520 -> V.Vector (Mat 'D 'D 'D) -- ^ Train set of descriptors.
521 -> IO ()
522 add dm trainDescriptors =
523 withPtr (upcast dm) $ \dmPtr ->
524 withArrayPtr trainDescriptors $ \trainVecPtr ->
525 [C.block| void {
526 std::vector<Mat> buffer( $(Mat * trainVecPtr)
527 , $(Mat * trainVecPtr) + $(int32_t c'trainVecLength) );
528 $(DescriptorMatcher * dmPtr)->add(buffer);
529 }|]
530 where
531 c'trainVecLength = fromIntegral $ V.length trainDescriptors
532 train :: a
533 -> IO ()
534 train dm =
535 withPtr (upcast dm) $ \dmPtr ->
536 [C.block| void { $(DescriptorMatcher * dmPtr)->train(); } |]
537 match
538 :: a
539 -> Mat 'D 'D 'D -- ^ Query set of descriptors.
540 -> Mat 'D 'D 'D -- ^ Train set of descriptors.
541 -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8))
542 -- ^ Mask specifying permissible matches between an input query and
543 -- train matrices of descriptors..
544 -> IO (V.Vector DMatch)
545 match dm queryDescriptors trainDescriptors mbMask =
546 withPtr (upcast dm) $ \dmPtr ->
547 withPtr queryDescriptors $ \queryPtr ->
548 withPtr trainDescriptors $ \trainPtr ->
549 withPtr mbMask $ \maskPtr ->
550 alloca $ \(numMatchesPtr :: Ptr Int32) ->
551 alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'DMatch))) -> mask_ $ do
552 [C.block| void {
553 cv::Mat * maskPtr = $(Mat * maskPtr);
554 std::vector<cv::DMatch> matches = std::vector<cv::DMatch>();
555 $(DescriptorMatcher * dmPtr)->match
556 ( *$(Mat * queryPtr)
557 , *$(Mat * trainPtr)
558 , matches
559 , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
560 );
561 *$(int32_t * numMatchesPtr) = matches.size();
562 cv::DMatch * * * arrayPtrPtr = $(DMatch * * * arrayPtrPtr);
563 cv::DMatch * * arrayPtr = new cv::DMatch * [matches.size()];
564 *arrayPtrPtr = arrayPtr;
565 for (std::vector<cv::DMatch>::size_type ix = 0; ix != matches.size(); ix++)
566 {
567 cv::DMatch & org = matches[ix];
568 cv::DMatch * newMatch =
569 new cv::DMatch( org.queryIdx
570 , org.trainIdx
571 , org.imgIdx
572 , org.distance
573 );
574 arrayPtr[ix] = newMatch;
575 }
576 }|]
577 (numMatches :: Int) <- fromIntegral <$> peek numMatchesPtr
578 arrayPtr <- peek arrayPtrPtr
579 matches <- mapM (fromPtr . pure) =<< peekArray numMatches arrayPtr
580 [CU.block| void {
581 delete [] *$(DMatch * * * arrayPtrPtr);
582 }|]
583 pure $ V.fromList matches
584 -- | Match in pre-trained matcher
585 --
586 match'
587 :: a
588 -> Mat 'D 'D 'D -- ^ Query set of descriptors.
589 -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8))
590 -- ^ Mask specifying permissible matches between an input query and
591 -- train matrices of descriptors..
592 -> IO (V.Vector DMatch)
593 match' dm queryDescriptors mbMask =
594 withPtr (upcast dm) $ \dmPtr ->
595 withPtr queryDescriptors $ \queryPtr ->
596 withPtr mbMask $ \maskPtr ->
597 alloca $ \(numMatchesPtr :: Ptr Int32) ->
598 alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'DMatch))) -> mask_ $ do
599 [C.block| void {
600 cv::Mat * maskPtr = $(Mat * maskPtr);
601 std::vector<cv::DMatch> matches = std::vector<cv::DMatch>();
602 $(DescriptorMatcher * dmPtr)->match
603 ( *$(Mat * queryPtr)
604 , matches
605 , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
606 );
607 *$(int32_t * numMatchesPtr) = matches.size();
608 cv::DMatch * * * arrayPtrPtr = $(DMatch * * * arrayPtrPtr);
609 cv::DMatch * * arrayPtr = new cv::DMatch * [matches.size()];
610 *arrayPtrPtr = arrayPtr;
611 for (std::vector<cv::DMatch>::size_type ix = 0; ix != matches.size(); ix++)
612 {
613 cv::DMatch & org = matches[ix];
614 cv::DMatch * newMatch =
615 new cv::DMatch( org.queryIdx
616 , org.trainIdx
617 , org.imgIdx
618 , org.distance
619 );
620 arrayPtr[ix] = newMatch;
621 }
622 }|]
623 (numMatches :: Int) <- fromIntegral <$> peek numMatchesPtr
624 arrayPtr <- peek arrayPtrPtr
625 matches <- mapM (fromPtr . pure) =<< peekArray numMatches arrayPtr
626 [CU.block| void {
627 delete [] *$(DMatch * * * arrayPtrPtr);
628 }|]
629 pure $ V.fromList matches
630
631
632 newtype BaseMatcher = BaseMatcher {unBaseMatcher :: ForeignPtr C'DescriptorMatcher}
633
634 type instance C BaseMatcher = C'DescriptorMatcher
635
636 instance WithPtr BaseMatcher where
637 withPtr = withForeignPtr . unBaseMatcher
638
639
640 --------------------------------------------------------------------------------
641 -- BFMatcher
642 --------------------------------------------------------------------------------
643
644 {- | Brute-force descriptor matcher
645
646 For each descriptor in the first set, this matcher finds the closest descriptor
647 in the second set by trying each one. This descriptor matcher supports masking
648 permissible matches of descriptor sets.
649
650 Example:
651
652 @
653 bfMatcherImg
654 :: forall (width :: Nat)
655 (width2 :: Nat)
656 (height :: Nat)
657 (channels :: Nat)
658 (depth :: *)
659 . ( Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog
660 , width2 ~ (*) width 2
661 )
662 => IO (Mat (ShapeT [height, width2]) ('S channels) ('S depth))
663 bfMatcherImg = do
664 let (kpts1, descs1) = exceptError $ orbDetectAndCompute orb frog Nothing
665 (kpts2, descs2) = exceptError $ orbDetectAndCompute orb rotatedFrog Nothing
666
667 bfmatcher <- newBFMatcher Norm_Hamming True
668 matches <- match bfmatcher
669 descs1 -- Query descriptors
670 descs2 -- Train descriptors
671 Nothing
672 exceptErrorIO $ pureExcept $
673 withMatM (Proxy :: Proxy [height, width2])
674 (Proxy :: Proxy channels)
675 (Proxy :: Proxy depth)
676 white $ \\imgM -> do
677 matCopyToM imgM (V2 0 0) frog Nothing
678 matCopyToM imgM (V2 width 0) rotatedFrog Nothing
679
680 -- Draw the matches as lines from the query image to the train image.
681 forM_ matches $ \\dmatch -> do
682 let matchRec = dmatchAsRec dmatch
683 queryPt = kpts1 V.! fromIntegral (dmatchQueryIdx matchRec)
684 trainPt = kpts2 V.! fromIntegral (dmatchTrainIdx matchRec)
685 queryPtRec = keyPointAsRec queryPt
686 trainPtRec = keyPointAsRec trainPt
687
688 -- We translate the train point one width to the right in order to
689 -- match the position of rotatedFrog in imgM.
690 line imgM
691 (round \<$> kptPoint queryPtRec :: V2 Int32)
692 ((round \<$> kptPoint trainPtRec :: V2 Int32) ^+^ V2 width 0)
693 blue 1 LineType_AA 0
694 where
695 orb = mkOrb defaultOrbParams {orb_nfeatures = 50}
696
697 width = fromInteger $ natVal (Proxy :: Proxy width)
698
699 rotatedFrog = exceptError $
700 warpAffine frog rotMat InterArea False False (BorderConstant black)
701 rotMat = getRotationMatrix2D (V2 250 195 :: V2 CFloat) 45 0.8
702 @
703
704 <<doc/generated/examples/bfMatcherImg.png bfMatcherImg>>
705
706 <http://docs.opencv.org/3.0-last-rst/modules/features2d/doc/common_interfaces_of_descriptor_matchers.html#bfmatcher OpenCV Sphinx doc>
707 -}
708 newtype BFMatcher = BFMatcher {unBFMatcher :: ForeignPtr C'BFMatcher}
709
710 type instance C BFMatcher = C'BFMatcher
711
712 instance WithPtr BFMatcher where
713 withPtr = withForeignPtr . unBFMatcher
714
715 instance FromPtr BFMatcher where
716 fromPtr = objFromPtr BFMatcher $ \ptr ->
717 [CU.exp| void { delete $(BFMatcher * ptr) }|]
718
719
720 --------------------------------------------------------------------------------
721
722 newBFMatcher
723 :: NormType
724 -- ^ 'Norm_L1' and 'Norm_L2' norms are preferable choices for SIFT and
725 -- SURF descriptors, 'Norm_Hamming' should be used with 'Orb', BRISK and
726 -- BRIEF, 'Norm_Hamming2' should be used with 'Orb' when 'WTA_K_3' or
727 -- 'WTA_K_4' (see 'orb_WTA_K').
728 -> Bool
729 -- ^ If it is false, this is will be default 'BFMatcher' behaviour when
730 -- it finds the k nearest neighbors for each query descriptor. If
731 -- crossCheck == True, then the @knnMatch()@ method with @k=1@ will only
732 -- return pairs @(i,j)@ such that for i-th query descriptor the j-th
733 -- descriptor in the matcher's collection is the nearest and vice versa,
734 -- i.e. the 'BFMatcher' will only return consistent pairs. Such technique
735 -- usually produces best results with minimal number of outliers when
736 -- there are enough matches. This is alternative to the ratio test, used
737 -- by D. Lowe in SIFT paper.
738 -> IO BFMatcher
739 newBFMatcher normType crossCheck = fromPtr
740 [CU.exp|BFMatcher * {
741 new cv::BFMatcher
742 ( $(int32_t c'normType)
743 , $(bool c'crossCheck)
744 )
745 }|]
746 where
747 c'normType = marshalNormType NormAbsolute normType
748 c'crossCheck = fromBool crossCheck
749
750 --------------------------------------------------------------------------------
751
752 instance DescriptorMatcher BFMatcher where
753 upcast (BFMatcher ptr) = BaseMatcher $ castForeignPtr ptr
754
755
756
757 --------------------------------------------------------------------------------
758 -- FlannBasedMatcher
759 --------------------------------------------------------------------------------
760
761 {- | Flann-based descriptor matcher.
762
763 This matcher trains @flann::Index_@ on a train descriptor collection and calls it
764 nearest search methods to find the best matches. So, this matcher may be faster
765 when matching a large train collection than the brute force matcher.
766 @FlannBasedMatcher@ does not support masking permissible matches of descriptor
767 sets because flann::Index does not support this.
768
769 Example:
770
771 @
772 fbMatcherImg
773 :: forall (width :: Nat)
774 (width2 :: Nat)
775 (height :: Nat)
776 (channels :: Nat)
777 (depth :: *)
778 . ( Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog
779 , width2 ~ (*) width 2
780 )
781 => IO (Mat (ShapeT [height, width2]) ('S channels) ('S depth))
782 fbMatcherImg = do
783 let (kpts1, descs1) = exceptError $ orbDetectAndCompute orb frog Nothing
784 (kpts2, descs2) = exceptError $ orbDetectAndCompute orb rotatedFrog Nothing
785
786 fbmatcher <- newFlannBasedMatcher (def { indexParams = FlannLshIndexParams 20 10 2 })
787 matches <- match fbmatcher
788 descs1 -- Query descriptors
789 descs2 -- Train descriptors
790 Nothing
791 exceptErrorIO $ pureExcept $
792 withMatM (Proxy :: Proxy [height, width2])
793 (Proxy :: Proxy channels)
794 (Proxy :: Proxy depth)
795 white $ \\imgM -> do
796 matCopyToM imgM (V2 0 0) frog Nothing
797 matCopyToM imgM (V2 width 0) rotatedFrog Nothing
798
799 -- Draw the matches as lines from the query image to the train image.
800 forM_ matches $ \\dmatch -> do
801 let matchRec = dmatchAsRec dmatch
802 queryPt = kpts1 V.! fromIntegral (dmatchQueryIdx matchRec)
803 trainPt = kpts2 V.! fromIntegral (dmatchTrainIdx matchRec)
804 queryPtRec = keyPointAsRec queryPt
805 trainPtRec = keyPointAsRec trainPt
806
807 -- We translate the train point one width to the right in order to
808 -- match the position of rotatedFrog in imgM.
809 line imgM
810 (round \<$> kptPoint queryPtRec :: V2 Int32)
811 ((round \<$> kptPoint trainPtRec :: V2 Int32) ^+^ V2 width 0)
812 blue 1 LineType_AA 0
813 where
814 orb = mkOrb defaultOrbParams {orb_nfeatures = 50}
815
816 width = fromInteger $ natVal (Proxy :: Proxy width)
817
818 rotatedFrog = exceptError $
819 warpAffine frog rotMat InterArea False False (BorderConstant black)
820 rotMat = getRotationMatrix2D (V2 250 195 :: V2 CFloat) 45 0.8
821 @
822
823 <<doc/generated/examples/fbMatcherImg.png fbMatcherImg>>
824
825 <http://docs.opencv.org/3.0-last-rst/modules/features2d/doc/common_interfaces_of_descriptor_matchers.html#flannbasedmatcher OpenCV Sphinx doc>
826 -}
827 newtype FlannBasedMatcher = FlannBasedMatcher {unFlannBasedMatcher :: ForeignPtr C'FlannBasedMatcher}
828
829 type instance C FlannBasedMatcher = C'FlannBasedMatcher
830
831 instance WithPtr FlannBasedMatcher where
832 withPtr = withForeignPtr . unFlannBasedMatcher
833
834 instance FromPtr FlannBasedMatcher where
835 fromPtr = objFromPtr FlannBasedMatcher $ \ptr ->
836 [CU.exp| void { delete $(FlannBasedMatcher * ptr) }|]
837
838
839 --------------------------------------------------------------------------------
840
841
842 data FlannIndexParams = FlannKDTreeIndexParams { trees :: Int }
843 | FlannLshIndexParams { tableNumber :: Int, keySize :: Int, multiProbeLevel :: Int }
844
845
846 data FlannSearchParams = FlannSearchParams { checks :: Int, eps :: Float, sorted :: Bool }
847
848
849 data FlannBasedMatcherParams = FlannBasedMatcherParams
850 { indexParams :: FlannIndexParams
851 , searchParams :: FlannSearchParams
852 }
853
854
855 instance Default FlannIndexParams where
856 def = FlannKDTreeIndexParams { trees = 4 }
857
858
859 instance Default FlannSearchParams where
860 def = FlannSearchParams { checks = 32, eps = 0, sorted = True }
861
862
863 instance Default FlannBasedMatcherParams where
864 def = FlannBasedMatcherParams def def
865
866
867 -- NB: 1) it's OK to pass these new object as raw pointers because these directly pass to Ptr() in FlannBasedMatcher
868 -- 2) also, these objects use only in this internal module, so we don't create inlinec-wrappers for it, but pass
869 -- between calls as void* pointers
870
871 marshalIndexParams :: FlannIndexParams -> Ptr ()
872 marshalIndexParams (FlannKDTreeIndexParams tree) = unsafePerformIO $
873 [CU.exp| void* { new flann::KDTreeIndexParams($(int32_t c'tree)) } |]
874 where c'tree = fromIntegral tree
875 marshalIndexParams (FlannLshIndexParams tableNumber keySize multiProbeLevel) = unsafePerformIO $
876 [CU.exp| void* { new cv::flann::LshIndexParams($(int32_t c'tableNumber), $(int32_t c'keySize), $(int32_t c'multiProbeLevel)) } |]
877 where c'tableNumber = fromIntegral tableNumber
878 c'keySize = fromIntegral keySize
879 c'multiProbeLevel = fromIntegral multiProbeLevel
880
881 marshallSearchParams :: FlannSearchParams -> Ptr ()
882 marshallSearchParams (FlannSearchParams checks eps sorted) = unsafePerformIO $
883 [CU.exp| void* { new cv::flann::SearchParams($(int32_t c'checks), $(float c'eps), $(bool c'sorted)) } |]
884 where c'checks = fromIntegral checks
885 c'eps = realToFrac eps
886 c'sorted = fromBool sorted
887
888
889 newFlannBasedMatcher :: FlannBasedMatcherParams -> IO FlannBasedMatcher
890 newFlannBasedMatcher FlannBasedMatcherParams{..} = fromPtr
891 [CU.exp|FlannBasedMatcher * {
892 new cv::FlannBasedMatcher((flann::IndexParams*)($(void* c'indexParams)), (flann::SearchParams*)($(void* c'searchParams)))
893 }|]
894 where
895 c'indexParams = marshalIndexParams indexParams
896 c'searchParams = marshallSearchParams searchParams
897
898 --------------------------------------------------------------------------------
899
900 instance DescriptorMatcher FlannBasedMatcher where
901 upcast (FlannBasedMatcher ptr) = BaseMatcher $ castForeignPtr ptr
902
903
904 --------------------------------------------------------------------------------
905
906 data DrawMatchesParams = DrawMatchesParams
907 { matchColor :: Scalar
908 , singlePointColor :: Scalar
909 -- , matchesMask -- TODO
910 , flags :: Int32
911 }
912
913
914 instance Default DrawMatchesParams where
915 def = DrawMatchesParams
916 { matchColor = toScalar $ V4 (255::Double) 255 255 125
917 , singlePointColor = toScalar $ V4 (255::Double) 255 255 125
918 , flags = 0
919 }
920
921 drawMatches :: Mat ('S [height, width]) channels depth
922 -> V.Vector KeyPoint
923 -> Mat ('S [height, width]) channels depth
924 -> V.Vector KeyPoint
925 -> V.Vector DMatch
926 -> DrawMatchesParams
927 -> CvExcept (Mat ('S ['D, 'D]) channels depth)
928 drawMatches img1 keypoints1 img2 keypoints2 matches1to2 (DrawMatchesParams{..}) = unsafeWrapException $ do
929 outImg <- newEmptyMat
930 handleCvException (pure $ unsafeCoerceMat outImg) $
931 withPtr img1 $ \img1Ptr ->
932 withArrayPtr keypoints1 $ \kps1Ptr ->
933 withPtr img2 $ \img2Ptr ->
934 withArrayPtr keypoints2 $ \kps2Ptr ->
935 withArrayPtr matches1to2 $ \mt12Ptr ->
936 withPtr outImg $ \outImgPtr ->
937 [cvExcept|
938 std::vector<KeyPoint> kps1($(KeyPoint * kps1Ptr), $(KeyPoint * kps1Ptr) + $(int32_t c'kps1Length));
939 std::vector<KeyPoint> kps2($(KeyPoint * kps2Ptr), $(KeyPoint * kps2Ptr) + $(int32_t c'kps2Length));
940 std::vector<DMatch> mt12($(DMatch * mt12Ptr), $(DMatch * mt12Ptr) + $(int32_t c'matches1to2Length));
941 drawMatches(
942 *$(Mat* img1Ptr),
943 kps1,
944 *$(Mat* img2Ptr),
945 kps2,
946 mt12,
947 *$(Mat* outImgPtr));
948 |]
949 where
950 c'kps1Length = fromIntegral $ V.length keypoints1
951 c'kps2Length = fromIntegral $ V.length keypoints2
952 c'matches1to2Length = fromIntegral $ V.length matches1to2