never executed always true always false
    1 {-# language CPP #-}
    2 {-# language MultiParamTypeClasses #-}
    3 {-# language QuasiQuotes #-}
    4 {-# language TemplateHaskell #-}
    5 
    6 {-# OPTIONS_GHC -fno-warn-orphans #-}
    7 
    8 #ifndef ENABLE_INTERNAL_DOCUMENTATION
    9 {-# OPTIONS_HADDOCK hide #-}
   10 #endif
   11 
   12 module OpenCV.Internal.Core.Types
   13     ( -- * Scalar
   14       Scalar(..)
   15     , newScalar
   16     , ToScalar(..), FromScalar(..)
   17       -- * RotatedRect
   18     , RotatedRect(..)
   19     , newRotatedRect
   20       -- * TermCriteria
   21     , TermCriteria(..)
   22     , newTermCriteria
   23       -- * Range
   24     , Range(..)
   25     , newRange
   26     , newWholeRange
   27       -- * Polygons
   28     , withPolygons
   29     , withArrayPtr
   30     ) where
   31 
   32 import "base" Control.Exception ( bracket_ )
   33 import "base" Data.Bits ( (.|.) )
   34 import "base" Data.Functor ( ($>) )
   35 import "base" Data.Int ( Int32 )
   36 import "base" Data.Proxy ( Proxy(..) )
   37 import "base" Foreign.C.Types
   38 import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
   39 import "base" Foreign.Marshal.Alloc ( alloca, allocaBytes )
   40 import "base" Foreign.Marshal.Array ( allocaArray )
   41 import "base" Foreign.Ptr ( Ptr, plusPtr )
   42 import "base" Foreign.Storable ( sizeOf, peek, poke )
   43 import "base" System.IO.Unsafe ( unsafePerformIO )
   44 import qualified "inline-c" Language.C.Inline as C
   45 import qualified "inline-c" Language.C.Inline.Unsafe as CU
   46 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
   47 import "linear" Linear.V4 ( V4(..) )
   48 import "this" OpenCV.Core.Types.Point
   49 import "this" OpenCV.Core.Types.Size
   50 import "this" OpenCV.Internal
   51 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
   52 import "this" OpenCV.Internal.Core.Types.Constants
   53 import "this" OpenCV.Internal.C.PlacementNew
   54 import "this" OpenCV.Internal.C.PlacementNew.TH
   55 import "this" OpenCV.Internal.C.Types
   56 import qualified "vector" Data.Vector as V
   57 
   58 --------------------------------------------------------------------------------
   59 
   60 C.context openCvCtx
   61 
   62 C.include "opencv2/core.hpp"
   63 C.using "namespace cv"
   64 
   65 
   66 --------------------------------------------------------------------------------
   67 -- Types
   68 --------------------------------------------------------------------------------
   69 
   70 -- | A 4-element vector with 64 bit floating point elements
   71 --
   72 -- The type 'Scalar' is widely used in OpenCV to pass pixel values.
   73 --
   74 -- <http://docs.opencv.org/3.0-last-rst/modules/core/doc/basic_structures.html#scalar OpenCV Sphinx doc>
   75 newtype Scalar = Scalar {unScalar :: ForeignPtr (C Scalar)}
   76 
   77 -- | Rotated (i.e. not up-right) rectangles on a plane
   78 --
   79 -- Each rectangle is specified by the center point (mass center), length of each
   80 -- side (represented by 'Size2f') and the rotation angle in degrees.
   81 --
   82 -- <http://docs.opencv.org/3.0-last-rst/modules/core/doc/basic_structures.html#rotatedrect OpenCV Sphinx doc>
   83 newtype RotatedRect = RotatedRect {unRotatedRect :: ForeignPtr (C RotatedRect)}
   84 
   85 -- | Termination criteria for iterative algorithms
   86 --
   87 -- <http://docs.opencv.org/3.0-last-rst/modules/core/doc/basic_structures.html#termcriteria OpenCV Sphinx doc>
   88 newtype TermCriteria = TermCriteria {unTermCriteria :: ForeignPtr (C TermCriteria)}
   89 
   90 -- | A continuous subsequence (slice) of a sequence
   91 --
   92 -- The type is used to specify a row or a column span in a matrix (`Mat`) and
   93 -- for many other purposes. @'mkRange' a b@ is basically the same as @a:b@ in
   94 -- Matlab or @a..b@ in Python. As in Python, start is an inclusive left boundary
   95 -- of the range and end is an exclusive right boundary of the range. Such a
   96 -- half-opened interval is usually denoted as @[start, end)@.
   97 --
   98 -- <http://docs.opencv.org/3.0-last-rst/modules/core/doc/basic_structures.html#range OpenCV Sphinx doc>
   99 newtype Range = Range {unRange :: ForeignPtr (C Range)}
  100 
  101 
  102 --------------------------------------------------------------------------------
  103 -- Conversions
  104 --------------------------------------------------------------------------------
  105 
  106 class ToScalar  a where toScalar  :: a -> Scalar
  107 
  108 instance ToScalar  Scalar  where toScalar  = id
  109 
  110 instance ToScalar  (V4 CDouble) where toScalar  = unsafePerformIO . newScalar
  111 
  112 instance ToScalar  (V4 Double ) where toScalar  = toScalar  . fmap (realToFrac :: Double -> CDouble)
  113 
  114 class FromScalar  a where fromScalar  :: Scalar  -> a
  115 
  116 instance FromScalar  Scalar  where fromScalar  = id
  117 
  118 instance FromScalar (V4 CDouble) where
  119     fromScalar s = unsafePerformIO $
  120       alloca $ \xPtr ->
  121       alloca $ \yPtr ->
  122       alloca $ \zPtr ->
  123       alloca $ \wPtr ->
  124       withPtr s $ \sPtr -> do
  125         [CU.block| void {
  126           const Scalar & s = *$(Scalar * sPtr);
  127           *$(double * xPtr) = s[0];
  128           *$(double * yPtr) = s[1];
  129           *$(double * zPtr) = s[2];
  130           *$(double * wPtr) = s[3];
  131         }|]
  132         V4 <$> peek xPtr
  133            <*> peek yPtr
  134            <*> peek zPtr
  135            <*> peek wPtr
  136 
  137 instance FromScalar (V4 Double) where fromScalar = fmap (realToFrac :: CDouble -> Double) . fromScalar
  138 
  139 --------------------------------------------------------------------------------
  140 -- Constructing new values
  141 --------------------------------------------------------------------------------
  142 
  143 newScalar :: V4 CDouble -> IO Scalar
  144 newScalar (V4 x y z w) = fromPtr $
  145     [CU.exp|Scalar * { new cv::Scalar( $(double x)
  146                                      , $(double y)
  147                                      , $(double z)
  148                                      , $(double w)
  149                                      )
  150                      }|]
  151 
  152 newRotatedRect
  153     :: ( IsPoint2 point2 CFloat
  154        , IsSize   size   CFloat
  155        )
  156     => point2 CFloat -- ^ Rectangle mass center
  157     -> size   CFloat -- ^ Width and height of the rectangle
  158     -> CFloat
  159        -- ^ The rotation angle (in degrees). When the angle is 0, 90,
  160        -- 180, 270 etc., the rectangle becomes an up-right rectangle.
  161     -> IO RotatedRect
  162 newRotatedRect center size angle = fromPtr $
  163     withPtr (toPoint center) $ \centerPtr ->
  164     withPtr (toSize  size)   $ \sizePtr   ->
  165       [CU.exp| RotatedRect * {
  166           new cv::RotatedRect( *$(Point2f * centerPtr)
  167                              , *$(Size2f * sizePtr)
  168                              , $(float angle)
  169                              )
  170       }|]
  171 
  172 newTermCriteria
  173     :: Maybe Int    -- ^ Optionally the maximum number of iterations/elements.
  174     -> Maybe Double -- ^ Optionally the desired accuracy.
  175     -> IO TermCriteria
  176 newTermCriteria mbMaxCount mbEpsilon = fromPtr $
  177     [CU.exp|TermCriteria * {
  178       new cv::TermCriteria( $(int32_t c'type    )
  179                           , $(int32_t c'maxCount)
  180                           , $(double  c'epsilon )
  181                           )
  182     }|]
  183   where
  184     c'type =   maybe 0 (const c'TERMCRITERIA_COUNT) mbMaxCount
  185            .|. maybe 0 (const c'TERMCRITERIA_EPS  ) mbEpsilon
  186     c'maxCount = maybe 0 fromIntegral mbMaxCount
  187     c'epsilon  = maybe 0 realToFrac   mbEpsilon
  188 
  189 newRange
  190     :: Int32 -- ^ Inclusive start
  191     -> Int32 -- ^ Exlusive end
  192     -> IO Range
  193 newRange start end = fromPtr $
  194     [CU.exp|Range * { new cv::Range( $(int32_t start), $(int32_t end)) }|]
  195 
  196 -- | Special 'Range' value which means "the whole sequence" or "the whole range"
  197 newWholeRange :: IO Range
  198 newWholeRange = fromPtr $
  199     [CU.block|Range * {
  200       cv::Range a = cv::Range::all();
  201       return new cv::Range(a.start, a.end);
  202     }|]
  203 
  204 
  205 --------------------------------------------------------------------------------
  206 -- Polygons
  207 --------------------------------------------------------------------------------
  208 
  209 withPolygons
  210     :: forall a point2
  211      . (IsPoint2 point2 Int32)
  212     => V.Vector (V.Vector (point2 Int32))
  213     -> (Ptr (Ptr (C Point2i)) -> IO a)
  214     -> IO a
  215 withPolygons polygons act =
  216     allocaArray (V.length polygons) $ \polygonsPtr -> do
  217       let go :: Ptr (Ptr (C Point2i)) -> Int -> IO a
  218           go !acc !ix
  219             | ix < V.length polygons =
  220                 let pts = V.map toPoint $ V.unsafeIndex polygons ix
  221                 in withArrayPtr pts $ \ptsPtr -> do
  222                      poke acc ptsPtr
  223                      go (acc `plusPtr` sizeOf (undefined :: Ptr (Ptr (C Point2i)))) (ix + 1)
  224             | otherwise = act polygonsPtr
  225       go polygonsPtr 0
  226 
  227 -- | Perform an action with a temporary pointer to an array of values
  228 --
  229 -- The input values are placed consecutively in memory using the 'PlacementNew'
  230 -- mechanism.
  231 --
  232 -- This function is intended for types which are not managed by the Haskell
  233 -- runtime, but by a foreign system (such as C).
  234 --
  235 -- The pointer is not guaranteed to be usuable outside the scope of this
  236 -- function. The same warnings apply as for 'withForeignPtr'.
  237 withArrayPtr
  238     :: forall a b
  239      . (WithPtr a, CSizeOf (C a), PlacementNew (C a))
  240     => V.Vector a
  241     -> (Ptr (C a) -> IO b)
  242     -> IO b
  243 withArrayPtr arr act =
  244     allocaBytes arraySize $ \arrPtr ->
  245       bracket_
  246         (V.foldM'_ copyNext arrPtr arr)
  247         (deconstructArray arrPtr )
  248         (act arrPtr)
  249   where
  250     elemSize = cSizeOf (Proxy :: Proxy (C a))
  251     arraySize = elemSize * V.length arr
  252 
  253     copyNext :: Ptr (C a) -> a -> IO (Ptr (C a))
  254     copyNext !ptr obj = copyObj ptr obj $> plusPtr ptr elemSize
  255 
  256     copyObj :: Ptr (C a) -> a -> IO ()
  257     copyObj dstPtr src =
  258         withPtr src $ \srcPtr ->
  259           placementNew srcPtr dstPtr
  260 
  261     deconstructArray :: Ptr (C a) -> IO ()
  262     deconstructArray !begin = deconstructNext begin
  263       where
  264         deconstructNext !ptr
  265             | ptr == end = pure ()
  266             | otherwise = do placementDelete ptr
  267                              deconstructNext $ ptr `plusPtr` elemSize
  268 
  269         end :: Ptr (C a)
  270         end = begin `plusPtr` arraySize
  271 
  272 --------------------------------------------------------------------------------
  273 
  274 type instance C Scalar       = C'Scalar
  275 type instance C RotatedRect  = C'RotatedRect
  276 type instance C TermCriteria = C'TermCriteria
  277 type instance C Range        = C'Range
  278 
  279 --------------------------------------------------------------------------------
  280 
  281 instance WithPtr Scalar       where withPtr = withForeignPtr . unScalar
  282 instance WithPtr RotatedRect  where withPtr = withForeignPtr . unRotatedRect
  283 instance WithPtr TermCriteria where withPtr = withForeignPtr . unTermCriteria
  284 instance WithPtr Range        where withPtr = withForeignPtr . unRange
  285 
  286 --------------------------------------------------------------------------------
  287 
  288 mkPlacementNewInstance ''Scalar
  289 
  290 --------------------------------------------------------------------------------
  291 
  292 instance FromPtr Scalar where
  293     fromPtr = objFromPtr Scalar $ \ptr ->
  294                 [CU.exp| void { delete $(Scalar * ptr) }|]
  295 
  296 instance FromPtr RotatedRect where
  297     fromPtr = objFromPtr RotatedRect $ \ptr ->
  298                 [CU.exp| void { delete $(RotatedRect * ptr) }|]
  299 
  300 instance FromPtr TermCriteria where
  301     fromPtr = objFromPtr TermCriteria $ \ptr ->
  302                 [CU.exp| void { delete $(TermCriteria * ptr) }|]
  303 
  304 instance FromPtr Range where
  305     fromPtr = objFromPtr Range $ \ptr ->
  306                 [CU.exp| void { delete $(Range * ptr) }|]