module CV.Image (
Image(..)
, create
, empty
, emptyCopy
, cloneImage
, withClone
, withCloneValue
, CreateImage
, ChannelOf
, GrayScale
, DFT
, RGB
, RGBA
, RGB_Channel(..)
, LAB
, LAB_Channel(..)
, D32
, D64
, D8
, Tag
, lab
, rgba
, rgb
, compose
, composeMultichannelImage
, Loadable(..)
, saveImage
, loadColorImage
, loadImage
, GetPixel(..)
, SetPixel(..)
, getAllPixels
, getAllPixelsRowMajor
, mapImageInplace
, ImageDepth
, Sized(..)
, getArea
, getChannel
, getImageChannels
, getImageDepth
, getImageInfo
, setCOI
, setROI
, resetROI
, getRegion
, withIOROI
, withROI
, blendBlit
, blit
, blitM
, subPixelBlit
, safeBlit
, montage
, tileImages
, rgbToGray
, grayToRGB
, rgbToLab
, bgrToRgb
, rgbToBgr
, unsafeImageTo32F
, unsafeImageTo8Bit
, BareImage(..)
, creatingImage
, unImage
, unS
, withGenBareImage
, withBareImage
, creatingBareImage
, withGenImage
, withImage
, imageFPTR
, ensure32F
, setCatch
, CvException
) where
import System.Mem
import System.Directory
import System.FilePath
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Utils
import Foreign.ForeignPtr hiding (newForeignPtr,unsafeForeignPtrToPtr)
import Foreign.Concurrent
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq
import CV.Bindings.Error
import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.Storable
import System.IO.Unsafe
import Data.Word
import Data.Complex
import Data.Complex
import Control.Monad
import Control.Exception
import Data.Data
import Data.Typeable
data GrayScale
data DFT
data RGB
data RGB_Channel = Red |Green |Blue deriving (Eq,Ord,Enum)
data BGR
data LAB
data RGBA
data LAB_Channel = LAB_L |LAB_A |LAB_B deriving (Eq,Ord,Enum)
type family ChannelOf a :: *
type instance ChannelOf RGB_Channel = RGB
type instance ChannelOf LAB_Channel = LAB
type D8 = Word8
type D32 = Float
type D64 = Double
newtype Image channels depth = S BareImage
unS (S i) = i
imageFPTR :: Image c d -> ForeignPtr BareImage
imageFPTR (S (BareImage fptr)) = fptr
withImage :: Image c d -> (Ptr BareImage ->IO a) -> IO a
withImage (S i) op = withBareImage i op
withUniPtr with x fun = with x $ \y ->
fun (castPtr y)
withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage
newtype BareImage = BareImage (ForeignPtr (BareImage))
withBareImage (BareImage fptr) = withForeignPtr fptr
freeBareImage ptr = with ptr cvReleaseImage
instance NFData (Image a b) where
rnf a@(S (BareImage fptr)) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()
creatingImage fun = do
iptr <- fun
fptr <- newForeignPtr iptr (freeBareImage iptr)
return . S . BareImage $ fptr
creatingBareImage fun = do
iptr <- fun
fptr <- newForeignPtr iptr (freeBareImage iptr)
return . BareImage $ fptr
unImage (S (BareImage fptr)) = fptr
data Tag tp;
rgb = undefined :: Tag RGB
rgba = undefined :: Tag RGBA
lab = undefined :: Tag LAB
class Composes a where
type Source a :: *
compose :: Source a -> a
instance (CreateImage (Image RGBA a)) => Composes (Image RGBA a) where
type Source (Image RGBA a) = (Image GrayScale a, Image GrayScale a
,Image GrayScale a, Image GrayScale a)
compose (r,g,b,a) = composeMultichannelImage (Just b) (Just g) (Just r) (Just a) rgba
instance (CreateImage (Image RGB a)) => Composes (Image RGB a) where
type Source (Image RGB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a)
compose (r,g,b) = composeMultichannelImage (Just b) (Just g) (Just r) Nothing rgb
instance (CreateImage (Image LAB a)) => Composes (Image LAB a) where
type Source (Image LAB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a)
compose (l,a,b) = composeMultichannelImage (Just l) (Just a) (Just b) Nothing lab
composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannelImage = composeMultichannel
composeMultichannel :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannel (c2)
(c1)
(c3)
(c4)
totag
= unsafePerformIO $do
res <- create (size)
withMaybe c1 $ \cc1 ->
withMaybe c2 $ \cc2 ->
withMaybe c3 $ \cc3 ->
withMaybe c4 $ \cc4 ->
withGenImage res $ \cres -> cvMerge cc1 cc2 cc3 cc4 cres
return res
where
withMaybe (Just i) op = withGenImage i op
withMaybe (Nothing) op = op nullPtr
size = getSize . head . catMaybes $ [c1,c2,c3,c4]
class Loadable a where
readFromFile :: FilePath -> IO a
instance Loadable ((Image GrayScale D32)) where
readFromFile fp = do
e <- loadImage fp
case e of
Just i -> return i
Nothing -> throw $ CvIOError $ "Could not load "++fp
instance Loadable ((Image RGB D32)) where
readFromFile fp = do
e <- loadColorImage8 fp
case e of
Just i -> return $ unsafeImageTo32F $ bgrToRgb i
Nothing -> throw $ CvIOError $ "Could not load "++fp
instance Loadable ((Image RGB D8)) where
readFromFile fp = do
e <- loadColorImage8 fp
case e of
Just i -> return $ bgrToRgb i
Nothing -> throw $ CvIOError $ "Could not load "++fp
instance Loadable ((Image GrayScale D8)) where
readFromFile fp = do
e <- loadImage8 fp
case e of
Just i -> return i
Nothing -> throw $ CvIOError $ "Could not load "++fp
unsafeloadUsing x p n = do
exists <- doesFileExist n
if not exists then return Nothing
else do
i <- withCString n $ \name ->
creatingBareImage (cvLoadImage name p)
bw <- x i
return . Just .S $ bw
loadImage :: FilePath -> IO (Maybe (Image GrayScale D32))
loadImage = unsafeloadUsing imageTo32F 0
loadImage8 :: FilePath -> IO (Maybe (Image GrayScale D8))
loadImage8 = unsafeloadUsing imageTo8Bit 0
loadColorImage :: FilePath -> IO (Maybe (Image BGR D32))
loadColorImage = unsafeloadUsing imageTo32F 1
loadColorImage8 :: FilePath -> IO (Maybe (Image BGR D8))
loadColorImage8 = unsafeloadUsing imageTo8Bit 1
class Sized a where
type Size a :: *
getSize :: a -> Size a
instance Sized BareImage where
type Size BareImage = (Int,Int)
getSize image = unsafePerformIO $ withBareImage image $ \i -> do
w <- getImageWidth i
h <- getImageHeight i
return (fromIntegral w,fromIntegral h)
instance Sized (Image c d) where
type Size (Image c d) = (Int,Int)
getSize = getSize . unS
cvRGBtoGRAY = 7 :: CInt
cvRGBtoLAB = 45 :: CInt
data CvtCodes = CV_BGR2BGRA
| CV_RGB2RGBA
| CV_BGRA2BGR
| CV_RGBA2RGB
| CV_BGR2RGBA
| CV_RGB2BGRA
| CV_RGBA2BGR
| CV_BGRA2RGB
| CV_BGR2RGB
| CV_RGB2BGR
| CV_BGRA2RGBA
| CV_RGBA2BGRA
| CV_BGR2GRAY
| CV_RGB2GRAY
| CV_GRAY2BGR
| CV_GRAY2RGB
| CV_GRAY2BGRA
| CV_GRAY2RGBA
| CV_BGRA2GRAY
| CV_RGBA2GRAY
| CV_BGR2BGR565
| CV_RGB2BGR565
| CV_BGR5652BGR
| CV_BGR5652RGB
| CV_BGRA2BGR565
| CV_RGBA2BGR565
| CV_BGR5652BGRA
| CV_BGR5652RGBA
| CV_GRAY2BGR565
| CV_BGR5652GRAY
| CV_BGR2BGR555
| CV_RGB2BGR555
| CV_BGR5552BGR
| CV_BGR5552RGB
| CV_BGRA2BGR555
| CV_RGBA2BGR555
| CV_BGR5552BGRA
| CV_BGR5552RGBA
| CV_GRAY2BGR555
| CV_BGR5552GRAY
| CV_BGR2XYZ
| CV_RGB2XYZ
| CV_XYZ2BGR
| CV_XYZ2RGB
| CV_BGR2YCrCb
| CV_RGB2YCrCb
| CV_YCrCb2BGR
| CV_YCrCb2RGB
| CV_BGR2HSV
| CV_RGB2HSV
| CV_BGR2Lab
| CV_RGB2Lab
| CV_BayerBG2BGR
| CV_BayerGB2BGR
| CV_BayerRG2BGR
| CV_BayerGR2BGR
| CV_BayerBG2RGB
| CV_BayerGB2RGB
| CV_BayerRG2RGB
| CV_BayerGR2RGB
| CV_BGR2Luv
| CV_RGB2Luv
| CV_BGR2HLS
| CV_RGB2HLS
| CV_HSV2BGR
| CV_HSV2RGB
| CV_Lab2BGR
| CV_Lab2RGB
| CV_Luv2BGR
| CV_Luv2RGB
| CV_HLS2BGR
| CV_HLS2RGB
| CV_BayerBG2BGR_VNG
| CV_BayerGB2BGR_VNG
| CV_BayerRG2BGR_VNG
| CV_BayerGR2BGR_VNG
| CV_BayerBG2RGB_VNG
| CV_BayerGB2RGB_VNG
| CV_BayerRG2RGB_VNG
| CV_BayerGR2RGB_VNG
| CV_BGR2HSV_FULL
| CV_RGB2HSV_FULL
| CV_BGR2HLS_FULL
| CV_RGB2HLS_FULL
| CV_HSV2BGR_FULL
| CV_HSV2RGB_FULL
| CV_HLS2BGR_FULL
| CV_HLS2RGB_FULL
| CV_LBGR2Lab
| CV_LRGB2Lab
| CV_LBGR2Luv
| CV_LRGB2Luv
| CV_Lab2LBGR
| CV_Lab2LRGB
| CV_Luv2LBGR
| CV_Luv2LRGB
| CV_BGR2YUV
| CV_RGB2YUV
| CV_YUV2BGR
| CV_YUV2RGB
| CV_COLORCVT_MAX
instance Enum CvtCodes where
fromEnum CV_BGR2BGRA = 0
fromEnum CV_RGB2RGBA = 0
fromEnum CV_BGRA2BGR = 1
fromEnum CV_RGBA2RGB = 1
fromEnum CV_BGR2RGBA = 2
fromEnum CV_RGB2BGRA = 2
fromEnum CV_RGBA2BGR = 3
fromEnum CV_BGRA2RGB = 3
fromEnum CV_BGR2RGB = 4
fromEnum CV_RGB2BGR = 4
fromEnum CV_BGRA2RGBA = 5
fromEnum CV_RGBA2BGRA = 5
fromEnum CV_BGR2GRAY = 6
fromEnum CV_RGB2GRAY = 7
fromEnum CV_GRAY2BGR = 8
fromEnum CV_GRAY2RGB = 8
fromEnum CV_GRAY2BGRA = 9
fromEnum CV_GRAY2RGBA = 9
fromEnum CV_BGRA2GRAY = 10
fromEnum CV_RGBA2GRAY = 11
fromEnum CV_BGR2BGR565 = 12
fromEnum CV_RGB2BGR565 = 13
fromEnum CV_BGR5652BGR = 14
fromEnum CV_BGR5652RGB = 15
fromEnum CV_BGRA2BGR565 = 16
fromEnum CV_RGBA2BGR565 = 17
fromEnum CV_BGR5652BGRA = 18
fromEnum CV_BGR5652RGBA = 19
fromEnum CV_GRAY2BGR565 = 20
fromEnum CV_BGR5652GRAY = 21
fromEnum CV_BGR2BGR555 = 22
fromEnum CV_RGB2BGR555 = 23
fromEnum CV_BGR5552BGR = 24
fromEnum CV_BGR5552RGB = 25
fromEnum CV_BGRA2BGR555 = 26
fromEnum CV_RGBA2BGR555 = 27
fromEnum CV_BGR5552BGRA = 28
fromEnum CV_BGR5552RGBA = 29
fromEnum CV_GRAY2BGR555 = 30
fromEnum CV_BGR5552GRAY = 31
fromEnum CV_BGR2XYZ = 32
fromEnum CV_RGB2XYZ = 33
fromEnum CV_XYZ2BGR = 34
fromEnum CV_XYZ2RGB = 35
fromEnum CV_BGR2YCrCb = 36
fromEnum CV_RGB2YCrCb = 37
fromEnum CV_YCrCb2BGR = 38
fromEnum CV_YCrCb2RGB = 39
fromEnum CV_BGR2HSV = 40
fromEnum CV_RGB2HSV = 41
fromEnum CV_BGR2Lab = 44
fromEnum CV_RGB2Lab = 45
fromEnum CV_BayerBG2BGR = 46
fromEnum CV_BayerGB2BGR = 47
fromEnum CV_BayerRG2BGR = 48
fromEnum CV_BayerGR2BGR = 49
fromEnum CV_BayerBG2RGB = 48
fromEnum CV_BayerGB2RGB = 49
fromEnum CV_BayerRG2RGB = 46
fromEnum CV_BayerGR2RGB = 47
fromEnum CV_BGR2Luv = 50
fromEnum CV_RGB2Luv = 51
fromEnum CV_BGR2HLS = 52
fromEnum CV_RGB2HLS = 53
fromEnum CV_HSV2BGR = 54
fromEnum CV_HSV2RGB = 55
fromEnum CV_Lab2BGR = 56
fromEnum CV_Lab2RGB = 57
fromEnum CV_Luv2BGR = 58
fromEnum CV_Luv2RGB = 59
fromEnum CV_HLS2BGR = 60
fromEnum CV_HLS2RGB = 61
fromEnum CV_BayerBG2BGR_VNG = 62
fromEnum CV_BayerGB2BGR_VNG = 63
fromEnum CV_BayerRG2BGR_VNG = 64
fromEnum CV_BayerGR2BGR_VNG = 65
fromEnum CV_BayerBG2RGB_VNG = 64
fromEnum CV_BayerGB2RGB_VNG = 65
fromEnum CV_BayerRG2RGB_VNG = 62
fromEnum CV_BayerGR2RGB_VNG = 63
fromEnum CV_BGR2HSV_FULL = 66
fromEnum CV_RGB2HSV_FULL = 67
fromEnum CV_BGR2HLS_FULL = 68
fromEnum CV_RGB2HLS_FULL = 69
fromEnum CV_HSV2BGR_FULL = 70
fromEnum CV_HSV2RGB_FULL = 71
fromEnum CV_HLS2BGR_FULL = 72
fromEnum CV_HLS2RGB_FULL = 73
fromEnum CV_LBGR2Lab = 74
fromEnum CV_LRGB2Lab = 75
fromEnum CV_LBGR2Luv = 76
fromEnum CV_LRGB2Luv = 77
fromEnum CV_Lab2LBGR = 78
fromEnum CV_Lab2LRGB = 79
fromEnum CV_Luv2LBGR = 80
fromEnum CV_Luv2LRGB = 81
fromEnum CV_BGR2YUV = 82
fromEnum CV_RGB2YUV = 83
fromEnum CV_YUV2BGR = 84
fromEnum CV_YUV2RGB = 85
fromEnum CV_COLORCVT_MAX = 100
toEnum 0 = CV_BGR2BGRA
toEnum 0 = CV_RGB2RGBA
toEnum 1 = CV_BGRA2BGR
toEnum 1 = CV_RGBA2RGB
toEnum 2 = CV_BGR2RGBA
toEnum 2 = CV_RGB2BGRA
toEnum 3 = CV_RGBA2BGR
toEnum 3 = CV_BGRA2RGB
toEnum 4 = CV_BGR2RGB
toEnum 4 = CV_RGB2BGR
toEnum 5 = CV_BGRA2RGBA
toEnum 5 = CV_RGBA2BGRA
toEnum 6 = CV_BGR2GRAY
toEnum 7 = CV_RGB2GRAY
toEnum 8 = CV_GRAY2BGR
toEnum 8 = CV_GRAY2RGB
toEnum 9 = CV_GRAY2BGRA
toEnum 9 = CV_GRAY2RGBA
toEnum 10 = CV_BGRA2GRAY
toEnum 11 = CV_RGBA2GRAY
toEnum 12 = CV_BGR2BGR565
toEnum 13 = CV_RGB2BGR565
toEnum 14 = CV_BGR5652BGR
toEnum 15 = CV_BGR5652RGB
toEnum 16 = CV_BGRA2BGR565
toEnum 17 = CV_RGBA2BGR565
toEnum 18 = CV_BGR5652BGRA
toEnum 19 = CV_BGR5652RGBA
toEnum 20 = CV_GRAY2BGR565
toEnum 21 = CV_BGR5652GRAY
toEnum 22 = CV_BGR2BGR555
toEnum 23 = CV_RGB2BGR555
toEnum 24 = CV_BGR5552BGR
toEnum 25 = CV_BGR5552RGB
toEnum 26 = CV_BGRA2BGR555
toEnum 27 = CV_RGBA2BGR555
toEnum 28 = CV_BGR5552BGRA
toEnum 29 = CV_BGR5552RGBA
toEnum 30 = CV_GRAY2BGR555
toEnum 31 = CV_BGR5552GRAY
toEnum 32 = CV_BGR2XYZ
toEnum 33 = CV_RGB2XYZ
toEnum 34 = CV_XYZ2BGR
toEnum 35 = CV_XYZ2RGB
toEnum 36 = CV_BGR2YCrCb
toEnum 37 = CV_RGB2YCrCb
toEnum 38 = CV_YCrCb2BGR
toEnum 39 = CV_YCrCb2RGB
toEnum 40 = CV_BGR2HSV
toEnum 41 = CV_RGB2HSV
toEnum 44 = CV_BGR2Lab
toEnum 45 = CV_RGB2Lab
toEnum 46 = CV_BayerBG2BGR
toEnum 47 = CV_BayerGB2BGR
toEnum 48 = CV_BayerRG2BGR
toEnum 49 = CV_BayerGR2BGR
toEnum 48 = CV_BayerBG2RGB
toEnum 49 = CV_BayerGB2RGB
toEnum 46 = CV_BayerRG2RGB
toEnum 47 = CV_BayerGR2RGB
toEnum 50 = CV_BGR2Luv
toEnum 51 = CV_RGB2Luv
toEnum 52 = CV_BGR2HLS
toEnum 53 = CV_RGB2HLS
toEnum 54 = CV_HSV2BGR
toEnum 55 = CV_HSV2RGB
toEnum 56 = CV_Lab2BGR
toEnum 57 = CV_Lab2RGB
toEnum 58 = CV_Luv2BGR
toEnum 59 = CV_Luv2RGB
toEnum 60 = CV_HLS2BGR
toEnum 61 = CV_HLS2RGB
toEnum 62 = CV_BayerBG2BGR_VNG
toEnum 63 = CV_BayerGB2BGR_VNG
toEnum 64 = CV_BayerRG2BGR_VNG
toEnum 65 = CV_BayerGR2BGR_VNG
toEnum 64 = CV_BayerBG2RGB_VNG
toEnum 65 = CV_BayerGB2RGB_VNG
toEnum 62 = CV_BayerRG2RGB_VNG
toEnum 63 = CV_BayerGR2RGB_VNG
toEnum 66 = CV_BGR2HSV_FULL
toEnum 67 = CV_RGB2HSV_FULL
toEnum 68 = CV_BGR2HLS_FULL
toEnum 69 = CV_RGB2HLS_FULL
toEnum 70 = CV_HSV2BGR_FULL
toEnum 71 = CV_HSV2RGB_FULL
toEnum 72 = CV_HLS2BGR_FULL
toEnum 73 = CV_HLS2RGB_FULL
toEnum 74 = CV_LBGR2Lab
toEnum 75 = CV_LRGB2Lab
toEnum 76 = CV_LBGR2Luv
toEnum 77 = CV_LRGB2Luv
toEnum 78 = CV_Lab2LBGR
toEnum 79 = CV_Lab2LRGB
toEnum 80 = CV_Luv2LBGR
toEnum 81 = CV_Luv2LRGB
toEnum 82 = CV_BGR2YUV
toEnum 83 = CV_RGB2YUV
toEnum 84 = CV_YUV2BGR
toEnum 85 = CV_YUV2RGB
toEnum 100 = CV_COLORCVT_MAX
toEnum unmatched = error ("CvtCodes.toEnum: Cannot match " ++ show unmatched)
data CvtFlags = CvtFlip
| CvtSwapRB
instance Enum CvtFlags where
fromEnum CvtFlip = 1
fromEnum CvtSwapRB = 2
toEnum 1 = CvtFlip
toEnum 2 = CvtSwapRB
toEnum unmatched = error ("CvtFlags.toEnum: Cannot match " ++ show unmatched)
rgbToLab :: Image RGB D32 -> Image LAB D32
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS
rgbToGray :: Image RGB D32 -> Image GrayScale D32
rgbToGray = S . convertTo cvRGBtoGRAY 1 . unS
grayToRGB :: Image GrayScale D32 -> Image RGB D32
grayToRGB = S . convertTo (fromIntegral . fromEnum $ CV_GRAY2BGR) 3 . unS
bgrToRgb :: Image BGR D8 -> Image RGB D8
bgrToRgb = S . swapRB . unS
rgbToBgr :: Image RGB D8 -> Image BGR D8
rgbToBgr = S . swapRB . unS
swapRB :: BareImage -> BareImage
swapRB img = unsafePerformIO $ do
res <- cloneBareImage img
withBareImage img $ \cimg ->
withBareImage res $ \cres ->
cvConvertImage (castPtr cimg) (castPtr cres) (fromIntegral . fromEnum $ CvtSwapRB)
return res
class GetPixel a where
type P a :: *
getPixel :: (Int,Int) -> a -> P a
instance GetPixel (Image GrayScale D32) where
type P (Image GrayScale D32) = D32
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Float))):: Ptr Float)
instance GetPixel (Image GrayScale D8) where
type P (Image GrayScale D8) = D8
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Word8))):: Ptr Word8)
instance GetPixel (Image DFT D32) where
type P (Image DFT D32) = Complex D32
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: Float)
re <- peek (castPtr (d`plusPtr` (y*cs + x*2*fs)))
im <- peek (castPtr (d`plusPtr` (y*cs +(x*2+1)*fs)))
return (re:+im)
instance GetPixel (Image RGB D32) where
type P (Image RGB D32) = (D32,D32,D32)
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: Float)
b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
return (r,g,b)
instance GetPixel (Image BGR D32) where
type P (Image BGR D32) = (D32,D32,D32)
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: Float)
b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
return (r,g,b)
instance GetPixel (Image BGR D8) where
type P (Image BGR D8) = (D8,D8,D8)
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: D8)
b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
return (r,g,b)
instance GetPixel (Image RGB D8) where
type P (Image RGB D8) = (D8,D8,D8)
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: D8)
b <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
r <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
return (r,g,b)
instance GetPixel (Image LAB D32) where
type P (Image LAB D32) = (D32,D32,D32)
getPixel (x,y) i = unsafePerformIO $
withGenImage i $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: Float)
l <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
a <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
return (l,a,b)
mapImageInplace :: (P (Image GrayScale D32) -> P (Image GrayScale D32))
-> Image GrayScale D32
-> IO ()
mapImageInplace f image = withGenImage image $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let (w,h) = getSize image
cs = fromIntegral s
fs = sizeOf (undefined :: Float)
forM_ [(x,y) | x<-[0..w1], y <- [0..h1]] $ \(x,y) ->do
v <- peek (castPtr (d `plusPtr` (y*cs+x*fs)))
poke (castPtr (d `plusPtr` (y*cs+x*fs))) (f v)
convertTo :: CInt -> CInt -> BareImage -> BareImage
convertTo code channels img = unsafePerformIO $creatingBareImage $ do
res <- wrapCreateImage32F w h channels
withBareImage img $ \cimg ->
cvCvtColor (castPtr cimg) (castPtr res) code
return res
where
(fromIntegral -> w,fromIntegral -> h) = getSize img
class CreateImage a where
create :: (Int,Int) -> IO a
instance CreateImage (Image GrayScale D32) where
create (w,h) = creatingImage $ wrapCreateImage32F (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image DFT D32) where
create (w,h) = creatingImage $ wrapCreateImage32F (fromIntegral w) (fromIntegral h) 2
instance CreateImage (Image LAB D32) where
create (w,h) = creatingImage $ wrapCreateImage32F (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D32) where
create (w,h) = creatingImage $ wrapCreateImage32F (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D32) where
create (w,h) = creatingImage $ wrapCreateImage32F (fromIntegral w) (fromIntegral h) 4
instance CreateImage (Image GrayScale D64) where
create (w,h) = creatingImage $ wrapCreateImage64F (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D64) where
create (w,h) = creatingImage $ wrapCreateImage64F (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D64) where
create (w,h) = creatingImage $ wrapCreateImage64F (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D64) where
create (w,h) = creatingImage $ wrapCreateImage64F (fromIntegral w) (fromIntegral h) 4
instance CreateImage (Image GrayScale D8) where
create (w,h) = creatingImage $ wrapCreateImage8U (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D8) where
create (w,h) = creatingImage $ wrapCreateImage8U (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D8) where
create (w,h) = creatingImage $ wrapCreateImage8U (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D8) where
create (w,h) = creatingImage $ wrapCreateImage8U (fromIntegral w) (fromIntegral h) 4
empty :: (CreateImage (Image a b)) => (Int,Int) -> (Image a b)
empty size = unsafePerformIO $ create size
emptyCopy :: (CreateImage (Image a b)) => Image a b -> (Image a b)
emptyCopy img = unsafePerformIO $ create (getSize img)
class Save a where
save :: FilePath -> a -> IO ()
instance Save (Image BGR D32) where
save filename image = primitiveSave filename (unS . unsafeImageTo8Bit $ image)
instance Save (Image RGB D32) where
save filename image = primitiveSave filename (swapRB . unS . unsafeImageTo8Bit $ image)
instance Save (Image RGB D8) where
save filename image = primitiveSave filename (swapRB . unS $ image)
instance Save (Image GrayScale D8) where
save filename image = primitiveSave filename (unS $ image)
instance Save (Image GrayScale D32) where
save filename image = primitiveSave filename (unS . unsafeImageTo8Bit $ image)
primitiveSave :: FilePath -> BareImage -> IO ()
primitiveSave filename fpi = do
exists <- doesDirectoryExist (takeDirectory filename)
when (not exists) $throw (CvIOError $ "Directory does not exist: " ++ (takeDirectory filename))
withCString filename $ \name ->
withGenBareImage fpi $ \cvArr ->
alloca (\defs -> poke defs 0 >> cvSaveImage name cvArr defs >> return ())
saveImage :: (Save (Image c d)) => FilePath -> Image c d -> IO ()
saveImage = save
getArea :: (Sized a,Num b, Size a ~ (b,b)) => a -> b
getArea = uncurry (*).getSize
getRegion :: (Int,Int) -> (Int,Int) -> Image c d -> Image c d
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
| x+w <= width && y+h <= height = S . getRegion' (x,y) (w,h) $ unS image
| otherwise = error $ "Region outside image:"
++ show (getSize image) ++
"/"++show (x+w,y+h)
where
(fromIntegral -> width,fromIntegral -> height) = getSize image
getRegion' (x,y) (w,h) image = unsafePerformIO $
withBareImage image $ \i ->
creatingBareImage (getSubImage
i x y w h)
tileImages image1 image2 (x,y) = unsafePerformIO $
withImage image1 $ \i1 ->
withImage image2 $ \i2 ->
creatingImage (simpleMergeImages
i1 i2 x y)
blitFix = blit
blit :: Image GrayScale D32 -> Image GrayScale D32 -> (Int,Int) -> IO ()
blit image1 image2 (x,y)
| badSizes = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
| otherwise = withImage image1 $ \i1 ->
withImage image2 $ \i2 ->
(plainBlit i1 i2 (fromIntegral y) (fromIntegral x))
where
((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0
blitM (rw,rh) imgs = resultPic
where
resultPic = unsafePerformIO $ do
r <- create (fromIntegral rw,fromIntegral rh)
sequence_ [blit r i (fromIntegral x, fromIntegral y)
| ((x,y),i) <- imgs ]
return r
subPixelBlit
:: Image c d -> Image c d -> (CDouble, CDouble) -> IO ()
subPixelBlit (image1) (image2) (x,y)
| badSizes = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
| otherwise = withImage image1 $ \i1 ->
withImage image2 $ \i2 ->
(subpixel_blit i1 i2 y x)
where
((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 ||x<0 || y<0
safeBlit i1 i2 (x,y) = unsafePerformIO $ do
res <- cloneImage i1
blit res i2 (x,y)
return res
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
withImage image1 $ \i1 ->
withImage image1Alpha $ \i1a ->
withImage image2Alpha $ \i2a ->
withImage image2 $ \i2 ->
(alphaBlit i1 i1a i2 i2a y x)
cloneImage :: Image a b -> IO (Image a b)
cloneImage img = withGenImage img $ \image ->
creatingImage (cvCloneImage image)
cloneBareImage :: BareImage -> IO BareImage
cloneBareImage img = withGenBareImage img $ \image ->
creatingBareImage (cvCloneImage image)
withClone
:: Image channels depth
-> (Image channels depth -> IO ())
-> IO (Image channels depth)
withClone img fun = do
result <- cloneImage img
fun result
return result
withCloneValue
:: Image channels depth
-> (Image channels depth -> IO a)
-> IO a
withCloneValue img fun = do
result <- cloneImage img
r <- fun result
return r
unsafeImageTo32F :: Image c d -> Image c D32
unsafeImageTo32F img = unsafePerformIO $ withGenImage img $ \image ->
creatingImage
(ensure32F image)
unsafeImageTo8Bit :: Image cspace a -> Image cspace D8
unsafeImageTo8Bit img = unsafePerformIO $ withGenImage img $ \image ->
creatingImage
(ensure8U image)
imageTo32F img = withGenBareImage img $ \image ->
creatingBareImage
(ensure32F image)
imageTo8Bit img = withGenBareImage img $ \image ->
creatingBareImage
(ensure8U image)
data ImageDepth = Depth32F
| Depth64F
| Depth8U
| Depth8S
| Depth16U
| Depth16S
| Depth32S
instance Enum ImageDepth where
fromEnum Depth32F = 32
fromEnum Depth64F = 64
fromEnum Depth8U = 8
fromEnum Depth8S = 2147483656
fromEnum Depth16U = 16
fromEnum Depth16S = 2147483664
fromEnum Depth32S = 2147483680
toEnum 32 = Depth32F
toEnum 64 = Depth64F
toEnum 8 = Depth8U
toEnum 2147483656 = Depth8S
toEnum 16 = Depth16U
toEnum 2147483664 = Depth16S
toEnum 2147483680 = Depth32S
toEnum unmatched = error ("ImageDepth.toEnum: Cannot match " ++ show unmatched)
deriving instance Show ImageDepth
getImageDepth :: Image c d -> IO ImageDepth
getImageDepth i = withImage i $ \c_img -> (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) c_img >>= return.toEnum.fromIntegral
getImageChannels i = withImage i $ \c_img -> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) c_img
getImageInfo x = do
let s = getSize x
d <- getImageDepth x
c <- getImageChannels x
return (s,d,c)
setROI (fromIntegral -> x,fromIntegral -> y)
(fromIntegral -> w,fromIntegral -> h)
image = withImage image $ \i ->
wrapSetImageROI i x y w h
resetROI image = withImage image $ \i ->
cvResetImageROI i
setCOI chnl image = withImage image $ \i ->
cvSetImageCOI i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
cvSetImageCOI i 0
getChannel :: (Enum a) => a -> Image (ChannelOf a) d -> Image GrayScale d
getChannel no image = unsafePerformIO $ creatingImage $ do
let (w,h) = getSize image
setCOI (1+fromEnum no) image
cres <- wrapCreateImage32F (fromIntegral w) (fromIntegral h) 1
withGenImage image $ \cimage ->
cvCopy cimage (castPtr cres) (nullPtr)
resetCOI image
return cres
withIOROI pos size image op = do
setROI pos size image
x <- op
resetROI image
return x
withROI :: (Int, Int) -> (Int, Int) -> Image c d -> (Image c d -> a) -> a
withROI pos size image op = unsafePerformIO $ do
setROI pos size image
let x = op image
resetROI image
return x
class SetPixel a where
type SP a :: *
setPixel :: (Int,Int) -> SP a -> a -> IO ()
instance SetPixel (Image GrayScale D32) where
type SP (Image GrayScale D32) = D32
setPixel (x,y) v image = withGenImage image $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
poke (castPtr (d`plusPtr` (y*(fromIntegral s)
+ x*sizeOf (0::Float))):: Ptr Float)
v
instance SetPixel (Image GrayScale D8) where
type SP (Image GrayScale D8) = D8
setPixel (x,y) v image = withGenImage image $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
poke (castPtr (d`plusPtr` (y*(fromIntegral s)
+ x*sizeOf (0::Word8))):: Ptr Word8)
v
instance SetPixel (Image RGB D32) where
type SP (Image RGB D32) = (D32,D32,D32)
setPixel (x,y) (r,g,b) image = withGenImage image $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: Float)
poke (castPtr (d`plusPtr` (y*cs +x*3*fs))) b
poke (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs))) g
poke (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs))) r
instance SetPixel (Image DFT D32) where
type SP (Image DFT D32) = Complex D32
setPixel (x,y) (re:+im) image = withGenImage image $ \c_i -> do
d <- (\ptr -> do {peekByteOff ptr 68 ::IO (Ptr CChar)}) c_i
s <- (\ptr -> do {peekByteOff ptr 72 ::IO CInt}) c_i
let cs = fromIntegral s
fs = sizeOf (undefined :: Float)
poke (castPtr (d`plusPtr` (y*cs + x*2*fs))) re
poke (castPtr (d`plusPtr` (y*cs + (x*2+1)*fs))) im
getAllPixels image = [getPixel (i,j) image
| i <- [0..width1 ]
, j <- [0..height1]]
where
(width,height) = getSize image
getAllPixelsRowMajor image = [getPixel (i,j) image
| j <- [0..height1]
, i <- [0..width1]
]
where
(width,height) = getSize image
montage :: (CreateImage (Image GrayScale D32)) => (Int,Int) -> Int -> [Image GrayScale D32] -> Image GrayScale D32
montage (u',v') space' imgs
| u'*v' /= (length imgs) = error ("Montage mismatch: "++show (u,v, length imgs))
| otherwise = resultPic
where
space = fromIntegral space'
(u,v) = (fromIntegral u', fromIntegral v')
(rw,rh) = (u*xstep,v*ystep)
(w,h) = getSize (head imgs)
(xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
edge = space`div`2
resultPic = unsafePerformIO $ do
r <- create (rw,rh)
sequence_ [blit r i (edge + x*xstep, edge + y*ystep)
| y <- [0..v1] , x <- [0..u1]
| i <- imgs ]
return r
data CvException = CvException Int String String String Int
deriving (Show, Typeable)
data CvIOError = CvIOError String deriving (Show,Typeable)
instance Exception CvException
instance Exception CvIOError
setCatch = do
let catch i cstr1 cstr2 cstr3 j = do
func <- peekCString cstr1
msg <- peekCString cstr2
file <- peekCString cstr3
throw (CvException (fromIntegral i) func msg file (fromIntegral j))
return 0
cb <- mk'CvErrorCallback catch
c'cvRedirectError cb nullPtr nullPtr
c'cvSetErrMode c'CV_ErrModeSilent
foreign import ccall safe "CV/Image.chs.h cvReleaseImage"
cvReleaseImage :: ((Ptr (Ptr (BareImage))) -> (IO ()))
foreign import ccall safe "CV/Image.chs.h cvMerge"
cvMerge :: ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> (IO ()))))))
foreign import ccall safe "CV/Image.chs.h cvLoadImage"
cvLoadImage :: ((Ptr CChar) -> (CInt -> (IO (Ptr (BareImage)))))
foreign import ccall safe "CV/Image.chs.h getImageWidth"
getImageWidth :: ((Ptr (BareImage)) -> (IO CInt))
foreign import ccall safe "CV/Image.chs.h getImageHeight"
getImageHeight :: ((Ptr (BareImage)) -> (IO CInt))
foreign import ccall safe "CV/Image.chs.h cvConvertImage"
cvConvertImage :: ((Ptr ()) -> ((Ptr ()) -> (CInt -> (IO ()))))
foreign import ccall safe "CV/Image.chs.h wrapCreateImage32F"
wrapCreateImage32F :: (CInt -> (CInt -> (CInt -> (IO (Ptr (BareImage))))))
foreign import ccall safe "CV/Image.chs.h cvCvtColor"
cvCvtColor :: ((Ptr ()) -> ((Ptr ()) -> (CInt -> (IO ()))))
foreign import ccall safe "CV/Image.chs.h wrapCreateImage64F"
wrapCreateImage64F :: (CInt -> (CInt -> (CInt -> (IO (Ptr (BareImage))))))
foreign import ccall safe "CV/Image.chs.h wrapCreateImage8U"
wrapCreateImage8U :: (CInt -> (CInt -> (CInt -> (IO (Ptr (BareImage))))))
foreign import ccall safe "CV/Image.chs.h cvSaveImage"
cvSaveImage :: ((Ptr CChar) -> ((Ptr ()) -> ((Ptr CInt) -> (IO CInt))))
foreign import ccall safe "CV/Image.chs.h getSubImage"
getSubImage :: ((Ptr (BareImage)) -> (CInt -> (CInt -> (CInt -> (CInt -> (IO (Ptr (BareImage))))))))
foreign import ccall safe "CV/Image.chs.h simpleMergeImages"
simpleMergeImages :: ((Ptr (BareImage)) -> ((Ptr (BareImage)) -> (CInt -> (CInt -> (IO (Ptr (BareImage)))))))
foreign import ccall safe "CV/Image.chs.h plainBlit"
plainBlit :: ((Ptr (BareImage)) -> ((Ptr (BareImage)) -> (CInt -> (CInt -> (IO ())))))
foreign import ccall safe "CV/Image.chs.h subpixel_blit"
subpixel_blit :: ((Ptr (BareImage)) -> ((Ptr (BareImage)) -> (CDouble -> (CDouble -> (IO ())))))
foreign import ccall safe "CV/Image.chs.h alphaBlit"
alphaBlit :: ((Ptr (BareImage)) -> ((Ptr (BareImage)) -> ((Ptr (BareImage)) -> ((Ptr (BareImage)) -> (CInt -> (CInt -> (IO ())))))))
foreign import ccall safe "CV/Image.chs.h cvCloneImage"
cvCloneImage :: ((Ptr (BareImage)) -> (IO (Ptr (BareImage))))
foreign import ccall safe "CV/Image.chs.h ensure32F"
ensure32F :: ((Ptr (BareImage)) -> (IO (Ptr (BareImage))))
foreign import ccall safe "CV/Image.chs.h ensure8U"
ensure8U :: ((Ptr (BareImage)) -> (IO (Ptr (BareImage))))
foreign import ccall safe "CV/Image.chs.h wrapSetImageROI"
wrapSetImageROI :: ((Ptr (BareImage)) -> (CInt -> (CInt -> (CInt -> (CInt -> (IO ()))))))
foreign import ccall safe "CV/Image.chs.h cvResetImageROI"
cvResetImageROI :: ((Ptr (BareImage)) -> (IO ()))
foreign import ccall safe "CV/Image.chs.h cvSetImageCOI"
cvSetImageCOI :: ((Ptr (BareImage)) -> (CInt -> (IO ())))
foreign import ccall safe "CV/Image.chs.h cvCopy"
cvCopy :: ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> (IO ()))))