never executed always true always false
1 {-# language QuasiQuotes #-}
2 {-# language TemplateHaskell #-}
3 {-# language MultiParamTypeClasses #-}
4 module OpenCV.ImgProc.CascadeClassifier
5 ( CascadeClassifier
6 , newCascadeClassifier
7 , cascadeClassifierDetectMultiScale
8 , cascadeClassifierDetectMultiScaleNC
9 ) where
10
11 import "base" Data.Int
12 import "base" Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
13 import "base" Foreign.C.String (withCString)
14 import "base" System.IO.Unsafe (unsafePerformIO)
15 import "base" Data.Word
16 import "base" Foreign.Marshal.Alloc (alloca)
17 import "base" Foreign.Ptr (Ptr)
18 import "base" Control.Exception (mask_)
19 import "base" Foreign.Storable (peek)
20 import "base" Foreign.Marshal.Array (peekArray)
21 import qualified "inline-c" Language.C.Inline as C
22 import qualified "inline-c" Language.C.Inline.Unsafe as CU
23 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
24 import qualified "vector" Data.Vector as V
25 import "linear" Linear (V2(..))
26 import "this" OpenCV.Core.Types
27 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
28 import "this" OpenCV.Internal.C.Types
29 import "this" OpenCV.Internal
30 import "this" OpenCV.TypeLevel
31
32 C.context openCvCtx
33
34 C.include "opencv2/core.hpp"
35 C.include "opencv2/objdetect.hpp"
36 C.using "namespace cv"
37
38 newtype CascadeClassifier = CascadeClassifier {unCascadeClassifier :: ForeignPtr (C CascadeClassifier)}
39
40 type instance C CascadeClassifier = C'CascadeClassifier
41
42 instance WithPtr CascadeClassifier where
43 withPtr = withForeignPtr . unCascadeClassifier
44
45 instance FromPtr CascadeClassifier where
46 fromPtr = objFromPtr CascadeClassifier $ \ptr ->
47 [CU.exp| void { delete $(CascadeClassifier * ptr) }|]
48
49 -- | Create a new cascade classifier. Returns 'Nothing' if the classifier
50 -- is empty after initialization. This usually means that the file could
51 -- not be loaded (e.g. it doesn't exist, is corrupt, etc.)
52 newCascadeClassifier :: FilePath -> IO (Maybe CascadeClassifier)
53 newCascadeClassifier fp = do
54 cc <- withCString fp $ \c'fp -> fromPtr
55 [CU.exp| CascadeClassifier * { new CascadeClassifier(cv::String($(const char * c'fp))) } |]
56 -- TODO: empty() seems to return bogus numbers when the classifier is not
57 -- empty, and I'm not sure why. This is also why I'm not using toBool.
58 empty <- fmap (== 1) (withPtr cc (\ccPtr -> [CU.exp| bool { $(CascadeClassifier * ccPtr)->empty() } |]))
59 return $ if empty
60 then Nothing
61 else Just cc
62
63 {- |
64 Example:
65
66 @
67 cascadeClassifierArnold
68 :: forall (width :: Nat)
69 (height :: Nat)
70 (channels :: Nat)
71 (depth :: * )
72 . (Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Arnold_small)
73 => IO (Mat (ShapeT [height, width]) ('S channels) ('S depth))
74 cascadeClassifierArnold = do
75 -- Create two classifiers from data files.
76 Just ccFrontal <- newCascadeClassifier "data/haarcascade_frontalface_default.xml"
77 Just ccEyes <- newCascadeClassifier "data/haarcascade_eye.xml"
78 -- Detect some features.
79 let eyes = ccDetectMultiscale ccEyes arnoldGray
80 faces = ccDetectMultiscale ccFrontal arnoldGray
81 -- Draw the result.
82 pure $ exceptError $
83 withMatM (Proxy :: Proxy [height, width])
84 (Proxy :: Proxy channels)
85 (Proxy :: Proxy depth)
86 white $ \\imgM -> do
87 void $ matCopyToM imgM (V2 0 0) arnold_small Nothing
88 forM_ eyes $ \\eyeRect -> lift $ rectangle imgM eyeRect blue 2 LineType_8 0
89 forM_ faces $ \\faceRect -> lift $ rectangle imgM faceRect green 2 LineType_8 0
90 where
91 arnoldGray = exceptError $ cvtColor bgr gray arnold_small
92
93 ccDetectMultiscale cc = cascadeClassifierDetectMultiScale cc Nothing Nothing minSize maxSize
94
95 minSize = Nothing :: Maybe (V2 Int32)
96 maxSize = Nothing :: Maybe (V2 Int32)
97 @
98
99 <<doc/generated/examples/cascadeClassifierArnold.png cascadeClassifierArnold>>
100 -}
101 cascadeClassifierDetectMultiScale
102 :: (IsSize size Int32)
103 => CascadeClassifier
104 -> Maybe Double -- ^ Scale factor, default is 1.1
105 -> Maybe Int32 -- ^ Min neighbours, default 3
106 -> Maybe (size Int32) -- ^ Minimum size. Default: no minimum.
107 -> Maybe (size Int32) -- ^ Maximum size. Default: no maximum.
108 -> Mat ('S [w, h]) ('S 1) ('S Word8)
109 -> V.Vector (Rect Int32)
110 cascadeClassifierDetectMultiScale cc scaleFactor minNeighbours minSize maxSize src = unsafePerformIO $
111 withPtr cc $ \ccPtr ->
112 withPtr src $ \srcPtr ->
113 withPtr c'minSize $ \minSizePtr ->
114 withPtr c'maxSize $ \maxSizePtr ->
115 alloca $ \(numRectsPtr :: Ptr Int32) ->
116 alloca $ \(rectsPtrPtr :: Ptr (Ptr (Ptr (C'Rect Int32)))) -> mask_ $ do
117 [CU.block| void {
118 std::vector<cv::Rect> rects;
119 $(CascadeClassifier * ccPtr)->detectMultiScale(
120 *$(Mat * srcPtr),
121 rects,
122 $(double c'scaleFactor),
123 $(int32_t c'minNeighbours),
124 0,
125 *$(Size2i * minSizePtr),
126 *$(Size2i * maxSizePtr));
127 *$(int32_t * numRectsPtr) = rects.size();
128 cv::Rect * * rectsPtr = new cv::Rect * [rects.size()];
129 *$(Rect2i * * * rectsPtrPtr) = rectsPtr;
130 for (std::vector<cv::Rect>::size_type i = 0; i != rects.size(); i++) {
131 rectsPtr[i] = new cv::Rect(rects[i]);
132 }
133 } |]
134 numRects <- fromIntegral <$> peek numRectsPtr
135 rectsPtr <- peek rectsPtrPtr
136 rects :: [Rect Int32] <- peekArray numRects rectsPtr >>= mapM (fromPtr . return)
137 [CU.block| void { delete [] *$(Rect2i * * * rectsPtrPtr); }|]
138 return (V.fromList rects)
139 where
140 c'scaleFactor = maybe 1.1 realToFrac scaleFactor
141 c'minNeighbours = maybe 3 fromIntegral minNeighbours
142 c'minSize = maybe (toSize (V2 0 0)) toSize minSize
143 c'maxSize = maybe (toSize (V2 0 0)) toSize maxSize
144
145 {- | Special version which returns bounding rectangle, rejectLevels, and levelWeights
146
147 -}
148 cascadeClassifierDetectMultiScaleNC
149 :: (IsSize size Int32)
150 => CascadeClassifier
151 -> Maybe Double -- ^ Scale factor, default is 1.1
152 -> Maybe Int32 -- ^ Min neighbours, default 3
153 -> Maybe (size Int32) -- ^ Minimum size. Default: no minimum.
154 -> Maybe (size Int32) -- ^ Maximum size. Default: no maximum.
155 -> Mat ('S [w, h]) ('S 1) ('S Word8)
156 -> V.Vector (Rect Int32, Int32, Double)
157 cascadeClassifierDetectMultiScaleNC cc scaleFactor minNeighbours minSize maxSize src = unsafePerformIO $
158 withPtr cc $ \ccPtr ->
159 withPtr src $ \srcPtr ->
160 withPtr c'minSize $ \minSizePtr ->
161 withPtr c'maxSize $ \maxSizePtr ->
162 alloca $ \(numRectsPtr :: Ptr Int32) ->
163 alloca $ \(rectsPtrPtr :: Ptr (Ptr (Ptr (C'Rect Int32)))) ->
164 alloca $ \(rejectLevelsPtrPtr :: Ptr (Ptr Int32)) ->
165 alloca $ \(levelWeightsPtrPtr :: Ptr (Ptr C.CDouble)) -> mask_ $ do
166 [CU.block| void {
167 std::vector<cv::Rect> rects;
168 std::vector<int> rejectLevels;
169 std::vector<double> levelWeights;
170 $(CascadeClassifier * ccPtr)->detectMultiScale(
171 *$(Mat * srcPtr),
172 rects,
173 rejectLevels,
174 levelWeights,
175 $(double c'scaleFactor),
176 $(int32_t c'minNeighbours),
177 0,
178 *$(Size2i * minSizePtr),
179 *$(Size2i * maxSizePtr),
180 true);
181 *$(int32_t * numRectsPtr) = rects.size();
182
183 cv::Rect * * rectsPtr = new cv::Rect * [rects.size()];
184 *$(Rect2i * * * rectsPtrPtr) = rectsPtr;
185
186 int32_t * rejectLevelsPtr = new int32_t [rejectLevels.size()];
187 *$(int32_t * * rejectLevelsPtrPtr) = rejectLevelsPtr;
188
189 double * levelWeightsPtr = new double [levelWeights.size()];
190 *$(double * * levelWeightsPtrPtr) = levelWeightsPtr;
191
192
193 for (std::vector<cv::Rect>::size_type i = 0; i != rects.size(); i++) {
194
195 rectsPtr[i] = new cv::Rect(rects[i]);
196 rejectLevelsPtr[i] = rejectLevels[i];
197 levelWeightsPtr[i] = levelWeights[i];
198 }
199 } |]
200 numRects <- fromIntegral <$> peek numRectsPtr
201 rectsPtr <- peek rectsPtrPtr
202 rejectLevelsPtr <- peek rejectLevelsPtrPtr
203 levelWeightsPtr <- peek levelWeightsPtrPtr
204 rects :: [Rect Int32] <- peekArray numRects rectsPtr >>= mapM (fromPtr . return)
205 rejectLevels :: [Int32] <- peekArray numRects rejectLevelsPtr -- >>= mapM (fromPtr . return)
206 levelWeights :: [Double] <- map realToFrac <$> peekArray numRects levelWeightsPtr
207
208 [CU.block| void {
209 delete [] *$(Rect2i * * * rectsPtrPtr);
210 delete [] *$(int32_t * * rejectLevelsPtrPtr);
211 delete [] *$(double * * levelWeightsPtrPtr);
212 }|]
213 return (V.fromList $ zip3 rects rejectLevels levelWeights)
214 where
215 c'scaleFactor = maybe 1.1 realToFrac scaleFactor
216 c'minNeighbours = maybe 3 fromIntegral minNeighbours
217 c'minSize = maybe (toSize (V2 0 0)) toSize minSize
218 c'maxSize = maybe (toSize (V2 0 0)) toSize maxSize