content: {-# language TemplateHaskell #-}
  {-# language QuasiQuotes #-}
  {-# language RecordWildCards #-}
  
  module OpenCV.Features2d
      ( -- * ORB
        Orb
      , OrbScoreType(..)
      , WTA_K(..)
      , OrbParams(..)
      , defaultOrbParams
      , mkOrb
      , orbDetectAndCompute
  
        -- * BLOB
      , SimpleBlobDetector
      , SimpleBlobDetectorParams(..)
      , BlobFilterByArea(..)
      , BlobFilterByCircularity(..)
      , BlobFilterByColor(..)
      , BlobFilterByConvexity(..)
      , BlobFilterByInertia(..)
      , defaultSimpleBlobDetectorParams
      , mkSimpleBlobDetector
      , blobDetect
  
        -- * DescriptorMatcher
      , DescriptorMatcher(..)
      , drawMatches
        -- ** BFMatcher
      , BFMatcher
      , newBFMatcher
        -- ** FlannBasedMatcher
      , FlannBasedMatcher
      , FlannIndexParams(..)
      , FlannSearchParams(..)
      , FlannBasedMatcherParams(..)
      , newFlannBasedMatcher
      ) where
  
  import "base" Control.Exception ( mask_ )
  import "base" Data.Int
  import "base" Data.Monoid ( (<>) )
  import "base" Data.Word
  import "base" Data.Maybe
  import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, castForeignPtr )
  import "base" Foreign.Marshal.Alloc ( alloca )
  import "base" Foreign.Marshal.Array ( peekArray )
  import "base" Foreign.Marshal.Utils ( fromBool )
  import "base" Foreign.Ptr ( Ptr, nullPtr )
  import "base" Foreign.Storable ( peek )
  import "base" System.IO.Unsafe ( unsafePerformIO )
  import "data-default" Data.Default
  import "linear" Linear.V4
  import qualified "inline-c" Language.C.Inline as C
  import qualified "inline-c" Language.C.Inline.Unsafe as CU
  import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
  import "mtl" Control.Monad.Error.Class ( MonadError, throwError )
  import "this" OpenCV.Core.Types
  import "this" OpenCV.Internal
  import "this" OpenCV.Internal.Features2d.Constants
  import "this" OpenCV.Internal.C.FinalizerTH
  import "this" OpenCV.Internal.C.Inline ( openCvCtx )
  import "this" OpenCV.Internal.C.Types
  import "this" OpenCV.Internal.Core.ArrayOps
  import "this" OpenCV.Internal.Core.Types ( withArrayPtr, unsafeWithArrayPtr, Scalar )
  import "this" OpenCV.Internal.Core.Types.Mat
  import "this" OpenCV.Internal.Exception ( cvExcept, unsafeWrapException, handleCvException )
  import "this" OpenCV.TypeLevel
  import qualified "vector" Data.Vector as V
  
  --------------------------------------------------------------------------------
  
  C.context openCvCtx
  
  C.include "opencv2/core.hpp"
  C.include "opencv2/features2d.hpp"
  C.include "orb.hpp"
  C.include "simple_blob_detector.hpp"
  
  C.using "namespace cv"
  C.using "namespace cv::flann"
  
  infinity :: Float
  infinity = 1 / 0
  
  --------------------------------------------------------------------------------
  -- ORB - Oriented BRIEF
  --------------------------------------------------------------------------------
  
  -- Internally, an Orb is a pointer to a @cv::Ptr<cv::ORB>@, which in turn points
  -- to an actual @cv::ORB@ object.
  newtype Orb = Orb {unOrb :: ForeignPtr C'Ptr_ORB}
  
  type instance C Orb = C'Ptr_ORB
  
  instance WithPtr Orb where
      withPtr = withForeignPtr . unOrb
  
  mkFinalizer ReleaseDeletePtr "deleteOrb" "cv::Ptr<cv::ORB>" ''C'Ptr_ORB
  
  instance FromPtr Orb where fromPtr = objFromPtr Orb deleteOrb
  
  --------------------------------------------------------------------------------
  
  data WTA_K
     = WTA_K_2
     | WTA_K_3
     | WTA_K_4
  
  marshalWTA_K :: WTA_K -> Int32
  marshalWTA_K = \case
      WTA_K_2 -> 2
      WTA_K_3 -> 3
      WTA_K_4 -> 4
  
  data OrbScoreType
     = HarrisScore
     | FastScore
  
  marshalOrbScoreType :: OrbScoreType -> Int32
  marshalOrbScoreType = \case
      HarrisScore -> c'HARRIS_SCORE
      FastScore   -> c'FAST_SCORE
  
  data OrbParams
     = OrbParams
       { orb_nfeatures :: !Int32
         -- ^ The maximum number of features to retain.
       , orb_scaleFactor :: !Float
         -- ^ Pyramid decimation ratio, greater than 1. 'orb_scaleFactor' == 2
         -- means the classical pyramid, where each next level has 4x less pixels
         -- than the previous, but such a big scale factor will degrade feature
         -- matching scores dramatically. On the other hand, too close to 1 scale
         -- factor will mean that to cover certain scale range you will need more
         -- pyramid levels and so the speed will suffer.
       , orb_nlevels :: !Int32
         -- ^ The number of pyramid levels. The smallest level will have linear
         -- size equal to input_image_linear_size / 'orb_scaleFactor' **
         -- 'orb_nlevels'.
       , orb_edgeThreshold :: !Int32
         -- ^ This is size of the border where the features are not detected. It
         -- should roughly match the patchSize parameter.
       , orb_firstLevel :: !Int32
         -- ^ It should be 0 in the current implementation.
       , orb_WTA_K :: !WTA_K
         -- ^ The number of points that produce each element of the oriented BRIEF
         -- descriptor. The default value 'WTA_K_2' means the BRIEF where we take
         -- a random point pair and compare their brightnesses, so we get 0/1
         -- response. Other possible values are 'WTA_K_3' and 'WTA_K_4'. For
         -- example, 'WTA_K_3' means that we take 3 random points (of course,
         -- those point coordinates are random, but they are generated from the
         -- pre-defined seed, so each element of BRIEF descriptor is computed
         -- deterministically from the pixel rectangle), find point of maximum
         -- brightness and output index of the winner (0, 1 or 2). Such output
         -- will occupy 2 bits, and therefore it will need a special variant of
         -- Hamming distance, denoted as 'Norm_Hamming2' (2 bits per bin). When
         -- 'WTA_K_4', we take 4 random points to compute each bin (that will also
         -- occupy 2 bits with possible values 0, 1, 2 or 3).
       , orb_scoreType :: !OrbScoreType
         -- ^ The default 'HarrisScore' means that Harris algorithm is used to
         -- rank features (the score is written to KeyPoint::score and is used to
         -- retain best nfeatures features); 'FastScore' is alternative value of
         -- the parameter that produces slightly less stable keypoints, but it is
         -- a little faster to compute.
       , orb_patchSize :: !Int32
         -- ^ Size of the patch used by the oriented BRIEF descriptor. Of course,
         -- on smaller pyramid layers the perceived image area covered by a
         -- feature will be larger.
       , orb_fastThreshold :: !Int32
       }
  
  defaultOrbParams :: OrbParams
  defaultOrbParams =
      OrbParams
       { orb_nfeatures     = 500
       , orb_scaleFactor   = 1.2
       , orb_nlevels       = 8
       , orb_edgeThreshold = 31
       , orb_firstLevel    = 0
       , orb_WTA_K         = WTA_K_2
       , orb_scoreType     = HarrisScore
       , orb_patchSize     = 31
       , orb_fastThreshold = 20
       }
  
  --------------------------------------------------------------------------------
  
  newOrb :: OrbParams -> IO Orb
  newOrb OrbParams{..} = fromPtr
      [CU.block|Ptr_ORB * {
        cv::Ptr<cv::ORB> orbPtr =
          cv::ORB::create
          ( $(int32_t orb_nfeatures)
          , $(float   c'scaleFactor)
          , $(int32_t orb_nlevels)
          , $(int32_t orb_edgeThreshold)
          , $(int32_t orb_firstLevel)
          , $(int32_t c'WTA_K)
  #ifdef OPENCV4
          , cv::ORB::ScoreType($(int32_t c'scoreType))
  #else
          , $(int32_t c'scoreType)
  #endif
          , $(int32_t orb_patchSize)
          , $(int32_t orb_fastThreshold)
          );
        return new cv::Ptr<cv::ORB>(orbPtr);
      }|]
    where
      c'scaleFactor = realToFrac orb_scaleFactor
      c'WTA_K       = marshalWTA_K        orb_WTA_K
      c'scoreType   = marshalOrbScoreType orb_scoreType
  
  mkOrb :: OrbParams -> Orb
  mkOrb = unsafePerformIO . newOrb
  
  --------------------------------------------------------------------------------
  
  {- | Detect keypoints and compute descriptors
  
  Example:
  
  @
  orbDetectAndComputeImg
      :: forall (width    :: Nat)
                (height   :: Nat)
                (channels :: Nat)
                (depth    :: *)
       . (Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog)
      => Mat (ShapeT [height, width]) ('S channels) ('S depth)
  orbDetectAndComputeImg = exceptError $ do
      (kpts, _descs) <- orbDetectAndCompute orb frog Nothing
      withMatM (Proxy :: Proxy [height, width])
               (Proxy :: Proxy channels)
               (Proxy :: Proxy depth)
               white $ \\imgM -> do
        void $ matCopyToM imgM (V2 0 0) frog Nothing
        for_ kpts $ \\kpt -> do
          let kptRec = keyPointAsRec kpt
          circle imgM (round \<$> kptPoint kptRec :: V2 Int32) 5 blue 1 LineType_AA 0
    where
      orb = mkOrb defaultOrbParams
  @
  
  <<doc/generated/examples/orbDetectAndComputeImg.png orbDetectAndComputeImg>>
  -}
  orbDetectAndCompute
      :: MonadError CvException m
      => Orb
      -> Mat ('S [height, width]) channels depth -- ^ Image.
      -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8)) -- ^ Mask.
      -> m ( V.Vector KeyPoint
                  , Mat 'D 'D 'D
                  )
  orbDetectAndCompute orb img mbMask = unsafeWrapException $ do
      descriptors <- newEmptyMat
      withPtr orb $ \orbPtr ->
        withPtr img $ \imgPtr ->
        withPtr mbMask $ \maskPtr ->
        withPtr descriptors $ \descPtr ->
        alloca $ \(numPtsPtr :: Ptr C.CSize) ->
        alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'KeyPoint))) -> mask_ $ do
          ptrException <- [cvExcept|
            cv::ORB * orb = *$(Ptr_ORB * orbPtr);
            cv::Mat * maskPtr = $(Mat * maskPtr);
  
            std::vector<cv::KeyPoint> keypoints = std::vector<cv::KeyPoint>();
            orb->
              detectAndCompute
              ( *$(Mat * imgPtr)
              , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
              , keypoints
              , *$(Mat * descPtr)
              , false
              );
  
            *$(size_t * numPtsPtr) = keypoints.size();
  
            cv::KeyPoint * * * arrayPtrPtr = $(KeyPoint * * * arrayPtrPtr);
            cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()];
            *arrayPtrPtr = arrayPtr;
  
            for (std::vector<cv::KeyPoint>::size_type ix = 0; ix != keypoints.size(); ix++)
            {
              cv::KeyPoint & org = keypoints[ix];
              cv::KeyPoint * newPt =
                new cv::KeyPoint( org.pt
                                , org.size
                                , org.angle
                                , org.response
                                , org.octave
                                , org.class_id
                                );
              arrayPtr[ix] = newPt;
            }
          |]
          if ptrException /= nullPtr
          then Left . BindingException <$> fromPtr (pure ptrException)
          else do
            numPts <- peek numPtsPtr
            arrayPtr <- peek arrayPtrPtr
            keypoints <- mapM (fromPtr . pure) =<< peekArray (fromIntegral numPts) arrayPtr
  
            [CU.block| void {
              delete [] *$(KeyPoint * * * arrayPtrPtr);
            }|]
  
            pure $ Right (V.fromList keypoints, relaxMat descriptors)
  
  --------------------------------------------------------------------------------
  -- BLOB - Binary Large OBject
  --------------------------------------------------------------------------------
  
  -- Internally, a SimpleBlobDetector is a pointer to a @cv::Ptr<cv::SimpleBlobDetector>@, which in turn points
  -- to an actual @cv::SimpleBlobDetector@ object.
  newtype SimpleBlobDetector
        = SimpleBlobDetector
          { unSimpleBlobDetector :: ForeignPtr C'Ptr_SimpleBlobDetector
          }
  
  type instance C SimpleBlobDetector = C'Ptr_SimpleBlobDetector
  
  instance WithPtr SimpleBlobDetector where
      withPtr = withForeignPtr . unSimpleBlobDetector
  
  mkFinalizer ReleaseDeletePtr
              "deleteSimpleBlobDetector"
              "cv::Ptr<cv::SimpleBlobDetector>"
              ''C'Ptr_SimpleBlobDetector
  
  instance FromPtr SimpleBlobDetector where
      fromPtr = objFromPtr SimpleBlobDetector deleteSimpleBlobDetector
  
  data BlobFilterByArea
       = BlobFilterByArea
       { blob_minArea :: !Float
       , blob_maxArea :: !Float
       } deriving Eq
  
  data BlobFilterByCircularity
       = BlobFilterByCircularity
       { blob_minCircularity :: !Float
       , blob_maxCircularity :: !Float
       } deriving Eq
  
  data BlobFilterByColor
       = BlobFilterByColor
       { blob_blobColor :: !Word8
       } deriving Eq
  
  data BlobFilterByConvexity
       = BlobFilterByConvexity
       { blob_minConvexity :: !Float
       , blob_maxConvexity :: !Float
       } deriving Eq
  
  data BlobFilterByInertia
       = BlobFilterByInertia
       { blob_minInertiaRatio :: !Float
       , blob_maxInertiaRatio :: !Float
       } deriving Eq
  
  data SimpleBlobDetectorParams
     = SimpleBlobDetectorParams
       { blob_minThreshold :: !Float
       , blob_maxThreshold :: !Float
       , blob_thresholdStep :: !Float
       , blob_minRepeatability :: !Int32
       , blob_minDistBetweenBlobs :: !Float
       , blob_filterByArea :: !(Maybe BlobFilterByArea)
         -- ^ Extracted blobs have an area between 'minArea' (inclusive) and
         --   'maxArea' (exclusive).
       , blob_filterByCircularity :: !(Maybe BlobFilterByCircularity)
         -- ^ Extracted blobs have circularity
         --   @(4 * pi * Area)/(perimeter * perimeter)@ between 'minCircularity'
         --   (inclusive) and 'maxCircularity' (exclusive).
       , blob_filterByColor :: !(Maybe BlobFilterByColor)
         -- ^ This filter compares the intensity of a binary image at the center of
         --   a blob to 'blobColor'. If they differ, the blob is filtered out. Use
         --   @blobColor = 0@ to extract dark blobs and @blobColor = 255@ to extract
         --   light blobs.
       , blob_filterByConvexity :: !(Maybe BlobFilterByConvexity)
         -- ^ Extracted blobs have convexity (area / area of blob convex hull) between
         --   'minConvexity' (inclusive) and 'maxConvexity' (exclusive).
       , blob_filterByInertia :: !(Maybe BlobFilterByInertia)
         -- ^ Extracted blobs have this ratio between 'minInertiaRatio' (inclusive)
         --   and 'maxInertiaRatio' (exclusive).
       }
  
  defaultSimpleBlobDetectorParams :: SimpleBlobDetectorParams
  defaultSimpleBlobDetectorParams =
      SimpleBlobDetectorParams
      { blob_minThreshold = 50
      , blob_maxThreshold = 220
      , blob_thresholdStep = 10
      , blob_minRepeatability = 2
      , blob_minDistBetweenBlobs = 10
      , blob_filterByArea = Just (BlobFilterByArea 25 5000)
      , blob_filterByCircularity = Nothing
      , blob_filterByColor = Just (BlobFilterByColor 0)
      , blob_filterByConvexity = Just (BlobFilterByConvexity 0.95 infinity)
      , blob_filterByInertia = Just (BlobFilterByInertia 0.1 infinity)
      }
  
  --------------------------------------------------------------------------------
  
  newSimpleBlobDetector :: SimpleBlobDetectorParams -> IO SimpleBlobDetector
  newSimpleBlobDetector SimpleBlobDetectorParams{..} = fromPtr
      [CU.block|Ptr_SimpleBlobDetector * {
        cv::SimpleBlobDetector::Params params;
        params.blobColor           = $(unsigned char c'blobColor);
        params.filterByArea        = $(bool c'filterByArea);
        params.filterByCircularity = $(bool c'filterByCircularity);
        params.filterByColor       = $(bool c'filterByColor);
        params.filterByConvexity   = $(bool c'filterByConvexity);
        params.filterByInertia     = $(bool c'filterByInertia);
        params.maxArea             = $(float c'maxArea);
        params.maxCircularity      = $(float c'maxCircularity);
        params.maxConvexity        = $(float c'maxConvexity);
        params.maxInertiaRatio     = $(float c'maxInertiaRatio);
        params.maxThreshold        = $(float c'maxThreshold);
        params.minArea             = $(float c'minArea);
        params.minCircularity      = $(float c'minCircularity);
        params.minConvexity        = $(float c'minConvexity);
        params.minDistBetweenBlobs = $(float c'minDistBetweenBlobs);
        params.minInertiaRatio     = $(float c'minInertiaRatio);
        params.minRepeatability    = $(float c'minRepeatability);
        params.minThreshold        = $(float c'minThreshold);
        params.thresholdStep       = $(float c'thresholdStep);
        cv::Ptr<cv::SimpleBlobDetector> detectorPtr =
          cv::SimpleBlobDetector::create(params);
        return new cv::Ptr<cv::SimpleBlobDetector>(detectorPtr);
      }|]
    where
      c'minThreshold        = realToFrac blob_minThreshold
      c'maxThreshold        = realToFrac blob_maxThreshold
      c'thresholdStep       = realToFrac blob_thresholdStep
      c'minRepeatability    = realToFrac blob_minRepeatability
      c'minDistBetweenBlobs = realToFrac blob_minDistBetweenBlobs
      c'filterByArea        = fromBool (isJust blob_filterByArea)
      c'filterByCircularity = fromBool (isJust blob_filterByCircularity)
      c'filterByColor       = fromBool (isJust blob_filterByColor)
      c'filterByConvexity   = fromBool (isJust blob_filterByConvexity)
      c'filterByInertia     = fromBool (isJust blob_filterByInertia)
      c'minArea             = realToFrac (fromMaybe 25 (fmap blob_minArea blob_filterByArea))
      c'maxArea             = realToFrac (fromMaybe 5000 (fmap blob_maxArea blob_filterByArea))
      c'minCircularity      = realToFrac (fromMaybe 0.8 (fmap blob_minCircularity blob_filterByCircularity))
      c'maxCircularity      = realToFrac (fromMaybe infinity (fmap blob_maxCircularity blob_filterByCircularity))
      c'blobColor           = fromIntegral (fromMaybe 0 (fmap blob_blobColor blob_filterByColor))
      c'minConvexity        = realToFrac (fromMaybe 0.95 (fmap blob_minConvexity blob_filterByConvexity))
      c'maxConvexity        = realToFrac (fromMaybe infinity (fmap blob_maxConvexity blob_filterByConvexity))
      c'minInertiaRatio     = realToFrac (fromMaybe 0.1 (fmap blob_minInertiaRatio blob_filterByInertia))
      c'maxInertiaRatio     = realToFrac (fromMaybe infinity (fmap blob_maxInertiaRatio blob_filterByInertia))
  
  mkSimpleBlobDetector :: SimpleBlobDetectorParams -> SimpleBlobDetector
  mkSimpleBlobDetector = unsafePerformIO . newSimpleBlobDetector
  
  --------------------------------------------------------------------------------
  
  {- | Detect keypoints and compute descriptors
  -}
  blobDetect
      :: MonadError CvException m
      => SimpleBlobDetector
      -> Mat ('S [height, width]) channels depth -- ^ Image.
      -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8)) -- ^ Mask.
      -> m (V.Vector KeyPoint)
  blobDetect detector img mbMask = unsafeWrapException $ do
      withPtr detector $ \detectorPtr ->
        withPtr img $ \imgPtr ->
        withPtr mbMask $ \maskPtr ->
        alloca $ \(numPtsPtr :: Ptr C.CSize) ->
        alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'KeyPoint))) -> mask_ $ do
          ptrException <- [cvExcept|
            cv::SimpleBlobDetector * detector = *$(Ptr_SimpleBlobDetector * detectorPtr);
            cv::Mat * maskPtr = $(Mat * maskPtr);
  
            std::vector<cv::KeyPoint> keypoints = std::vector<cv::KeyPoint>();
            detector->
              detect
              ( *$(Mat * imgPtr)
              , keypoints
              , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
              );
  
            *$(size_t * numPtsPtr) = keypoints.size();
  
            cv::KeyPoint * * * arrayPtrPtr = $(KeyPoint * * * arrayPtrPtr);
            cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()];
            *arrayPtrPtr = arrayPtr;
  
            for (std::vector<cv::KeyPoint>::size_type ix = 0; ix != keypoints.size(); ix++)
            {
              arrayPtr[ix] = new cv::KeyPoint(keypoints[ix]);
            }
          |]
          if ptrException /= nullPtr
          then Left . BindingException <$> fromPtr (pure ptrException)
          else do
            numPts <- peek numPtsPtr
            arrayPtr <- peek arrayPtrPtr
            keypoints <- mapM (fromPtr . pure) =<< peekArray (fromIntegral numPts) arrayPtr
  
            [CU.block| void {
              delete [] *$(KeyPoint * * * arrayPtrPtr);
            }|]
  
            pure $ Right (V.fromList keypoints)
  
  --------------------------------------------------------------------------------
  -- DescriptorMatcher
  --------------------------------------------------------------------------------
  
  class DescriptorMatcher a where
      upcast :: a -> BaseMatcher
  
      add :: a
          -> V.Vector (Mat 'D 'D 'D) -- ^ Train set of descriptors.
          -> IO ()
      add dm trainDescriptors =
          fmap (fromMaybe ()) $ -- adding 0 training descriptors does nothing
          withPtr (upcast dm) $ \dmPtr ->
          withArrayPtr trainDescriptors $ \trainVecPtr ->
              [C.block| void {
                  std::vector<Mat> buffer( $(Mat * trainVecPtr)
                                         , $(Mat * trainVecPtr) + $(int32_t c'trainVecLength) );
                  $(DescriptorMatcher * dmPtr)->add(buffer);
              }|]
        where
          c'trainVecLength = fromIntegral $ V.length trainDescriptors
  
      train :: a -> IO ()
      train dm =
          withPtr (upcast dm) $ \dmPtr ->
              [C.block| void { $(DescriptorMatcher * dmPtr)->train(); } |]
  
      match
          :: a
          -> Mat 'D 'D 'D -- ^ Query set of descriptors.
          -> Mat 'D 'D 'D -- ^ Train set of descriptors.
          -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8))
             -- ^ Mask specifying permissible matches between an input query and
             -- train matrices of descriptors..
          -> IO (V.Vector DMatch)
      match dm queryDescriptors trainDescriptors mbMask =
          withPtr (upcast dm)      $ \dmPtr    ->
          withPtr queryDescriptors $ \queryPtr ->
          withPtr trainDescriptors $ \trainPtr ->
          withPtr mbMask           $ \maskPtr  ->
          alloca $ \(numMatchesPtr :: Ptr C.CSize) ->
          alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'DMatch))) -> mask_ $ do
              [C.block| void {
                  cv::Mat * maskPtr = $(Mat * maskPtr);
                  std::vector<cv::DMatch> matches = std::vector<cv::DMatch>();
                  $(DescriptorMatcher * dmPtr)->match
                      ( *$(Mat * queryPtr)
                      , *$(Mat * trainPtr)
                      , matches
                      , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
                      );
                  *$(size_t * numMatchesPtr) = matches.size();
                  cv::DMatch * * * arrayPtrPtr = $(DMatch * * * arrayPtrPtr);
                  cv::DMatch * * arrayPtr = new cv::DMatch * [matches.size()];
                  *arrayPtrPtr = arrayPtr;
                  for (std::vector<cv::DMatch>::size_type ix = 0; ix != matches.size(); ix++)
                  {
                      cv::DMatch & org = matches[ix];
                      cv::DMatch * newMatch =
                          new cv::DMatch( org.queryIdx
                                        , org.trainIdx
                                        , org.imgIdx
                                        , org.distance
                                        );
                      arrayPtr[ix] = newMatch;
                  }
              }|]
              numMatches <- peek numMatchesPtr
              arrayPtr <- peek arrayPtrPtr
              matches <- mapM (fromPtr . pure) =<< peekArray (fromIntegral numMatches) arrayPtr
              [CU.block| void {
                  delete [] *$(DMatch * * * arrayPtrPtr);
              }|]
              pure $ V.fromList matches
  
      -- | Match in pre-trained matcher
      match'
          :: a
          -> Mat 'D 'D 'D -- ^ Query set of descriptors.
          -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8))
             -- ^ Mask specifying permissible matches between an input query and
             -- train matrices of descriptors..
          -> IO (V.Vector DMatch)
      match' dm queryDescriptors mbMask =
          withPtr (upcast dm)      $ \dmPtr    ->
          withPtr queryDescriptors $ \queryPtr ->
          withPtr mbMask           $ \maskPtr  ->
          alloca $ \(numMatchesPtr :: Ptr C.CSize) ->
          alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'DMatch))) -> mask_ $ do
              [C.block| void {
                  cv::Mat * maskPtr = $(Mat * maskPtr);
                  std::vector<cv::DMatch> matches = std::vector<cv::DMatch>();
                  $(DescriptorMatcher * dmPtr)->match
                      ( *$(Mat * queryPtr)
                      , matches
                      , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())
                      );
                  *$(size_t * numMatchesPtr) = matches.size();
                  cv::DMatch * * * arrayPtrPtr = $(DMatch * * * arrayPtrPtr);
                  cv::DMatch * * arrayPtr = new cv::DMatch * [matches.size()];
                  *arrayPtrPtr = arrayPtr;
                  for (std::vector<cv::DMatch>::size_type ix = 0; ix != matches.size(); ix++)
                  {
                      cv::DMatch & org = matches[ix];
                      cv::DMatch * newMatch =
                          new cv::DMatch( org.queryIdx
                                        , org.trainIdx
                                        , org.imgIdx
                                        , org.distance
                                        );
                      arrayPtr[ix] = newMatch;
                  }
              }|]
              numMatches <- peek numMatchesPtr
              arrayPtr <- peek arrayPtrPtr
              matches <- mapM (fromPtr . pure) =<< peekArray (fromIntegral numMatches) arrayPtr
              [CU.block| void {
                  delete [] *$(DMatch * * * arrayPtrPtr);
              }|]
              pure $ V.fromList matches
  
  newtype BaseMatcher = BaseMatcher {unBaseMatcher :: ForeignPtr C'DescriptorMatcher}
  
  type instance C BaseMatcher = C'DescriptorMatcher
  
  instance WithPtr BaseMatcher where
      withPtr = withForeignPtr . unBaseMatcher
  
  --------------------------------------------------------------------------------
  -- BFMatcher
  --------------------------------------------------------------------------------
  
  {- | Brute-force descriptor matcher
  
  For each descriptor in the first set, this matcher finds the closest descriptor
  in the second set by trying each one. This descriptor matcher supports masking
  permissible matches of descriptor sets.
  
  Example:
  
  @
  bfMatcherImg
      :: forall (width    :: Nat)
                (width2   :: Nat)
                (height   :: Nat)
                (channels :: Nat)
                (depth    :: *)
       . ( Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog
         , width2 ~ (*) width 2
         )
      => IO (Mat (ShapeT [height, width2]) ('S channels) ('S depth))
  bfMatcherImg = do
      let (kpts1, descs1) = exceptError $ orbDetectAndCompute orb frog        Nothing
          (kpts2, descs2) = exceptError $ orbDetectAndCompute orb rotatedFrog Nothing
  
      bfmatcher <- newBFMatcher Norm_Hamming True
      matches <- match bfmatcher
                       descs1 -- Query descriptors
                       descs2 -- Train descriptors
                       Nothing
      exceptErrorIO $
        withMatM (Proxy :: Proxy [height, width2])
                 (Proxy :: Proxy channels)
                 (Proxy :: Proxy depth)
                 white $ \\imgM -> do
          matCopyToM imgM (V2 0     0) frog        Nothing
          matCopyToM imgM (V2 width 0) rotatedFrog Nothing
  
          -- Draw the matches as lines from the query image to the train image.
          for_ matches $ \\dmatch -> do
            let matchRec = dmatchAsRec dmatch
                queryPt = kpts1 V.! fromIntegral (dmatchQueryIdx matchRec)
                trainPt = kpts2 V.! fromIntegral (dmatchTrainIdx matchRec)
                queryPtRec = keyPointAsRec queryPt
                trainPtRec = keyPointAsRec trainPt
  
            -- We translate the train point one width to the right in order to
            -- match the position of rotatedFrog in imgM.
            line imgM
                 (round \<$> kptPoint queryPtRec :: V2 Int32)
                 ((round \<$> kptPoint trainPtRec :: V2 Int32) ^+^ V2 width 0)
                 blue 1 LineType_AA 0
    where
      orb = mkOrb defaultOrbParams {orb_nfeatures = 50}
  
      width = fromInteger $ natVal (Proxy :: Proxy width)
  
      rotatedFrog :: Frog
      rotatedFrog = exceptError $
                    warpAffine frog rotMat InterArea False False (BorderConstant black)
      rotMat = getRotationMatrix2D (V2 250 195 :: V2 CFloat) 45 0.8
  @
  
  <<doc/generated/examples/bfMatcherImg.png bfMatcherImg>>
  
  <http://docs.opencv.org/3.0-last-rst/modules/features2d/doc/common_interfaces_of_descriptor_matchers.html#bfmatcher OpenCV Sphinx doc>
  -}
  newtype BFMatcher = BFMatcher {unBFMatcher :: ForeignPtr C'BFMatcher}
  
  type instance C BFMatcher = C'BFMatcher
  
  instance WithPtr BFMatcher where
      withPtr = withForeignPtr . unBFMatcher
  
  mkFinalizer DeletePtr "deleteBFMatcher" "cv::BFMatcher" ''C'BFMatcher
  
  instance FromPtr BFMatcher where
      fromPtr = objFromPtr BFMatcher deleteBFMatcher
  
  --------------------------------------------------------------------------------
  
  newBFMatcher
      :: NormType
         -- ^ 'Norm_L1' and 'Norm_L2' norms are preferable choices for SIFT and
         -- SURF descriptors, 'Norm_Hamming' should be used with 'Orb', BRISK and
         -- BRIEF, 'Norm_Hamming2' should be used with 'Orb' when 'WTA_K_3' or
         -- 'WTA_K_4' (see 'orb_WTA_K').
      -> Bool
         -- ^ If it is false, this is will be default 'BFMatcher' behaviour when
         -- it finds the k nearest neighbors for each query descriptor. If
         -- crossCheck == True, then the @knnMatch()@ method with @k=1@ will only
         -- return pairs @(i,j)@ such that for i-th query descriptor the j-th
         -- descriptor in the matcher's collection is the nearest and vice versa,
         -- i.e. the 'BFMatcher' will only return consistent pairs. Such technique
         -- usually produces best results with minimal number of outliers when
         -- there are enough matches. This is alternative to the ratio test, used
         -- by D. Lowe in SIFT paper.
      -> IO BFMatcher
  newBFMatcher normType crossCheck = fromPtr
      [CU.exp|BFMatcher * {
        new cv::BFMatcher
            ( $(int32_t c'normType)
            , $(bool c'crossCheck)
            )
      }|]
    where
      c'normType = marshalNormType NormAbsolute normType
      c'crossCheck = fromBool crossCheck
  
  --------------------------------------------------------------------------------
  
  instance DescriptorMatcher BFMatcher where
      upcast (BFMatcher ptr) = BaseMatcher $ castForeignPtr ptr
  
  
  
  --------------------------------------------------------------------------------
  -- FlannBasedMatcher
  --------------------------------------------------------------------------------
  
  {- | Flann-based descriptor matcher.
  
  This matcher trains @flann::Index_@ on a train descriptor collection and calls it
  nearest search methods to find the best matches. So, this matcher may be faster
  when matching a large train collection than the brute force matcher.
  @FlannBasedMatcher@ does not support masking permissible matches of descriptor
  sets because flann::Index does not support this.
  
  Example:
  
  @
  fbMatcherImg
      :: forall (width    :: Nat)
                (width2   :: Nat)
                (height   :: Nat)
                (channels :: Nat)
                (depth    :: *)
       . ( Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog
         , width2 ~ (*) width 2
         )
      => IO (Mat (ShapeT [height, width2]) ('S channels) ('S depth))
  fbMatcherImg = do
      let (kpts1, descs1) = exceptError $ orbDetectAndCompute orb frog        Nothing
          (kpts2, descs2) = exceptError $ orbDetectAndCompute orb rotatedFrog Nothing
  
      fbmatcher <- newFlannBasedMatcher (def { indexParams = FlannLshIndexParams 20 10 2 })
      matches <- match fbmatcher
                       descs1 -- Query descriptors
                       descs2 -- Train descriptors
                       Nothing
      exceptErrorIO $
        withMatM (Proxy :: Proxy [height, width2])
                 (Proxy :: Proxy channels)
                 (Proxy :: Proxy depth)
                 white $ \\imgM -> do
          matCopyToM imgM (V2 0     0) frog        Nothing
          matCopyToM imgM (V2 width 0) rotatedFrog Nothing
  
          -- Draw the matches as lines from the query image to the train image.
          for_ matches $ \\dmatch -> do
            let matchRec = dmatchAsRec dmatch
                queryPt = kpts1 V.! fromIntegral (dmatchQueryIdx matchRec)
                trainPt = kpts2 V.! fromIntegral (dmatchTrainIdx matchRec)
                queryPtRec = keyPointAsRec queryPt
                trainPtRec = keyPointAsRec trainPt
  
            -- We translate the train point one width to the right in order to
            -- match the position of rotatedFrog in imgM.
            line imgM
                 (round \<$> kptPoint queryPtRec :: V2 Int32)
                 ((round \<$> kptPoint trainPtRec :: V2 Int32) ^+^ V2 width 0)
                 blue 1 LineType_AA 0
    where
      orb = mkOrb defaultOrbParams {orb_nfeatures = 50}
  
      width = fromInteger $ natVal (Proxy :: Proxy width)
  
      rotatedFrog :: Frog
      rotatedFrog = exceptError $
                    warpAffine frog rotMat InterArea False False (BorderConstant black)
      rotMat = getRotationMatrix2D (V2 250 195 :: V2 CFloat) 45 0.8
  @
  
  <<doc/generated/examples/fbMatcherImg.png fbMatcherImg>>
  
  <http://docs.opencv.org/3.0-last-rst/modules/features2d/doc/common_interfaces_of_descriptor_matchers.html#flannbasedmatcher OpenCV Sphinx doc>
  -}
  newtype FlannBasedMatcher = FlannBasedMatcher {unFlannBasedMatcher :: ForeignPtr C'FlannBasedMatcher}
  
  type instance C FlannBasedMatcher = C'FlannBasedMatcher
  
  instance WithPtr FlannBasedMatcher where
      withPtr = withForeignPtr . unFlannBasedMatcher
  
  mkFinalizer DeletePtr "deleteFlannBasedMatcher" "cv::FlannBasedMatcher" ''C'FlannBasedMatcher
  
  instance FromPtr FlannBasedMatcher where
      fromPtr = objFromPtr FlannBasedMatcher deleteFlannBasedMatcher
  
  --------------------------------------------------------------------------------
  
  
  data FlannIndexParams = FlannKDTreeIndexParams { trees :: Int }
                        | FlannLshIndexParams { tableNumber :: Int, keySize :: Int, multiProbeLevel :: Int }
  
  
  data FlannSearchParams = FlannSearchParams { checks :: Int, eps :: Float, sorted :: Bool }
  
  
  data FlannBasedMatcherParams = FlannBasedMatcherParams
      { indexParams :: FlannIndexParams
      , searchParams :: FlannSearchParams
      }
  
  
  instance Default FlannIndexParams where
      def = FlannKDTreeIndexParams { trees = 4 }
  
  
  instance Default FlannSearchParams where
      def = FlannSearchParams { checks = 32, eps = 0, sorted = True }
  
  
  instance Default FlannBasedMatcherParams where
      def = FlannBasedMatcherParams def def
  
  
  -- NB: 1) it's OK to pass these new object as raw pointers because these directly pass to Ptr() in FlannBasedMatcher
  --     2) also, these objects use only in this internal module, so we don't create inlinec-wrappers for it, but pass
  --        between calls as void* pointers
  
  marshalIndexParams :: FlannIndexParams -> Ptr ()
  marshalIndexParams (FlannKDTreeIndexParams tree) = unsafePerformIO $
      [CU.exp| void* { new flann::KDTreeIndexParams($(int32_t c'tree)) } |]
      where c'tree = fromIntegral tree
  marshalIndexParams (FlannLshIndexParams tableNumber keySize multiProbeLevel) = unsafePerformIO $
      [CU.exp| void* { new cv::flann::LshIndexParams($(int32_t c'tableNumber), $(int32_t c'keySize), $(int32_t c'multiProbeLevel)) } |]
      where c'tableNumber     = fromIntegral tableNumber
            c'keySize         = fromIntegral keySize
            c'multiProbeLevel = fromIntegral multiProbeLevel
  
  marshallSearchParams :: FlannSearchParams -> Ptr ()
  marshallSearchParams (FlannSearchParams checks eps sorted) = unsafePerformIO $
      [CU.exp| void* { new cv::flann::SearchParams($(int32_t c'checks), $(float c'eps), $(bool c'sorted)) } |]
      where c'checks = fromIntegral checks
            c'eps    = realToFrac eps
            c'sorted = fromBool sorted
  
  
  newFlannBasedMatcher :: FlannBasedMatcherParams -> IO FlannBasedMatcher
  newFlannBasedMatcher FlannBasedMatcherParams{..} = fromPtr
      [CU.exp|FlannBasedMatcher * {
        new cv::FlannBasedMatcher((flann::IndexParams*)($(void* c'indexParams)), (flann::SearchParams*)($(void* c'searchParams)))
      }|]
    where
      c'indexParams  = marshalIndexParams indexParams
      c'searchParams = marshallSearchParams searchParams
  
  --------------------------------------------------------------------------------
  
  instance DescriptorMatcher FlannBasedMatcher where
      upcast (FlannBasedMatcher ptr) = BaseMatcher $ castForeignPtr ptr
  
  
  --------------------------------------------------------------------------------
  
  data DrawMatchesParams = DrawMatchesParams
      { matchColor :: Scalar
      , singlePointColor :: Scalar
      -- , matchesMask -- TODO
      , flags :: Int32
      }
  
  
  instance Default DrawMatchesParams where
      def = DrawMatchesParams
          { matchColor = toScalar $ V4 (255::Double) 255 255 125
          , singlePointColor = toScalar $ V4 (255::Double) 255 255 125
          , flags = 0
          }
  
  -- TODO (RvD): DrawMatchesParams is not actually used in this function
  -- but it should
  drawMatches
      :: (MonadError CvException m)
      => Mat ('S [height, width]) channels depth
      -> V.Vector KeyPoint
      -> Mat ('S [height, width]) channels depth
      -> V.Vector KeyPoint
      -> V.Vector DMatch
      -> DrawMatchesParams
      -> m (Mat ('S ['D, 'D]) channels depth)
  drawMatches img1 keypoints1 img2 keypoints2 matches1to2 _params
      | V.null keypoints1 = emptyVecErr "keypoints1"
      | V.null keypoints2 = emptyVecErr "keypoints2"
      | V.null matches1to2 = emptyVecErr "matches1to2"
      | otherwise = unsafeWrapException $ do
          outImg <- newEmptyMat
          handleCvException (pure $ unsafeCoerceMat outImg) $
            withPtr img1 $ \img1Ptr ->
            unsafeWithArrayPtr keypoints1 $ \kps1Ptr ->
            withPtr img2 $ \img2Ptr ->
            unsafeWithArrayPtr keypoints2 $ \kps2Ptr ->
            unsafeWithArrayPtr matches1to2 $ \mt12Ptr ->
            withPtr outImg $ \outImgPtr ->
              [cvExcept|
                std::vector<KeyPoint> kps1
                  ( $(KeyPoint * kps1Ptr)
                  , $(KeyPoint * kps1Ptr) + $(int32_t c'kps1Length)
                  );
                std::vector<KeyPoint> kps2
                  ( $(KeyPoint * kps2Ptr)
                  , $(KeyPoint * kps2Ptr) + $(int32_t c'kps2Length)
                  );
                std::vector<DMatch> mt12
                  ( $(DMatch * mt12Ptr)
                  , $(DMatch * mt12Ptr) + $(int32_t c'matches1to2Length)
                  );
                drawMatches
                  ( *$(Mat * img1Ptr)
                  , kps1
                  , *$(Mat * img2Ptr)
                  , kps2
                  , mt12
                  , *$(Mat * outImgPtr)
                  );
              |]
    where
      emptyVecErr name = throwError $ CvException $ "drawMatches: empty " <> name
  
      c'kps1Length = fromIntegral $ V.length keypoints1
      c'kps2Length = fromIntegral $ V.length keypoints2
      c'matches1to2Length = fromIntegral $ V.length matches1to2
  