never executed always true always false
    1 {-# language TemplateHaskell #-}
    2 {-# language QuasiQuotes #-}
    3 
    4 module OpenCV.Video.MotionAnalysis
    5     ( -- * BackgroundSubtractor
    6       BackgroundSubtractor(..)
    7       -- * Background subtractors
    8     , BackgroundSubtractorMOG2
    9     , BackgroundSubtractorKNN
   10     , newBackgroundSubtractorKNN
   11     , newBackgroundSubtractorMOG2
   12     ) where
   13 
   14 import "base" Control.Exception ( mask_ )
   15 import "base" Data.Int
   16 import "base" Data.Maybe
   17 import "base" Data.Word
   18 import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
   19 import "base" Foreign.Marshal.Alloc ( alloca )
   20 import "base" Foreign.Marshal.Utils ( fromBool, toBool )
   21 import "base" Foreign.Storable ( peek )
   22 import qualified "inline-c" Language.C.Inline as C
   23 import qualified "inline-c" Language.C.Inline.Unsafe as CU
   24 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
   25 import "primitive" Control.Monad.Primitive
   26 import "this" OpenCV.Core.Types
   27 import "this" OpenCV.Internal
   28 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
   29 import "this" OpenCV.Internal.Core.Types.Mat
   30 import "this" OpenCV.Internal.C.Types
   31 import "this" OpenCV.TypeLevel
   32 
   33 --------------------------------------------------------------------------------
   34 
   35 C.context openCvCtx
   36 
   37 C.include "opencv2/core.hpp"
   38 C.include "opencv2/video.hpp"
   39 C.include "video_motion_analysis.hpp"
   40 
   41 C.using "namespace cv"
   42 
   43 #include <bindings.dsl.h>
   44 #include "opencv2/core.hpp"
   45 #include "opencv2/video.hpp"
   46 
   47 #include "namespace.hpp"
   48 #include "video_motion_analysis.hpp"
   49 
   50 --------------------------------------------------------------------------------
   51 -- BackgroundSubtractor
   52 --------------------------------------------------------------------------------
   53 
   54 class BackgroundSubtractor a where
   55     bgSubApply
   56         :: (PrimMonad m)
   57         => a (PrimState m)
   58         -> Double
   59            -- ^ The value between 0 and 1 that indicates how fast the background
   60            -- model is learnt. Negative parameter value makes the algorithm to
   61            -- use some automatically chosen learning rate. 0 means that the
   62            -- background model is not updated at all, 1 means that the
   63            -- background model is completely reinitialized from the last frame.
   64         -> Mat ('S [h, w]) channels depth
   65            -- ^ Next video frame.
   66         -> m (Mat ('S [h, w]) ('S 1) ('S Word8))
   67            -- ^ The output foreground mask as an 8-bit binary image.
   68 
   69     getBackgroundImage
   70         :: (PrimMonad m)
   71         => a (PrimState m)
   72         -> m (Mat ('S [h, w]) channels depth)
   73            -- ^ The output background image.
   74 
   75 {- |
   76 
   77 Example:
   78 
   79 @
   80 carAnim :: Animation (ShapeT [240, 320]) ('S 3) ('S Word8)
   81 carAnim = carOverhead
   82 
   83 mog2Anim :: IO (Animation (ShapeT [240, 320]) ('S 3) ('S Word8))
   84 mog2Anim = do
   85     mog2 <- newBackgroundSubtractorMOG2 Nothing Nothing Nothing
   86     forM carOverhead $ \(delay, img) -> do
   87       fg <- bgSubApply mog2 0.1 img
   88       fgBgr <- exceptErrorIO $ pureExcept $ cvtColor gray bgr fg
   89       pure (delay, fgBgr)
   90 @
   91 
   92 Original:
   93 <<doc/generated/examples/car.gif carAnim>>
   94 
   95 Foreground:
   96 <<doc/generated/examples/mog2.gif mog2Anim>>
   97 -}
   98 
   99 --------------------------------------------------------------------------------
  100 -- Background subtractors
  101 --------------------------------------------------------------------------------
  102 
  103 newtype BackgroundSubtractorKNN s
  104       = BackgroundSubtractorKNN
  105         { unBackgroundSubtractorKNN :: ForeignPtr C'Ptr_BackgroundSubtractorKNN }
  106 
  107 newtype BackgroundSubtractorMOG2 s
  108       = BackgroundSubtractorMOG2
  109         { unBackgroundSubtractorMOG2 :: ForeignPtr C'Ptr_BackgroundSubtractorMOG2 }
  110 
  111 type instance C (BackgroundSubtractorKNN  s) = C'Ptr_BackgroundSubtractorKNN
  112 type instance C (BackgroundSubtractorMOG2 s) = C'Ptr_BackgroundSubtractorMOG2
  113 
  114 instance WithPtr (BackgroundSubtractorKNN s) where
  115     withPtr = withForeignPtr . unBackgroundSubtractorKNN
  116 
  117 instance WithPtr (BackgroundSubtractorMOG2 s) where
  118     withPtr = withForeignPtr . unBackgroundSubtractorMOG2
  119 
  120 instance FromPtr (BackgroundSubtractorKNN s) where
  121     fromPtr = objFromPtr BackgroundSubtractorKNN $ \ptr ->
  122                 [CU.block| void {
  123                   cv::Ptr<cv::BackgroundSubtractorKNN> * knn_ptr_ptr =
  124                     $(Ptr_BackgroundSubtractorKNN * ptr);
  125                   knn_ptr_ptr->release();
  126                   delete knn_ptr_ptr;
  127                 }|]
  128 
  129 instance FromPtr (BackgroundSubtractorMOG2 s) where
  130     fromPtr = objFromPtr BackgroundSubtractorMOG2 $ \ptr ->
  131                 [CU.block| void {
  132                   cv::Ptr<cv::BackgroundSubtractorMOG2> * mog2_ptr_ptr =
  133                     $(Ptr_BackgroundSubtractorMOG2 * ptr);
  134                   mog2_ptr_ptr->release();
  135                   delete mog2_ptr_ptr;
  136                 }|]
  137 
  138 --------------------------------------------------------------------------------
  139 
  140 newBackgroundSubtractorKNN
  141     :: (PrimMonad m)
  142     => Maybe Int32
  143        -- ^ Length of the history.
  144     -> Maybe Double
  145        -- ^ Threshold on the squared distance between the pixel and the sample
  146        -- to decide whether a pixel is close to that sample. This parameter does
  147        -- not affect the background update.
  148     -> Maybe Bool
  149        -- ^ If 'True', the algorithm will detect shadows and mark them. It
  150        -- decreases the speed a bit, so if you do not need this feature, set the
  151        -- parameter to 'False'.
  152     -> m (BackgroundSubtractorKNN (PrimState m))
  153 newBackgroundSubtractorKNN mbHistory mbDist2Threshold mbDetectShadows = unsafePrimToPrim $ fromPtr
  154     [CU.block|Ptr_BackgroundSubtractorKNN * {
  155       cv::Ptr<cv::BackgroundSubtractorKNN> knnPtr =
  156         cv::createBackgroundSubtractorKNN
  157         ( $(int32_t c'history       )
  158         , $(double  c'dist2Threshold)
  159         , $(bool    c'detectShadows )
  160         );
  161       return new cv::Ptr<cv::BackgroundSubtractorKNN>(knnPtr);
  162     }|]
  163   where
  164     c'history        = fromMaybe 500 mbHistory
  165     c'dist2Threshold = maybe 400 realToFrac mbDist2Threshold
  166     c'detectShadows  = fromBool $ fromMaybe True mbDetectShadows
  167 
  168 newBackgroundSubtractorMOG2
  169     :: (PrimMonad m)
  170     => Maybe Int32
  171        -- ^ Length of the history.
  172     -> Maybe Double
  173        -- ^ Threshold on the squared Mahalanobis distance between the pixel and
  174        -- the model to decide whether a pixel is well described by the
  175        -- background model. This parameter does not affect the background
  176        -- update.
  177     -> Maybe Bool
  178        -- ^ If 'True', the algorithm will detect shadows and mark them. It
  179        -- decreases the speed a bit, so if you do not need this feature, set the
  180        -- parameter to 'False'.
  181     -> m (BackgroundSubtractorMOG2 (PrimState m))
  182 newBackgroundSubtractorMOG2 mbHistory mbVarThreshold mbDetectShadows = unsafePrimToPrim $ fromPtr
  183     [CU.block|Ptr_BackgroundSubtractorMOG2 * {
  184       cv::Ptr<cv::BackgroundSubtractorMOG2> mog2Ptr =
  185         cv::createBackgroundSubtractorMOG2
  186         ( $(int32_t c'history      )
  187         , $(double  c'varThreshold )
  188         , $(bool    c'detectShadows)
  189         );
  190       return new cv::Ptr<cv::BackgroundSubtractorMOG2>(mog2Ptr);
  191     }|]
  192   where
  193     c'history       = fromMaybe 500 mbHistory
  194     c'varThreshold  = maybe 16 realToFrac mbVarThreshold
  195     c'detectShadows = fromBool $ fromMaybe True mbDetectShadows
  196 
  197 --------------------------------------------------------------------------------
  198 
  199 instance Algorithm BackgroundSubtractorKNN where
  200     algorithmClearState knn = unsafePrimToPrim $
  201         withPtr knn $ \knnPtr ->
  202           [C.block|void {
  203               cv::BackgroundSubtractorKNN * knn = *$(Ptr_BackgroundSubtractorKNN * knnPtr);
  204               knn->clear();
  205           }|]
  206 
  207     algorithmIsEmpty knn = unsafePrimToPrim $
  208         withPtr knn $ \knnPtr ->
  209         alloca $ \emptyPtr -> do
  210           [C.block|void {
  211               cv::BackgroundSubtractorKNN * knn = *$(Ptr_BackgroundSubtractorKNN * knnPtr);
  212               *$(bool * emptyPtr) = knn->empty();
  213           }|]
  214           toBool <$> peek emptyPtr
  215 
  216 instance Algorithm BackgroundSubtractorMOG2 where
  217     algorithmClearState mog2 = unsafePrimToPrim $
  218         withPtr mog2 $ \mog2Ptr ->
  219           [C.block|void {
  220               cv::BackgroundSubtractorMOG2 * mog2 = *$(Ptr_BackgroundSubtractorMOG2 * mog2Ptr);
  221               mog2->clear();
  222           }|]
  223 
  224     algorithmIsEmpty mog2 = unsafePrimToPrim $
  225         withPtr mog2 $ \mog2Ptr ->
  226         alloca $ \emptyPtr -> do
  227           [C.block|void {
  228               cv::BackgroundSubtractorMOG2 * mog2 = *$(Ptr_BackgroundSubtractorMOG2 * mog2Ptr);
  229               *$(bool * emptyPtr) = mog2->empty();
  230           }|]
  231           toBool <$> peek emptyPtr
  232 
  233 instance BackgroundSubtractor BackgroundSubtractorKNN where
  234     bgSubApply knn learningRate img = unsafePrimToPrim $ do
  235         fgMask <- newEmptyMat
  236         withPtr knn $ \knnPtr ->
  237           withPtr img $ \imgPtr ->
  238           withPtr fgMask $ \fgMaskPtr -> mask_ $ do
  239             [C.block| void {
  240               cv::BackgroundSubtractorKNN * knn = *$(Ptr_BackgroundSubtractorKNN * knnPtr);
  241               knn->apply
  242               ( *$(Mat * imgPtr)
  243               , *$(Mat * fgMaskPtr)
  244               , $(double c'learningRate)
  245               );
  246             }|]
  247         pure $ unsafeCoerceMat fgMask
  248       where
  249         c'learningRate = realToFrac learningRate
  250 
  251     getBackgroundImage knn = unsafePrimToPrim $ do
  252         img <- newEmptyMat
  253         withPtr knn $ \knnPtr ->
  254           withPtr img $ \imgPtr -> mask_ $ do
  255             [C.block| void {
  256               cv::BackgroundSubtractorKNN * knn = *$(Ptr_BackgroundSubtractorKNN * knnPtr);
  257               knn->getBackgroundImage(*$(Mat * imgPtr));
  258             }|]
  259             pure $ unsafeCoerceMat img
  260 
  261 instance BackgroundSubtractor BackgroundSubtractorMOG2 where
  262     bgSubApply mog2 learningRate img = unsafePrimToPrim $ do
  263         fgMask <- newEmptyMat
  264         withPtr mog2 $ \mog2Ptr ->
  265           withPtr img $ \imgPtr ->
  266           withPtr fgMask $ \fgMaskPtr -> mask_ $ do
  267             [C.block| void {
  268               cv::BackgroundSubtractorMOG2 * mog2 = *$(Ptr_BackgroundSubtractorMOG2 * mog2Ptr);
  269               mog2->apply
  270               ( *$(Mat * imgPtr)
  271               , *$(Mat * fgMaskPtr)
  272               , $(double c'learningRate)
  273               );
  274             }|]
  275         pure $ unsafeCoerceMat fgMask
  276       where
  277         c'learningRate = realToFrac learningRate
  278 
  279     getBackgroundImage mog2 = unsafePrimToPrim $ do
  280         img <- newEmptyMat
  281         withPtr mog2 $ \mog2Ptr ->
  282           withPtr img $ \imgPtr -> mask_ $ do
  283             [C.block| void {
  284               cv::BackgroundSubtractorMOG2 * mog2 = *$(Ptr_BackgroundSubtractorMOG2 * mog2Ptr);
  285               mog2->getBackgroundImage(*$(Mat * imgPtr));
  286             }|]
  287             pure $ unsafeCoerceMat img