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