never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE TemplateHaskell #-}
5 {-# LANGUAGE UndecidableInstances #-}
6
7 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
8
9 module OpenCV.Core.Types.Mat
10 ( -- * Matrix
11 Mat
12 , MatShape
13 , MatChannels
14 , MatDepth
15 , ToMat(..), FromMat(..)
16
17 , typeCheckMat
18 , relaxMat
19 , coerceMat
20
21 , emptyMat
22 , mkMat
23 , eyeMat
24 , cloneMat
25 , matSubRect
26 , matCopyTo
27 , matConvertTo
28
29 , matFromFunc
30
31 -- * Mutable Matrix
32 , typeCheckMatM
33 , relaxMatM
34 , coerceMatM
35
36 , freeze
37 , thaw
38 , mkMatM
39 , createMat
40 , withMatM
41 , cloneMatM
42 , matCopyToM
43
44 , All
45 , IsStatic
46 , foldMat
47
48 -- * Meta information
49 , MatInfo(..)
50 , matInfo
51
52 , Depth(..)
53
54 , ShapeT
55 , ChannelsT
56 , DepthT
57
58 , ToShape(toShape)
59 , ToShapeDS(toShapeDS)
60 , ToChannels, toChannels
61 , ToChannelsDS, toChannelsDS
62 , ToDepth(toDepth)
63 , ToDepthDS(toDepthDS)
64 ) where
65
66 import "base" Control.Monad ( forM, forM_ )
67 import "base" Control.Monad.ST ( runST )
68 import "base" Data.Int ( Int32 )
69 import "base" Data.List ( foldl' )
70 import "base" Data.Proxy ( Proxy(..) )
71 import "base" Data.Word ( Word8 )
72 import "base" Foreign.Marshal.Array ( peekArray )
73 import "base" Foreign.Ptr ( Ptr, castPtr, plusPtr )
74 import "base" Foreign.Storable ( Storable )
75 import "base" GHC.TypeLits
76 import "base" System.IO.Unsafe ( unsafePerformIO )
77 import qualified "inline-c" Language.C.Inline as C
78 import qualified "inline-c" Language.C.Inline.Unsafe as CU
79 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
80 import "linear" Linear.V2 ( V2(..) )
81 import "linear" Linear.V4 ( V4(..) )
82 import "primitive" Control.Monad.Primitive ( PrimMonad, PrimState, unsafePrimToPrim )
83 import "this" OpenCV.Core.Types.Rect ( Rect2i )
84 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
85 import "this" OpenCV.Internal.C.Types
86 import "this" OpenCV.Internal.Core.Types.Mat
87 import "this" OpenCV.Internal.Core.Types.Mat.ToFrom
88 import "this" OpenCV.Internal.Exception
89 import "this" OpenCV.Internal.Mutable
90 import "this" OpenCV.TypeLevel
91 import "this" OpenCV.Unsafe ( unsafeWrite )
92 import "transformers" Control.Monad.Trans.Except
93 import qualified "vector" Data.Vector as V
94 import qualified "vector" Data.Vector.Storable as DV
95
96 --------------------------------------------------------------------------------
97
98 C.context openCvCtx
99
100 C.include "opencv2/core.hpp"
101 C.using "namespace cv"
102
103
104 --------------------------------------------------------------------------------
105 -- Matrix
106 --------------------------------------------------------------------------------
107
108 emptyMat :: Mat ('S '[]) ('S 1) ('S Word8)
109 emptyMat = unsafePerformIO newEmptyMat
110
111 -- | Identity matrix
112 --
113 -- <http://docs.opencv.org/3.0-last-rst/modules/core/doc/basic_structures.html#mat-eye OpenCV Sphinx doc>
114 eyeMat
115 :: ( ToInt32 height
116 , ToInt32 width
117 , ToChannels channels
118 , ToDepth depth
119 )
120 => height -- ^
121 -> width -- ^
122 -> channels -- ^
123 -> depth -- ^
124 -> Mat (ShapeT (height ::: width ::: Z)) (ChannelsT channels) (DepthT depth)
125 eyeMat height width channels depth = unsafeCoerceMat $ unsafePerformIO $
126 fromPtr [CU.exp|Mat * {
127 new Mat(Mat::eye( $(int32_t c'height)
128 , $(int32_t c'width)
129 , $(int32_t c'type)
130 ))
131 }|]
132 where
133 c'type = marshalFlags depth' channels'
134
135 c'height = toInt32 height
136 c'width = toInt32 width
137 channels' = toChannels channels
138 depth' = toDepth depth
139
140 {- | Extract a sub region from a 2D-matrix (image)
141
142 Example:
143
144 @
145 matSubRectImg :: Mat ('S ['D, 'D]) ('S 3) ('S Word8)
146 matSubRectImg = exceptError $
147 withMatM (h ::: 2 * w ::: Z)
148 (Proxy :: Proxy 3)
149 (Proxy :: Proxy Word8)
150 white $ \\imgM -> do
151 matCopyToM imgM (V2 0 0) birds_512x341 Nothing
152 matCopyToM imgM (V2 w 0) subImg Nothing
153 lift $ rectangle imgM subRect blue 1 LineType_4 0
154 lift $ rectangle imgM (toRect $ HRect (V2 w 0) (V2 w h) :: Rect2i) blue 1 LineType_4 0
155 where
156 subRect = toRect $ HRect (V2 96 131) (V2 90 60)
157 subImg = exceptError $
158 resize (ResizeAbs $ toSize $ V2 w h) InterCubic =<<
159 matSubRect birds_512x341 subRect
160 [h, w] = miShape $ matInfo birds_512x341
161 @
162
163 <<doc/generated/examples/matSubRectImg.png matSubRectImg>>
164 -}
165 matSubRect
166 :: Mat ('S [height, width]) channels depth
167 -> Rect2i
168 -> CvExcept (Mat ('S ['D, 'D]) channels depth)
169 matSubRect matIn rect = unsafeWrapException $ do
170 matOut <- newEmptyMat
171 handleCvException (pure $ unsafeCoerceMat matOut) $
172 withPtr matIn $ \matInPtr ->
173 withPtr matOut $ \matOutPtr ->
174 withPtr rect $ \rectPtr ->
175 [cvExceptU|
176 *$(Mat * matOutPtr) =
177 Mat( *$(Mat * matInPtr)
178 , *$(Rect2i * rectPtr)
179 );
180 |]
181
182 matCopyTo
183 :: Mat ('S [dstHeight, dstWidth]) channels depth -- ^
184 -> V2 Int32 -- ^
185 -> Mat ('S [srcHeight, srcWidth]) channels depth -- ^
186 -> Maybe (Mat ('S [srcHeight, srcWidth]) ('S 1) ('S Word8))
187 -> CvExcept (Mat ('S [dstHeight, dstWidth]) channels depth)
188 matCopyTo dst topLeft src mbSrcMask = runST $ do
189 dstM <- thaw dst
190 eResult <- runExceptT $ matCopyToM dstM topLeft src mbSrcMask
191 case eResult of
192 Left err -> pure $ throwE err
193 Right () -> pure <$> unsafeFreeze dstM
194
195
196 {- | Converts an array to another data type with optional scaling
197
198 <http://docs.opencv.org/3.0-last-rst/modules/core/doc/basic_structures.html?highlight=convertto#mat-convertto OpenCV Sphinx doc>
199 -}
200 matConvertTo
201 :: forall shape channels srcDepth dstDepth
202 . (ToDepthDS (Proxy dstDepth))
203 => Maybe Double -- ^ Optional scale factor.
204 -> Maybe Double -- ^ Optional delta added to the scaled values.
205 -> Mat shape channels srcDepth
206 -> CvExcept (Mat shape channels dstDepth)
207 matConvertTo alpha beta src = unsafeWrapException $ do
208 dst <- newEmptyMat
209 handleCvException (pure $ unsafeCoerceMat dst) $
210 withPtr src $ \srcPtr ->
211 withPtr dst $ \dstPtr ->
212 [cvExcept|
213 $(Mat * srcPtr)->
214 convertTo( *$(Mat * dstPtr)
215 , $(int32_t c'rtype)
216 , $(double c'alpha)
217 , $(double c'beta)
218 );
219 |]
220 where
221 rtype :: Maybe Depth
222 rtype = dsToMaybe $ toDepthDS (Proxy :: Proxy dstDepth)
223
224 c'rtype = maybe (-1) marshalDepth rtype
225 c'alpha = maybe 1 realToFrac alpha
226 c'beta = maybe 0 realToFrac beta
227
228 {- | Create a matrix whose elements are defined by a function.
229
230 Example:
231
232 @
233 matFromFuncImg
234 :: forall size. (size ~ 300)
235 => Mat (ShapeT [size, size]) ('S 4) ('S Word8)
236 matFromFuncImg = exceptError $
237 matFromFunc
238 (Proxy :: Proxy [size, size])
239 (Proxy :: Proxy 4)
240 (Proxy :: Proxy Word8)
241 example
242 where
243 example [y, x] 0 = 255 - normDist (V2 x y ^-^ bluePt )
244 example [y, x] 1 = 255 - normDist (V2 x y ^-^ greenPt)
245 example [y, x] 2 = 255 - normDist (V2 x y ^-^ redPt )
246 example [y, x] 3 = normDist (V2 x y ^-^ alphaPt)
247 example _pos _channel = error "impossible"
248
249 normDist :: V2 Int -> Word8
250 normDist v = floor $ min 255 $ 255 * Linear.norm (fromIntegral \<$> v) / s'
251
252 bluePt = V2 0 0
253 greenPt = V2 s s
254 redPt = V2 s 0
255 alphaPt = V2 0 s
256
257 s = fromInteger $ natVal (Proxy :: Proxy size) :: Int
258 s' = fromIntegral s :: Double
259 @
260
261 <<doc/generated/examples/matFromFuncImg.png matFromFuncImg>>
262 -}
263 matFromFunc
264 :: forall shape channels depth
265 . ( ToShape shape
266 , ToChannels channels
267 , ToDepth depth
268 , Storable (StaticDepthT depth)
269 )
270 => shape
271 -> channels
272 -> depth
273 -> ([Int] -> Int -> StaticDepthT depth) -- ^
274 -> CvExcept (Mat (ShapeT shape) (ChannelsT channels) (DepthT depth))
275 matFromFunc shape channels depth func =
276 withMatM shape channels depth (0 :: V4 Double) $ \matM ->
277 forM_ positions $ \pos ->
278 forM_ [0 .. fromIntegral channels' - 1] $ \channel ->
279 unsafeWrite matM pos channel $ func pos channel
280 where
281 positions :: [[Int]]
282 positions = dimPositions $ V.toList $ V.map fromIntegral shapeVec
283
284 shapeVec :: V.Vector Int32
285 shapeVec = toShape shape
286
287 channels' :: Int32
288 channels' = toChannels channels
289
290 --------------------------------------------------------------------------------
291 -- Mutable Matrix
292 --------------------------------------------------------------------------------
293
294 matCopyToM
295 :: (PrimMonad m)
296 => Mut (Mat ('S [dstHeight, dstWidth]) channels depth) (PrimState m) -- ^
297 -> V2 Int32 -- ^
298 -> Mat ('S [srcHeight, srcWidth]) channels depth -- ^
299 -> Maybe (Mat ('S [srcHeight, srcWidth]) ('S 1) ('S Word8))
300 -> CvExceptT m ()
301 matCopyToM dstM (V2 x y) src mbSrcMask = ExceptT $
302 unsafePrimToPrim $ handleCvException (pure ()) $
303 withPtr dstM $ \dstPtr ->
304 withPtr src $ \srcPtr ->
305 withPtr mbSrcMask $ \srcMaskPtr ->
306 [cvExcept|
307 const cv::Mat * const srcPtr = $(const Mat * const srcPtr);
308 const int32_t x = $(int32_t x);
309 const int32_t y = $(int32_t y);
310 cv::Mat * srcMaskPtr = $(Mat * srcMaskPtr);
311 srcPtr->copyTo( $(Mat * dstPtr)
312 ->rowRange(y, y + srcPtr->rows)
313 .colRange(x, x + srcPtr->cols)
314 , srcMaskPtr
315 ? cv::_InputArray(*srcMaskPtr)
316 : cv::_InputArray(cv::noArray())
317 );
318 |]
319
320 -- Mat * srcPtr = $(Mat * srcPtr);
321 -- Mat dstRoi = Mat( *$(Mat * matOutPtr)
322 -- , Rect( *$(Point2i * topLeftPtr)
323 -- , srcPtr->size()
324 -- )
325 -- );
326 -- srcPtr->copyTo(dstRoi);
327
328
329 -- |Transforms a given list of matrices of equal shape, channels, and depth,
330 -- by folding the given function over all matrix elements at each position.
331 foldMat :: forall (shape :: [DS Nat]) (channels :: Nat) (depth :: *) a
332 . ( Storable depth
333 , Storable a
334 , All IsStatic shape
335 )
336 => (a -> DV.Vector depth -> a) -- ^
337 -> a
338 -> [Mat ('S shape) ('S channels) ('S depth)]
339 -> Maybe (DV.Vector a)
340 foldMat _ _ [] = Nothing
341 foldMat f z mats = Just . DV.fromList . unsafePerformIO $ mapM go (dimPositions shape)
342 where
343 go :: [Int32] -> IO a
344 go pos = pixelsAt pos >>= return . foldl' f z
345
346 MatInfo !shape _ !channels = matInfo (head mats)
347
348 stepsAndPtrs :: IO [([Int32], Ptr depth)]
349 stepsAndPtrs = forM mats $ \mat ->
350 withMatData mat $ \step ptr ->
351 return (fromIntegral <$> step, castPtr ptr)
352
353 pixelsAt :: [Int32] -> IO [DV.Vector depth]
354 pixelsAt pos = mapM go' =<< stepsAndPtrs
355 where
356 go' :: ([Int32], Ptr depth) -> IO (DV.Vector depth)
357 go' (step, dataPtr) = do
358 let !offset = fromIntegral . sum $ zipWith (*) step pos
359 vals <- peekArray (fromIntegral channels) (dataPtr `plusPtr` offset)
360 return $ DV.fromList vals