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