never executed always true always false
    1 {-# language CPP #-}
    2 
    3 #ifndef ENABLE_INTERNAL_DOCUMENTATION
    4 {-# OPTIONS_HADDOCK hide #-}
    5 #endif
    6 
    7 module OpenCV.Internal.Core.Types.Mat.HMat
    8     ( HMat(..)
    9     , HElems(..)
   10     , hElemsDepth
   11     , hElemsLength
   12     , ToHElems(toHElems)
   13 
   14     , matToHMat
   15     , hMatToMat
   16     ) where
   17 
   18 import "base" Data.Foldable
   19 import "base" Data.Int
   20 import "base" Data.Word
   21 import "base" Foreign.C.Types
   22 import "base" Foreign.Ptr ( Ptr )
   23 import "base" Foreign.Storable ( Storable(..), peekElemOff, pokeElemOff )
   24 import "base" System.IO.Unsafe ( unsafePerformIO )
   25 import qualified "bytestring" Data.ByteString as B
   26 import "linear" Linear.Vector ( zero )
   27 import "linear" Linear.V4 ( V4(..) )
   28 import "this" OpenCV.Core.Types
   29 import "this" OpenCV.Internal.Core.Types.Mat
   30 import "this" OpenCV.TypeLevel
   31 import qualified "vector" Data.Vector as V
   32 import qualified "vector" Data.Vector.Generic as VG
   33 import qualified "vector" Data.Vector.Unboxed as VU
   34 import qualified "vector" Data.Vector.Unboxed.Mutable as VUM
   35 
   36 --------------------------------------------------------------------------------
   37 
   38 data HMat
   39    = HMat
   40      { hmShape    :: ![Int32]
   41      , hmChannels :: !Int32
   42      , hmElems    :: !HElems
   43      } deriving (Show, Eq)
   44 
   45 data HElems
   46    = HElems_8U       !(VU.Vector Word8)
   47    | HElems_8S       !(VU.Vector Int8)
   48    | HElems_16U      !(VU.Vector Word16)
   49    | HElems_16S      !(VU.Vector Int16)
   50    | HElems_32S      !(VU.Vector Int32)
   51    | HElems_32F      !(VU.Vector Float)
   52    | HElems_64F      !(VU.Vector Double)
   53    | HElems_USRTYPE1 !(V.Vector B.ByteString)
   54      deriving (Show, Eq)
   55 
   56 hElemsDepth :: HElems -> Depth
   57 hElemsDepth = \case
   58     HElems_8U       _v -> Depth_8U
   59     HElems_8S       _v -> Depth_8S
   60     HElems_16U      _v -> Depth_16U
   61     HElems_16S      _v -> Depth_16S
   62     HElems_32S      _v -> Depth_32S
   63     HElems_32F      _v -> Depth_32F
   64     HElems_64F      _v -> Depth_64F
   65     HElems_USRTYPE1 _v -> Depth_USRTYPE1
   66 
   67 hElemsLength :: HElems -> Int
   68 hElemsLength = \case
   69     HElems_8U       v -> VG.length v
   70     HElems_8S       v -> VG.length v
   71     HElems_16U      v -> VG.length v
   72     HElems_16S      v -> VG.length v
   73     HElems_32S      v -> VG.length v
   74     HElems_32F      v -> VG.length v
   75     HElems_64F      v -> VG.length v
   76     HElems_USRTYPE1 v -> VG.length v
   77 
   78 class ToHElems a where
   79     toHElems :: VU.Vector a -> HElems
   80 
   81 instance ToHElems Word8  where toHElems = HElems_8U
   82 instance ToHElems Int8   where toHElems = HElems_8S
   83 instance ToHElems Word16 where toHElems = HElems_16U
   84 instance ToHElems Int16  where toHElems = HElems_16S
   85 instance ToHElems Int32  where toHElems = HElems_32S
   86 instance ToHElems Float  where toHElems = HElems_32F
   87 instance ToHElems Double where toHElems = HElems_64F
   88 
   89 matToHMat :: Mat shape channels depth -> HMat
   90 matToHMat mat = unsafePerformIO $ withMatData mat $ \step dataPtr -> do
   91     elems <- copyElems info (map fromIntegral step) dataPtr
   92     pure HMat
   93          { hmShape    = miShape    info
   94          , hmChannels = miChannels info
   95          , hmElems    = elems
   96          }
   97   where
   98     info = matInfo mat
   99 
  100     copyElems
  101         :: MatInfo
  102         -> [Int]     -- ^ step
  103         -> Ptr Word8 -- ^ data
  104         -> IO HElems
  105     copyElems (MatInfo shape depth channels) step dataPtr =
  106         case depth of
  107           Depth_8U  -> HElems_8U  <$> copyToVec
  108           Depth_8S  -> HElems_8S  <$> copyToVec
  109           Depth_16U -> HElems_16U <$> copyToVec
  110           Depth_16S -> HElems_16S <$> copyToVec
  111           Depth_32S -> HElems_32S <$> copyToVec
  112           Depth_32F -> HElems_32F <$> copyToVec
  113           Depth_64F -> HElems_64F <$> copyToVec
  114           Depth_USRTYPE1 -> HElems_USRTYPE1 <$> error "todo"
  115       where
  116         copyToVec :: (Storable a, VU.Unbox a) => IO (VU.Vector a)
  117         copyToVec = do
  118             v <- VUM.unsafeNew $ product0 (map fromIntegral shape) * (fromIntegral channels)
  119             forM_ (zip [0,channels..] $ dimPositions $ map fromIntegral shape) $ \(posIx, pos) -> do
  120                 let elemPtr = matElemAddress dataPtr step pos
  121                 forM_ [0 .. channels - 1] $ \channelIx -> do
  122                   e <- peekElemOff elemPtr $ fromIntegral channelIx
  123                   VUM.unsafeWrite v (fromIntegral $ posIx + channelIx) e
  124             VU.unsafeFreeze v
  125 
  126 hMatToMat :: HMat -> Mat 'D 'D 'D
  127 hMatToMat (HMat shape channels elems) = unsafePerformIO $ do
  128     mat <- exceptErrorIO $ newMat sizes channels depth scalar
  129     withMatData mat copyElems
  130     pure mat
  131   where
  132     sizes = V.fromList shape
  133     depth = hElemsDepth elems
  134 
  135     scalar :: Scalar
  136     scalar = toScalar (zero :: V4 CDouble)
  137 
  138     copyElems :: [CSize] -> Ptr Word8 -> IO ()
  139     copyElems step dataPtr = case elems of
  140         HElems_8U       v -> copyFromVec v
  141         HElems_8S       v -> copyFromVec v
  142         HElems_16U      v -> copyFromVec v
  143         HElems_16S      v -> copyFromVec v
  144         HElems_32S      v -> copyFromVec v
  145         HElems_32F      v -> copyFromVec v
  146         HElems_64F      v -> copyFromVec v
  147         HElems_USRTYPE1 _v -> error "todo"
  148       where
  149         copyFromVec :: (Storable a, VU.Unbox a) => VU.Vector a -> IO ()
  150         copyFromVec v =
  151             forM_ (zip [0, fromIntegral channels ..] $ dimPositions (fromIntegral <$> shape)) $ \(posIx, pos) -> do
  152               let elemPtr = matElemAddress dataPtr (fromIntegral <$> step) pos
  153               forM_ [0 .. channels - 1] $ \channelIx ->
  154                 pokeElemOff elemPtr (fromIntegral channelIx) $ VU.unsafeIndex v (fromIntegral $ posIx + channelIx)
  155 
  156 product0 :: (Num a) => [a] -> a
  157 product0 [] = 0
  158 product0 xs = product xs