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