diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..38b28b8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +dist +*_hsc.c +*_hsc.h +*.hi +*.o + diff --git a/HOpenCV.cabal b/HOpenCV.cabal index c9697d7..3a2de63 100644 --- a/HOpenCV.cabal +++ b/HOpenCV.cabal @@ -1,63 +1,93 @@ name: HOpenCV -version: 0.1.2.2 +version: 0.4.0 license: BSD3 -maintainer: Noam Lewis -bug-reports: mailto:jones.noamle@gmail.com +author: Noam Lewis +maintainer: Anthony Cowley +stability: experimental category: AI, Graphics -synopsis: A binding for the OpenCV computer vision library -Tested-With: GHC == 6.10.4 +synopsis: A binding for the OpenCV computer vision library. +Tested-With: GHC==7.6.1 description: - Initial version with very limited bindings to OpenCV 2.0. (See: ) - . - For a functional interface to this library, see the package "cv-combinators". - . - Online module documentation, if not build below, can be found at . + Limited bindings to OpenCV 2.4. (See: ) . /Installation/ . - You must install OpenCV (development packages) prior to installing this package. Currently only tested on Ubuntu Linux, but should work on most linux distributions. For OpenCV installation on other *nix platforms, see - . - On /Ubuntu/ systems, the appropriate version of OpenCV can be installed by (the instructions are for Karmic): + You must install OpenCV (development packages) prior to installing this package. Currently tested on Mac OS 10.7. . - > sudo add-apt-repository ppa:gijzelaar/opencv2-karmic - > sudo apt-get update - > sudo apt-get install libcv-dev libhighgui-dev + /Usage/ . - You should then have libcv4 and libhighgui4 installed automatically too. + The "OpenCV.HighCV" module exposes the most commonly used functionality. The @Core@ modules contain to low-level OpenCV interfaces, while modules not in the @Core@ directory provide specific types of operations. . - -build-type: Simple -cabal-version: >= 1.2 -extra-source-files: - src/AI/CV/OpenCV/HOpenCV_wrap.h + See @src\/Examples\/VideoFunhouse@ for an example application. +build-type: Custom +cabal-version: >= 1.8 +extra-source-files: src/OpenCV/Core/HOpenCV_wrap.h + src/Examples/VideoFunhouse/Makefile + src/Examples/VideoFunhouse/Rate.hs + src/Examples/VideoFunhouse/VideoFunhouse.hs + src/Examples/Closing/Closing.hs +source-repository head + type: git + location: git://github.com/acowley/HOpenCV.git + +Flag OpenCV21 + Description: Link against OpenCV 2.1 + Default: False + +Flag MotionAnalysis + Description: Export optical flow bindings. Doesn't work with GHCi. + Default: False library exposed-modules: - AI.CV.OpenCV.CV - AI.CV.OpenCV.CxCore - AI.CV.OpenCV.HighGui - AI.CV.OpenCV.Types + OpenCV.Core.CV + OpenCV.Core.CVOp + OpenCV.Core.CxCore + OpenCV.Core.HighGui + OpenCV.Core.Image + OpenCV.Core.ImageUtil + OpenCV.Core.ColorConversion + OpenCV.HighCV + OpenCV.GUI + OpenCV.Video + OpenCV.FloodFill + OpenCV.PixelUtils + OpenCV.ColorConversion + OpenCV.Drawing + OpenCV.Contours + OpenCV.Threshold + OpenCV.ArrayOps + OpenCV.Filtering + OpenCV.FeatureDetection + OpenCV.Histograms + OpenCV.Color c-sources: - src/AI/CV/OpenCV/HOpenCV_wrap.c + src/OpenCV/Core/HOpenCV_wrap.c + src/OpenCV/ArrayOps_hsc.c + src/OpenCV/FloodFill_hsc.c + src/OpenCV/Drawing_hsc.c + other-modules: OpenCV.Core.StorableUtil hs-Source-Dirs: src - include-dirs: /usr/include/opencv - extra-libraries: cv,highgui - build-depends: base >=4 && <5, allocated-processor >= 0.0.1, vector-space - ghc-options: -Wall -fno-warn-type-defaults - -executable test-hopencv - c-sources: - src/AI/CV/OpenCV/HOpenCV_wrap.c - include-dirs: /usr/include/opencv - hs-source-dirs: src - Build-Depends: base >=4 && <5 - main-is: Test.hs - Ghc-Options: -Wall -fno-warn-type-defaults - Ghc-Prof-Options: -prof -auto-all - extra-libraries: cv,highgui - other-modules: AI.CV.OpenCV.CxCore, AI.CV.OpenCV.CV, AI.CV.OpenCV.HighGui, AI.CV.OpenCV.Types + if flag(MotionAnalysis) + exposed-modules: OpenCV.Motion + if os(windows) + include-dirs: C:\\OpenCV2.2\\include + extra-lib-dirs: C:\\OpenCV2.2\\bin + extra-libraries: opencv_core220,opencv_imgproc220,opencv_highgui220,opencv_video220 + else + if flag(OpenCV21) + CC-Options: "-DOCV21" + extra-libraries: cv highgui + else + extra-libraries: opencv_core,opencv_imgproc,opencv_highgui,opencv_video + -- needed to load in ghci-7.8 + cc-options: -fPIC ---source-repository head --- type: git --- location: git://github.com/sinelaw/HOpenCV.git + build-depends: base >= 4.6 && <5, + template-haskell, + vector-space >= 0.7.2, + directory >= 1.0.1.0 && < 2, + vector >= 0.7, + singletons, tagged + ghc-options: -Wall -fno-warn-name-shadowing -O2 -funbox-strict-fields diff --git a/README b/README deleted file mode 100644 index bba9a97..0000000 --- a/README +++ /dev/null @@ -1,15 +0,0 @@ -HOpenCV -------- - -OpenCV bindings for Haskell (rather low-level) - -For a functional wrapping of this library, see cv-combinators - - -TODO: ------ - -* Embed the depth and number of channels of images in their type using a typeclass - This will make things a little safer (e.g. prevent us calling cvCanny with color images in most cases) - - diff --git a/README.md b/README.md new file mode 100644 index 0000000..c7e8e3f --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# HOpenCV + +[OpenCV](http://opencv.willowgarage.com/wiki/) bindings for Haskell +(tested with OpenCV 2.1, 2.2, 2.3.0, and 2.3.1). + +- Image color channel count and color depth are statically checked. + +- A functional interface is provided through the HighCV module. + +- When operations are directly composed, they will be performed + in-place where possible as the intermediate images are not + observable. GHC's optimizations must be enabled (e.g. -O2). + +- See + [src/Examples](https://github.com/acowley/HOpenCV/tree/master/src/Examples) + for example programs. In particular, the + [VideoFunhouse](https://github.com/acowley/HOpenCV/tree/master/src/Examples/VideoFunhouse) + executable demonstrates realtime image processing on either the + video feed from a webcam or a video file. Fusion of in-place + operations is demonstrated along with light-weight parallelism. + +NOTE: Only a small part of OpenCV is currently wrapped. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..b745d2d --- /dev/null +++ b/Setup.hs @@ -0,0 +1,20 @@ +import Data.List (intercalate) +import Distribution.Simple +import System.Cmd +import System.Exit +import System.FilePath + +libs :: [String] +libs = ["opencv_core", "opencv_imgproc", "opencv_highgui", "opencv_video"] + +runHsc2hs :: FilePath -> IO ExitCode +runHsc2hs f = system $ "hsc2hs "++f++" "++libs' + where libs' = intercalate " " $ map ("-L -l"++) libs + +srcPath :: FilePath +srcPath = "src/OpenCV" + +main :: IO () +main = do mapM_ (runHsc2hs . (srcPath ) . flip addExtension "hsc") + ["ArrayOps", "FloodFill", "Drawing"] + defaultMain diff --git a/src/AI/CV/OpenCV/CV.hsc b/src/AI/CV/OpenCV/CV.hsc deleted file mode 100644 index db58062..0000000 --- a/src/AI/CV/OpenCV/CV.hsc +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} - -module AI.CV.OpenCV.CV where - -import Foreign.C.Types -import Foreign.Ptr - -import Data.Bits - -import AI.CV.OpenCV.CxCore - -#include - - -foreign import ccall unsafe "cv.h cvCanny" - c_cvCanny :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> CInt -> IO () - -cvCanny :: (IplArrayType i1, IplArrayType i2) => - Ptr i1 -> Ptr i2 -> CDouble -> CDouble -> CInt -> IO () -cvCanny src dst threshold1 threshold2 apertureSize = - c_cvCanny (fromArr src) (fromArr dst) (realToFrac threshold1) (realToFrac threshold2) apertureSize - - -data InterpolationMethod = CV_INTER_NN - | CV_INTER_LINEAR - | CV_INTER_CUBIC - | CV_INTER_AREA - deriving (Enum,Eq) - -foreign import ccall unsafe "cv.h cvResize" - c_cvResize :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () - -cvResize :: (IplArrayType i1, IplArrayType i2) => Ptr i1 -> Ptr i2 -> InterpolationMethod -> IO () -cvResize src dst interp = c_cvResize (fromArr src) (fromArr dst) (fromIntegral . fromEnum $ interp) - -foreign import ccall unsafe "HOpenCV_warp.h dilate" - c_dilate :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () - -cvDilate :: (IplArrayType i1, IplArrayType i2) => Ptr i1 -> Ptr i2 -> CInt -> IO () -cvDilate src dst iter = c_dilate (fromArr src) (fromArr dst) iter - - -foreign import ccall unsafe "cv.h cvPyrDown" - c_cvPyrDown :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () - --- for now only one filter type is supported so no need for the CInt (filter type) -constCvGaussian5x5 :: CInt -constCvGaussian5x5 = 7 -cvPyrDown :: (IplArrayType i1, IplArrayType i2) => Ptr i1 -> Ptr i2 -> IO () -cvPyrDown src dst = c_cvPyrDown (fromArr src) (fromArr dst) constCvGaussian5x5 - ------------------------------------------------------------------------------- - -data CvHaarClassifierCascade - --- thanks to http://book.realworldhaskell.org/read/interfacing-with-c-the-ffi.html -newtype HaarDetectFlag = HaarDetectFlag { unHaarDetectFlag :: CInt } - deriving (Eq, Show) - -#{enum HaarDetectFlag, HaarDetectFlag - , cvHaarFlagNone = 0 - , cvHaarDoCannyPruning = CV_HAAR_DO_CANNY_PRUNING - , cvHaarScaleImage = CV_HAAR_SCALE_IMAGE - , cvHaarFindBiggestObject = CV_HAAR_FIND_BIGGEST_OBJECT - , cvHaarDoRoughSearch = CV_HAAR_DO_ROUGH_SEARCH - } - -combineHaarFlags :: [HaarDetectFlag] -> HaarDetectFlag -combineHaarFlags = HaarDetectFlag . foldr ((.|.) . unHaarDetectFlag) 0 - -foreign import ccall unsafe "HOpenCV_warp.h c_cvHaarDetectObjects" - c_cvHaarDetectObjects :: Ptr CvArr -- ^ image - -> Ptr CvHaarClassifierCascade -- ^ cascade - -> Ptr CvMemStorage -- ^ storage - -> CDouble -- ^ scale_factor - -> CInt -- ^ min_neighbors - -> CInt -- ^ flags - -> CInt -> CInt -- ^ min_size - -> IO (Ptr (CvSeq CvRect)) - -cvHaarDetectObjects :: (IplArrayType i) => - Ptr i -- ^ image - -> Ptr CvHaarClassifierCascade -- ^ cascade - -> Ptr CvMemStorage -- ^ storage - -> CDouble -- ^ scale_factor - -> CInt -- ^ min_neighbors - -> HaarDetectFlag -- ^ flags - -> CvSize -- ^ min_size - -> IO (Ptr (CvSeq CvRect)) -cvHaarDetectObjects image cascade storage scaleFactor minNeighbors flags minSize = - c_cvHaarDetectObjects (fromArr image) cascade storage scaleFactor minNeighbors (unHaarDetectFlag flags) (sizeWidth minSize) (sizeHeight minSize) - \ No newline at end of file diff --git a/src/AI/CV/OpenCV/CxCore.hsc b/src/AI/CV/OpenCV/CxCore.hsc deleted file mode 100644 index 94a3456..0000000 --- a/src/AI/CV/OpenCV/CxCore.hsc +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeFamilies #-} - -module AI.CV.OpenCV.CxCore where - -import Foreign.ForeignPtrWrap -import Foreign.C.Types -import Foreign.C.String -import Foreign - -import Data.VectorSpace as VectorSpace - -#include - ------------------------------------------------------- -toFromIntegral :: (RealFrac c, Integral b, Integral a, Num b1) => (b1 -> c) -> a -> b -toFromIntegral f = round . f . fromIntegral - -toFromIntegral2 :: (Integral a, Num b, Integral a1, Num b1, RealFrac a2, Integral b2) => (b -> b1 -> a2) -> a -> a1 -> b2 -toFromIntegral2 f x y = round (f (fromIntegral x) (fromIntegral y)) ------------------------------------------------------- - -data CvSize = CvSize { sizeWidth :: CInt, sizeHeight :: CInt } - deriving (Show, Eq) -instance Storable CvSize where - sizeOf _ = (#size CvSize) - alignment _ = alignment (undefined :: CInt) - peek ptr = do - w <- (#peek CvSize, width) ptr - h <- (#peek CvSize, height) ptr - return (CvSize w h) - poke ptr (CvSize w h) = do - (#poke CvSize, width) ptr w - (#poke CvSize, height) ptr h - -liftCvSize ::(RealFrac c, Num b) => (b -> c) -> CvSize -> CvSize -liftCvSize f (CvSize w h) = CvSize (f' w) (f' h) - where f' = toFromIntegral f - -liftCvSize2 :: (Num b, Num b1, RealFrac a) => (b -> b1 -> a) -> CvSize -> CvSize -> CvSize -liftCvSize2 f (CvSize w1 h1) (CvSize w2 h2) = CvSize (f' w1 w2) (f' h1 h2) - where f' = toFromIntegral2 f - -instance AdditiveGroup CvSize where - zeroV = CvSize 0 0 - (^+^) = liftCvSize2 (+) - negateV = liftCvSize (0-) - -instance VectorSpace CvSize where - type Scalar CvSize = Double -- todo: use CInt instead of Double here? - a *^ s = liftCvSize (a*) s - - -data CvRect = CvRect { rectX :: CInt, rectY :: CInt, rectWidth :: CInt, rectHeight :: CInt } - deriving (Show, Eq) - -instance Storable CvRect where - sizeOf _ = (#size CvRect) - alignment _ = alignment (undefined :: CInt) - peek ptr = do - x <- (#peek CvRect, x) ptr - y <- (#peek CvRect, y) ptr - w <- (#peek CvRect, width) ptr - h <- (#peek CvRect, height) ptr - return (CvRect x y w h) - poke ptr (CvRect x y w h) = do - (#poke CvRect, x) ptr x - (#poke CvRect, y) ptr y - (#poke CvRect, width) ptr w - (#poke CvRect, height) ptr h - - -liftCvRect :: (RealFrac c, Num b) => (b -> c) -> CvRect -> CvRect -liftCvRect f (CvRect x y w h) = CvRect (f' x) (f' y) (f' w) (f' h) - where f' = toFromIntegral f - -liftCvRect2 :: (Num b, Num b1, RealFrac a) => (b -> b1 -> a) -> CvRect -> CvRect -> CvRect -liftCvRect2 f (CvRect x1 y1 w1 h1) (CvRect x2 y2 w2 h2) = CvRect (f' x1 x2) (f' y1 y2) (f' w1 w2) (f' h1 h2) - where f' = toFromIntegral2 f - -instance AdditiveGroup CvRect where - zeroV = CvRect 0 0 0 0 - (^+^) = liftCvRect2 (+) - negateV = liftCvRect (0-) - -instance VectorSpace CvRect where - type Scalar CvRect = Double -- todo: use CInt instead of Double here? - a *^ r = liftCvRect (a*) r - - - ------------------------------------------------------- -class IplArrayType a - -data CvArr -instance IplArrayType CvArr - -data IplImage -instance IplArrayType IplImage - -data CvMemStorage - -data CvSeq a - -fromArr :: IplArrayType a => Ptr a -> Ptr CvArr -fromArr = castPtr - -newtype Depth = Depth { unDepth :: CInt } - deriving (Eq, Show) - -#{enum Depth, Depth - , iplDepth1u = IPL_DEPTH_1U - , iplDepth8u = IPL_DEPTH_8U - , iplDepth8s = IPL_DEPTH_8S - , iplDepth16u = IPL_DEPTH_16U - , iplDepth16s = IPL_DEPTH_16S - , iplDepth32s = IPL_DEPTH_32S - , iplDepth32f = IPL_DEPTH_32F - , iplDepth64f = IPL_DEPTH_64F -} - -validDepths :: [Depth] -validDepths = [iplDepth1u, iplDepth8u, iplDepth8s, iplDepth16u, iplDepth16s, iplDepth32s, iplDepth32f, iplDepth64f] - -depthsLookupList :: [(CInt, Depth)] -depthsLookupList = map (\d -> (unDepth d, d)) validDepths - -numToDepth :: CInt -> Maybe Depth -numToDepth x = lookup x depthsLookupList - - ---------------------------------------------------------------- --- mem storage -foreign import ccall unsafe "cxcore.h cvCreateMemStorage" - c_cvCreateMemStorage :: CInt -> IO (Ptr CvMemStorage) - -cvCreateMemStorage :: CInt -> IO (Ptr CvMemStorage) -cvCreateMemStorage = errorName "Failed to create mem storage" . checkPtr . c_cvCreateMemStorage - -foreign import ccall unsafe "HOpenCV_warp.h release_mem_storage" - cvReleaseMemStorage :: Ptr CvMemStorage -> IO () - -foreign import ccall unsafe "HOpenCV_warp.h &release_mem_storage" - cp_release_mem_storage :: FunPtr (Ptr CvMemStorage -> IO ()) - -createMemStorageF :: CInt -> IO (ForeignPtr CvMemStorage) -createMemStorageF = (createForeignPtr cp_release_mem_storage) . cvCreateMemStorage - - --- images / matrices / arrays - -foreign import ccall unsafe "HOpenCV_warp.h create_image" - c_cvCreateImage :: CInt -> CInt -> CInt -> CInt -> IO (Ptr IplImage) - -cvCreateImage :: CvSize -> CInt -> Depth -> IO (Ptr IplImage) -cvCreateImage size numChans depth = errorName "Failed to create image" . checkPtr $ c_cvCreateImage (sizeWidth size) (sizeHeight size) (unDepth depth) numChans - -foreign import ccall unsafe "HOpenCV_warp.h release_image" - cvReleaseImage :: Ptr IplImage -> IO () - -foreign import ccall unsafe "HOpenCV_warp.h &release_image" - cp_release_image :: FunPtr (Ptr IplImage -> IO ()) - -createImageF :: CvSize -> CInt -> Depth -> IO (ForeignPtr IplImage) -createImageF x y z = createForeignPtr cp_release_image $ cvCreateImage x y z - -foreign import ccall unsafe "cxcore.h cvCloneImage" - c_cvCloneImage :: Ptr IplImage -> IO (Ptr IplImage) - -cvCloneImage :: Ptr IplImage -> IO (Ptr IplImage) -cvCloneImage = errorName "Failed to clone image" . checkPtr . c_cvCloneImage - -cloneImageF :: Ptr IplImage -> IO (ForeignPtr IplImage) -cloneImageF x = createForeignPtr cp_release_image $ cvCloneImage x - -foreign import ccall unsafe "HOpenCV_warp.h get_size" - c_get_size :: Ptr CvArr -> Ptr CvSize -> IO () - -foreign import ccall unsafe "cxcore.h cvCopy" - c_cvCopy :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () - --- todo add mask support -cvCopy :: IplArrayType a => Ptr a -> Ptr a -> IO () -cvCopy src dst = c_cvCopy (fromArr src) (fromArr dst) nullPtr - -cvGetSize :: IplArrayType a => Ptr a -> CvSize -cvGetSize p = unsafePerformIO $ - alloca $ \cvSizePtr -> do - c_get_size (castPtr p) cvSizePtr - size <- peek cvSizePtr - return size - -foreign import ccall unsafe "HOpenCV_warp.h get_depth" - c_get_depth :: Ptr IplImage -> IO CInt - -getDepth :: Ptr IplImage -> IO Depth -getDepth img = do - depthInt <- c_get_depth img - case numToDepth depthInt of - Nothing -> fail "Bad depth in image struct" - Just depth -> return depth - -foreign import ccall unsafe "HOpenCV_warp.h get_nChannels" - c_get_nChannels :: Ptr IplImage -> IO CInt - -getNumChannels :: Integral a => Ptr IplImage -> IO a -getNumChannels img = fmap fromIntegral $ c_get_nChannels img - - -foreign import ccall unsafe "cxcore.h cvConvertScale" - cvConvertScale :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> IO () - - -foreign import ccall unsafe "HOpenCV_warp.h cv_free" - cvFree :: Ptr a -> IO () - -foreign import ccall unsafe "cxcore.h cvLoad" - c_cvLoad :: CString -> Ptr CvMemStorage -> CString -> Ptr CString -> IO (Ptr a) - -cvLoad :: String -> Ptr CvMemStorage -> Maybe String -> IO (Ptr a, Maybe String) -cvLoad filename memstorage name = withCString filename cvLoad' - where cvLoad' filenameC = do - case name of - Nothing -> cvLoad'' filenameC nullPtr - Just n' -> withCString n' $ cvLoad'' filenameC - cvLoad'' filenameC nameC = alloca $ \ptrRealNameC -> do - ptrObj <- errorName "cvLoad failed" . checkPtr $ c_cvLoad filenameC memstorage nameC ptrRealNameC - realNameC <- peek ptrRealNameC - realName <- if realNameC == nullPtr - then return Nothing - else fmap Just $ peekCString realNameC - cvFree realNameC - return (ptrObj, realName) - -foreign import ccall unsafe "cxcore.h cvGetSeqElem" - cvGetSeqElem :: Ptr (CvSeq a) -> CInt -> IO (Ptr a) - --- foreign import ccall unsafe "HOpenCV_warp.h c_rect_cvGetSeqElem" --- cvGetSeqElemRect :: Ptr (CvSeq (Ptr CvRect)) -> CInt -> IO (Ptr CvRect) - -foreign import ccall unsafe "HOpenCV_warp.h seq_total" - seqNumElems :: Ptr (CvSeq a) -> IO CInt - -seqToPList :: Ptr (CvSeq a) -> IO [Ptr a] -seqToPList pseq = do - numElems <- seqNumElems pseq - mapM (cvGetSeqElem pseq) [1..(numElems)] - -seqToList :: Storable a => Ptr (CvSeq a) -> IO [a] -seqToList pseq = do - numElems <- seqNumElems pseq - flip mapM [1..(numElems)] $ \i -> do - elemP <- cvGetSeqElem pseq i - elem' <- peek elemP - return elem' - --- seqToRectList :: Ptr (CvSeq (Ptr CvRect)) -> IO [CvRect] --- seqToRectList pseq = do --- numElems <- seqNumElems pseq --- flip mapM [1..(numElems)] $ \i -> do --- rectP <- cvGetSeqElemRect pseq i --- rect <- peek rectP --- return rect - -foreign import ccall unsafe "HOpenCV_warp.h c_cvRectangle" - c_cvRectangle :: Ptr CvArr -> CInt -> CInt -> CInt -> CInt -> IO () - -cvRectangle :: IplArrayType a => Ptr a -> CvRect -> IO () -cvRectangle dst (CvRect x y w h) = c_cvRectangle (fromArr dst) x y w h - ------------------------------------------------------------------------------- --- Debugging stuff, not part of opencv - --- | Debugging function to print some of the internal details of an IplImage structure -foreign import ccall unsafe "HOpenCV_warp.h debug_print_image_header" - c_debug_print_image_header :: Ptr IplImage -> IO () diff --git a/src/AI/CV/OpenCV/HOpenCV_wrap.h b/src/AI/CV/OpenCV/HOpenCV_wrap.h deleted file mode 100644 index 913b929..0000000 --- a/src/AI/CV/OpenCV/HOpenCV_wrap.h +++ /dev/null @@ -1,36 +0,0 @@ -#include -#include - -void debug_print_image_header(IplImage *image); - -void release_capture(CvCapture *capture); - - -void new_window(int num, int flags); -void del_window(int num); -void show_image(int num, IplImage *image); - -IplImage *create_image(int width, int height, int depth, int channels); -void release_image(IplImage *image); - -void get_size(const CvArr *arr, CvSize *size); -int get_depth(const IplImage *image); -int get_nChannels(const IplImage *image); - -void dilate(const CvArr *src, CvArr *dest, int iterations); - -void release_mem_storage(CvMemStorage *mem_store); -void cv_free(void *obj); - -int seq_total(const CvSeq *seq); -/* CvRect *c_rect_cvGetSeqElem(const CvSeq *seq, int index); */ - -void c_cvRectangle(CvArr *img, int x, int y, int width, int height); - - -CvSeq *c_cvHaarDetectObjects( const CvArr* image, - CvHaarClassifierCascade* cascade, - CvMemStorage* storage, double scale_factor, - int min_neighbors , int flags, - int width, int height); - diff --git a/src/AI/CV/OpenCV/HighGui.hs b/src/AI/CV/OpenCV/HighGui.hs deleted file mode 100644 index e5ff616..0000000 --- a/src/AI/CV/OpenCV/HighGui.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} - -module AI.CV.OpenCV.HighGui where - -import Foreign.ForeignPtrWrap -import Foreign.C.Types -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.C.String - -import AI.CV.OpenCV.CxCore - - ------------------------------------------------- --- General -foreign import ccall unsafe "highgui.h cvConvertImage" - c_cvConvertImage :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () - -cvConvertImage :: (IplArrayType a, IplArrayType a1) => Ptr a -> Ptr a1 -> CInt -> IO () -cvConvertImage src dst flags = c_cvConvertImage (fromArr src) (fromArr dst) flags - ------------------------------------------------- --- Capturing -data CvCapture - - -foreign import ccall unsafe "highgui.h cvCreateCameraCapture" - c_cvCreateCameraCapture :: CInt -> IO (Ptr CvCapture) - -cvCreateCameraCapture :: CInt -> IO (Ptr CvCapture) -cvCreateCameraCapture x = errorName "Failed to create camera" . checkPtr $ c_cvCreateCameraCapture . fromIntegral $ x - -foreign import ccall unsafe "highgui.h cvCreateFileCapture" - c_cvCreateFileCapture :: CString -> IO (Ptr CvCapture) - -cvCreateFileCapture :: String -> IO (Ptr CvCapture) -cvCreateFileCapture filename = err' . checkPtr $ withCString filename f - where err' = errorName $ "Failed to capture from file: '" ++ filename ++ "'" - f filenameC = c_cvCreateFileCapture filenameC - - -foreign import ccall unsafe "HOpenCV_warp.h release_capture" - cvReleaseCapture :: Ptr CvCapture -> IO () - -foreign import ccall unsafe "HOpenCV_warp.h &release_capture" - cp_release_capture :: FunPtr (Ptr CvCapture -> IO () ) - -createCameraCaptureF :: CInt -> IO (ForeignPtr CvCapture) -createCameraCaptureF = (createForeignPtr cp_release_capture) . cvCreateCameraCapture - - - -foreign import ccall unsafe "highgui.h cvQueryFrame" - c_cvQueryFrame :: Ptr CvCapture -> IO (Ptr IplImage) - -cvQueryFrame :: Ptr CvCapture -> IO (Ptr IplImage) -cvQueryFrame cap = errorName "Failed to query frame from camera" . checkPtr $ c_cvQueryFrame cap - -------------------------------------------------- --- Windows -foreign import ccall unsafe "HOpenCV_wrap.h new_window" - c_newWindow :: CInt -> CInt -> IO () - -newWindow :: CInt -> Bool -> IO () -newWindow num autoSize = c_newWindow num (if autoSize then 1 else 0) - -foreign import ccall unsafe "HOpenCV_wrap.h del_window" - delWindow :: CInt -> IO () - -foreign import ccall unsafe "HOpenCV_wrap.h show_image" - showImage :: CInt -> Ptr IplImage -> IO () - -foreign import ccall unsafe "highgui.h cvWaitKey" - waitKey :: CInt -> IO CInt diff --git a/src/AI/CV/OpenCV/Types.hs b/src/AI/CV/OpenCV/Types.hs deleted file mode 100644 index dd84a2d..0000000 --- a/src/AI/CV/OpenCV/Types.hs +++ /dev/null @@ -1,16 +0,0 @@ -module AI.CV.OpenCV.Types where - - -import AI.CV.OpenCV.CxCore -import AI.CV.OpenCV.HighGui - -import Foreign -import Foreign.ForeignPtr - - - -type PImage = Ptr IplImage -type PCapture = Ptr CvCapture - -type FPImage = ForeignPtr IplImage -type FPCapture = ForeignPtr CvCapture diff --git a/src/Examples/OneOffs/Closing.hs b/src/Examples/OneOffs/Closing.hs new file mode 100644 index 0000000..bdad420 --- /dev/null +++ b/src/Examples/OneOffs/Closing.hs @@ -0,0 +1,3 @@ +import OpenCV.HighCV + +main = toFile "closed.png" . erode 8 . dilate 8 =<< fromFileGray "input.png" \ No newline at end of file diff --git a/src/Examples/OneOffs/EqualizeCenter.hs b/src/Examples/OneOffs/EqualizeCenter.hs new file mode 100644 index 0000000..bda4274 --- /dev/null +++ b/src/Examples/OneOffs/EqualizeCenter.hs @@ -0,0 +1,12 @@ +import Control.Applicative +import OpenCV.HighCV +import OpenCV.ArrayOps +import OpenCV.Histograms + +boostSaturation :: ColorImage -> ColorImage +boostSaturation img = convertHSVToBGR $ replaceChannel 1 s hsv + where hsv = convertBGRToHSV img + s = withROI (CvRect 100 100 300 300) (convertScale 2 0) $ isolateChannel 1 hsv + +main = fromFileColor "../PerfTest/lena.jpg" >>= + toFile "eq.png" . boostSaturation diff --git a/src/Examples/OneOffs/VideoWriter.hs b/src/Examples/OneOffs/VideoWriter.hs new file mode 100644 index 0000000..169e0e9 --- /dev/null +++ b/src/Examples/OneOffs/VideoWriter.hs @@ -0,0 +1,16 @@ +-- | Save video from an attached webcam to compressed video on disk +-- while also showing it on-screen. +import OpenCV.HighCV +import System.Exit (exitSuccess) + +main :: IO () +main = do cam <- createCameraCapture Nothing :: IO (IO ColorImage) + writeImg <- createVideoWriter "foo.avi" (toFourCC "XVID") 24 (640,480) + (showImg,close) <- namedWindow "Video Test" [AutoSize] + let kb 27 = close >> exitSuccess + kb _ = go + go = do img <- cam + showImg img + writeImg img + waitKey 1 >>= maybe go kb + go \ No newline at end of file diff --git a/src/Examples/OneOffs/input.png b/src/Examples/OneOffs/input.png new file mode 100644 index 0000000..e942bb8 Binary files /dev/null and b/src/Examples/OneOffs/input.png differ diff --git a/src/Examples/PerfTest/Makefile b/src/Examples/PerfTest/Makefile new file mode 100644 index 0000000..5deeae6 --- /dev/null +++ b/src/Examples/PerfTest/Makefile @@ -0,0 +1,4 @@ +all: PerfTest.hs + ghc -O2 PerfTest.hs -ddump-simpl-stats -fforce-recomp -rtsopts -threaded -fspec-constr-count=15 + +# Suggested RTS options: ./PerfTest +RTS -A4M diff --git a/src/Examples/PerfTest/PerfTest.hs b/src/Examples/PerfTest/PerfTest.hs new file mode 100644 index 0000000..4d4e294 --- /dev/null +++ b/src/Examples/PerfTest/PerfTest.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeSynonymInstances #-} +import OpenCV.HighCV +import OpenCV.ArrayOps +import OpenCV.Filtering +import Control.Parallel +import Criterion.Main + +-- Morphological closing +close :: GrayImage -> GrayImage +close = erode 4 . dilate 4 +{-# INLINE close #-} + +-- Posterize into four shades of blue. +fourTones :: GrayImage -> ColorImage +fourTones g = cvOr light dark + where t = close . thresholdBinaryOtsu 255 $ g + lightMean = avgMask g t + l1 = close $ cmpS CmpGT lightMean g + l2 = convertGrayToRGB $ cvNot l1 `cvAnd` t + light = cvAndS (255,0,0) (convertGrayToRGB l1) `cvOr` + cvAndS (220,0,0) l2 + t' = cvNot t + darkMean = avgMask g t' + d2 = close $ cmpS CmpLT darkMean g + d1 = convertGrayToRGB $ cvNot d2 `cvAnd` t' + dark = cvAndS (180,0,0) d1 `cvOr` + cvAndS (140,0,0) (convertGrayToRGB d2) +{-# INLINE fourTones #-} + +-- Smoothed Canny edges. +neonEdges :: GrayImage -> ColorImage +neonEdges = convertGrayToRGB . smoothGaussian 5. dilate 1 . canny 70 110 3 +{-# INLINE neonEdges #-} + +-- A blueprint effect. +blueprint :: ColorImage -> ColorImage +blueprint x = toned `par` neon `pseq` add neon toned + where g = convertRGBToGray x + toned = fourTones g + neon = neonEdges g +{-# INLINE blueprint #-} + +-- No parallelism. +blueprintSlow :: ColorImage -> ColorImage +blueprintSlow x = add (fourTones g) (neonEdges g) + where g = convertRGBToGray x +{-# INLINE blueprintSlow #-} + +main :: IO () +main = do img <- fromFile "lena.jpg" + defaultMain [ + bench "blueprint" $ whnf blueprint img + , bench "blueprintSlow" $ whnf blueprintSlow img ] diff --git a/src/Examples/PerfTest/lena.jpg b/src/Examples/PerfTest/lena.jpg new file mode 100644 index 0000000..f06aa74 Binary files /dev/null and b/src/Examples/PerfTest/lena.jpg differ diff --git a/src/Examples/VideoFunhouse/Makefile b/src/Examples/VideoFunhouse/Makefile new file mode 100644 index 0000000..cf3ef65 --- /dev/null +++ b/src/Examples/VideoFunhouse/Makefile @@ -0,0 +1,5 @@ +all: VideoFunhouse.hs Rate.hs + ghc -O2 VideoFunhouse.hs -fforce-recomp -rtsopts -threaded -fspec-constr-count=18 -with-rtsopts="-A4M" + +clean: + rm *.hi *.o VideoFunhouse \ No newline at end of file diff --git a/src/Examples/VideoFunhouse/Rate.hs b/src/Examples/VideoFunhouse/Rate.hs new file mode 100644 index 0000000..9aeb564 --- /dev/null +++ b/src/Examples/VideoFunhouse/Rate.hs @@ -0,0 +1,42 @@ +module Rate where +import Data.IORef +import Data.Time.Clock +import Text.Printf + +trackRate :: IO (IO String) +trackRate = do numFrames <- newIORef 0 + oldRate <- newIORef "" + startTime <- getCurrentTime >>= newIORef + let reportRate = + do t <- getCurrentTime + s <- readIORef startTime + let dt = realToFrac $ diffUTCTime t s :: Float + msg = printf "%.2f" (30.0 / dt) + writeIORef startTime t + writeIORef numFrames 0 + writeIORef oldRate msg + return msg + moveAlong n = writeIORef numFrames (n+1) >> readIORef oldRate + return $ do n <- readIORef numFrames + if n == 29 then reportRate else moveAlong n + +perfMon :: IO (IO (), IO String, IO ()) +perfMon = do numFrames <- newIORef 0 + oldRate <- newIORef "" + startTime <- getCurrentTime >>= newIORef + totalTime <- newIORef (0::Double) + let start = getCurrentTime >>= writeIORef startTime + stop = do t <- getCurrentTime + s <- readIORef startTime + let dt = realToFrac $ diffUTCTime t s :: Double + modifyIORef totalTime ((+ dt) $!) + n <- readIORef numFrames + if n == 29 + then do oy <- readIORef totalTime + msg <- formatMsg `fmap` readIORef totalTime + writeIORef numFrames 0 + writeIORef totalTime 0 + writeIORef oldRate msg + else writeIORef numFrames (n+1) + return (start, readIORef oldRate, stop) + where formatMsg = printf "%d" . (round::Double->Int) . (30.0 /) diff --git a/src/Examples/VideoFunhouse/VideoFunhouse.hs b/src/Examples/VideoFunhouse/VideoFunhouse.hs new file mode 100644 index 0000000..d72ee31 --- /dev/null +++ b/src/Examples/VideoFunhouse/VideoFunhouse.hs @@ -0,0 +1,167 @@ +-- |An example application demonstrating realtime image processing on +-- the video feed from an attached webcam or a video file specified as +-- a command line argument. The executable prints usage instructions +-- to the console when run. +import OpenCV.HighCV +import OpenCV.ArrayOps +import OpenCV.Filtering +import OpenCV.Histograms +import Control.Applicative +import Control.Parallel +import System.Environment (getArgs) +import System.Exit (exitSuccess) +import Rate + +-- Canny edges +edges = convertGrayToRGB . canny 70 110 3 . convertRGBToGray +{-# INLINE edges #-} + +-- Heavily smoothed video with red edge highlights. +edgesOnSmoothed x = let e = edges x; s = smooth x in e `par` s `pseq` add e s + where edges = cvAndS (0,0,255) . convertGrayToRGB . dilate 1 + . canny 70 110 3 . convertRGBToGray + smooth = smoothGaussian 21 +{-# INLINE edgesOnSmoothed #-} + +-- Morphological closing +close :: GrayImage -> GrayImage +close = erode 4 . dilate 4 +{-# INLINE close #-} + +-- Posterize into two shades of blue. +twoTone :: GrayImage -> ColorImage +twoTone g = light t `cvOr` dark t + where t = close . thresholdBinaryOtsu 255 $ g + light = cvAndS (255,0,0) . convertGrayToRGB + dark = cvAndS (180,0,0) . convertGrayToRGB . cvNot +{-# INLINE twoTone #-} + +-- Smoothed Canny edges. +neonEdges :: GrayImage -> ColorImage +neonEdges = convertGrayToRGB . smoothGaussian 3 . dilate 1 . canny 70 110 3 + +-- Boost saturation +boostSat x = convertHSVToBGR $ replaceChannel 1 s' hsv + where hsv = convertBGRToHSV x + s' = convertScale 2.0 0 . isolateChannel 1 $ hsv +{-# INLINE boostSat #-} + +-- Saturate and blur the borders +centralFocus :: ColorImage -> ColorImage +centralFocus img = withROI r (copy (setROI r img)) bg + where bg = smoothGaussian 35 . boostSat $ img + r = CvRect 150 100 340 280 +{-# INLINE centralFocus #-} + +-- A two-tone blueprint effect. +blueprint x = toned `par` neon `pseq` add neon toned + where g = convertRGBToGray x + toned = twoTone g + neon = neonEdges g +{-# INLINE blueprint #-} + +-- No parallelism +blueprintSlow x = add (neonEdges g) (twoTone g) + where g = convertRGBToGray x +{-# INLINE blueprintSlow #-} + +-- Posterize into four shades of blue. +fourTones :: GrayImage -> ColorImage +fourTones g = cvOr light dark + where t = close . thresholdBinaryOtsu 255 $ g + lightMean = avgMask g t + l1 = close $ cmpS CmpGT lightMean g + l2 = convertGrayToRGB $ cvNot l1 `cvAnd` t + light = cvAndS (255,0,0) (convertGrayToRGB l1) `cvOr` + cvAndS (220,0,0) l2 + t' = cvNot t + darkMean = avgMask g t' + d2 = close $ cmpS CmpLT darkMean g + d1 = convertGrayToRGB $ cvNot d2 `cvAnd` t' + dark = cvAndS (180,0,0) d1 `cvOr` + cvAndS (140,0,0) (convertGrayToRGB d2) +{-# INLINE fourTones #-} + +-- A four-tone blueprint effect. +blueprint2 x = toned `par` neon `pseq` add neon toned + where g = convertRGBToGray x + toned = fourTones g + neon = neonEdges g +{-# INLINE blueprint2 #-} + +-- No parallelism +blueprint2slow x = add (neonEdges g) (fourTones g) + where g = convertRGBToGray x +{-# INLINE blueprint2slow #-} + +-- NOTE: trackRate counts all the time in between frames. In low-light +-- situations, a camera may run at a lower rate to effect a longer +-- exposure time. To still report a useful performance metric, the +-- perfMon monitor counts only the time a frame is being processed and +-- drawn. Thus, the displayed framerate is the maximum theoretical +-- rate the processing and display code could run at if the image +-- capturing mechanism could feed it that fast. + +main = do args <- getArgs + cam <- case args of + ["--help"] -> do putStrLn "Usage: ./VideoFunhouse [filename]" + putStr "If no file is given, a connected " + putStrLn "camera is opened." + exitSuccess + [fname] -> createFileCaptureLoop fname + _ -> createCameraCapture (Just 0) + (showImg,close) <- namedWindow "Video Funhouse" [AutoSize] + --rater <- trackRate + (startFrame', curr, stopFrame) <- perfMon + str <- prepFont ComplexSerif False 1 1 2 + let showFPS :: IO (ColorImage -> ColorImage) + --showFPS = str (300,450) (0,255,0) . (++ " FPS") <$> rater + showFPS = str (300,450) (0,255,0) . (++ " FPS") <$> curr + startFrame x = startFrame' >> return x + checkKey b _ 49 = go b id -- 1 + checkKey b _ 50 = go b edges -- 2 + checkKey b _ 51 = go b edgesOnSmoothed -- 3 + checkKey b _ 52 = go b blueprint -- 4 + checkKey b _ 53 = go b blueprintSlow -- 5 + checkKey b _ 54 = go b blueprint2 -- 6 + checkKey b _ 55 = go b blueprint2slow -- 7 + checkKey b _ 56 = go b boostSat -- 8 + checkKey b _ 57 = go b centralFocus -- 9 + checkKey b p 102 = go (not b) p + checkKey _ _ 27 = close >> exitSuccess + checkKey b p _ = go b p + go False proc = cam >>= startFrame >>= showImg . proc >> + stopFrame >> waitKey 1 >>= + maybe (go False proc) (checkKey False proc) + go True proc = cam >>= startFrame >>= (showFPS <*>) . pure . proc >>= + showImg >> stopFrame >> waitKey 1 >>= + maybe (go True proc) (checkKey True proc) + -- go False proc = cam >>= showImg . proc >> waitKey 1 >>= + -- maybe (go False proc) (checkKey False proc) + -- go True proc = cam >>= (showFPS <*>) . pure . proc >>= showImg >> + -- waitKey 1 >>= + -- maybe (go True proc) (checkKey True proc) + showHelp + go False id + +showHelp :: IO () +showHelp = do p "Usage: VideoFunhouse [file]" + p "" + p "Press 'f' to toggle framerate display" + p " The rate is computed from the per-frame processing time." + p " Lighting conditions and the specific camera used will" + p " determine the actual rate at which frames are acquired." + p "" + p "Number keys select a video effect:" + p " 1 - Raw video" + p " 2 - Canny edges" + p " 3 - Smoothed image with red edge highlights" + p " 4 - A two-tone blueprint effect" + p " 5 - Two-tone blueprint effect without par annotations" + p " 6 - A four-tone blueprint effect" + p " 7 - Four-tone blueprint effect without par annotations" + p " 8 - Saturation boost" + p " 9 - Focus on the middle" + p "" + p "Press Esc to exit." + where p = putStrLn diff --git a/src/OpenCV/ArrayOps.hsc b/src/OpenCV/ArrayOps.hsc new file mode 100644 index 0000000..bb35873 --- /dev/null +++ b/src/OpenCV/ArrayOps.hsc @@ -0,0 +1,416 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, ScopedTypeVariables, + FlexibleContexts, DataKinds, ConstraintKinds #-} +-- |Array operations. +module OpenCV.ArrayOps (subRS, absDiff, abs, convertScale, + cvAnd, andMask, scaleAdd, cvAndS, + cvOr, cvOrS, set, cvAbs, cvAbsDiffS, + mul, mulS, add, addS, sub, subMask, + cmpS, avg, avgMask, cvNot, withROI, + ComparisonOp(..), isolateChannel, copy, + replaceChannel, convertScaleAbs, absSat) where +import Data.Word (Word8) +import Foreign.C.Types (CDouble(..), CInt(..)) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Marshal.Array +import Foreign.Marshal.Alloc +import Foreign.Storable (poke, peek) +import System.IO.Unsafe (unsafePerformIO) +import OpenCV.Core.CxCore (CvArr, CvRect(..), CmpOp(..), CvScalar(..), + cmpEq, cmpGT, cmpGE, cmpLT, cmpLE, cmpNE) +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp +import OpenCV.Core.StorableUtil + +type M = Monochromatic + +#include + +#def void c_cvSubRS(CvArr* src1, CvScalar* src2, CvArr* dst, const CvArr* mask) { cvSubRS(src1, *src2, dst, mask); } + +-- foreign import ccall "opencv2/core/core_c.h cvSubRS" +-- c_cvSubRS :: Ptr CvArr -> CDouble -> CDouble -> CDouble -> CDouble -> +-- Ptr CvArr -> Ptr CvArr -> IO () +foreign import ccall "" -- "static ArrayOps_hsc.h c_cvSubRS" + c_cvSubRS :: Ptr CvArr -> Ptr CvScalar -> + Ptr CvArr -> Ptr CvArr -> IO () + +-- |@subRS value src@ computes @value - src[i]@ for every pixel. +subRS :: (HasDepth d, ScalarOK s c d, Inplace r c d c d) => + s -> Image c d r -> Image c d r +subRS value = cv2 $ \src dst -> + withS (toCvScalar value) $ \sPtr -> + c_cvSubRS src sPtr dst nullPtr +{-# INLINE subRS #-} + +foreign import ccall "opencv2/core/core_c.h cvAbsDiff" + c_cvAbsDiff :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Calculate the absolute difference between two images. +absDiff :: (HasDepth d, Inplace r c d c d) => + Image c d r -> Image c d r -> Image c d r +absDiff src1 = cv2 $ \src2 dst -> + withIplImage src1 $ \src1' -> + c_cvAbsDiff (castPtr src1') src2 dst +{-# INLINE absDiff #-} + +#def void c_cvAbsDiffS(const CvArr* src, CvArr* dst, CvScalar* value) {\ + cvAbsDiffS(src, dst, *value);\ +} + +-- foreign import ccall "opencv2/core/core_c.h cvAbsDiffS" +-- c_cvAbsDiffS :: Ptr CvArr -> Ptr CvArr -> +-- CDouble -> CDouble -> CDouble -> CDouble -> IO () +foreign import ccall "" + c_cvAbsDiffS :: Ptr CvArr -> Ptr CvArr -> Ptr CvScalar -> IO () + +-- |Absolute difference of each pixel in an image and a scalar. +cvAbsDiffS :: (HasDepth d, Inplace r c d c d, ScalarOK s c d) => + s -> Image c d r -> Image c d r +cvAbsDiffS value = cv2 $ \src dst -> + withS (toCvScalar value) $ \vPtr -> + c_cvAbsDiffS src dst vPtr +{-# INLINE cvAbsDiffS #-} + +-- |Absolute value of each pixel. +cvAbs :: (HasDepth d, Inplace r c d c d) => Image c d r -> Image c d r +cvAbs = cv2 $ \src dst -> + withS (CvScalar 0 0 0 0) $ \sPtr -> + c_cvAbsDiffS src dst sPtr +{-# INLINE cvAbs #-} + +foreign import ccall "opencv2/core/core_c.h cvConvertScale" + c_cvConvertScale :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> IO () + +-- |Converts one array to another with optional affine +-- transformation. Each element of the source array is multiplied by +-- the @scale@ factor and added to the @shift@ value before being +-- converted to the destination type with rounding and saturation. All +-- the channels of multi-channel arrays are processed +-- independentally. Parameters are @scale@, @shift@, and the source +-- 'Image'. +convertScale :: (HasDepth d1, HasDepth d2, Inplace r c d1 c d2) => + Double -> Double -> Image c d1 r -> Image c d2 r +convertScale scale shift = cv2 $ \src dst -> + c_cvConvertScale src dst (rf scale) (rf shift) + where rf = realToFrac +{-# INLINE convertScale #-} + +foreign import ccall "opencv2/core/core_c.h cvConvertScaleAbs" + c_cvConvertScaleAbs :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> IO () + +-- |@convertScaleAbs scale shift@ scales each element of an image, +-- adds an offset to the scaled value, computes the absolute value, +-- and saturates to 8 bits. +convertScaleAbs :: (HasDepth d, Inplace r c d c Word8) => + CDouble -> CDouble -> Image c d r -> Image c Word8 r +convertScaleAbs scale shift = cv2 $ \src dst -> + c_cvConvertScaleAbs src dst scale shift +{-# INLINE convertScaleAbs #-} + +-- |Computes the absolute value of each pixel and saturates to 8 bits. +absSat :: (HasDepth d, Inplace r c d c Word8) => + Image c d r -> Image c Word8 r +absSat = convertScaleAbs 1 0 +{-# INLINE absSat #-} + +foreign import ccall "opencv2/core/core_c.h cvAnd" + c_cvAnd :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Calculate the per-element bitwise conjunction of two +-- arrays. Parameters are a mask and two source images. The mask +-- specifies the elements of the result that will be computed via the +-- conjunction, and those that will simply be copied from the third +-- parameter. +andMask :: (HasDepth d, Inplace r3 c d c d) => + Image Monochromatic Word8 r1 -> Image c d r2 -> + Image c d r3 -> Image c d r3 +andMask mask src1 = cv2 $ \src2 dst -> + withIplImage src1 $ \src1' -> + withIplImage mask $ \mask' -> + c_cvAnd (castPtr src1') src2 dst (castPtr mask') +{-# INLINE andMask #-} + +-- |Calculates the per-element bitwise conjunction of two arrays. +cvAnd :: (HasDepth d, Inplace r2 c d c d) => + Image c d r1 -> Image c d r2 -> Image c d r2 +cvAnd src1 = cv2 $ \src2 dst -> withIplImage src1 $ \src1' -> + c_cvAnd (castPtr src1') src2 dst nullPtr +{-# INLINE cvAnd #-} + +#def void c_cvAndS(const CvArr* src, CvScalar* value, CvArr* dst, const CvArr* mask) { cvAndS(src, *value, dst, mask); } + +-- foreign import ccall "opencv2/core/core_c.h cvAndS" +-- c_cvAndS :: Ptr CvArr -> CDouble -> CDouble -> CDouble -> CDouble -> +-- Ptr CvArr -> Ptr CvArr -> IO () +foreign import ccall "" + c_cvAndS :: Ptr CvArr -> Ptr CvScalar -> Ptr CvArr -> Ptr CvArr -> IO () + + +-- |Per-element bit-wise conjunction of an array and a scalar. +cvAndS :: (HasDepth d, ScalarOK s c d, Inplace r c d c d) => + s -> Image c d r -> Image c d r +cvAndS s = cv2 $ \img dst -> + withS (toCvScalar s) $ \sPtr -> + c_cvAndS img sPtr dst nullPtr +{-# INLINE cvAndS #-} + +#def void c_cvScaleAdd(const CvArr* src1, CvScalar* scale,\ + const CvArr* src2, CvArr* dst) {\ + cvScaleAdd(src1, *scale, src2, dst);\ +} + +-- foreign import ccall "opencv2/core/core_c.h cvScaleAdd" +-- c_cvScaleAdd :: Ptr CvArr -> CDouble -> CDouble -> CDouble -> CDouble -> +-- Ptr CvArr -> Ptr CvArr -> IO () +foreign import ccall "" + c_cvScaleAdd :: Ptr CvArr -> Ptr CvScalar -> Ptr CvArr -> Ptr CvArr -> IO () + + +-- |Calculate the sum of a scaled array and another array. @scaleAdd +-- src1 s src2@ computes @dst[i] = s*src1[i] + src2[i]@ +scaleAdd :: (ScalarOK s c d, HasDepth d, Inplace r2 c d c d) => + Image c d r1 -> s -> Image c d r2 -> Image c d r2 +scaleAdd src1 s = cv2 $ \src2 dst -> + withIplImage src1 $ \src1' -> + withS (toCvScalar s) $ \sPtr -> + c_cvScaleAdd (castPtr src1') sPtr src2 dst +{-# INLINE scaleAdd #-} + +foreign import ccall "opencv2/core/core_c.h cvMul" + c_cvMul :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> CDouble -> IO () + +cvMulHelper :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> Double -> IO () +cvMulHelper src1 src2 dst s = c_cvMul src1 src2 dst (realToFrac s) + +-- |Per-element product of two arrays. +mul :: (HasDepth d, Inplace r2 c d c d) => + Image c d r1 -> Image c d r2 -> Image c d r2 +mul src1 = cv2 $ \src2 dst -> + withIplImage src1 $ \src1' -> + cvMulHelper (castPtr src1') src2 dst 1 +{-# INLINE mul #-} + +-- |Per-element product of two arrays with an extra scale factor that +-- is multiplied with each product. +mulS :: (HasDepth d, Inplace r2 c d c d) => + Double -> Image c d r1 -> Image c d r2 -> Image c d r2 +mulS scale src1 = cv2 $ \src2 dst -> + withIplImage src1 $ \src1' -> + cvMulHelper (castPtr src1') src2 dst scale +{-# INLINE mulS #-} + +foreign import ccall "opencv2/core/core_c.h cvAdd" + c_cvAdd :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Per-element sum. +add :: (HasDepth d1, HasDepth d2, HasDepth d3, Inplace r2 c d2 c d3) => + Image c d1 r1 -> Image c d2 r2 -> Image c d3 r2 +add src1 = cv2 $ \src2 dst -> + withIplImage src1 $ \src1' -> + c_cvAdd (castPtr src1') src2 dst nullPtr +{-# INLINE add #-} + +#def void c_cvAddS(const CvArr* src, CvScalar* value, CvArr* dst,\ + const CvArr* mask) {\ + cvAddS(src, *value, dst, mask);\ +} + +-- foreign import ccall "opencv2/core/core_c.h cvAddS" +-- c_cvAddS :: Ptr CvArr -> CDouble -> CDouble -> CDouble -> CDouble -> +-- Ptr CvArr -> Ptr CvArr -> IO () +foreign import ccall "" + c_cvAddS :: Ptr CvArr -> Ptr CvScalar -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Computes the sum of an array and a scalar. +addS :: (HasDepth d, ScalarOK s c d, Inplace r c d c d) => + s -> Image c d r -> Image c d r +addS scalar = cv2 $ \src dst -> + withS (toCvScalar scalar) $ \sPtr -> + c_cvAddS src sPtr dst nullPtr +{-# INLINE addS #-} + +foreign import ccall "opencv2/core/core_c.h cvSub" + c_cvSub :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Per-element difference. +sub :: (HasDepth d, Inplace r2 c d c d) => + Image c d r1 -> Image c d r2 -> Image c d r2 +sub img1 = cv2 $ \img2 dst -> + withIplImage img1 $ \img1' -> + c_cvSub (castPtr img1') img2 dst nullPtr +{-# INLINE sub #-} + +-- |WARNING: Argument order may be confusing! @cvSubMask img2 mask +-- img1@ computes @dst[i] = img1[i] - img2[i] if mask[i]@. The idea is +-- that @dst@ is the same as @img1@ everywhere @mask@ is zero. This +-- permits in-place updating of @img1@. +subMask :: (HasDepth d, Inplace r3 c d c d, UpdateROI r3) => + Image c d r1 -> Image Monochromatic Word8 r2 -> Image c d r3 -> + Image c d r3 +subMask img2 mask = cv $ \img1 -> + withIplImage mask $ \mask' -> + withIplImage img2 $ \img2' -> + c_cvSub img1 (castPtr img2') img1 (castPtr mask') +{-# INLINE subMask #-} + +foreign import ccall "opencv2/core/core_c.h cvOr" + c_cvOr :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Per-element bit-wise disjunction of two arrays +cvOr :: (HasDepth d, Inplace r2 c d c d) => + Image c d r1 -> Image c d r2 -> Image c d r2 +cvOr img1 = cv2 $ \img2 dst -> + withIplImage img1 $ \img1' -> + c_cvOr (castPtr img1') img2 dst nullPtr +{-# INLINE cvOr #-} + +#def void c_cvOrS(const CvArr* src, CvScalar* value, CvArr* dst,\ + const CvArr* mask) {\ + cvOrS(src, *value, dst, mask);\ +} + +-- foreign import ccall "opencv2/core/core_c.h cvOrS" +-- c_cvOrS :: Ptr CvArr -> CDouble -> CDouble -> CDouble -> CDouble -> +-- Ptr CvArr -> Ptr CvArr -> IO () +foreign import ccall "" + c_cvOrS :: Ptr CvArr -> Ptr CvScalar -> Ptr CvArr -> Ptr CvArr -> IO () + + +-- |Per-element bit-wise disjunction of an array and a scalar. +cvOrS :: (HasDepth d, ScalarOK s c d, Inplace r c d c d) => + s -> Image c d r -> Image c d r +cvOrS scalar = cv2 $ \src dst -> + withS (toCvScalar scalar) $ \sPtr -> + c_cvOrS src sPtr dst nullPtr +{-# INLINE cvOrS #-} + +#def void c_cvSet(CvArr* src, CvScalar* value, const CvArr* mask) {\ + cvSet(src, *value, mask);\ +} + +-- foreign import ccall "opencv2/core/core_c.h cvSet" +-- c_cvSet :: Ptr CvArr -> CDouble -> CDouble -> CDouble -> CDouble -> +-- Ptr CvArr -> IO () +foreign import ccall "" + c_cvSet :: Ptr CvArr -> Ptr CvScalar -> Ptr CvArr -> IO () + +-- |Set every element of an array to a given value. +set :: (HasDepth d, ScalarOK s c d, Inplace r c d c d) => + s -> Image c d r -> Image c d r +set scalar img@Image{} = flip cv img $ \src -> + withS (toCvScalar scalar) $ \sPtr -> + c_cvSet src sPtr nullPtr +{-# INLINE set #-} + +setROICV :: forall c d r. HasDepth d => + CvRect -> Image c d r -> Image c d HasROI +setROICV (CvRect x y w h) = cv $ \img -> c_cvSetImageROI img x y w h +{-# INLINE setROICV #-} + +resetROICV :: forall c d r. HasDepth d => Image c d r -> Image c d NoROI +resetROICV = cv $ \img -> c_cvResetImageROI img +{-# INLINE resetROICV #-} + +-- |Restrict an operation to a specific region-of-interest. This +-- operation fuses. +withROI :: (HasDepth d1, HasDepth d2) => + CvRect -> (Image c1 d1 HasROI -> Image c2 d2 r2) -> + Image c1 d1 r -> Image c2 d2 NoROI +withROI r f = resetROICV . f . setROICV r +{-# INLINE withROI #-} + +foreign import ccall "opencv2/core/core_c.h cvCmpS" + c_cvCmpS :: Ptr CvArr -> CDouble -> Ptr CvArr -> CInt -> IO () + +data ComparisonOp = CmpEq | CmpGT | CmpGE | CmpLT | CmpLE | CmpNE + +cmpToCmp :: ComparisonOp -> CInt +cmpToCmp CmpEq = unCmpOp cmpEq +cmpToCmp CmpGT = unCmpOp cmpGT +cmpToCmp CmpGE = unCmpOp cmpGE +cmpToCmp CmpLT = unCmpOp cmpLT +cmpToCmp CmpLE = unCmpOp cmpLE +cmpToCmp CmpNE = unCmpOp cmpNE + +-- |Per-element comparison of an array and a scalar. +cmpS :: (HasDepth d, Inplace r M d M Word8) => + ComparisonOp -> d -> Image Monochromatic d r -> + Image Monochromatic Word8 r +cmpS op v = cv2 $ \src dst -> + c_cvCmpS src v' dst (cmpToCmp op) + where v' = realToFrac . toDouble $ v +{-# INLINE cmpS #-} + +foreign import ccall "HOpenCV_wrap.h c_cvAvg" + c_cvAvg :: Ptr CvArr -> Ptr CvArr -> Ptr CvScalar -> IO () + +avgWorker :: AsCvScalar b => Ptr CvArr -> Ptr CvArr -> IO b +avgWorker img mask = alloca $ \ptr -> + c_cvAvg img mask ptr >> fromCvScalar `fmap` peek ptr +-- avgWorker img mask = allocaArray 4 $ +-- \arr -> do c_cvAvg img mask arr +-- fromCvScalar `fmap` peek arr +-- -- [r,g,b,a] <- peekArray 4 arr +-- -- return $ fromCvScalar (r,g,b,a) + +-- |Calculates the mean independently for each channel. +avg :: (HasDepth d, ScalarOK s c d) => Image c d r -> CvScalarT c d +avg img = unsafePerformIO . withIplImage img $ flip avgWorker nullPtr . castPtr +{-# NOINLINE avg #-} + +-- |@avgMask img mask@ calculates the mean independently for each +-- channel for each element of the source array whose entry in @mask@ +-- is non-zero. +avgMask :: (HasDepth d, ScalarOK s c d) => + Image c d r1 -> Image Monochromatic Word8 r2 -> CvScalarT c d +avgMask img mask = unsafePerformIO . withIplImage img $ \src -> + withIplImage mask $ avgWorker (castPtr src) . castPtr +{-# NOINLINE avgMask #-} + +foreign import ccall "opencv2/core/core_c.h cvNot" + c_cvNot :: Ptr CvArr -> Ptr CvArr -> IO () + +-- |Per-element bit-wise inversion. +cvNot :: (HasDepth d, Inplace r c d c d) => + Image c d r -> Image c d r +cvNot = cv2 $ \src dst -> c_cvNot src dst +{-# INLINE cvNot #-} + +foreign import ccall "opencv2/core/core_c.h cvMixChannels" + cvMixChannels :: Ptr (Ptr CvArr) -> CInt -> Ptr (Ptr CvArr) -> CInt -> + Ptr CInt -> CInt -> IO () + +-- |Isolate a specific channel from a trichromatic image. +isolateChannel :: (HasDepth d, Inplace r Trichromatic d M d) => + CInt -> Image Trichromatic d r -> Image Monochromatic d r +isolateChannel n = cv2 $ \src dst -> + alloca $ \p1 -> poke p1 src >> + (alloca $ \p2 -> + poke p2 dst >> + (withArray [n,0] $ \ft -> + cvMixChannels p1 1 p2 1 ft 1)) +{-# INLINE isolateChannel #-} + +-- |Replace a specific channel of a trichromatic image with the single +-- channel from a monochromatic image. +replaceChannel :: (HasDepth d, Inplace r2 Trichromatic d Trichromatic d) => + CInt -> Image Monochromatic d r1 -> + Image Trichromatic d r2 -> Image Trichromatic d r2 +replaceChannel n c = cv2 $ \src dst -> + withIplImage c $ \cp -> + withArray [castPtr cp, src] $ \p1 -> + withArray [dst] $ \p2 -> + withArray [0,n,1+n',n',1+n'',n''] $ \ft -> + cvMixChannels p1 2 p2 1 ft 3 + where n' = (n + 1) `rem` 3 + n'' = (n + 2) `rem` 3 +{-# INLINE replaceChannel #-} + +foreign import ccall "opencv2/core/core_c.h cvCopy" + cvCopy :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +copy :: (UpdateROI r2, HasDepth d) => + Image c d r1 -> Image c d r2 -> Image c d r2 +copy src = cv $ \dst -> withIplImage src $ \src' -> + cvCopy (castPtr src') dst nullPtr +{-# INLINE copy #-} diff --git a/src/OpenCV/Color.hs b/src/OpenCV/Color.hs new file mode 100644 index 0000000..0f94b4d --- /dev/null +++ b/src/OpenCV/Color.hs @@ -0,0 +1,25 @@ +-- |A convenient 8-bit-per-channel RGB data type with a 'Storable' +-- instance. +module OpenCV.Color where +import Control.Applicative +import Data.Word (Word8) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable(..)) + +data RGB8 = RGB8 {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + +instance Storable RGB8 where + sizeOf _ = 3 + alignment _ = 4 + peek ptr = RGB8 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2 + where ptr' = castPtr ptr + poke ptr (RGB8 r g b) = do poke ptr' r + pokeElemOff ptr' 1 g + pokeElemOff ptr' 2 b + where ptr' = castPtr ptr + +-- |Map a function over each component of an RGB triple. +rgbmap :: (Word8 -> Word8) -> RGB8 -> RGB8 +rgbmap f (RGB8 r g b) = RGB8 (f r) (f g) (f b) diff --git a/src/OpenCV/ColorConversion.hs b/src/OpenCV/ColorConversion.hs new file mode 100644 index 0000000..e550277 --- /dev/null +++ b/src/OpenCV/ColorConversion.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts, DataKinds #-} +-- |Type-safe color conversion functions. +module OpenCV.ColorConversion + (convertGrayToRGB, convertGrayToBGR, + convertBGRToGray, convertRGBToGray, + convertBayerBgToBGR, convertBayerBgToRGB, + convertRGBToHSV, convertBGRToHSV, convertHSVToBGR, + convertColor) where +import OpenCV.Core.CV +import OpenCV.Core.ImageUtil +import OpenCV.Core.ColorConversion +import OpenCV.Core.CVOp + +type M = Monochromatic +type T = Trichromatic + +convertGrayToRGB :: (HasDepth d, Inplace r M d T d) => + Image Monochromatic d r -> Image Trichromatic d r +convertGrayToRGB = convertColor cv_GRAY2RGB +{-# INLINE convertGrayToRGB #-} + +convertGrayToBGR :: (HasDepth d, Inplace r M d T d) => + Image Monochromatic d r -> Image Trichromatic d r +convertGrayToBGR = convertColor cv_GRAY2BGR +{-# INLINE convertGrayToBGR #-} + +convertBGRToGray :: (HasDepth d, Inplace r T d M d) => + Image Trichromatic d r -> Image Monochromatic d r +convertBGRToGray = convertColor cv_BGR2GRAY +{-# INLINE convertBGRToGray #-} + +convertRGBToGray :: (HasDepth d, Inplace r T d M d) => + Image Trichromatic d r -> Image Monochromatic d r +convertRGBToGray = convertBGRToGray +{-# INLINE convertRGBToGray #-} + +convertBayerBgToBGR :: (HasDepth d, Inplace r M d T d) => + Image Monochromatic d r -> Image Trichromatic d r +convertBayerBgToBGR = convertColor cv_BayerBG2BGR +{-# INLINE convertBayerBgToBGR #-} + +convertBayerBgToRGB :: (HasDepth d, Inplace r M d T d) => + Image Monochromatic d r -> Image Trichromatic d r +convertBayerBgToRGB = convertColor cv_BayerBG2RGB +{-# INLINE convertBayerBgToRGB #-} + +convertRGBToHSV :: (HasDepth d, Inplace r T d T d) => + Image Trichromatic d r -> Image Trichromatic d r +convertRGBToHSV = convertColor cv_RGB2HSV +{-# INLINE convertRGBToHSV #-} + +convertBGRToHSV :: (HasDepth d, Inplace r T d T d) => + Image Trichromatic d r -> Image Trichromatic d r +convertBGRToHSV = convertColor cv_BGR2HSV +{-# INLINE convertBGRToHSV #-} + +convertHSVToBGR :: (HasDepth d, Inplace r T d T d) => + Image Trichromatic d r -> Image Trichromatic d r +convertHSVToBGR = convertColor cv_HSV2BGR +{-# INLINE convertHSVToBGR #-} + +-- |Convert the color model of an image. +convertColor :: (HasDepth d, Inplace r c1 d c2 d) => + ColorConversion -> Image c1 d r -> Image c2 d r +convertColor cc = cv2 $ \src dst -> cvCvtColor src dst cc +{-# INLINE convertColor #-} \ No newline at end of file diff --git a/src/OpenCV/Contours.hsc b/src/OpenCV/Contours.hsc new file mode 100644 index 0000000..0ad9f62 --- /dev/null +++ b/src/OpenCV/Contours.hsc @@ -0,0 +1,223 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +-- |Incomplete support for cvFindContours. +module OpenCV.Contours ( + + -- * contour + Contour(..), + withContourList, + -- ** functions to use with 'withContourList' + cvContourArea, + cvContourPerimeter, + followPoints, + + cvDrawContours, + -- * moments + cvMoments, + CvMoments(..), + + cvGetSpatialMoment, + cvGetCentralMoment, + cvGetNormalizedCentralMoment, + cvGetHuMoments, + CvHuMoments(..), + + -- * unused + ContourMode(..), ContourMethod(..), + ) where +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr -- (Ptr, castPtr, nullPtr) +import Foreign.Storable +import Foreign.Marshal.Alloc -- (alloca) +import Foreign.ForeignPtr.Safe +import Foreign.Marshal + +import Control.Monad + +#include +#include + +foreign import ccall "HOpenCV_wrap.h c_cvFindContours" + c_cvFindContours :: Ptr CvArr -> Ptr CvMemStorage -> Ptr (Ptr (CvSeq a)) -> + CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt + +foreign import ccall "HOpenCV_wrap.h c_cvGetSeqPoint" + c_cvGetSeqPoint :: Ptr (CvSeq a) -> CInt -> Ptr CInt -> Ptr CInt -> IO () + +foreign import ccall "HOpenCV_wrap.h c_cvContourArea" + cvContourArea :: Contour -> IO Double + +foreign import ccall "HOpenCV_wrap.h c_cvContourPerimeter" + cvContourPerimeter :: Contour -> IO Double + +foreign import ccall "HOpenCV_wrap.h c_cvMoments" + c_cvMoments :: Ptr CvArr -> Ptr CvMoments -> IO () + +cvMoments :: IplArrayType a => Ptr a -> IO CvMoments +cvMoments img = do + p <- mallocForeignPtrBytes (# size CvMoments ) + withForeignPtr p (c_cvMoments (castPtr img)) + return (CvMoments p) + +foreign import ccall "cvGetSpatialMoment" + c_cvGetSpatialMoment :: Ptr CvMoments -> CInt -> CInt -> IO Double + +cvGetSpatialMoment, cvGetCentralMoment, cvGetNormalizedCentralMoment + :: CvMoments + -> CInt -- ^ x + -> CInt -- ^ y + -> IO Double +cvGetSpatialMoment (CvMoments p) xord yord = + withForeignPtr p (\ p' -> c_cvGetSpatialMoment p' xord yord ) + +foreign import ccall "cvGetCentralMoment" + c_cvGetCentralMoment :: Ptr CvMoments -> CInt -> CInt -> IO Double + +cvGetCentralMoment (CvMoments p) xord yord = + withForeignPtr p (\ p' -> c_cvGetCentralMoment p' xord yord ) + +foreign import ccall "cvGetNormalizedCentralMoment" + c_cvGetNormalizedCentralMoment :: Ptr CvMoments -> CInt -> CInt -> IO Double + +cvGetNormalizedCentralMoment (CvMoments p) xord yord = + withForeignPtr p (\ p' -> c_cvGetNormalizedCentralMoment p' xord yord ) + +foreign import ccall "cvGetHuMoments" + c_cvGetHuMoments :: Ptr CvMoments -> Ptr () -> IO () + +foreign import ccall "c_cvDrawContours" + c_cvDrawContours :: Ptr IplImage + -> Contour + -> Ptr CvScalar -- ^ RGBA external_color + -> Ptr CvScalar -- ^ RGBA hole_color + -> CInt -- max level + -> CInt -- thickness + -> CInt -- line-type + -> Ptr CvPoint -- offset + -> IO () + +cvDrawContours :: + Ptr IplImage + -> Contour + -> CvScalar -- ^ external color + -> CvScalar -- ^ hole color + -> CInt -- ^ max level + -> CInt -- ^ thickness + -> CInt -- ^ line type + -> CvPoint -- ^ offset + -> IO () +cvDrawContours img contour external_color hole_color max_level thickness line_type offset = + with external_color $ \ec -> + with hole_color $ \ hc -> + with offset $ \offset' -> + c_cvDrawContours img contour ec hc max_level thickness line_type offset' + + +cvGetHuMoments :: CvMoments -> IO CvHuMoments +cvGetHuMoments (CvMoments m) = allocaBytes (# size CvHuMoments ) $ \p -> do + withForeignPtr m $ \m' -> c_cvGetHuMoments m' p + h1 <- (#peek CvHuMoments, hu1) p + h2 <- (#peek CvHuMoments, hu2) p + h3 <- (#peek CvHuMoments, hu3) p + h4 <- (#peek CvHuMoments, hu4) p + h5 <- (#peek CvHuMoments, hu5) p + h6 <- (#peek CvHuMoments, hu6) p + h7 <- (#peek CvHuMoments, hu7) p + return (CvHuMoments h1 h2 h3 h4 h5 h6 h7) + +newtype Contour = Contour (Ptr (CvSeq (CInt, CInt))) + +-- | abstract. Use 'cvGetSpatialMoment' etc. +newtype CvMoments = CvMoments (ForeignPtr CvMoments) + +data CvHuMoments = CvHuMoments !Double !Double !Double !Double !Double !Double !Double + deriving Show + +-- |Contour extraction mode. +data ContourMode = CV_RETR_EXTERNAL -- ^retrieves only the extreme + -- outer contours + + | CV_RETR_LIST -- ^retrieves all of the contours + -- and puts them in the list + + | CV_RETR_CCOMP -- ^retrieves all of the contours + -- and organizes them into a + -- two-level hierarchy: on the top + -- level are the external + -- boundaries of the components, + -- on the second level are the + -- boundaries of the holes + + | CV_RETR_TREE -- ^retrieves all of the contours + -- and reconstructs the full + -- hierarchy of nested contours + | CV_RETR_FLOODFILL + deriving (Enum, Eq) + +data ContourMethod = CV_CHAIN_CODE -- ^ ?? + | CV_CHAIN_APPROX_NONE + -- ^translates all of the points from the chain + -- code into points + + | CV_CHAIN_APPROX_SIMPLE + -- ^compresses horizontal, vertical, and diagonal + -- segments and leaves only their end points + + | CV_CHAIN_APPROX_TC89_L1 + -- ^applies one of the flavors of the Teh-Chin + -- chain approximation algorithm + + | CV_CHAIN_APPROX_TC89_KCOS + -- ^applies one of the flavors of the Teh-Chin + -- chain approximation algorithm + + | CV_LINK_RUNS + -- ^uses a completely different contour retrieval + -- algorithm by linking horizontal segments of + -- 1's. Only the CV_RETR_LIST retrieval mode can be + -- used with this method. + deriving Enum + +-- |The function retrieves 'CvContour's from the binary image using the +-- algorithm Suzuki85. The contours are a useful tool for shape +-- analysis and object detection and recognition. +-- +-- only does @CV_RETR_LIST CV_CHAIN_APPROX_SIMPLE@ +-- +withContourList :: Image Monochromatic d roi -> (Contour -> IO r) -> IO [r] +withContourList img fn = withIplImage img $ \imgPtr -> do + storage <- cvCreateMemStorage 0 + cseq <- new nullPtr + n <- c_cvFindContours (fromArr imgPtr) storage + cseq + (#size CvContour) + (fromIntegral (fromEnum CV_RETR_LIST)) + (fromIntegral (fromEnum CV_CHAIN_APPROX_SIMPLE)) 0 0 + cs <- mapContours fn n . Contour =<< peek cseq + cvReleaseMemStorage storage + free cseq + return cs + +mapContours :: (Contour -> IO b) -> CInt -> Contour -> IO [ b ] +mapContours fn n (Contour p0) = go [] n p0 where + go acc 0 p = return $ reverse acc + go acc n p | p == nullPtr = return $ reverse acc + go acc n p = do + b <- fn (Contour p) + p' <- (#peek CvSeq, h_next) p + go (b:acc) (n-1) p' + +followPoints :: Contour -> IO [(CInt, CInt)] +followPoints (Contour p) = do + m <- (#peek CvSeq, total) p + alloca $ \x -> alloca $ \y -> + let go (-1) acc = return acc + go ni acc = do + c_cvGetSeqPoint p ni x y + xy <- liftM2 (,) (peek x) (peek y) + go (ni-1) (xy : acc) + in go ((m::CInt) - 1) [] + diff --git a/src/OpenCV/Core/CV.hsc b/src/OpenCV/Core/CV.hsc new file mode 100644 index 0000000..c0cedd5 --- /dev/null +++ b/src/OpenCV/Core/CV.hsc @@ -0,0 +1,148 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, ScopedTypeVariables #-} +-- |Support for features from the OpenCV Image Filtering library. +module OpenCV.Core.CV + ( InterpolationMethod(..), + cvResize, cvDilate, cvErode, cvPyrDown, cvHoughLines2, + --CvHaarClassifierCascade, HaarDetectFlag, + --cvHaarFlagNone, cvHaarDoCannyPruning, + --cvHaarScaleImage, cvHaarFindBiggestObject, cvHaarDoRoughSearch, + --combineHaarFlags, cvHaarDetectObjects, + cvCvtColor, + cvSampleLine, Connectivity(..) + ) where + +import Foreign.C.Types +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (peekArray) +import Foreign.Storable (Storable, sizeOf) +import Foreign.Ptr +import OpenCV.Core.CxCore +import OpenCV.Core.ColorConversion + +#include + +data InterpolationMethod = CV_INTER_NN + | CV_INTER_LINEAR + | CV_INTER_CUBIC + | CV_INTER_AREA + deriving (Enum,Eq) + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvResize" + c_cvResize :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () + +cvResize :: (IplArrayType i1, IplArrayType i2) => Ptr i1 -> Ptr i2 -> InterpolationMethod -> IO () +cvResize src dst interp = c_cvResize (fromArr src) (fromArr dst) (fromIntegral . fromEnum $ interp) + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvDilate" + c_dilate :: Ptr CvArr -> Ptr CvArr -> Ptr () -> CInt -> IO () + +-- |Dilate the first image using a 3x3 rectangular structuring element +-- and store the result in the second image. The third parameter is +-- the number of dilation iterations to perform. +cvDilate :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () +cvDilate src dst iter = c_dilate (fromArr src) (fromArr dst) nullPtr iter + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvErode" + c_erode :: Ptr CvArr -> Ptr CvArr -> Ptr () -> CInt -> IO () + +-- |Erode the first image using a 3x3 rectangular structuring element +-- and store the result in the second image. The third parameter is +-- the number of erosion iterations to perform. +cvErode :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () +cvErode src dst iter = c_erode src dst nullPtr iter + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvHoughLines2" + c_cvHoughLines2 :: Ptr CvArr -> Ptr CvMemStorage -> CInt -> CDouble -> CDouble -> CInt -> CDouble -> CDouble -> IO (Ptr (CvSeq a)) + +cvHoughLines2 :: IplArrayType i => Ptr i -> Ptr CvMemStorage -> CInt -> Double -> Double -> Int -> Double -> Double -> IO (Ptr (CvSeq a)) +cvHoughLines2 img storage method rho theta threshold param1 param2 = + c_cvHoughLines2 (fromArr img) storage method (realToFrac rho) + (realToFrac theta) (fromIntegral threshold) + (realToFrac param1) (realToFrac param2) + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvCvtColor" + c_cvCvtColor :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvSampleLine" + c_cvSampleLine :: Ptr CvArr -> CInt -> CInt -> CInt -> CInt -> Ptr a -> + CInt -> IO CInt + +-- |Line connectivity used for sampling. +data Connectivity = Four | Eight + +-- |Read all of the image points lying on the line between pt1 and +-- pt2, including the end points. Takes an image, two points, and the +-- line connectivity; returns all the pixel values along that line. +cvSampleLine :: forall a b. (IplArrayType a, Storable b) => + Ptr a -> (Int,Int) -> (Int,Int) -> Connectivity -> IO [b] +cvSampleLine img (x1,y1) (x2,y2) c = + do nc <- getNumChannels (castPtr img) + allocaBytes (sz'*nc) $ + \buffer -> do n <- c_cvSampleLine (fromArr img) (fi x1) (fi y1) + (fi x2) (fi y2) buffer c' + peekArray ((fromIntegral n)*nc) buffer + where fi = fromIntegral + (sz,c') = case c of + Four -> (abs (x2 - x1) + abs (y2 - y1) + 1, 4) + Eight -> (max (abs (x2 - x1) + 1) (abs (y2 - y1) + 1), 8) + sz' = sizeOf (undefined::b) * sz + +-- |Convert the color of the first 'IplImage', storing the result in +-- the second. The second image must have the same dimensions as the +-- first and the same depth, but it's number of color channels may be +-- different and must be compatible with the given 'ColorConversion' +-- code. +cvCvtColor :: Ptr CvArr -> Ptr CvArr -> ColorConversion -> IO () +cvCvtColor src dst code = c_cvCvtColor (fromArr src) (fromArr dst) (colorConv code) + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvPyrDown" + c_cvPyrDown :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () + +-- for now only one filter type is supported so no need for the CInt (filter type) +constCvGaussian5x5 :: CInt +constCvGaussian5x5 = 7 +cvPyrDown :: (IplArrayType i1, IplArrayType i2) => Ptr i1 -> Ptr i2 -> IO () +cvPyrDown src dst = c_cvPyrDown (fromArr src) (fromArr dst) constCvGaussian5x5 + +------------------------------------------------------------------------------ +{- +data CvHaarClassifierCascade + +-- thanks to http://book.realworldhaskell.org/read/interfacing-with-c-the-ffi.html +newtype HaarDetectFlag = HaarDetectFlag { unHaarDetectFlag :: CInt } + deriving (Eq, Show) + +#{enum HaarDetectFlag, HaarDetectFlag + , cvHaarFlagNone = 0 + , cvHaarDoCannyPruning = CV_HAAR_DO_CANNY_PRUNING + , cvHaarScaleImage = CV_HAAR_SCALE_IMAGE + , cvHaarFindBiggestObject = CV_HAAR_FIND_BIGGEST_OBJECT + , cvHaarDoRoughSearch = CV_HAAR_DO_ROUGH_SEARCH + } + +combineHaarFlags :: [HaarDetectFlag] -> HaarDetectFlag +combineHaarFlags = HaarDetectFlag . foldr ((.|.) . unHaarDetectFlag) 0 + +foreign import ccall "HOpenCV_wrap.h c_cvHaarDetectObjects" + c_cvHaarDetectObjects :: Ptr CvArr -- ^ image + -> Ptr CvHaarClassifierCascade -- ^ cascade + -> Ptr CvMemStorage -- ^ storage + -> CDouble -- ^ scale_factor + -> CInt -- ^ min_neighbors + -> CInt -- ^ flags + -> CInt -> CInt -- ^ min_size + -> IO (Ptr (CvSeq CvRect)) + +cvHaarDetectObjects :: (IplArrayType i) => + Ptr i -- ^ image + -> Ptr CvHaarClassifierCascade -- ^ cascade + -> Ptr CvMemStorage -- ^ storage + -> CDouble -- ^ scale_factor + -> CInt -- ^ min_neighbors + -> HaarDetectFlag -- ^ flags + -> CvSize -- ^ min_size + -> IO (Ptr (CvSeq CvRect)) +cvHaarDetectObjects image cascade storage scaleFactor minNeighbors flags minSize = + c_cvHaarDetectObjects (fromArr image) cascade storage scaleFactor minNeighbors (unHaarDetectFlag flags) (sizeWidth minSize) (sizeHeight minSize) + +-} \ No newline at end of file diff --git a/src/OpenCV/Core/CVOp.hs b/src/OpenCV/Core/CVOp.hs new file mode 100644 index 0000000..45fc6b3 --- /dev/null +++ b/src/OpenCV/Core/CVOp.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, + TypeSynonymInstances, CPP, DataKinds, KindSignatures, GADTs #-} +-- |Combinators that fuse compositions of image processing operations +-- for in-place mutation. +-- +-- The 'cv' wrapper is intended for operations that take a single +-- array argument, and mutate that array in-place. A canonical example +-- is a function that draws lines on an image. Compositions of such +-- operations may all mutate the same image in-place, but an argument +-- given to the composition, or indeed given to a standalone operation +-- of this variety, must be duplicated before being operated upon. +-- +-- In contrast, the 'cv2' wrapper is for operations that take separate +-- @src@ and @dst@ (source and destination) arguments. When the image +-- types of these arguments are the same, it is possible to supply the +-- same value for both arguments, thus avoiding an image allocation. A +-- standalone operation of this variety, or a composition beginning +-- with such an operation, must have a destination image +-- allocated. This is cheaper than duplicating the input image as with +-- operations wrapped by the `cv` combinator. +module OpenCV.Core.CVOp (cv, Inplace(..)) where +import OpenCV.Core.CxCore (IplArrayType, CvArr) +import OpenCV.Core.ImageUtil +import OpenCV.Core.Image +import Control.Monad (void) +import Data.Int +import Data.Monoid +import Foreign.ForeignPtr +import Foreign.Ptr +import System.IO.Unsafe +import Data.Word (Word8, Word16) + +-- |A CV operation is an IO function on a 'Image'. +newtype CVOp (c::Channels) d = CVOp { op :: Ptr CvArr -> IO () } + +-- |A wrapper for operations that mutate an array in-place. The input +-- to such operations must be duplicated before being passed to the +-- operation. +cv :: forall a c d e r1 r2. + (HasDepth d, IplArrayType e, UpdateROI r2) => + (Ptr e -> IO a) -> Image c d r1 -> Image c d r2 +--cv = runCV . mkCVOp +cv f img@Image{} = runCV (mkCVOp f) img + where mkCVOp :: (Ptr e -> IO a) -> CVOp c d + mkCVOp f = CVOp (void . f. castPtr) +{-# INLINE cv #-} + +instance Monoid (CVOp c d) where + mempty = CVOp . const $ return () + CVOp f `mappend` CVOp g = CVOp (\x -> g x >> f x) + {-# INLINE mappend #-} + +withClone :: UpdateROI r2 => + (Ptr e -> IO a) -> Image c d r1 -> IO (Image c d r2) +withClone f img@Image{} = duplicateImagePtr img >>= + flip withForeignPtr (\x -> f (castPtr x) >> peekIpl x) + +-- |Run a 'CVOp'. +runCV :: UpdateROI r2 => CVOp c d -> Image c d r1 -> Image c d r2 +runCV = (unsafeDupablePerformIO .) . withClone . op +{-# NOINLINE runCV #-} + +-- Apply a binary function to the same argument twice. +dupArg :: (Ptr e -> Ptr e -> IO a) -> Ptr e -> IO a +dupArg f = \x -> f x x + +-- |Wrapper for operations that want an argument /and/ a compatible +-- destination buffer, but don't need a clone of an input. +cv2Alloc :: forall a c1 d1 c2 d2 e r. (HasDepth d1, HasDepth d2, SingI c2) => + (Ptr e -> Ptr e -> IO a) -> Image c1 d1 r -> Image c2 d2 r +cv2Alloc = runBinOp . mkBinOp + where mkBinOp :: (Ptr e -> Ptr e -> IO a) -> BinOp c1 d1 c2 d2 + mkBinOp f = BinOp (\x y -> void (f (castPtr x) (castPtr y))) +{-# INLINE cv2Alloc #-} + +bi2unary :: BinOp c d c d -> CVOp c d +bi2unary = CVOp . dupArg . binop + +unary2bi :: CVOp c d -> BinOp c d c d +unary2bi = BinOp . const . op + +-- |Some operations benefit from operating in-place over a defined +-- region-of-interest (ROI). If an operation must recompute every +-- pixel of the result image, then there is no need to initialize a +-- fresh destination image to the contents of the source +-- image. However, if we will only be recomputing a ROI of the source +-- image, then the result image should be initialized as a copy of the +-- source image so that its contents outside the ROI match the +-- original image. +class (HasDepth d1, HasDepth d2, SingI c2) => + Inplace (r::ROIEnabled) (c1::Channels) d1 (c2::Channels) d2 where + cv2 :: IplArrayType e => + (Ptr e -> Ptr e -> IO a) -> Image c1 d1 r -> Image c2 d2 r + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +-- | We clone an image and operate within its ROI if the source and +-- destination images are compatible (same number of channels and +-- pixel depth). +instance (c1~c2, HasDepth d, SingI c2) => Inplace HasROI c1 d c2 d where + cv2 = cv . dupArg + {-# INLINE [1] cv2 #-} + +instance (HasDepth d1, HasDepth d2) => + Inplace HasROI Trichromatic d1 Monochromatic d2 where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance (HasDepth d1, HasDepth d2) => + Inplace HasROI Monochromatic d1 Trichromatic d2 where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance SingI c2 => Inplace HasROI c1 Word8 c2 Float where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance SingI c2 => Inplace HasROI c1 Word8 c2 Word16 where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance SingI c2 => Inplace HasROI c1 Word8 c2 Double where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance SingI c2 => Inplace HasROI c1 Word16 c2 Word8 where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance SingI c2 => Inplace HasROI c1 Float c2 Word8 where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +instance (HasDepth d1, HasDepth d2, SingI c2) => Inplace NoROI c1 d1 c2 d2 where + cv2 = cv2Alloc + {-# INLINE [1] cv2 #-} + +-- If the source and destination are not compatible, then it doesn't +-- matter if there is a ROI set as we can never operate in-place. +instance SingI c2 => Inplace HasROI c1 Word8 c2 Int16 where + +instance SingI c2 => Inplace HasROI c1 Float c2 Word16 where + +instance SingI c2 => Inplace HasROI c1 Float c2 Int16 where + +instance SingI c2 => Inplace HasROI c1 Float c2 Double where + +instance SingI c2 => Inplace HasROI c1 Word16 c2 Int16 where + +instance SingI c2 => Inplace HasROI c1 Word16 c2 Float where + +instance SingI c2 => Inplace HasROI c1 Word16 c2 Double where + +instance SingI c2 => Inplace HasROI c1 Double c2 Float where + +instance SingI c2 => Inplace HasROI c1 Double c2 Word16 where + +instance SingI c2 => Inplace HasROI c1 Double c2 Word8 where + +instance SingI c2 => Inplace HasROI c1 Double c2 Int16 where + +instance SingI c2 => Inplace HasROI c1 Int16 c2 Word8 where + +instance SingI c2 => Inplace HasROI c1 Int16 c2 Word16 where + +-- |This can be in-place due to the common representation. +instance SingI c2 => Inplace HasROI c1 Int16 c2 Float where + +newtype BinOp (c1::Channels) d1 (c2::Channels) d2 = + BinOp { binop :: Ptr CvArr -> Ptr CvArr -> IO () } + +-- Compose 'BinOp's for in-place mutation when the types allow it. +cbop :: BinOp c d c d -> BinOp c0 d0 c d -> BinOp c0 d0 c d +cbop (BinOp f) (BinOp g) = BinOp $ \x y -> g x y >> f y y + +withDst :: (HasDepth d1, HasDepth d2, IplArrayType e, SingI c2) => + (Ptr e -> Ptr e -> IO a) -> + Image c1 d1 r -> IO (Image c2 d2 r) +withDst f img = do img2' <- mallocImage (width img) (height img) + let img2 = updateROI (roi img) img2' + _ <- withIplImage img2 go + return img2 + where go x = withIplImage img (flip f (castPtr x) . castPtr) + +runBinOp :: (HasDepth d1, HasDepth d2, SingI c2) => + BinOp c1 d1 c2 d2 -> Image c1 d1 r -> Image c2 d2 r +runBinOp = (unsafeDupablePerformIO .) . withDst . binop +{-# NOINLINE runBinOp #-} + +{-# RULES "runCV/fuse" + forall f g x. runCV f (runCV g x) = runCV (f <> g) x #-} + +{-# RULES "runBinOp/fuse" + forall f g x. runBinOp f (runBinOp g x) = runBinOp (cbop f g) x #-} + +{-# RULES "runCV/runBinOp/fuse" + forall f g x. runCV f (runBinOp g x) = runBinOp (cbop (unary2bi f) g) x #-} + +{-# RULES "runBinOp/runCV/fuse" + forall f g x. runBinOp f (runCV g x) = runCV (bi2unary f <> g) x #-} diff --git a/src/OpenCV/Core/ColorConversion.hsc b/src/OpenCV/Core/ColorConversion.hsc new file mode 100644 index 0000000..bb07d4c --- /dev/null +++ b/src/OpenCV/Core/ColorConversion.hsc @@ -0,0 +1,84 @@ +-- |Constants for color conversion +module OpenCV.Core.ColorConversion where +import Foreign.C.Types (CInt) + +#include + +newtype ColorConversion = ColorConversion { colorConv :: CInt } deriving Eq + +-- Note: See Util/ColorConversion.hs for a script to convert the C +-- #defines to the below hsc2hs code. +#{enum ColorConversion, ColorConversion + , cv_BGR2BGRA = CV_BGR2BGRA + , cv_RGB2RGBA = CV_RGB2RGBA + , cv_BGRA2BGR = CV_BGRA2BGR + , cv_RGBA2RGB = CV_RGBA2RGB + , cv_BGR2RGBA = CV_BGR2RGBA + , cv_RGB2BGRA = CV_RGB2BGRA + , cv_RGBA2BGR = CV_RGBA2BGR + , cv_BGRA2RGB = CV_BGRA2RGB + , cv_BGR2RGB = CV_BGR2RGB + , cv_RGB2BGR = CV_RGB2BGR + , cv_BGRA2RGBA = CV_BGRA2RGBA + , cv_RGBA2BGRA = CV_RGBA2BGRA + , cv_BGR2GRAY = CV_BGR2GRAY + , cv_RGB2GRAY = CV_RGB2GRAY + , cv_GRAY2BGR = CV_GRAY2BGR + , cv_GRAY2RGB = CV_GRAY2RGB + , cv_GRAY2BGRA = CV_GRAY2BGRA + , cv_GRAY2RGBA = CV_GRAY2RGBA + , cv_BGRA2GRAY = CV_BGRA2GRAY + , cv_RGBA2GRAY = CV_RGBA2GRAY + , cv_BGR2BGR565 = CV_BGR2BGR565 + , cv_RGB2BGR565 = CV_RGB2BGR565 + , cv_BGR5652BGR = CV_BGR5652BGR + , cv_BGR5652RGB = CV_BGR5652RGB + , cv_BGRA2BGR565 = CV_BGRA2BGR565 + , cv_RGBA2BGR565 = CV_RGBA2BGR565 + , cv_BGR5652BGRA = CV_BGR5652BGRA + , cv_BGR5652RGBA = CV_BGR5652RGBA + , cv_GRAY2BGR565 = CV_GRAY2BGR565 + , cv_BGR5652GRAY = CV_BGR5652GRAY + , cv_BGR2BGR555 = CV_BGR2BGR555 + , cv_RGB2BGR555 = CV_RGB2BGR555 + , cv_BGR5552BGR = CV_BGR5552BGR + , cv_BGR5552RGB = CV_BGR5552RGB + , cv_BGRA2BGR555 = CV_BGRA2BGR555 + , cv_RGBA2BGR555 = CV_RGBA2BGR555 + , cv_BGR5552BGRA = CV_BGR5552BGRA + , cv_BGR5552RGBA = CV_BGR5552RGBA + , cv_GRAY2BGR555 = CV_GRAY2BGR555 + , cv_BGR5552GRAY = CV_BGR5552GRAY + , cv_BGR2XYZ = CV_BGR2XYZ + , cv_RGB2XYZ = CV_RGB2XYZ + , cv_XYZ2BGR = CV_XYZ2BGR + , cv_XYZ2RGB = CV_XYZ2RGB + , cv_BGR2YCrCb = CV_BGR2YCrCb + , cv_RGB2YCrCb = CV_RGB2YCrCb + , cv_YCrCb2BGR = CV_YCrCb2BGR + , cv_YCrCb2RGB = CV_YCrCb2RGB + , cv_BGR2HSV = CV_BGR2HSV + , cv_RGB2HSV = CV_RGB2HSV + , cv_BGR2Lab = CV_BGR2Lab + , cv_RGB2Lab = CV_RGB2Lab + , cv_BayerBG2BGR = CV_BayerBG2BGR + , cv_BayerGB2BGR = CV_BayerGB2BGR + , cv_BayerRG2BGR = CV_BayerRG2BGR + , cv_BayerGR2BGR = CV_BayerGR2BGR + , cv_BayerBG2RGB = CV_BayerBG2RGB + , cv_BayerGB2RGB = CV_BayerGB2RGB + , cv_BayerRG2RGB = CV_BayerRG2RGB + , cv_BayerGR2RGB = CV_BayerGR2RGB + , cv_BGR2Luv = CV_BGR2Luv + , cv_RGB2Luv = CV_RGB2Luv + , cv_BGR2HLS = CV_BGR2HLS + , cv_RGB2HLS = CV_RGB2HLS + , cv_HSV2BGR = CV_HSV2BGR + , cv_HSV2RGB = CV_HSV2RGB + , cv_Lab2BGR = CV_Lab2BGR + , cv_Lab2RGB = CV_Lab2RGB + , cv_Luv2BGR = CV_Luv2BGR + , cv_Luv2RGB = CV_Luv2RGB + , cv_HLS2BGR = CV_HLS2BGR + , cv_HLS2RGB = CV_HLS2RGB + } \ No newline at end of file diff --git a/src/OpenCV/Core/CxCore.hsc b/src/OpenCV/Core/CxCore.hsc new file mode 100644 index 0000000..f12f17e --- /dev/null +++ b/src/OpenCV/Core/CxCore.hsc @@ -0,0 +1,442 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeFamilies #-} +module OpenCV.Core.CxCore where +import Control.Applicative +import Control.Monad ((>=>)) +import Foreign.C.Types +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import System.IO.Error (modifyIOError) +import Data.VectorSpace as VectorSpace + +#include + +------------------------------------------------------ +toFromIntegral :: (RealFrac c, Integral b, Integral a, Num b1) => (b1 -> c) -> a -> b +toFromIntegral f = round . f . fromIntegral + +toFromIntegral2 :: (Integral a, Num b, Integral a1, Num b1, RealFrac a2, Integral b2) => + (b -> b1 -> a2) -> a -> a1 -> b2 +toFromIntegral2 f x y = round (f (fromIntegral x) (fromIntegral y)) +------------------------------------------------------ + +data CvSize = CvSize { sizeWidth :: CInt, sizeHeight :: CInt } + deriving (Show, Eq) +instance Storable CvSize where + sizeOf _ = (#size CvSize) + alignment _ = alignment (undefined :: CInt) + peek ptr = do + w <- (#peek CvSize, width) ptr + h <- (#peek CvSize, height) ptr + return (CvSize w h) + poke ptr (CvSize w h) = do + (#poke CvSize, width) ptr w + (#poke CvSize, height) ptr h + +--liftCvSize ::(RealFrac c, Num b) => (b -> c) -> CvSize -> CvSize +--liftCvSize f (CvSize w h) = CvSize (f' w) (f' h) +-- where f' = toFromIntegral f +liftCvSize :: (CInt -> CInt) -> CvSize -> CvSize +liftCvSize f (CvSize w h) = CvSize (f w) (f h) + +-- liftCvSize2 :: (Num b, Num b1, RealFrac a) => (b -> b1 -> a) -> CvSize -> CvSize -> CvSize +-- liftCvSize2 f (CvSize w1 h1) (CvSize w2 h2) = CvSize (f' w1 w2) (f' h1 h2) +-- where f' = toFromIntegral2 f +liftCvSize2 :: (CInt -> CInt -> CInt) -> CvSize -> CvSize -> CvSize +liftCvSize2 f (CvSize w1 h1) (CvSize w2 h2) = CvSize (f w1 w2) (f h1 h2) + +instance AdditiveGroup CvSize where + zeroV = CvSize 0 0 + (^+^) = liftCvSize2 (+) + negateV = liftCvSize (0 -) + +instance VectorSpace CvSize where + type Scalar CvSize = Double -- todo: use CInt instead of Double here? + a *^ s = liftCvSize (floor . (a*) . fromIntegral) s + +data CvRect = CvRect { rectX :: {-# UNPACK #-} !CInt + , rectY :: {-# UNPACK #-} !CInt + , rectWidth :: {-# UNPACK #-} !CInt + , rectHeight :: {-# UNPACK #-} !CInt } + deriving (Show, Eq) + +instance Storable CvRect where + sizeOf _ = (#size CvRect) + alignment _ = alignment (undefined :: CInt) + peek ptr = do + x <- (#peek CvRect, x) ptr + y <- (#peek CvRect, y) ptr + w <- (#peek CvRect, width) ptr + h <- (#peek CvRect, height) ptr + return (CvRect x y w h) + poke ptr (CvRect x y w h) = do + (#poke CvRect, x) ptr x + (#poke CvRect, y) ptr y + (#poke CvRect, width) ptr w + (#poke CvRect, height) ptr h + +-- |Apply a function to each component of a 'CvRect'. +-- liftCvRect :: (RealFrac c, Num b) => (b -> c) -> CvRect -> CvRect +-- liftCvRect f (CvRect x y w h) = CvRect (f' x) (f' y) (f' w) (f' h) +-- where f' = toFromIntegral f +liftCvRect :: (CInt -> CInt) -> CvRect -> CvRect +liftCvRect f (CvRect x y w h) = CvRect (f x) (f y) (f w) (f h) + +-- liftCvRect2 :: (Num b, Num b1, RealFrac a) => (b -> b1 -> a) -> CvRect -> CvRect -> CvRect +-- liftCvRect2 f (CvRect x1 y1 w1 h1) (CvRect x2 y2 w2 h2) = CvRect (f' x1 x2) (f' y1 y2) (f' w1 w2) (f' h1 h2) +-- where f' = toFromIntegral2 f +liftCvRect2 :: (CInt -> CInt -> CInt) -> CvRect -> CvRect -> CvRect +liftCvRect2 f (CvRect x1 y1 w1 h1) (CvRect x2 y2 w2 h2) = + CvRect (f x1 x2) (f y1 y2) (f w1 w2) (f h1 h2) + +instance AdditiveGroup CvRect where + zeroV = CvRect 0 0 0 0 + (^+^) = liftCvRect2 (+) + negateV = liftCvRect (0 -) + +instance VectorSpace CvRect where + type Scalar CvRect = Double -- todo: use CInt instead of Double here? + a *^ r = liftCvRect (round . (a*) . fromIntegral) r + +data CvPoint = CvPoint {-# UNPACK #-} !CInt {-# UNPACK #-} !CInt + +instance Storable CvPoint where + sizeOf _ = (#size CvPoint) + alignment _ = alignment (undefined :: CInt) + peek ptr = CvPoint <$> (#peek CvPoint, x) ptr + <*> (#peek CvPoint, y) ptr + poke ptr (CvPoint x y) = (#poke CvPoint, x) ptr x >> + (#poke CvPoint, y) ptr y + + +data CvScalar = CvScalar {-# UNPACK #-} !CDouble + {-# UNPACK #-} !CDouble + {-# UNPACK #-} !CDouble + {-# UNPACK #-} !CDouble + deriving Show + +instance Storable CvScalar where + sizeOf _ = (#size CvScalar) + alignment _ = alignment (undefined :: CDouble) + peek ptr = do [x,y,z,w] <- peekArray 4 $ (#ptr CvScalar, val) ptr + return $ CvScalar x y z w + poke ptr (CvScalar x y z w) = pokeArray ((#ptr CvScalar, val) ptr) + [x,y,z,w] + +liftCvScalar :: (CDouble -> CDouble) -> CvScalar -> CvScalar +liftCvScalar f (CvScalar x y z w) = CvScalar (f x) (f y) (f z) (f w) + +instance AdditiveGroup CvScalar where + zeroV = CvScalar 0 0 0 0 + CvScalar x1 y1 z1 w1 ^+^ CvScalar x2 y2 z2 w2 = + CvScalar (x1+x2) (y1+y2) (z1+z2) (w1+w2) + negateV = liftCvScalar (0 -) + +instance VectorSpace CvScalar where + type Scalar CvScalar = CDouble + a *^ s = liftCvScalar (a*) s + +------------------------------------------------------ +-- |A 'CvContour' has a bounding 'CvRect' and a color. +data CvContour = CvContour CvRect Int deriving (Show, Eq) + +instance Storable CvContour where + sizeOf _ = (#size CvContour) + alignment _ = alignment (undefined::CDouble) + peek ptr = do + rect <- (#peek CvContour, rect) ptr + color <- (#peek CvContour, color) ptr + return $ CvContour rect color + poke ptr (CvContour r c) = do + (#poke CvContour, rect) ptr r + (#poke CvContour, color) ptr c + +------------------------------------------------------ +class IplArrayType a + +data CvArr +instance IplArrayType CvArr + +data IplImage +instance IplArrayType IplImage + +instance Storable IplImage where + sizeOf _ = (#size IplImage) + alignment _ = alignment (undefined::CDouble) + +data CvMemStorage + +data CvSeq a + +fromArr :: IplArrayType a => Ptr a -> Ptr CvArr +fromArr = castPtr + +newtype Depth = Depth { unDepth :: CInt } + deriving (Eq, Show) + +#{enum Depth, Depth + , iplDepth1u = IPL_DEPTH_1U + , iplDepth8u = IPL_DEPTH_8U + , iplDepth8s = IPL_DEPTH_8S + , iplDepth16u = IPL_DEPTH_16U + , iplDepth16s = IPL_DEPTH_16S + , iplDepth32s = IPL_DEPTH_32S + , iplDepth32f = IPL_DEPTH_32F + , iplDepth64f = IPL_DEPTH_64F +} + +validDepths :: [Depth] +validDepths = [iplDepth1u, iplDepth8u, iplDepth8s, iplDepth16u, + iplDepth16s, iplDepth32s, iplDepth32f, iplDepth64f] + +depthsLookupList :: [(CInt, Depth)] +depthsLookupList = map (\d -> (unDepth d, d)) validDepths + +numToDepth :: CInt -> Maybe Depth +numToDepth x = lookup x depthsLookupList + + +--------------------------------------------------------------- +-- mem storage +foreign import ccall "opencv2/core/core_.h cvCreateMemStorage" + c_cvCreateMemStorage :: CInt -> IO (Ptr CvMemStorage) + +cvCreateMemStorage :: CInt -> IO (Ptr CvMemStorage) +cvCreateMemStorage = errorName "Failed to create mem storage" . checkPtr . c_cvCreateMemStorage + +-- foreign import ccall "HOpenCV_wrap.h release_mem_storage" +-- cvReleaseMemStorage :: Ptr CvMemStorage -> IO () + +foreign import ccall "opencv2/core/core_c.h cvReleaseMemStorage" + c_cvReleaseMemStorage :: Ptr (Ptr CvMemStorage) -> IO () + +cvReleaseMemStorage :: Ptr CvMemStorage -> IO () +cvReleaseMemStorage mem = alloca $ \p -> poke p mem >> c_cvReleaseMemStorage p + +foreign import ccall "HOpenCV_wrap.h &release_mem_storage" + cp_release_mem_storage :: FunPtr (Ptr CvMemStorage -> IO ()) + +createMemStorageF :: CInt -> IO (ForeignPtr CvMemStorage) +createMemStorageF = (createForeignPtr cp_release_mem_storage) . cvCreateMemStorage + +-- images / matrices / arrays + +foreign import ccall "HOpenCV_wrap.h create_image" + c_cvCreateImage :: CInt -> CInt -> CInt -> CInt -> IO (Ptr IplImage) + +-- |Allocate memory for an 'IplImage' with the given dimensions, +-- number of color channels, and color depth. +cvCreateImage :: CvSize -> CInt -> Depth -> IO (Ptr IplImage) +cvCreateImage size numChans depth = + errorName "Failed to create image" . checkPtr $ + c_cvCreateImage (sizeWidth size) (sizeHeight size) (unDepth depth) numChans + +-- foreign import ccall "HOpenCV_wrap.h release_image" +-- cvReleaseImage :: Ptr IplImage -> IO () +foreign import ccall "opencv2/core/core_c.h cvReleaseImage" + c_cvReleaseImage :: Ptr (Ptr IplImage) -> IO () + +-- |Release the memory allocated to an 'IplImage'. +cvReleaseImage :: Ptr IplImage -> IO () +cvReleaseImage mem = alloca $ \p -> poke p mem >> c_cvReleaseImage p + +foreign import ccall "HOpenCV_wrap.h &release_image" + cp_release_image :: FunPtr (Ptr IplImage -> IO ()) + +createImageF :: CvSize -> CInt -> Depth -> IO (ForeignPtr IplImage) +createImageF x y z = createForeignPtr cp_release_image $ cvCreateImage x y z + +foreign import ccall "opencv2/core/core_c.h cvCloneImage" + c_cvCloneImage :: Ptr IplImage -> IO (Ptr IplImage) + +cloneImage :: Ptr IplImage -> IO (Ptr IplImage) +cloneImage = errorName "Failed to clone image" . checkPtr . c_cvCloneImage + +cloneImageF :: Ptr IplImage -> IO (ForeignPtr IplImage) +cloneImageF x = createForeignPtr cp_release_image $ cloneImage x + +foreign import ccall "HOpenCV_wrap.h get_size" + c_get_size :: Ptr CvArr -> Ptr CvSize -> IO () + +foreign import ccall "opencv2/core/core_c.h cvCopy" + c_cvCopy :: Ptr CvArr -> Ptr CvArr -> Ptr CvArr -> IO () + +-- todo add mask support +cvCopy :: IplArrayType a => Ptr a -> Ptr a -> IO () +cvCopy src dst = c_cvCopy (fromArr src) (fromArr dst) nullPtr + +cvGetSize :: IplArrayType a => Ptr a -> IO CvSize +cvGetSize p = alloca $ \cvSizePtr -> do + c_get_size (castPtr p) cvSizePtr + size <- peek cvSizePtr + return size + +foreign import ccall "HOpenCV_wrap.h get_depth" + c_get_depth :: Ptr IplImage -> IO CInt + +getDepth :: Ptr IplImage -> IO Depth +getDepth img = do + depthInt <- c_get_depth img + case numToDepth depthInt of + Nothing -> fail "Bad depth in image struct" + Just depth -> return depth + +foreign import ccall "HOpenCV_wrap.h get_nChannels" + c_get_nChannels :: Ptr IplImage -> IO CInt + +getNumChannels :: Integral a => Ptr IplImage -> IO a +getNumChannels img = fmap fromIntegral $ c_get_nChannels img + + +foreign import ccall "opencv/cxcore.h cvConvertScale" + cvConvertScale :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> IO () + +foreign import ccall "HOpenCV_wrap.h cv_free" + cvFree :: Ptr a -> IO () + +foreign import ccall "HOpenCV_wrap.h &cv_free" + cvFreePtr :: FunPtr (Ptr a -> IO ()) + +foreign import ccall "opencv2/core/core_c.h cvLoad" + c_cvLoad :: CString -> Ptr CvMemStorage -> CString -> Ptr CString -> IO (Ptr a) + +cvLoad :: String -> Ptr CvMemStorage -> Maybe String -> IO (Ptr a, Maybe String) +cvLoad filename memstorage name = withCString filename cvLoad' + where cvLoad' filenameC = do + case name of + Nothing -> cvLoad'' filenameC nullPtr + Just n' -> withCString n' $ cvLoad'' filenameC + cvLoad'' filenameC nameC = alloca $ \ptrRealNameC -> do + ptrObj <- errorName "cvLoad failed" . checkPtr $ c_cvLoad filenameC memstorage nameC ptrRealNameC + realNameC <- peek ptrRealNameC + realName <- if realNameC == nullPtr + then return Nothing + else fmap Just $ peekCString realNameC + cvFree realNameC + return (ptrObj, realName) + +foreign import ccall "opencv2/core/core_c.h cvGetSeqElem" + cvGetSeqElem :: Ptr (CvSeq a) -> CInt -> IO (Ptr a) + +-- foreign import ccall "HOpenCV_wrap.h c_rect_cvGetSeqElem" +-- cvGetSeqElemRect :: Ptr (CvSeq (Ptr CvRect)) -> CInt -> IO (Ptr CvRect) + +foreign import ccall "HOpenCV_wrap.h seq_total" + seqNumElems :: Ptr (CvSeq a) -> IO CInt + +seqToPList :: Ptr (CvSeq a) -> IO [Ptr a] +seqToPList pseq = do + numElems <- seqNumElems pseq + mapM (cvGetSeqElem pseq) [1..(numElems)] + +seqToList :: Storable a => Ptr (CvSeq a) -> IO [a] +seqToList pseq = do + numElems <- seqNumElems pseq + flip mapM [1..(numElems)] $ \i -> do + elemP <- cvGetSeqElem pseq i + elem' <- peek elemP + return elem' + +-- seqToRectList :: Ptr (CvSeq (Ptr CvRect)) -> IO [CvRect] +-- seqToRectList pseq = do +-- numElems <- seqNumElems pseq +-- flip mapM [1..(numElems)] $ \i -> do +-- rectP <- cvGetSeqElemRect pseq i +-- rect <- peek rectP +-- return rect + +foreign import ccall "HOpenCV_wrap.h c_cvRectangle" + c_cvRectangle :: Ptr CvArr -> CInt -> CInt -> CInt -> CInt -> IO () + +cvRectangle :: IplArrayType a => Ptr a -> CvRect -> IO () +cvRectangle dst (CvRect x y w h) = c_cvRectangle (fromArr dst) x y w h + +foreign import ccall "HOpenCV_wrap.h c_cvLine" + c_cvLine :: Ptr CvArr -> CInt -> CInt -> CInt -> CInt -> + CDouble -> CDouble -> CDouble -> CInt -> + CInt -> CInt -> IO () + +cvLine :: Ptr CvArr -> (Int, Int) -> (Int, Int) -> + (Double, Double, Double) -> Int -> Int -> IO () +cvLine dst (x1,y1) (x2,y2) (r,g,b) thickness lineType = + c_cvLine (fromArr dst) (fi x1) (fi y1) (fi x2) (fi y2) + (fr r) (fr g) (fr b) (fi thickness) (fi lineType) 0 + where fi = fromIntegral + fr = realToFrac + +foreign import ccall "opencv2/core/core_c.h cvFillConvexPoly" + c_cvFillConvexPoly :: Ptr CvArr -> Ptr CInt -> CInt -> CDouble -> CDouble -> CDouble -> CDouble -> CInt -> CInt -> IO () + +data CvFont +instance Storable CvFont where + sizeOf _ = (#size CvFont) + alignment _ = alignment (undefined::CDouble) + +italicFont :: CInt +italicFont = (#const CV_FONT_ITALIC) + +foreign import ccall "opencv2/core/core_c.h cvInitFont" + cvInitFont :: Ptr CvFont -> CInt -> CDouble -> CDouble -> CDouble -> + CInt -> CInt -> IO () + +foreign import ccall "opencv2/core/core_c.h cvPutText" + cvPutText :: Ptr CvArr -> CString -> CInt -> CInt -> Ptr CvFont -> + CDouble -> CDouble -> CDouble -> IO () + +newtype ArrayNorm = ArrayNorm { unNorm :: CInt } + deriving (Eq, Show) +#{enum ArrayNorm, ArrayNorm + , cv_C = CV_C + , cv_L1 = CV_L1 + , cv_L2 = CV_L2 + , cv_NormMask = CV_NORM_MASK + , cv_Relative = CV_RELATIVE + , cv_Diff = CV_DIFF + , cv_MinMax = CV_MINMAX } + +foreign import ccall "opencv2/core/core_c.h cvNormalize" + cvNormalize :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> CInt -> + Ptr CvArr -> IO () + +newtype CmpOp = CmpOp { unCmpOp :: CInt } +#{enum CmpOp, CmpOp + , cmpEq = CV_CMP_EQ + , cmpGT = CV_CMP_GT + , cmpGE = CV_CMP_GE + , cmpLT = CV_CMP_LT + , cmpLE = CV_CMP_LE + , cmpNE = CV_CMP_NE } + +-- |Convert null pointers to 'Nothing' and non-null pointers to 'Just' +-- values. +ptrToMaybe :: Ptr a -> Maybe (Ptr a) +ptrToMaybe p = if p == nullPtr then Nothing else Just p + +-- |Add a 'String' name to a thrown error. +-- NOTE: adapated from the allocated-processor packge. +errorName :: String -> IO a -> IO a +errorName = modifyIOError . const . userError + +-- |Fail if an action results in a null pointer. +-- NOTE: adapted from the allocated-processor package. +checkPtr :: IO (Ptr a) -> IO (Ptr a) +checkPtr = (>>= aux) + where aux r | r == nullPtr = fail "Null Pointer" + | otherwise = return r + +-- |Wrap a 'ForeignPtr' around a 'Ptr' after checking that the 'Ptr' +-- is non-null. The supplied finalizer is attached to the +-- 'ForeignPtr'. +-- NOTE: adapted from the allocated-processor package. +createForeignPtr :: FunPtr (Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a) +createForeignPtr = (checkPtr >=>) . newForeignPtr + +------------------------------------------------------------------------------ +-- Debugging stuff, not part of opencv + +-- | Debugging function to print some of the internal details of an IplImage structure +foreign import ccall "HOpenCV_wrap.h debug_print_image_header" + c_debug_print_image_header :: Ptr IplImage -> IO () diff --git a/src/AI/CV/OpenCV/HOpenCV_wrap.c b/src/OpenCV/Core/HOpenCV_wrap.c similarity index 53% rename from src/AI/CV/OpenCV/HOpenCV_wrap.c rename to src/OpenCV/Core/HOpenCV_wrap.c index 6ae3121..9948d25 100644 --- a/src/AI/CV/OpenCV/HOpenCV_wrap.c +++ b/src/OpenCV/Core/HOpenCV_wrap.c @@ -1,6 +1,11 @@ -#include -#include -#include +#ifdef OCV21 +#include +#include +#else +#include +#include +#include +#endif #include @@ -18,10 +23,13 @@ void debug_print_image_header(IplImage *image) "\twidth: %d\n" "\theight: %d\n" "\timageSize: %d\n" - "\twidthStep: %d\n", + "\timageData: %p\n" + "\twidthStep: %d\n" + "\timageDataOrigin: %p\n", image->nSize, image->ID, image->nChannels, image->alphaChannel, image->depth, image->dataOrder, image->origin, image->align, - image->width, image->height, image->imageSize, image->widthStep); + image->width, image->height, image->imageSize, image->imageData, + image->widthStep, image->imageDataOrigin); } /****************************************************************************/ @@ -32,6 +40,12 @@ void release_capture(CvCapture *capture) cvReleaseCapture(&temp); } +void release_video_writer(CvVideoWriter *writer) +{ + CvVideoWriter *temp = writer; + cvReleaseVideoWriter(&temp); +} + /****************************************************************************/ void num_to_name(int num, char *name, int length) @@ -97,6 +111,14 @@ void dilate(const CvArr *src, CvArr *dest, int iterations) cvDilate(src, dest, NULL, iterations); } +CvVideoWriter* cvCreateVideoWriter2( const char* filename, int fourcc, + double fps, int frame_x, int frame_y, + int is_color CV_DEFAULT(1)) +{ + return cvCreateVideoWriter(filename, fourcc, fps, cvSize(frame_x, frame_y), is_color); +} + + /**********************************************************/ void release_mem_storage(CvMemStorage *mem_store) @@ -117,6 +139,12 @@ int seq_total(const CvSeq *seq) { return seq->total; } +void c_cvGetSeqPoint(const CvSeq *seq, int i, int*x, int*y) { + CvPoint* p = CV_GET_SEQ_ELEM( CvPoint, seq, i); + *x = p->x; + *y = p->y; +} + /* Commonly used case of CV_GET_SEQ_ELEM is CvRect-typed elements. The macro CV_GET_SEQ_ELEM is supposed to be faster in some cases than the function cvGetSeqElem. */ @@ -133,14 +161,96 @@ void c_cvRectangle(CvArr *img, int x, int y, int width, int height) CV_RGB(255,0,0), 3 , 8, 0); } -/****************************************************************************/ +void c_cvLine(CvArr *img, int x1, int y1, int x2, int y2, double r, double g, + double b, int thickness, int lineType, int shift) +{ + cvLine(img, cvPoint(x1,y1), cvPoint(x2,y2), CV_RGB(r,g,b), thickness, + lineType, shift); +} + +CvFont defaultFont; +unsigned char defaultFontInitialized = 0; + +void c_cvPutText(CvArr *img, const char* msg, int x, int y, + double r, double g, double b) +{ + if(!defaultFontInitialized) + { + cvInitFont(&defaultFont, CV_FONT_HERSHEY_SIMPLEX, 1.0, 1.0, 0.0, 1, 8); + defaultFontInitialized = 1; + } + cvPutText(img, msg, cvPoint(x,y), &defaultFont, CV_RGB(r,g,b)); +} + +int c_cvFindContours(CvArr *img, CvMemStorage *storage, CvSeq** first_contour, + int header_size, int mode, int method, int offset_x, + int offset_y) +{ + return cvFindContours(img, storage, first_contour, header_size, mode, + method, cvPoint(offset_x,offset_y)); +} + + +double c_cvContourArea( const CvArr *contour) +{ + return cvContourArea( contour, CV_WHOLE_SEQ, 0 ); +} + + +void c_cvMoments( const CvArr* arr, CvMoments* moments) +{ + cvMoments( arr, moments, 0); +} + +double c_cvContourPerimeter( const void* contour) +{ + cvContourPerimeter(contour); +} + +// int c_cvFollowContourList + +void c_cvSetRoi(IplImage* img, int x, int y, int width, int height) +{ + cvSetImageROI(img, cvRect(x,y,width,height)); +} + +void c_cvGetROI(IplImage* img, int* rptr) +{ + CvRect r = cvGetImageROI(img); + rptr[0] = r.x; + rptr[1] = r.y; + rptr[2] = r.width; + rptr[3] = r.height; +} + +void c_cvAvg(const CvArr *img, const CvArr *mask, CvScalar* avg) +{ + CvScalar s = cvAvg(img, mask); + memcpy(avg, &s, sizeof(CvScalar)); +} + + +void c_cvDrawContours( CvArr * img, CvSeq* contour, + CvScalar * external_color, + CvScalar * hole_color, + int max_level, int max_thickness, int line_type, CvPoint * offset ) +{ + cvDrawContours( img, contour, *external_color, *hole_color, + max_level, max_thickness, line_type, *offset); +} + + + +/****************************************************************************/ +/* CvSeq *c_cvHaarDetectObjects( const CvArr* image, CvHaarClassifierCascade* cascade, CvMemStorage* storage, double scale_factor, int min_neighbors , int flags, - int width, int height) + int min_width, int min_height, + int max_width, int max_height) { - return cvHaarDetectObjects(image, cascade, storage, scale_factor, min_neighbors, flags, cvSize(width, height)); + return cvHaarDetectObjects(image, cascade, storage, scale_factor, min_neighbors, flags, cvSize(min_width, min_height), cvSize(max_width, max_height)); } - +*/ diff --git a/src/OpenCV/Core/HOpenCV_wrap.h b/src/OpenCV/Core/HOpenCV_wrap.h new file mode 100644 index 0000000..67eb8be --- /dev/null +++ b/src/OpenCV/Core/HOpenCV_wrap.h @@ -0,0 +1,70 @@ +#ifdef OCV21 +#include +#include +#else +#include +#include +#endif + +void debug_print_image_header(IplImage *image); + +void release_capture(CvCapture *capture); +void release_video_writer(CvVideoWriter *writer); + + +void new_window(int num, int flags); +void del_window(int num); +void show_image(int num, IplImage *image); + +IplImage *create_image(int width, int height, int depth, int channels); +void release_image(IplImage *image); + +void get_size(const CvArr *arr, CvSize *size); +int get_depth(const IplImage *image); +int get_nChannels(const IplImage *image); + +void dilate(const CvArr *src, CvArr *dest, int iterations); + +void release_mem_storage(CvMemStorage *mem_store); +void cv_free(void *obj); + +int seq_total(const CvSeq *seq); +/* CvRect *c_rect_cvGetSeqElem(const CvSeq *seq, int index); */ + +void c_cvGetSeqPoint(const CvSeq *seq, int i, int*x, int*y); + + +CvVideoWriter* cvCreateVideoWriter(const char* filename, int fourcc, + double fps, int frame_x, int frame_y, int is_color); + +void c_cvRectangle(CvArr *img, int x, int y, int width, int height); + +void c_cvLine(CvArr *img, int x1, int y1, int x2, int y2, double r, double g, + double b, int thickness, int lineType, int shift); + +void c_cvSetRoi(IplImage* img, int x, int y, int width, int height); +void c_cvGetROI(IplImage* img, int* rptr); + +void c_cvPutText(CvArr *img, const char* msg, int x, int y, + double r, double g, double b); + +int c_cvFindContours(CvArr *img, CvMemStorage *storage, CvSeq** first_contour, + int header_size, int mode, int method, int offset_x, + int offset_y); + +double c_cvContourArea( const CvArr *contour); +double c_cvContourPerimeter( const void* contour); + +void c_cvAvg(const CvArr *img, const CvArr *mask, CvScalar* avg); + +CvSeq *c_cvHaarDetectObjects( const CvArr* image, + CvHaarClassifierCascade* cascade, + CvMemStorage* storage, double scale_factor, + int min_neighbors , int flags, + int width, int height); + + +void c_cvDrawContours( CvArr * img, CvSeq* contour, + CvScalar * external_color, + CvScalar * hole_color, + int max_level, int max_thickness, int line_type, CvPoint * offset ); diff --git a/src/OpenCV/Core/HighGui.hsc b/src/OpenCV/Core/HighGui.hsc new file mode 100644 index 0000000..b05facb --- /dev/null +++ b/src/OpenCV/Core/HighGui.hsc @@ -0,0 +1,262 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module OpenCV.Core.HighGui + (cvLoadImage, LoadColor(..), cvSaveImage, + CvCapture, cvCreateCameraCapture, + createCameraCaptureF, createFileCaptureF, + cvCreateFileCapture, setCapturePos, + CapturePos(..), cvQueryFrame, + newWindow, delWindow, showImage, cvWaitKey, + cvConvertImage, c_debug_ipl, + createVideoWriterF, cvWriteFrame, FourCC, toFourCC, + cvNamedWindow, cvDestroyWindow, cvShowImage, WindowFlag(..), + MouseCallback, cvSetMouseCallback, wrapMouseCB, cvInit, + windowFlagsToEnum, Event(..), EventFlag(..)) where + +import Data.Bits ((.&.), (.|.), shiftL) +import Foreign.C.Types +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.String + +import Data.List (foldl') +import OpenCV.Core.CxCore + +import Foreign.Marshal.Array + +#include + +------------------------------------------------ +-- General +foreign import ccall "opencv2/highgui/highgui_c.h cvConvertImage" + c_cvConvertImage :: Ptr CvArr -> Ptr CvArr -> CInt -> IO () + +cvConvertImage :: (IplArrayType a, IplArrayType a1) => Ptr a -> Ptr a1 -> CInt -> IO () +cvConvertImage src dst flags = c_cvConvertImage (fromArr src) (fromArr dst) flags + +-- |Determine the color model of an image loaded from a file. +data LoadColor = LoadColor -- ^Force a 3-channel color image + | LoadGray -- ^Force a grayscale image + | LoadUnchanged -- ^Load the image as is + +instance Enum LoadColor where + fromEnum LoadColor = (#const CV_LOAD_IMAGE_COLOR) + fromEnum LoadGray = (#const CV_LOAD_IMAGE_GRAYSCALE) + fromEnum LoadUnchanged = (#const CV_LOAD_IMAGE_UNCHANGED) + toEnum (#const CV_LOAD_IMAGE_COLOR) = LoadColor + toEnum (#const CV_LOAD_IMAGE_GRAYSCALE) = LoadGray + toEnum (#const CV_LOAD_IMAGE_UNCHANGED) = LoadUnchanged + toEnum x = error $ "Unknown LoadColor enum "++show x + +foreign import ccall "opencv2/highgui/highgui_c.h cvLoadImage" + c_cvLoadImage :: CString -> CInt -> IO (Ptr IplImage) + +cvLoadImage :: String -> LoadColor -> IO (Ptr IplImage) +cvLoadImage fileName col = withCString fileName (flip c_cvLoadImage col') + where col' = fromIntegral $ fromEnum col + +foreign import ccall "HOpenCV_wrap.h debug_print_image_header" + c_debug_ipl :: Ptr IplImage -> IO () + +foreign import ccall safe "opencv2/highgui/highgui_c.h cvSaveImage" + c_cvSaveImage :: CString -> Ptr CvArr -> Ptr Int -> IO () + +cvSaveImage :: IplArrayType a => String -> Ptr a -> IO () +cvSaveImage fileName img = withCString fileName $ + \str -> c_cvSaveImage str (fromArr img) nullPtr + +------------------------------------------------ +-- Capturing +data CvCapture + + +foreign import ccall "opencv2/highgui/highgui_c.h cvCreateCameraCapture" + c_cvCreateCameraCapture :: CInt -> IO (Ptr CvCapture) + +cvCreateCameraCapture :: Int -> IO (Ptr CvCapture) +cvCreateCameraCapture = errorName "Failed to create camera" . checkPtr . + c_cvCreateCameraCapture . fromIntegral + +foreign import ccall "opencv2/highgui/highgui_c.h cvCreateFileCapture" + c_cvCreateFileCapture :: CString -> IO (Ptr CvCapture) + +cvCreateFileCapture :: String -> IO (Ptr CvCapture) +cvCreateFileCapture filename = err' . checkPtr $ + withCString filename c_cvCreateFileCapture + where err' = errorName $ "Failed to capture from file: '" ++ filename ++ "'" + +foreign import ccall "opencv2/highgui/highgui_c.h cvSetCaptureProperty" + c_cvSetCaptureProperty :: Ptr CvCapture -> CInt -> CDouble -> IO () + +-- |The current position of a video capture. +data CapturePos = PosMsec Double + -- ^Position in milliseconds or video timestamp. + | PosFrames Int + -- ^0-based index of the next frame to be decoded or captured. + | PosRatio Double + -- ^Relative position of the video file (0 = start, 1 = end). + +posEnum :: CapturePos -> (CInt, CDouble) +posEnum (PosMsec t) = (#{const CV_CAP_PROP_POS_MSEC}, realToFrac t) +posEnum (PosFrames n) = (#{const CV_CAP_PROP_POS_FRAMES}, fromIntegral n) +posEnum (PosRatio r) = (#{const CV_CAP_PROP_POS_AVI_RATIO}, realToFrac r) + +-- |Set the current position of a video capture. +setCapturePos :: Ptr CvCapture -> CapturePos -> IO () +setCapturePos cap pos = uncurry (c_cvSetCaptureProperty cap) $ posEnum pos + +-- foreign import ccall "HOpenCV_wrap.h release_capture" +-- release_capture :: Ptr CvCapture -> IO () + +foreign import ccall "HOpenCV_wrap.h &release_capture" + cp_release_capture :: FunPtr (Ptr CvCapture -> IO ()) + +createCameraCaptureF :: Int -> IO (ForeignPtr CvCapture) +createCameraCaptureF = createForeignPtr cp_release_capture . cvCreateCameraCapture + +createFileCaptureF :: String -> IO (ForeignPtr CvCapture) +createFileCaptureF = createForeignPtr cp_release_capture . cvCreateFileCapture + +foreign import ccall "opencv2/highgui/highgui_c.h cvQueryFrame" + c_cvQueryFrame :: Ptr CvCapture -> IO (Ptr IplImage) + +cvQueryFrame :: Ptr CvCapture -> IO (Maybe (Ptr IplImage)) +cvQueryFrame cap = ptrToMaybe `fmap` c_cvQueryFrame cap + +data CvVideoWriter + +type FourCC = (Char, Char, Char, Char) + +-- | Parse a four-character 'String' into a 'FourCC' code (e.g. "XVID"). +toFourCC :: String -> FourCC +toFourCC [a,b,c,d] = (a,b,c,d) +toFourCC c = error $ "Invalid FourCC code: "++c + +fourCC :: FourCC -> CInt +fourCC (a,b,c,d) = (c1 .&. 255) + shiftL (c2 .&. 255) 8 + + shiftL (c3 .&. 255) 16 + shiftL (c4 .&. 255) 24 + where [c1,c2,c3,c4] = map (fromIntegral . fromEnum) [a,b,c,d] + +foreign import ccall "HOpenCV_wrap.h cvCreateVideoWriter2" + c_cvCreateVideoWriter :: CString -> CInt -> CDouble -> CInt -> CInt -> CInt -> + IO (Ptr CvVideoWriter) + +foreign import ccall "HOpenCV_wrap.h &release_video_writer" + cp_release_writer :: FunPtr (Ptr CvVideoWriter -> IO ()) + +cvCreateVideoWriter :: FilePath -> FourCC -> Double -> (Int, Int) -> + IO (Ptr CvVideoWriter) +cvCreateVideoWriter fname codec fps (w,h) = do + withCString fname $ \str -> + c_cvCreateVideoWriter str (fourCC codec) (realToFrac fps) + (fromIntegral w) (fromIntegral h) 1 + +-- |Create a video file writer. +createVideoWriterF :: FilePath -> FourCC -> Double -> (Int, Int) -> + IO (ForeignPtr CvVideoWriter) +createVideoWriterF fname codec fps sz = + createForeignPtr cp_release_writer $ cvCreateVideoWriter fname codec fps sz + +foreign import ccall "opencv2/highgui/highgui_c.h cvWriteFrame" + cvWriteFrame :: Ptr CvVideoWriter -> Ptr IplImage -> IO () + +{- +foreign import ccall "opencv2/core/types_c.h cvSize" + cvSize :: Int -> Int -> IO (Ptr ()) +-} + +------------------------------------------------- +-- Windows +foreign import ccall "HOpenCV_wrap.h new_window" + c_newWindow :: CInt -> CInt -> IO () + +newWindow :: CInt -> Bool -> IO () +newWindow num autoSize = c_newWindow num (if autoSize then 1 else 0) + +foreign import ccall "HOpenCV_wrap.h del_window" + delWindow :: CInt -> IO () + +foreign import ccall "HOpenCV_wrap.h show_image" + showImage :: CInt -> Ptr IplImage -> IO () + +foreign import ccall "opencv2/highgui/highgui_c.h cvWaitKey" + cvWaitKey :: CInt -> IO CInt + +-- New Windowing Code + +foreign import ccall "opencv2/highgui/highgui_c.h cvInitSystem" + cvInitSystem :: CInt -> Ptr CString -> IO () + +cvInit :: IO () +cvInit = cvInitSystem 0 nullPtr + +foreign import ccall "opencv2/highgui/highgui_c.h cvNamedWindow" + cvNamedWindow :: CString -> CInt -> IO () + +foreign import ccall "opencv2/highgui/highgui_c.h cvDestroyWindow" + cvDestroyWindow :: CString -> IO () + +foreign import ccall "opencv2/highgui/highgui_c.h cvShowImage" + cvShowImage :: CString -> Ptr CvArr -> IO () + +type CMouseCallback = CInt -> CInt -> CInt -> CInt -> Ptr () -> IO () + +foreign import ccall "opencv2/highgui/highgui_c.h cvSetMouseCallback" + cvSetMouseCallback :: CString -> FunPtr CMouseCallback -> Ptr () -> IO () + +foreign import ccall "wrapper" + mkMouseCB :: CMouseCallback -> IO (FunPtr CMouseCallback) + +data WindowFlag = AutoSize + +windowFlagToEnum :: WindowFlag -> CInt +windowFlagToEnum AutoSize = #{const CV_WINDOW_AUTOSIZE} + +windowFlagsToEnum :: [WindowFlag] -> CInt +windowFlagsToEnum = foldl' (.|.) 0 . map windowFlagToEnum + +data Event = MouseMove | LButtonDown | RButtonDown | MButtonDown + | LButtonUp | RButtonUp | MButtonUp | LButtonDblClk + | RButtonDblClk | MButtonDblClk + +type MouseCallback = Event -> (Int,Int) -> [EventFlag] -> IO () + +wrapMouseCB :: MouseCallback -> IO (FunPtr CMouseCallback) +wrapMouseCB cb = mkMouseCB $ + \e x y f _ -> cb (enumToEvent e) + (fromIntegral x, fromIntegral y) + (enumToEventFlags f) + +enumToEvent :: CInt -> Event +enumToEvent (#const CV_EVENT_MOUSEMOVE) = MouseMove +enumToEvent (#const CV_EVENT_LBUTTONDOWN) = LButtonDown +enumToEvent (#const CV_EVENT_RBUTTONDOWN) = RButtonDown +enumToEvent (#const CV_EVENT_MBUTTONDOWN) = MButtonDown +enumToEvent (#const CV_EVENT_LBUTTONUP) = LButtonUp +enumToEvent (#const CV_EVENT_RBUTTONUP) = RButtonUp +enumToEvent (#const CV_EVENT_MBUTTONUP) = MButtonUp +enumToEvent (#const CV_EVENT_LBUTTONDBLCLK) = LButtonDblClk +enumToEvent (#const CV_EVENT_RBUTTONDBLCLK) = RButtonDblClk +enumToEvent (#const CV_EVENT_MBUTTONDBLCLK) = MButtonDblClk +enumToEvent x = error $ "Unkonwn event "++show x + +data EventFlag = LButton | RButton | MButton | CtrlKey | ShiftKey | AltKey + deriving (Enum, Bounded) + +eventFlagToEnum :: EventFlag -> CInt +eventFlagToEnum LButton = (#const CV_EVENT_FLAG_LBUTTON) +eventFlagToEnum RButton = (#const CV_EVENT_FLAG_RBUTTON) +eventFlagToEnum MButton = (#const CV_EVENT_FLAG_MBUTTON) +eventFlagToEnum CtrlKey = (#const CV_EVENT_FLAG_CTRLKEY) +eventFlagToEnum ShiftKey = (#const CV_EVENT_FLAG_SHIFTKEY) +eventFlagToEnum AltKey = (#const CV_EVENT_FLAG_ALTKEY) + +enumToEventFlags :: CInt -> [EventFlag] +enumToEventFlags x = map fst . filter snd $ + zip [minBound..maxBound] + (map ((> 0) . (x .|.)) + (map eventFlagToEnum [minBound..maxBound])) + +-- Qt fonts +-- foreign import ccall "opencv2/highgui/highgui_c.h cvFontQt" +-- cvFontQt :: CString -> CInt -> CDouble -> CDouble -> CDouble -> +-- CInt -> CInt -> CInt -> IO CvFont diff --git a/src/OpenCV/Core/Image.hsc b/src/OpenCV/Core/Image.hsc new file mode 100644 index 0000000..88d8e1e --- /dev/null +++ b/src/OpenCV/Core/Image.hsc @@ -0,0 +1,370 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, ScopedTypeVariables, + TypeFamilies, MultiParamTypeClasses, FlexibleInstances, GADTs, + BangPatterns, FlexibleContexts, TypeSynonymInstances, + DataKinds, TemplateHaskell, ConstraintKinds #-} +{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-unused-binds #-} +module OpenCV.Core.Image ( + -- * Phantom types that statically describe image properties + Channels(..), ROIEnabled(..), + + -- * Value-level reification of type-level properties + HasDepth(..), + + -- * Typed support for image operations that take scalar (color) parameters + CvScalarT, AsCvScalar(..), ScalarOK, + + -- * Low-level image data structure + Image(..), mkImage, mallocImage, blackImage, blackoutPixels, + withIplImage, bytesPerPixel, numChannels, peekIpl, pokeIpl, + freeROI, c_cvSetImageROI, c_cvResetImageROI, setROI, resetROI, imageHasROI, + UpdateROI(..) + ) where +import OpenCV.Core.CxCore (IplImage,Depth(..),iplDepth8u, iplDepth16u, + iplDepth16s, iplDepth32f, iplDepth64f, cvFree, + CvRect(..), CvScalar(..)) +import OpenCV.Core.CV (cvCvtColor) +import OpenCV.Core.ColorConversion (cv_GRAY2BGR, cv_BGR2GRAY) +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Data.Bits (complement, (.&.)) +import Data.Int +import Data.Proxy +import Data.Singletons hiding (Proxy) +import Data.Singletons.TH +import Data.Word (Word8, Word16) +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (allocaArray, peekArray) +import Foreign.Ptr +import Foreign.Storable +import Unsafe.Coerce + +#include +{- +typedef struct _IplImage +{ + int nSize; + int ID; + int nChannels; + int alphaChannel; + int depth; + char colorModel[4]; + char channelSeq[4]; + int dataOrder; + int origin; + int align; + int width; + int height; + struct _IplROI *roi; + struct _IplImage *maskROI; + void *imageId; + struct _IplTileInfo *tileInfo; + int imageSize; + char *imageData; + int widthStep; + int BorderMode[4]; + int BorderConst[4]; + char *imageDataOrigin; +} +IplImage; +-} + +-- *Phantom types that statically describe image properties +data Channels = Trichromatic | Monochromatic +data ROIEnabled = HasROI | NoROI + +genSingletons [''Channels, ''ROIEnabled] + +-- NOTE: The singletons library defines various things for us that we +-- don't explicitly pattern match on or export, leading GHC to issue +-- unused binding warnings. We disable those warnings for this file. + +numChannels' :: Channels -> Int +numChannels' Trichromatic = 3 +numChannels' Monochromatic = 1 + +-- |Extract number of channels from the singleton value associated +-- with a type of the 'Channels' kind. +numChannels :: forall c. SingI c => Proxy (c::Channels) -> Int +numChannels _ = numChannels' . fromSing $ (sing::Sing c) + +hasROI :: forall r. SingI r => Proxy (r::ROIEnabled) -> Bool +hasROI _ = case fromSing (sing::Sing r) of + HasROI -> True + _ -> False + +imageHasROI :: forall c d r. SingI r => Image c d r -> Bool +imageHasROI _ = case fromSing (sing::Sing r) of + HasROI -> True + _ -> False + +class (Storable a, Num a) => HasDepth a where + depth :: a -> Depth + toDouble :: a -> Double + fromDouble :: Double -> a + +instance HasDepth Word8 where + depth _ = iplDepth8u + toDouble = fromIntegral + fromDouble = round +instance HasDepth Word16 where + depth _ = iplDepth16u + toDouble = fromIntegral + fromDouble = round +instance HasDepth Int16 where + depth _ = iplDepth16s + toDouble = fromIntegral + fromDouble = round +instance HasDepth Float where + depth _ = iplDepth32f + toDouble = realToFrac + fromDouble = realToFrac +instance HasDepth Double where + depth _ = iplDepth64f + toDouble = id + fromDouble = id + +-- |An image with a particular number of channels have an associated +-- scalar type built from the type of its pixels. This class lets us +-- ensure that a scalar value to be used in an operation with an image +-- is compatible with that image. +type family CvScalarT (c::Channels) d :: * +type instance CvScalarT Monochromatic d = d +type instance CvScalarT Trichromatic d = (d,d,d) + +type ScalarOK s c d = (AsCvScalar s, s ~ CvScalarT c d) + +-- |Scalar types are often round-tripped via doubles in OpenCV to +-- allow for non-overloaded interfaces of functions with scalar +-- parameters. +class AsCvScalar x where + toCvScalar :: x -> CvScalar + fromCvScalar :: CvScalar -> x + +instance AsCvScalar Word8 where + toCvScalar = depthToScalar + fromCvScalar (CvScalar r _ _ _) = floor r + +instance AsCvScalar Word16 where + toCvScalar = depthToScalar + fromCvScalar (CvScalar r _ _ _) = floor r + +instance AsCvScalar Int16 where + toCvScalar = depthToScalar + fromCvScalar (CvScalar r _ _ _) = floor r + +instance AsCvScalar Float where + toCvScalar = depthToScalar + fromCvScalar (CvScalar r _ _ _) = realToFrac r + +instance AsCvScalar Double where + toCvScalar = depthToScalar + fromCvScalar (CvScalar r _ _ _) = realToFrac r + +instance (HasDepth d, AsCvScalar d) => AsCvScalar (d,d,d) where + toCvScalar (r,g,b) = let f = realToFrac . toDouble + in CvScalar (f r) (f g) (f b) 0 + fromCvScalar (CvScalar r g b _) = let f = fromDouble . realToFrac + in (f r, f g, f b) + +depthToScalar :: HasDepth d => d -> CvScalar +depthToScalar x = let x' = realToFrac (toDouble x) + in CvScalar x' x' x' x' + +bytesPerPixel :: HasDepth d => d -> Int +bytesPerPixel = (`div` 8) . fromIntegral . unSign . unDepth . depth + where unSign = (complement #{const IPL_DEPTH_SIGN} .&.) + +-- |A data structure representing the information OpenCV uses from an +-- 'IplImage' struct. It includes the pixel origin, image width, image +-- height, image size (number of bytes), a pointer to the pixel data, +-- and the row stride. Its type is parameterized by the number of +-- color channels (i.e. 'Monochromatic' or 'Trichromatic'), the pixel +-- depth (e.g. 'Word8', 'Float'), and whether or not the image has a +-- region-of-interest (ROI) set ('HasROI' or 'NoROI'). +data Image (c::Channels) d (r::ROIEnabled) where + Image :: (SingI c, HasDepth d, SingI r, UpdateROI r) => + { origin :: !Int + , width :: !Int + , height :: !Int + , roi :: !(Maybe CvRect) + , imageSize :: !Int + , imageData :: !(ForeignPtr d) + , imageDataOrigin :: !(ForeignPtr d) + , widthStep :: !Int + } -> Image c d r + + +-- |@mkImage w h ptr@ makes an 'Image' of width, @w@, and height, @h@, +-- using pixel data at @ptr@. Pixels are assumed to be continuous, and +-- starting at the given pointer. +mkImage :: forall a c d. (Integral a, SingI c, HasDepth d) => + a -> a -> ForeignPtr d -> Image c d NoROI +mkImage w h pixels = Image 0 (fromIntegral w) (fromIntegral h) + Nothing (fromIntegral h*stride) pixels pixels stride + where stride = fromIntegral $ + fromIntegral w * numChannels (Proxy::Proxy c) * bytesPerPixel (undefined::d) + +-- |Set an image's region-of-interest. +setROI :: CvRect -> Image c d r -> Image c d HasROI +setROI r (Image o w h _ sz d ido ws) = Image o w h (Just r) sz d ido ws +{-# INLINE setROI #-} + +-- |Clear any region-of-interest set for an image. +resetROI :: forall c d r. Image c d r -> Image c d NoROI +resetROI x@(Image o w h _ sz d ido ws) + | hasROI (Proxy::Proxy r) = Image o w h Nothing sz d ido ws + | otherwise = unsafeCoerce x +{-# INLINE resetROI #-} + +-- |Prepare an 'Image' of the given width and height. The pixel and +-- color depths are gleaned from the type, and may often be inferred. +mallocImage :: forall a c d. (SingI c, HasDepth d, Integral a) => + a -> a -> IO (Image c d NoROI) +mallocImage w h = mkImage w h <$> mallocForeignPtrArray (fromIntegral numBytes) + where numBytes = fromIntegral (w * h) * + numChannels (Proxy::Proxy c) * bytesPerPixel (undefined::d) + +foreign import ccall "memset" + memset :: Ptr Word8 -> Word8 -> CInt -> IO () + +-- |Set an all of an 'Image'\'s pixels to black. +blackoutPixels :: Image c d r -> IO (Image c d r) +blackoutPixels img = do withForeignPtr (imageData img) $ \ptr -> + memset (castPtr ptr) 0 (fromIntegral $ imageSize img) + return img + +-- |Prepare an 'Image' of the given width and height with all pixels +-- set to zero. +blackImage :: (SingI c, HasDepth d, Integral a) => + a -> a -> IO (Image c d NoROI) +blackImage w h = mallocImage w h >>= blackoutPixels + +foreign import ccall "HOpenCV_wrap.h c_cvSetRoi" + c_cvSetImageROI :: Ptr IplImage -> CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "opencv2/core/core_c.h cvResetImageROI" + c_cvResetImageROI :: Ptr IplImage -> IO () + +withROI :: Image c d r -> Ptr IplImage -> (Ptr IplImage -> IO a) -> IO a +withROI img p f = case roi img of + Nothing -> f p + Just (CvRect x y w h) -> do c_cvSetImageROI p x y w h + r <- f p + c_cvResetImageROI p + return r + +-- |Provides the supplied function with a 'Ptr' to the 'IplImage' +-- underlying the given 'Image'. +withIplImage :: Image c d r -> (Ptr IplImage -> IO b) -> IO b +withIplImage img@(Image{}) f = alloca $ \p -> + withForeignPtr (imageData img) + (\hp -> do pokeIpl img p (castPtr hp) + withROI img p f) + +h2c :: Int -> CInt +h2c = fromIntegral + +c2h :: CInt -> Int +c2h = fromIntegral + +-- |Read a 'Image' from a 'Ptr' 'IplImage' +peekIpl :: (SingI c, HasDepth d, SingI r, UpdateROI r) => + Ptr IplImage -> IO (Image c d r) +peekIpl = peek . castPtr + +-- Poke a 'Ptr' 'IplImage' with a specific imageData 'Ptr' that is +-- currently valid. This is solely an auxiliary function to +-- 'withHIplImage'. +pokeIpl :: forall c d r. (SingI c, HasDepth d) => + Image (c::Channels) d r -> Ptr IplImage -> Ptr Word8 -> IO () +pokeIpl himg ptr hp = + do (#poke IplImage, nSize) ptr ((#size IplImage)::CInt) + (#poke IplImage, ID) ptr (0::CInt) + (#poke IplImage, nChannels) ptr (h2c $ numChannels (Proxy::Proxy c)) + (#poke IplImage, depth) ptr (unDepth (depth (undefined::d))) + (#poke IplImage, dataOrder) ptr (0::CInt) + (#poke IplImage, origin) ptr (h2c $ origin himg) + (#poke IplImage, align) ptr (4::CInt) + (#poke IplImage, width) ptr (h2c $ width himg) + (#poke IplImage, height) ptr (h2c $ height himg) + (#poke IplImage, roi) ptr nullPtr + (#poke IplImage, maskROI) ptr nullPtr + (#poke IplImage, imageId) ptr nullPtr + (#poke IplImage, tileInfo) ptr nullPtr + (#poke IplImage, imageSize) ptr (h2c $ imageSize himg) + (#poke IplImage, imageData) ptr hp + (#poke IplImage, widthStep) ptr (h2c $ widthStep himg) + (#poke IplImage, imageDataOrigin) ptr hp + +foreign import ccall "HOpenCV_wrap.h c_cvGetROI" + c_cvGetImageROI :: Ptr IplImage -> Ptr CInt -> IO () + +freeROI :: Ptr IplImage -> IO () +freeROI ptr = do p <- (#peek IplImage, roi) ptr + if (ptrToIntPtr p == 0) then return () else cvFree p + +maybePeekROI :: Ptr IplImage -> Ptr () -> IO (Maybe CvRect) +maybePeekROI img p | p == nullPtr = return Nothing + | otherwise = allocaArray 4 $ + \r -> do c_cvGetImageROI img r + [x,y,w,h] <- peekArray 4 r + return . Just $ CvRect x y w h + +-- |An internal class that makes runtime guarantees about type level +-- ROI assertions. +class SingI a => UpdateROI (a::ROIEnabled) where + updateROI :: Maybe CvRect -> Image c d a -> Image c d b + +-- These functions are runtime checks that type-level guarantees are +-- met. +instance UpdateROI NoROI where + updateROI Nothing x = unsafeCoerce $ resetROI x + updateROI _ _ = error "Tried to update the ROI of a NoROI Image" + +instance UpdateROI HasROI where + updateROI (Just r) x = unsafeCoerce $ setROI r x + updateROI _ _ = error "Tried to null out the ROI of a HasROI Image" + +-- |An 'Image' in Haskell conforms closely to OpenCV's 'IplImage' +-- structure type. Note that obtaining an 'Image' from an 'IplImage' +-- via 'peek' will not install a Haskell finalizer on the underlying +-- pixel data. That data is the responsibility of the provider of the +-- 'IplImage'. 'Image' values constructed within the Haskell runtime, +-- on the other hand, will have their underlying pixel data buffers +-- managed by the garbage collector. +instance forall c d r. (SingI c, HasDepth d, SingI r, UpdateROI r) => + Storable (Image c d r) where + sizeOf _ = (#size IplImage) + alignment _ = alignment (undefined :: CDouble) + poke = error "Poking a 'Ptr Image' is unsafe." + peek ptr = do + numChannels' <- c2h <$> (#peek IplImage, nChannels) ptr + depth' <- Depth <$> (#peek IplImage, depth) ptr + width' <- c2h <$> (#peek IplImage, width) ptr + height' <- c2h <$> (#peek IplImage, height) ptr + roir <- (#peek IplImage, roi) ptr >>= maybePeekROI (castPtr ptr) + when (depth' /= (depth (undefined::d))) + (error $ "IplImage has depth "++show depth'++ + " but desired Image has depth "++ + show (depth (undefined::d))) + if numChannels (Proxy::Proxy c) /= numChannels' + then do img2' <- mallocImage width' height' :: IO (Image c d NoROI) + let img2 = updateROI roir img2' :: Image c d r + let conv = if numChannels' == 1 + then cv_GRAY2BGR + else cv_BGR2GRAY + ptr' = castPtr ptr :: Ptr IplImage + withIplImage img2 $ \dst -> cvCvtColor (castPtr ptr') + (castPtr dst) + conv + (#peek IplImage, imageDataOrigin) ptr >>= cvFree + return $ unsafeCoerce img2 + else do origin' <- c2h <$> (#peek IplImage, origin) ptr + imageSize' <- c2h <$> (#peek IplImage, imageSize) ptr + imageData' <- (#peek IplImage, imageData) ptr >>= newForeignPtr_ + imageDataOrigin' <- (#peek IplImage, imageDataOrigin) ptr >>= newForeignPtr_ + widthStep' <- c2h <$> (#peek IplImage, widthStep) ptr + return $ Image origin' width' height' roir imageSize' + imageData' imageDataOrigin' widthStep' diff --git a/src/OpenCV/Core/ImageUtil.hs b/src/OpenCV/Core/ImageUtil.hs new file mode 100644 index 0000000..fedbf33 --- /dev/null +++ b/src/OpenCV/Core/ImageUtil.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns, MultiParamTypeClasses, + FlexibleInstances, DataKinds, KindSignatures #-} +-- |Functions for working with 'HIplImage's. +module OpenCV.Core.ImageUtil + (isColor, isMono, imgChannels, withPixelVector, pixelVector, + peekIpl, fromFileColor, fromFileGray, fromPGM16, toFile, + compatibleImage, duplicateImage, fromPixels, unsafePixelVector, + withImagePixels, fromGrayPixels, fromColorPixels, + withDuplicateImage, withCompatibleImage, setROI, resetROI, + mkImage, mallocImage, numPixels, blackImage, Image(..), + ROIEnabled(..), withIplImage, Channels(..), + GrayImage, GrayImage16, GrayImage16S, GrayImageF, ColorImage, + withDuplicatePixels, c_cvSetImageROI, c_cvResetImageROI, + HasDepth(..), CvScalarT, AsCvScalar(..), ScalarOK, + colorDepth, UpdateROI, SingI, withDuplicateRGBPixels, + ByteOrFloat, getRect, fromFile, unsafeWithHIplImage, + duplicateImagePtr, compatibleImagePtr, compatibleImagePtrPtr) where +import OpenCV.Core.CxCore (IplImage, cvFree, cvFreePtr, createImageF, + cloneImageF, cvCreateImage, CvSize(..), + getNumChannels, getDepth, cvGetSize) +import OpenCV.Core.HighGui (cvLoadImage, cvSaveImage, LoadColor(..)) +import OpenCV.Core.Image +import OpenCV.Color +import Control.Applicative +import Control.Arrow (second, (***)) +import Control.Monad (when, unless, join) +import Data.Int (Int16) +import Data.Proxy +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as VM +import Data.Singletons (SingI) +import Data.Word (Word8, Word16) +import Foreign.ForeignPtr +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr +import Foreign.Storable +import System.Directory (doesFileExist) +import System.IO (openFile, hGetLine, hGetBuf, hClose, hSetBinaryMode, + IOMode(..)) +import System.IO.Unsafe + +-- |Some operations are restricted to bytes or floats. +class (HasDepth a, Num a) => ByteOrFloat a where +instance ByteOrFloat Word8 where +instance ByteOrFloat Float where + +-- |Grayscale 8-bit (per-pixel) image type. +type GrayImage = Image Monochromatic Word8 NoROI + +-- |Grayscale unsigned 16-bit (per-pixel) image type. +type GrayImage16 = Image Monochromatic Word16 NoROI + +-- |Grayscale signed 16-bit (per-pixel) image type. +type GrayImage16S = Image Monochromatic Int16 NoROI + +-- |Grayscale single precision floating point image type. +type GrayImageF = Image Monochromatic Float NoROI + +-- |Color 8-bit (per-color) image type. +type ColorImage = Image Trichromatic Word8 NoROI + +-- |This is a way to let the type checker know that you belieave an +-- image to be tri-chromatic. If your image type can't be inferred any +-- other way, this is an alternative to adding a type annotation. +isColor :: Image Trichromatic d r -> Image Trichromatic d r +isColor = id + +-- |This is a way to let the type checker know that you believe an +-- image to be monochromatic. If your image type can't be inferred any +-- other way, this is an alternative to adding a type annotation. +isMono :: Image Monochromatic d r -> Image Monochromatic d r +isMono = id + +{-# INLINE isMono #-} +{-# INLINE isColor #-} + +-- |Return the number of color channels a 'HIplImage' has as a runtime +-- value. +imgChannels :: forall c d r. Image c d r -> Int +imgChannels Image{} = fromIntegral $ numChannels (Proxy::Proxy c) + +-- |Return the number of bytes per pixel color component of an +-- 'HIplImage'. +colorDepth :: forall c d r. Image c d r -> Int +colorDepth Image{} = bytesPerPixel (undefined::d) + +-- |The number of pixels in the image: @width img * height img@. +numPixels :: Image c d r -> Int +numPixels = fromIntegral . ((*) <$> width <*> height) + +-- |Apply the supplied function to a 'V.Vector' containing the pixels +-- that make up an 'HIplImage'. This does not copy the underlying +-- data. +withImagePixels :: Image c d NoROI -> (V.Vector d -> r) -> r +withImagePixels img@Image{} f = f $ V.unsafeFromForeignPtr (imageData img) 0 n + where n = fromIntegral (imageSize img) `div` colorDepth img + +-- |Apply the supplied function to a mutable 'VM.IOVector' containing +-- a copy of the pixel data from the input image. Returns the new +-- image and any result of the 'IO' action. +withDuplicatePixels :: Image c d NoROI -> (VM.IOVector d -> IO r) -> + IO (Image c d NoROI, r) +withDuplicatePixels img1@Image{} f = do img2 <- duplicateImage img1 + let ptr = imageDataOrigin img2 + r <- f $ VM.unsafeFromForeignPtr0 ptr n + return (img2, r) + where n = numPixels img1 * imgChannels img1 + +-- |Specialization of 'withDuplicatePixels' to ease the common case of +-- dealing with 8 bit triples for each pixel. +withDuplicateRGBPixels :: Image Trichromatic Word8 NoROI -> + (VM.IOVector RGB8 -> IO r) -> + IO (Image Trichromatic Word8 NoROI, r) +withDuplicateRGBPixels img1 f = do img2 <- duplicateImage img1 + let ptr = castForeignPtr $ + imageDataOrigin img2 + r <- f $ VM.unsafeFromForeignPtr0 ptr n + return (img2, r) + where n = numPixels img1 + +-- |Return a 'V.Vector' containing a copy of the pixels that make up +-- an 'Image'. +pixelVector :: forall c d. (HasDepth d, Storable d) => + Image c d NoROI -> V.Vector d +pixelVector img = unsafePerformIO $ + do ptr <- mallocForeignPtrBytes len + withForeignPtr ptr $ \dst -> + withForeignPtr (imageData img) $ \src -> + copyBytes dst src len + return $ V.unsafeFromForeignPtr0 ptr n + where len = fromIntegral $ imageSize img + n = len `quot` bytesPerPixel (undefined::d) +{-# NOINLINE pixelVector #-} + +-- |Return a 'V.Vector' pointing to the pixels that make up an +-- 'Image'. +unsafePixelVector :: forall c d. (HasDepth d, Storable d) => + Image c d NoROI -> V.Vector d +unsafePixelVector img = V.unsafeFromForeignPtr0 (imageData img) n + where n = imageSize img `quot` bytesPerPixel (undefined::d) + +-- Ensure that a file exists. +checkFile :: FilePath -> IO () +checkFile f = do e <- doesFileExist f + unless e (error $ "Can't find "++f) + +-- |Load a color 'HIplImage' from an 8-bit image file. If the image +-- file is grayscale, it will be converted to color. +fromFileColor :: FilePath -> IO (Image Trichromatic Word8 NoROI) +fromFileColor fileName = + do checkFile fileName + ptr <- cvLoadImage fileName LoadColor + img <- peekIpl ptr :: IO (Image Trichromatic Word8 NoROI) + addForeignPtrFinalizer cvFreePtr (imageDataOrigin img) + freeROI ptr + cvFree ptr + return img + +-- |Load a grayscale 'HIplImage' from an 8-bit image file. If the +-- image file is color, it will be converted to grayscale. +fromFileGray :: FilePath -> IO (Image Monochromatic Word8 NoROI) +fromFileGray fileName = + do checkFile fileName + ptr <- cvLoadImage fileName LoadGray + img <- peekIpl ptr :: IO (Image Monochromatic Word8 NoROI) + addForeignPtrFinalizer cvFreePtr (imageDataOrigin img) + return img + +-- |If the type of a loaded image is known (e.g. by a type annotation, +-- or usage of a narrowly typed functions), then we can automatically +-- dispatch to the proper image loading routine. +class LoadableFormat (c::Channels) d where + loadFormat :: (Proxy c,d) -> FilePath -> IO (Image c d NoROI) + +instance LoadableFormat Monochromatic Word8 where + loadFormat _ = fromFileGray + +instance LoadableFormat Trichromatic Word8 where + loadFormat _ = fromFileColor + +instance LoadableFormat Monochromatic Word16 where + loadFormat _ = fromPGM16 + +-- |An overloaded image file loader. The number of color channels and +-- color depth parts of the returned image's type must be inferrable +-- as they control how the image file is loaded. +fromFile :: forall c d. LoadableFormat c d => FilePath -> IO (Image c d NoROI) +fromFile = loadFormat (Proxy::Proxy c, undefined::d) + +-- |Load a grayscale 'HIplImage' from a 16-bit image file. NOTE: +-- OpenCV (as of v2.2) does not correctly handle 16-bit PGM loading, +-- so this 16bpp loader is restricted to PGM. This loading routine +-- converts from Most Significant Byte first (MSB) byte ordering (as +-- per the PGM spec) to LSB byte ordering for x86 compatibility. +fromPGM16 :: FilePath -> IO (Image Monochromatic Word16 NoROI) +fromPGM16 fileName = + do checkFile fileName + h <- openFile fileName ReadMode + magic <- hGetLine h + when (magic /= "P5") (hClose h >> + error (fileName ++" is not a PGM")) + (width, height) <- fmap ((read***read). second tail . break (==' ')) + (hGetLine h) :: IO (Int,Int) + maxCol <- hGetLine h + when (maxCol /= "65535") (hClose h >> + error (fileName ++" is not 16-bit")) + let numBytes = fromIntegral $ width*height*2 + fp <- mallocForeignPtrArray numBytes + hSetBinaryMode h True + withForeignPtr fp $ \ptr' -> + do let ptr = castPtr ptr' :: Ptr Word8 + n <- hGetBuf h ptr numBytes + when (n /= numBytes) (hClose h >> + error (fileName ++" unexpected EOF")) + let swapBytes !offset + | offset == numBytes = return () + | otherwise = do temp1 <- peekByteOff ptr offset :: IO Word8 + temp2 <- peekByteOff ptr (offset+1) :: IO Word8 + pokeByteOff ptr offset temp2 + pokeByteOff ptr (offset+1) temp1 + swapBytes (offset+2) + swapBytes 0 + hClose h + return $ mkImage width height fp + +-- |Save an image to the specified file. +toFile :: HasDepth d => FilePath -> Image c d r -> IO () +toFile fileName img = withIplImage img $ \ptr -> cvSaveImage fileName ptr + +-- |Allocate a new 'Image' with the same dimensions, number of color +-- channels, and color depth as an existing 'Image'. The pixel data of +-- the original 'Image' is not copied. +compatibleImage :: Image c d r -> IO (Image c d r) +compatibleImage img@Image{} = updateROI (roi img) <$> + mallocImage (width img) (height img) + +-- |Allocate a new 'IplImage' with the same dimensions, number of +-- color channels, and color depth as an existing 'HIplImage'. The +-- pixel data of the original 'HIplImage' is not copied. +compatibleImagePtr :: forall c d r. Image c d r -> IO (ForeignPtr IplImage) +compatibleImagePtr img@Image{} = createImageF (CvSize w' h') nc d + where w' = fromIntegral . width $ img + h' = fromIntegral . height $ img + nc = fromIntegral . imgChannels $ img + d = depth (undefined::d) + +compatibleImagePtrPtr :: Ptr IplImage -> IO (Ptr IplImage) +compatibleImagePtrPtr = + join . (liftA3 cvCreateImage <$> cvGetSize <*> getNumChannels <*> getDepth) + +-- |Create an exact duplicate of the given 'Image'. This allocates a +-- fresh array to store the copied pixels. +duplicateImage :: Image c d r -> IO (Image c d r) +duplicateImage img@Image{} = + do img' <- updateROI (roi img) <$> mallocImage (width img) (height img) + withForeignPtr (imageData img) $ \src -> + withForeignPtr (imageData img') $ \dst -> + copyBytes dst src (fromIntegral $ imageSize img) + return img' + +-- |Clone an 'Image', returning the 'Ptr' 'IplImage' underlying +-- the clone. +duplicateImagePtr :: Image c d r -> IO (ForeignPtr IplImage) +duplicateImagePtr = flip withIplImage cloneImageF + +-- |Pass the given function an 'Image' constructed from a width, a +-- height, and a 'V.Vector' of pixel values. The new 'Image'\'s pixel +-- data is shared with the supplied 'V.Vector'. In other words, this +-- lets the user apply a function on 'Image's to a 'V.Vector' of pixel +-- data. +withPixelVector :: forall a c d r. (HasDepth d, Integral a, SingI c) => + a -> a -> (Image c d NoROI -> r) -> V.Vector d -> r +withPixelVector w h f pix = if len == sz + then f $ mkImage w h fp + else error "Length disagreement" + where sz = fromIntegral (w * h) * numChannels (Proxy::Proxy c) + (fp,len) = case V.unsafeToForeignPtr (V.force pix) of + (fp,0,len) -> (fp,len) + _ -> error "fromPixels non-zero offset" + +-- |Construct a fresh 'Image' from a width, a height, and a 'V.Vector' +-- of pixel values. +fromPixels :: forall a c d. (Integral a, SingI c, HasDepth d) => + a -> a -> V.Vector d -> Image c d NoROI +fromPixels w h pix = unsafePerformIO $ + do fp <- copyData + return $ mkImage w h fp + where copyData = let (vfp,len) = V.unsafeToForeignPtr0 pix + in do fp <- mallocForeignPtrBytes len + withForeignPtr vfp $ \src -> + withForeignPtr fp $ \dst -> + copyBytes dst src len + return fp +{-# INLINE [0] fromPixels #-} + +-- |Helper function to explicitly type a vector of monochromatic pixel +-- data. Parameters are the output image's width, height, and pixel +-- content. +fromGrayPixels :: (HasDepth d, Integral a) => + a -> a -> V.Vector d -> Image Monochromatic d NoROI +fromGrayPixels w h = isMono . fromPixels w h + +-- |Helper function to explicitly type a vector of interleaved +-- trichromatic pixel data. Parameters are the output image's width, +-- height, and pixel content. +fromColorPixels :: (HasDepth d, Integral a) => + a -> a -> V.Vector d -> Image Trichromatic d NoROI +fromColorPixels w h = isColor . fromPixels w h + +-- |Provides the supplied function with a 'Ptr' to the 'IplImage' +-- underlying a new 'Image' that is an exact duplicate of the given +-- 'Image'. Returns the duplicate 'Image' after performing the given +-- action along with the result of that action. +withDuplicateImage :: Image c d r -> (Ptr IplImage -> IO b) -> + IO (Image c d r, b) +withDuplicateImage img1 f = do img2 <- duplicateImage img1 + r <- withIplImage img2 f + return (img2, r) + +-- |Provides the supplied function with a 'Ptr' to the 'IplImage' +-- underlying a new 'Image' of the same dimensions as the given +-- 'Image'. +withCompatibleImage :: Image c d r -> (Ptr IplImage -> IO b) -> + IO (Image c d r, b) +withCompatibleImage img1 f = do img2 <- compatibleImage img1 + r <- withIplImage img2 f + return (img2, r) + +unsafeWithHIplImage :: Image c d r -> (Ptr IplImage -> a) -> a +unsafeWithHIplImage img f = unsafePerformIO $ withIplImage img (return . f) + +-- |Extract a rectangular region of interest from an image. Returns a +-- new image whose pixel data is copied from the given rectangle of +-- the source image. Parameters are the upper-left corner of the +-- rectangle in image coordinates, the (width,height) of the rectangle +-- in pixels, and the source 'Image'. +getRect :: forall c d r. + (Int,Int) -> (Int,Int) -> Image c d r -> IO (Image c d NoROI) +getRect (rx,ry) (rw,rh) src@Image{} = + do img <- mallocImage rw rh :: IO (Image c d NoROI) + withForeignPtr (imageData img) $ \dst -> + withForeignPtr (imageData src) $ \src -> + mapM_ (\(dOff, sOff) -> copyBytes (plusPtr dst dOff) + (plusPtr src sOff) + rowLen) + (zip [0,rowLen..rw*rh*bpp-1] [start,start+stride..]) + return img + where stride = fromIntegral $ widthStep src + start = stride*ry + rx*bpp + bpp = imgChannels src * colorDepth src + rowLen = rw*bpp diff --git a/src/OpenCV/Core/StorableUtil.hs b/src/OpenCV/Core/StorableUtil.hs new file mode 100644 index 0000000..296e7b3 --- /dev/null +++ b/src/OpenCV/Core/StorableUtil.hs @@ -0,0 +1,7 @@ +module OpenCV.Core.StorableUtil where +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (Storable(poke)) +import Foreign.Ptr (Ptr) + +withS :: Storable a => a -> (Ptr a -> IO b) -> IO b +withS x f = alloca $ \ptr -> poke ptr x >> f ptr \ No newline at end of file diff --git a/src/OpenCV/Drawing.hsc b/src/OpenCV/Drawing.hsc new file mode 100644 index 0000000..708f07b --- /dev/null +++ b/src/OpenCV/Drawing.hsc @@ -0,0 +1,144 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module OpenCV.Drawing (prepFont, prepFontAlt, putText, FontFace(..), + LineType(..), RGB, drawLines, fillConvexPoly) where +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp +import OpenCV.Core.StorableUtil +import Data.Bits ((.|.)) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc (malloc) +import Foreign.Marshal.Array (withArray) +import Foreign.Ptr +import System.IO.Unsafe (unsafePerformIO) + +-- |The available font faces are a subset of the Hershey fonts. +data FontFace = NormalSans + | SmallSans + | ComplexSans + | NormalSerif + | ComplexSerif + | SmallSerif + | Script + | ComplexScript + deriving Enum + +initFont :: FontFace -> Bool -> CDouble -> CDouble -> CDouble -> CInt -> + LineType -> IO (Ptr CvFont) +initFont face italic hscale vscale shear thickness ltype = + do p <- malloc + cvInitFont p face' hscale vscale shear thickness lt + return p + where face' | italic = fi (fromEnum face) .|. italicFont + | otherwise = fi $ fromEnum face + lt = fi $ lineTypeEnum ltype + fi = fromIntegral + +-- |Default sans-serif font. +defaultFont :: Ptr CvFont +defaultFont = unsafePerformIO $ initFont NormalSans False 1 1 0 1 EightConn +{-# NOINLINE defaultFont #-} + +-- |Produce a text-drawing function given a font description. The +-- application @prepFont face italic hscale vscale thickness@ produces +-- a text-drawing function using a font with the given @face@ (which +-- may be @italic@), horizontal and verticale scale, and line +-- @thickness@. +prepFont :: (HasDepth d, UpdateROI r) => + FontFace -> Bool -> CDouble -> CDouble -> CInt -> + IO ((CInt, CInt) -> (CDouble, CDouble, CDouble) -> String -> + Image c d r -> Image c d r) +prepFont face italic hscale vscale thickness = + prepFontAlt face italic hscale vscale 0 thickness EightConn +{-# INLINE prepFont #-} + +#include + +#def void cvPutText_wrap(CvArr* img, const char* text, CvPoint* org,\ + const CvFont* font, CvScalar* color) {\ + cvPutText(img, text, *org, font, *color);\ +} + +foreign import ccall "cvPutText_wrap" + c_cvPutText :: Ptr CvArr -> CString -> Ptr CvPoint -> + Ptr CvFont -> Ptr CvScalar -> IO () + +-- |Produce a text-drawing function given a font description. The +-- application @prepFontAlt face italic hscale vscale shear thickness +-- ltype@ produces a text-drawing function using a font with the given +-- @face@ (which may be @italic@), horizontal and vertical scale, +-- @shear@, line @thickness@, and line type. +prepFontAlt :: (HasDepth d, UpdateROI r) => + FontFace -> Bool -> CDouble -> CDouble -> CDouble -> + CInt -> LineType -> + IO ((CInt, CInt) -> (CDouble, CDouble, CDouble) -> String -> + Image c d r -> Image c d r) +prepFontAlt face italic hscale vscale shear thickness ltype = + do f <- initFont face italic hscale vscale shear thickness ltype + let go (x,y) (r,g,b) msg = cv $ \dst -> + withCString msg $ \msg' -> + withS (CvPoint x y) $ \ptPtr -> + withS (CvScalar r g b 1) $ \colPtr -> + c_cvPutText dst msg' ptPtr f colPtr + --cvPutText dst msg' x y f r g b + {-# INLINE go #-} + return go +{-# INLINE prepFontAlt #-} + +putText :: (HasDepth d, UpdateROI r) => + (CInt, CInt) -> (CDouble, CDouble, CDouble) -> String -> + Image c d r -> Image c d r +putText (x,y) (r,g,b) msg = cv $ \dst -> + withCString msg $ \msg' -> + withS (CvPoint x y) $ \ptPtr -> + withS (CvScalar r g b 1) $ \colPtr -> + c_cvPutText dst msg' ptPtr defaultFont colPtr + -- cvPutText (castPtr dst) msg' (fi x) (fi y) + -- (fr r) (fr g) (fr b) + -- where fi = fromIntegral + -- fr = realToFrac +{-# INLINE putText #-} + +-- |Type of line to draw. +data LineType = EightConn -- ^8-connected line + | FourConn -- ^4-connected line + | AALine -- ^antialiased line + +-- |An RGB triple. +type RGB = (Double, Double, Double) + +-- |Convert a LineType into an integer. +lineTypeEnum :: LineType -> Int +lineTypeEnum EightConn = 8 +lineTypeEnum FourConn = 4 +lineTypeEnum AALine = 16 + +-- |Draw each line, defined by its endpoints, on a duplicate of the +-- given 'Image' using the specified RGB color, line thickness, +-- and aliasing style. +drawLines :: (HasDepth d, UpdateROI r) => + RGB -> Int -> LineType -> [((Int,Int),(Int,Int))] -> + Image c d r -> Image c d r +drawLines col thick lineType lines = + cv $ \img -> mapM_ (draw img) lines + where draw ptr (pt1, pt2) = cvLine ptr pt1 pt2 col thick lineType' + lineType' = lineTypeEnum lineType +{-# INLINE drawLines #-} + +-- |Draw a filled, convex polygon. Can draw all monotonic polygons +-- without self-intersections including those with horizontal top or +-- bottom edges. +fillConvexPoly :: (HasDepth d, UpdateROI r) => + RGB -> LineType -> [(Int,Int)] -> Image c d r -> Image c d r +fillConvexPoly (r,g,b) lineType pts = + cv $ \img -> withArray (concatMap flatten pts) $ \pts' -> + c_cvFillConvexPoly img pts' (fi $ length pts) + (fr r) (fr g) (fr b) 0 lt 0 + where lt = fi $ lineTypeEnum lineType + flatten (x,y) = [fi x, fi y] + fi = fromIntegral + fr = realToFrac + + + diff --git a/src/OpenCV/FeatureDetection.hs b/src/OpenCV/FeatureDetection.hs new file mode 100644 index 0000000..102812b --- /dev/null +++ b/src/OpenCV/FeatureDetection.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ForeignFunctionInterface, FlexibleContexts, DataKinds #-} +-- |Feature Detection. +module OpenCV.FeatureDetection (cornerHarris, cornerHarris', canny) where +import Foreign.C.Types (CInt(..), CDouble(..)) +import Foreign.Ptr (Ptr, castPtr) +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvCornerHarris" + c_cvHarris :: Ptr CvArr -> Ptr CvArr -> CInt -> CInt -> CDouble -> IO () + +harris :: Ptr IplImage -> Ptr IplImage -> Int -> Int -> Double -> IO () +harris src dst blockSize aperture k = + c_cvHarris (castPtr src) (castPtr dst) (fi blockSize) (fi aperture) (rf k) + where fi = fromIntegral + rf = realToFrac + +type M = Monochromatic + +-- |Equivalent to 'cornerHarris'' with an @aperture@ of @3@ and a @k@ +-- of @0.04@. +cornerHarris :: (ByteOrFloat d, Inplace r M d M Float) => + Int -> Image Monochromatic d r -> + Image Monochromatic Float r +cornerHarris blockSize = cornerHarris' blockSize 3 0.04 +{-# INLINE cornerHarris #-} + +-- |Harris corner detector. For each pixel, a 2x2 covariance matrix, +-- @M@, is computed over a @blockSize x blockSize@ neighborhood. The +-- value of @det(M) - k*trace(M)^2@ is stored in the destination +-- image. Corners in the image correspond to local maxima of the +-- destination image. The parameters are the @blockSize@, the +-- @aperture@ size to be used by the Sobel operator that is run during +-- corner evaluation, the value of @k@, and the source +-- 'Image'. +cornerHarris' :: (ByteOrFloat d, Inplace r M d M Float) => + Int -> Int -> Double -> Image Monochromatic d r -> + Image Monochromatic Float r +cornerHarris' blockSize aperture k = + cv2 $ \src dst -> harris src dst blockSize aperture k +{-# INLINE cornerHarris' #-} + +foreign import ccall "opencv2/imgprog/imgproc_c.h cvCanny" + c_cvCanny :: Ptr IplImage -> Ptr IplImage -> CDouble -> CDouble -> CInt -> IO () + +-- |Canny edge detector. @canny threshold1 threshold2 aperture src@ +-- finds edges in the source image with the larger of the two +-- thresholds used to find initial segments of strong edges while the +-- smaller threshold is used for edge linking. The third parameter is +-- the aperture size used for initial Sobel operator edge detection. +canny :: (HasDepth d, Inplace r M d M d) => + Double -> Double -> Int -> Image Monochromatic d r -> + Image Monochromatic d r +canny t1 t2 aperture = + cv2 $ \src dst -> c_cvCanny src dst (rf t1) (rf t2) (fi aperture) + --cv $ \src -> c_cvCanny src src (rf t1) (rf t2) (fi aperture) + where rf = realToFrac + fi = fromIntegral diff --git a/src/OpenCV/Filtering.hsc b/src/OpenCV/Filtering.hsc new file mode 100644 index 0000000..188b2d7 --- /dev/null +++ b/src/OpenCV/Filtering.hsc @@ -0,0 +1,107 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeFamilies #-} +-- |Image filtering operations. +module OpenCV.Filtering (smoothGaussian, smoothGaussian', + sobel, sobelDX, sobelDY, + ApertureSize(..), DerivativeOrder(..)) where +import Data.Word (Word8) +import Data.Int (Int16) +import Foreign.C.Types (CInt(..), CDouble(..)) +import Foreign.Ptr (Ptr, castPtr) +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp + +#include + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvSmooth" + c_cvSmooth :: Ptr CvArr -> Ptr CvArr -> CInt -> CInt -> CInt -> CDouble -> + CDouble -> IO () + +smooth :: Ptr IplImage -> Ptr IplImage -> CInt -> Int -> Int -> Double -> + Double -> IO () +smooth src dst smoothType param1 param2 param3 param4 = + c_cvSmooth (castPtr src) (castPtr dst) smoothType (fi param1) + (fi param2) (rf param3) (rf param4) + where fi = fromIntegral + rf = realToFrac + +cvGaussian :: CInt +cvGaussian = #{const CV_GAUSSIAN} + +-- |Smooth a source image using a linear convolution with a Gaussian +-- kernel. Parameters are the kernel width and the source +-- 'Image'. The kernel height will be set to the same value as the +-- width, and the Gaussian standard deviation will be calculated from +-- the kernel size. This function is the same as calling +-- @smoothGaussian' width Nothing Nothing@. May be performed in-place +-- under composition. +smoothGaussian :: (ByteOrFloat d, Inplace r c d c d) => + Int -> Image c d r -> Image c d r +smoothGaussian w = smoothGaussian' w Nothing Nothing +{-# INLINE smoothGaussian #-} + +-- |Smooth a source 'Image' using a linear convolution with a +-- Gaussian kernel. Parameters are the kernel width, the kernel height +-- (if 'Nothing', the height will be set to the same value as the +-- width), the Gaussian standard deviation (if 'Nothing', it will be +-- calculated from the kernel size), and the source image. May be +-- performed in-place under composition. +smoothGaussian' :: (ByteOrFloat d, Inplace r c d c d) => + Int -> Maybe Int -> Maybe Double -> Image c d r -> + Image c d r +smoothGaussian' w h sigma = + cv2 $ \src dst -> smooth src dst cvGaussian w h' sigma' 0 + where sigma' = case sigma of { Nothing -> 0; Just s -> s } + h' = case h of { Nothing -> 0; Just jh -> jh } +{-# INLINE smoothGaussian' #-} + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvSobel" + cvSobel :: Ptr CvArr -> Ptr CvArr -> CInt -> CInt -> CInt -> IO () + +-- |Size of the extended Sobel kernel. When 'ApertureOne' is used, a +-- 3x1 or 1x3 kernel is used with no Gaussian smoothing. Note that +-- 'ApertureOne' can only be used for the first or second x or y +-- derivatives. +data ApertureSize = ApertureOne | ApertureThree | ApertureFive | ApertureSeven + +-- |Order of the derivative computed using a Sobel operator. +data DerivativeOrder = OrderZero | OrderOne | OrderTwo | OrderThree + +apertureToInt :: ApertureSize -> CInt +apertureToInt ApertureOne = 1 +apertureToInt ApertureThree = 3 +apertureToInt ApertureFive = 5 +apertureToInt ApertureSeven = 7 + +orderToInt :: DerivativeOrder -> CInt +orderToInt OrderZero = 0 +orderToInt OrderOne = 1 +orderToInt OrderTwo = 2 +orderToInt OrderThree = 3 + +type family SobelDest a :: * +type instance SobelDest Word8 = Int16 +type instance SobelDest Float = Float + +-- |Calculates the first, second, third or mixed image derivatives +-- using an extended Sobel operators. @sobel xOrder yOrder apertureSize img@ +sobel :: (HasDepth d1, HasDepth d2, d2 ~ SobelDest d1, Inplace r c d1 c d2) => + DerivativeOrder -> DerivativeOrder -> ApertureSize -> + Image c d1 r -> Image c d2 r +sobel xOrder yOrder apertureSize = cv2 $ \src dst -> cvSobel src dst x y ap + where ap = apertureToInt apertureSize + x = orderToInt xOrder + y = orderToInt yOrder +{-# INLINE sobel #-} + +-- |Compute the first X derivative of an image using a Sobel operator. +sobelDX :: (HasDepth d1, HasDepth d2, d2 ~ SobelDest d1, Inplace r c d1 c d2) => + ApertureSize -> Image c d1 r -> Image c d2 r +sobelDX = sobel OrderOne OrderZero +{-# INLINE sobelDX #-} + +-- |Compute the first Y derivative of an image using a Sobel operator. +sobelDY :: (HasDepth d1, HasDepth d2, d2 ~ SobelDest d1, Inplace r c d1 c d2) => + ApertureSize -> Image c d1 r -> Image c d2 r +sobelDY = sobel OrderZero OrderOne +{-# INLINE sobelDY #-} \ No newline at end of file diff --git a/src/OpenCV/FloodFill.hsc b/src/OpenCV/FloodFill.hsc new file mode 100644 index 0000000..5c43000 --- /dev/null +++ b/src/OpenCV/FloodFill.hsc @@ -0,0 +1,72 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeFamilies #-} +-- |Miscellaneous image transformations. +module OpenCV.FloodFill (floodFill, FloodRange(..)) where +import Data.Bits ((.|.)) +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr (Ptr, nullPtr, castPtr) +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp +import OpenCV.Core.StorableUtil + +-- |Flag used to indicate whether pixels under consideration for +-- addition to a connected component should be compared to the seed +-- pixel of the component or their neighbors. Comparing to the seed +-- pixel leads to a component with a /fixed/ range, while comparing to +-- neighbors leads to a /floating/ range. +data FloodRange = FloodFixed | FloodFloating + +#include + +-- FIXME: This method of pushing structs onto the stack by value is +-- potentially risky as it assumes there are no packing issues +-- (e.g. bytes inserted between fields or at the end of the struct to +-- ensure a desired alignment). + +#def void cvFloodFill_wrap(CvArr* img, CvPoint* seedPt,\ + CvScalar* newVal, CvScalar* loDiff,\ + CvScalar* upDiff, void *comp, int flags,\ + CvArr* mask) {\ + cvFloodFill(img, *seedPt, *newVal, *loDiff, *upDiff, comp, flags, mask);\ +} + +-- "opencv2/imgproc/imgproc_c.h cvFloodFill" +foreign import ccall "cvFloodFill_wrap" + c_cvFloodFill :: Ptr CvArr -> Ptr CvPoint -> Ptr CvScalar -> Ptr CvScalar -> + Ptr CvScalar -> Ptr () -> CInt -> Ptr () -> IO () + +floodHelper :: (Int, Int) -> CvScalar -> CvScalar -> CvScalar -> FloodRange -> + Ptr IplImage -> IO () +floodHelper (x,y) newVal loDiff upDiff range src = + withS (CvPoint (fromIntegral x) (fromIntegral y)) $ \seedPtr -> + withS newVal $ \newValPtr -> + withS loDiff $ \loDiffPtr -> + withS upDiff $ \upDiffPtr -> + c_cvFloodFill (castPtr src) seedPtr newValPtr loDiffPtr upDiffPtr + nullPtr flags nullPtr + -- c_cvFloodFill (castPtr src) + -- (CvPoint (fromIntegral x) (fromIntegral y)) + -- newVal loDiff upDiff + -- nullPtr flags nullPtr + where flags = case range of + FloodFixed -> 4 .|. #{const CV_FLOODFILL_FIXED_RANGE} + FloodFloating -> 4 + +-- |Fills a connected component with the given color. Parameters are +-- the starting point (x,y) coordinates; the new value of the +-- repainted pixels; the maximal lower brigtness/color difference +-- between the currently observed pixel and one of its neighbors +-- belonging to the component, or the seed pixel; the maximal upper +-- brightness/color difference between the currently observed pixel +-- and one of its neighbors belonging to teh component, or the seed +-- pixel; a flag indicating whether pixels under consideration for +-- painting should be compared to the seed pixel ('FloodFixed') or to +-- their neighbors ('FloodFloating'); the source image. +floodFill :: (ByteOrFloat d, AsCvScalar s, s ~ CvScalarT c d) => + (Int, Int) -> s -> s -> s -> FloodRange -> + Image c d r -> Image c d r +floodFill seed newVal loDiff upDiff range img@Image{}= + flip cv img $ floodHelper seed (toCvScalar newVal) (toCvScalar loDiff) + (toCvScalar upDiff) range + +{-# INLINE floodFill #-} diff --git a/src/OpenCV/GUI.hs b/src/OpenCV/GUI.hs new file mode 100644 index 0000000..0c562e3 --- /dev/null +++ b/src/OpenCV/GUI.hs @@ -0,0 +1,56 @@ +-- |Very simple tools for showing images in a window. The 'runWindow' +-- and 'runNamedWindow' interfaces are the recommended entrypoints. +module OpenCV.GUI (namedWindow, WindowFlag(..), MouseCallback, + waitKey, cvInit, runWindow, runNamedWindow) where +import OpenCV.Core.Image +import OpenCV.Core.HighGui +import OpenCV.Core.CxCore (fromArr) +import Control.Monad ((>=>)) +import Data.Bits ((.&.)) +import Data.Word (Word8) +import Foreign.Ptr (castPtr) +import Foreign.C.String (newCString) + +bool :: a -> a -> Bool -> a +bool t _ True = t +bool _ f False = f + +-- |Simple window runner. Takes an action that produces images to be +-- shown in the window. Exits when any key is pressed. +runWindow :: IO (Image c Word8 r) -> IO () +runWindow mkImg = newWindow 0 True >> go + where go = do mkImg >>= flip withIplImage (showImage 0) + cvWaitKey 1 >>= bool (delWindow 0) go . (> 0) + +-- |Simple named window runner. Exits when any key is pressed. The +-- name is shown in the window's title bar. +runNamedWindow :: String -> IO (Image c Word8 r) -> IO () +runNamedWindow name mkImg = + do name' <- newCString name + cvNamedWindow name' (windowFlagsToEnum [AutoSize]) + let showImg = cvShowImage name' . castPtr + go = do mkImg >>= flip withIplImage showImg + cvWaitKey 1 >>= bool (cvDestroyWindow name') go . (> 0) + go + +-- |Create a new window with the given title. The return value is an +-- action for showing an image, and an action for destroying the +-- window. Be sure to repeatedly invoke 'waitKey' to keep the system +-- alive. +namedWindow :: String -> [WindowFlag] -> + --Maybe MouseCallback -> + IO (Image c d r -> IO (), IO ()) +namedWindow name flags = + do cstr <- newCString name + let showImg img = withIplImage img $ \imgPtr -> + cvShowImage cstr (fromArr imgPtr) + cvNamedWindow cstr (windowFlagsToEnum flags) + return (showImg, cvDestroyWindow cstr) + +-- | @waitKey delay@ waits for a key indifinitely if @delay <= 0@, or +-- for @delay@ milliseconds. The returned value is the code of the +-- pressed key or 'Nothing'. +waitKey :: Int -> IO (Maybe Int) +waitKey = cvWaitKey . fromIntegral >=> return . checkKey + where checkKey (-1) = Nothing + checkKey x = Just (fromIntegral (x .&. 0xFF)) diff --git a/src/OpenCV/HighCV.hs b/src/OpenCV/HighCV.hs new file mode 100644 index 0000000..271e227 --- /dev/null +++ b/src/OpenCV/HighCV.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DataKinds #-} +-- |High-level Haskell bindings to OpenCV operations. Some of these +-- operations will be performed in-place under composition. For +-- example, @dilate 8 . erode 8@ will allocate one new image rather +-- than two. +module OpenCV.HighCV ( + -- * Image Files + fromFile, fromFileGray, fromFileColor, + fromPGM16, toFile, + -- * Image Properties + width, height, numPixels, isColor, isMono, + -- * Image Construction + fromPixels, fromGrayPixels, fromColorPixels, peekIpl, + -- * Image Data Accessors + pixelVector, unsafePixelVector, withPixelVector, + withImagePixels, withDuplicatePixels, sampleLine, getRect, + withDuplicateRGBPixels, RGB8(..), rgbmap, + -- * Image Processing + erode, dilate, houghStandard, houghProbabilistic, + normalize, resize, setROI, resetROI, + module OpenCV.ColorConversion, + module OpenCV.Threshold, + module OpenCV.FloodFill, + module OpenCV.FeatureDetection, + Connectivity(..), + CvRect(..), liftCvRect, + cv_L2, cv_MinMax, + InterpolationMethod(..), + -- * GUI and Drawing + module OpenCV.GUI, + module OpenCV.Drawing, + -- * Video + module OpenCV.Video, + -- * Image types + Image, Channels(..), HasDepth, + GrayImage, ColorImage, GrayImage16, GrayImage16S, + GrayImageF, Word8, Word16, RGB8 + ) where +import OpenCV.Core.CxCore +import OpenCV.Core.CV +import OpenCV.Drawing +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp +import OpenCV.ColorConversion +import Data.Word (Word8, Word16) +import Foreign.C.Types (CDouble) +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe (unsafePerformIO) +import OpenCV.Color +import OpenCV.GUI +import OpenCV.Threshold +import OpenCV.FloodFill +import OpenCV.FeatureDetection +import OpenCV.Video + +-- |Erode an 'Image' with a 3x3 structuring element for the specified +-- number of iterations. +erode :: (HasDepth d, Inplace r c d c d) => + Int -> Image c d r -> Image c d r +erode n = cv2 $ \src dst -> cvErode src dst (fromIntegral n) +{-# INLINE erode #-} + +-- |Dilate an 'Image' with a 3x3 structuring element for the +-- specified number of iterations. +dilate :: (HasDepth d, Inplace r c d c d) => + Int -> Image c d r -> Image c d r +dilate n = cv2 $ \src dst -> cvDilate src dst (fromIntegral n) +{-# INLINE dilate #-} + +-- |Extract all the pixel values from an image along a line, including +-- the end points. Parameters are the two endpoints, the line +-- connectivity to use when sampling, and an image; returns the list +-- of pixel values. +sampleLine :: (Int, Int) -> (Int, Int) -> Connectivity -> Image c d r -> [d] +sampleLine pt1 pt2 conn img@Image{} = unsafePerformIO . withIplImage img $ + \p -> cvSampleLine p pt1 pt2 conn +{-# NOINLINE sampleLine #-} + +-- |Line detection in a binary image using a standard Hough +-- transform. Parameters are @rho@, the distance resolution in +-- pixels; @theta@, the angle resolution in radians; @threshold@, the +-- line classification accumulator threshold; and the input image. +houghStandard :: Double -> Double -> Int -> Image Monochromatic Word8 r -> + [((Int, Int),(Int,Int))] +houghStandard rho theta threshold img = unsafePerformIO $ + do storage <- cvCreateMemStorage (min 0 (fromIntegral threshold)) + cvSeq <- withIplImage img $ + \p -> cvHoughLines2 p storage 0 rho theta threshold 0 0 + hlines <- mapM (\p -> do f1 <- peek p + f2 <- peek (plusPtr p (sizeOf (undefined::Float))) + return (f1,f2)) + =<< seqToPList cvSeq + cvReleaseMemStorage storage + return $ map lineToSeg hlines + where lineToSeg :: (Float,Float) -> ((Int,Int),(Int,Int)) + lineToSeg (rho, theta) = let a = cos theta + b = sin theta + x0 = a * rho + y0 = b * rho + x1 = clampX $ x0 + 10000*(-b) + y1 = clampY $ y0 + 10000*a + x2 = clampX $ x0 - 10000*(-b) + y2 = clampY $ y0 - 10000*a + in ((x1,y1),(x2,y2)) + w = fromIntegral (width img) + h = fromIntegral (height img) + clampX x = max 0 (min (truncate x) (w - 1)) + clampY y = max 0 (min (truncate y) (h - 1)) +{-# NOINLINE houghStandard #-} + +-- |Line detection in a binary image using a probabilistic Hough +-- transform. Parameters are @rho@, the distance resolution in pixels; +-- @theta@, the angle resolution in radians; @threshold@, the line +-- classification accumulator threshold; and the input image. +houghProbabilistic :: Double -> Double -> Int -> Double -> Double -> + Image Monochromatic Word8 r -> [((Int, Int),(Int,Int))] +houghProbabilistic rho theta threshold minLength maxGap img = + unsafePerformIO $ + do storage <- cvCreateMemStorage (min 0 (fromIntegral threshold)) + cvSeq <- fmap snd . withDuplicateImage img $ + \p -> cvHoughLines2 p storage 1 rho theta threshold + minLength maxGap + hlines <- mapM (\p1 -> do x1 <- peek p1 + let p2 = plusPtr p1 step + p3 = plusPtr p2 step + p4 = plusPtr p3 step + y1 <- peek p2 + x2 <- peek p3 + y2 <- peek p4 + return ((x1,y1),(x2,y2))) + =<< seqToPList cvSeq + cvReleaseMemStorage storage + return hlines + where step = sizeOf (undefined::Int) +{-# NOINLINE houghProbabilistic #-} + +{- +-- |Find the 'CvContour's in an image. +findContours :: HIplImage a Monochromatic Word8 -> [CvContour] +findContours img = snd $ withDuplicateImage img $ + \src -> cvFindContours src CV_RETR_CCOMP CV_CHAIN_APPROX_SIMPLE +-} + +-- FIXME: There is no fusion mechanism that can handle 'resize'. The +-- problem is that the fusion combinators assume the output image is +-- the same size as the input image as this information is not +-- captured in the type. That said, it would be nice to be able to do +-- in-place updates to the output of 'resize'. + +-- |Resize the supplied 'Image' to the given width and height using +-- the supplied 'InterpolationMethod'. +resize :: InterpolationMethod -> Int -> Int -> + Image c d NoROI -> Image c d NoROI +resize method w h img@Image{} = + unsafePerformIO $ + do img' <- mallocImage w h + _ <- withIplImage img $ \src -> + withIplImage img' $ \dst -> + cvResize src dst method + return img' +{-# NOINLINE resize #-} + +-- |Normalize the range of color values in an image to the given +-- range. Example usage with a grayscale image is @normalize cv_MinMax +-- 0 255 img@ +normalize :: (HasDepth d, Inplace r c d c d) => + ArrayNorm -> CDouble -> CDouble -> Image c d r -> Image c d r +normalize ntype a b = cv2 $ \img dst -> + cvNormalize img dst a b (unNorm ntype) nullPtr +{-# INLINE normalize #-} + diff --git a/src/OpenCV/Histograms.hs b/src/OpenCV/Histograms.hs new file mode 100644 index 0000000..e9539fc --- /dev/null +++ b/src/OpenCV/Histograms.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module OpenCV.Histograms (equalizeHist) where +import Foreign.Ptr (Ptr) +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvEqualizeHist" + c_cvEqualizeHist :: Ptr CvArr -> Ptr CvArr -> IO () + +equalizeHist :: GrayImage -> GrayImage +equalizeHist = cv $ \src -> c_cvEqualizeHist src src diff --git a/src/OpenCV/Motion.hsc b/src/OpenCV/Motion.hsc new file mode 100644 index 0000000..3142485 --- /dev/null +++ b/src/OpenCV/Motion.hsc @@ -0,0 +1,46 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- |Motion analysis functions. +module OpenCV.Motion (calcOpticalFlowBM) where +import Data.Word (Word8) +import Foreign.C.Types (CInt) +import Foreign.Ptr (Ptr) +import System.IO.Unsafe +import OpenCV.Core.CxCore +import OpenCV.Core.HIplImage + +foreign import ccall "opencv2/video/tracking.hpp cvCalcOpticalFlowBM" + c_cvCalcOpticalFlowBM :: Ptr CvArr -> Ptr CvArr -> CInt -> CInt -> + CInt -> CInt -> CInt -> CInt -> + CInt -> Ptr CvArr -> Ptr CvArr -> IO () + +-- |Calculates the optical flow between two images using the block +-- matching method. The third parameter is the width and height of the +-- blocks to be compared; the fourth parameter is the block coordinate +-- increments; the fifth is the size of the scanned neighborhood in +-- pixels around the block. The result is a pair of the horizontal and +-- vertical components of optical flow. +calcOpticalFlowBM :: HIplImage Monochromatic Word8 r -> + HIplImage Monochromatic Word8 r -> + (Int,Int) -> (Int,Int) -> (Int,Int) -> + (HIplImage Monochromatic Float NoROI, + HIplImage Monochromatic Float NoROI) +calcOpticalFlowBM prev curr blockSize shiftSize maxRange = + unsafePerformIO $ + do velX <- mkHIplImage w h + velY <- mkHIplImage w h + withHIplImage prev $ \prevPtr -> + withHIplImage curr $ \currPtr -> + withHIplImage velX $ \vxPtr -> + withHIplImage velY $ \vyPtr -> + c_cvCalcOpticalFlowBM (fromArr prevPtr) (fromArr currPtr) + (sw blockSize) (sh blockSize) + (sw shiftSize) (sh shiftSize) + (sw maxRange) (sh maxRange) + 0 (fromArr vxPtr) (fromArr vyPtr) + return (velX, velY) + where fi = fromIntegral + w = (fi (width prev) - fst blockSize) `div` fst shiftSize + h = (fi (height prev) - snd blockSize) `div` snd shiftSize + sw = fromIntegral . fst -- size width + sh = fromIntegral . snd -- size height +{-# NOINLINE calcOpticalFlowBM #-} \ No newline at end of file diff --git a/src/OpenCV/PixelUtils.hs b/src/OpenCV/PixelUtils.hs new file mode 100644 index 0000000..f7513c0 --- /dev/null +++ b/src/OpenCV/PixelUtils.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE BangPatterns, DataKinds #-} +-- |Images obtained from OpenCV usually have the components of color +-- pixels arranged in BGR order and pad image rows with unused +-- bytes. This module provides mechanisms to drop the unused packing +-- bytes. +module OpenCV.PixelUtils where +import OpenCV.Core.Image +import OpenCV.Core.ImageUtil +import OpenCV.ColorConversion (convertRGBToGray) +import Control.Monad.ST (runST) +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as VM +import qualified Data.Vector.Generic as VG +import Unsafe.Coerce (unsafeCoerce) + +-- |OpenCV often stores color images with rows that are four times the +-- width (which aligns rows nicely, and can accommodate RGBA +-- pixels). For network transmission, it can be advantageous to strip +-- out that extra data. This function returns a fresh 'V.Vector' of +-- pixel data that excludes these unused bytes. If the original image +-- data is already packed, it is returned as a 'V.Vector' without +-- copying. +packPixels :: Image c d NoROI -> V.Vector d +packPixels img@Image{} = + if w' == stride + then pixelVector img + else runST $ do v <- VM.new (w*h*nc) + let sliceSrc x = V.unsafeSlice x w' pix + sliceDst x = VM.unsafeSlice x w' v + go !y !pSrc !pDst + | y < h = let s1 = sliceSrc pSrc + s2 = sliceDst pDst + pSrc' = pSrc + stride + pDst' = pDst + w' + in do V.unsafeCopy s2 s1 + go (y+1) pSrc' pDst' + | otherwise = VG.unsafeFreeze v + go 0 0 0 + where w = fromIntegral $ width img + h = fromIntegral $ height img + nc = imgChannels img + w' = w * nc + stride = fromIntegral $ widthStep img + pix = pixelVector img +{-# INLINE packPixels #-} + +-- |Return a Vector of bytes of a single color channel from a +-- tri-chromatic image. The desired channel must be one of 0, 1, or 2. +isolateChannel :: Int -> Image Trichromatic d NoROI -> V.Vector d +isolateChannel ch img@Image{} = + if ch < 0 || ch >= 3 + then error $ "Invalid channel "++show ch++" for trichromatic image" + else runST $ do v <- VM.new (w*h) + let go !x !p !p3 !y + | y >= h = VG.unsafeFreeze v + | x == w = go 0 p (p3+margin) (y+1) + | otherwise = do VM.unsafeWrite v p (get p3) + go (x+1) (p+1) (p3+3) y + go 0 0 ch 0 + where w = fromIntegral $ width img + h = fromIntegral $ height img + margin = fromIntegral (widthStep img) - (w * 3) + pix = pixelVector img + get = V.unsafeIndex pix +{-# INLINE isolateChannel #-} + +-- |Convert an 'Image' \'s pixel data to a 'V.Vector' of monochromatic bytes. +toMono :: Integral d => Image c d NoROI -> V.Vector d +toMono img@Image{} = if imgChannels img == 1 then packPixels img + else packPixels . convertRGBToGray . isColor $ + unsafeCoerce img + diff --git a/src/OpenCV/Threshold.hs b/src/OpenCV/Threshold.hs new file mode 100644 index 0000000..8fb6642 --- /dev/null +++ b/src/OpenCV/Threshold.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, TypeFamilies, + MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DataKinds #-} +-- |Image thresholding operations. These operations will perform +-- destructive, in-place updates when used in compositions. +module OpenCV.Threshold (thresholdBinary, thresholdBinaryInv, + thresholdTruncate, + thresholdToZero, thresholdToZeroInv, + thresholdBinaryOtsu, thresholdBinaryOtsuInv, + thresholdTruncateOtsu, + thresholdToZeroOtsu, thresholdToZeroOtsuInv) where +import Data.Bits ((.|.)) +import Data.Word (Word8) +import Foreign.C.Types (CDouble(..), CInt(..)) +import Foreign.Ptr (Ptr) +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.CVOp + +data ThresholdType = ThreshBinary + | ThreshBinaryInv + | ThreshTrunc + | ThreshToZero + | ThreshToZeroInv + deriving Enum + +fromEnumC :: Enum a => a -> CInt +fromEnumC = fromIntegral . fromEnum + +-- The OpenCV thresholding functions have the property that the source +-- image must be a single-channel with 8-bit or float pixels. The +-- destination image must be either the same pixel type as the source, +-- or 8-bit. This means that images of float pixels can be converted +-- to 8-bit images during the thresholding process. + +class (HasDepth d1, HasDepth d2) => SameOrByte d1 d2 where +instance SameOrByte Float Word8 where +instance ByteOrFloat d => SameOrByte d d where + +foreign import ccall "opencv2/imgproc/imgproc_c.h cvThreshold" + c_cvThreshold :: Ptr CvArr -> Ptr CvArr -> CDouble -> CDouble -> CInt -> + IO CDouble + +{- +class ByteOrFloat a => Thresholdable r a b where + doThreshold :: (ImgBuilder r, Inplace r a Monochromatic b Monochromatic) => + a -> a -> Int -> + HIplImage Monochromatic a r -> + HIplImage Monochromatic b r + +instance Inplace r Monochromatic Word8 Monochromatic Word8 => + Thresholdable r Word8 Word8 where + doThreshold = cvThreshold1 + {-# INLINE doThreshold #-} + +instance Inplace r Monochromatic Float Monochromatic Float => + Thresholdable r Float Float where + doThreshold = cvThreshold1 + {-# INLINE doThreshold #-} + +instance Inplace r Monochromatic Float Monochromatic Word8 => + Thresholdable r Float Word8 where + doThreshold = cvThreshold2 + {-# INLINE doThreshold #-} + +cvThreshold1 :: (ByteOrFloat a, ImgBuilder r, Inplace r M a M a) => + a -> a -> Int -> + HIplImage Monochromatic a r -> HIplImage Monochromatic a r +cvThreshold1 threshold maxValue tType = + cv $ \src -> void $ c_cvThreshold src src threshold' maxValue' tType' + where threshold' = realToFrac . toDouble $ threshold + maxValue' = realToFrac . toDouble $ maxValue + tType' = fromIntegral tType +{-# INLINE cvThreshold1 #-} +-} + +-- The worker function that calls c_cvThreshold. +cvThreshold2 :: (ByteOrFloat d1, SameOrByte d1 d2, Inplace r M d1 M d2) => + d1 -> d1 -> CInt -> Image Monochromatic d1 r -> + Image Monochromatic d2 r +cvThreshold2 threshold maxValue tType = + cv2 $ \src dst -> + do _r <- c_cvThreshold src dst threshold' maxValue' tType' + return () + --return (fromDouble (realToFrac r)) -- FIXME: This is dropped by cv2! + where threshold' = realToFrac . toDouble $ threshold + maxValue' = realToFrac . toDouble $ maxValue + tType' = fromIntegral tType +{-# INLINE cvThreshold2 #-} + +-- cvThreshold :: (Thresholdable d1 d2, ImgBuilder r) => d1 -> d1 -> Int -> +-- HIplImage Monochromatic d1 r -> HIplImage Monochromatic d2 r +-- cvThreshold = doThreshold +cvThreshold :: (ByteOrFloat d1, SameOrByte d1 d2, Inplace r M d1 M d2) => + d1 -> d1 -> CInt -> + Image Monochromatic d1 r -> Image Monochromatic d2 r +cvThreshold = cvThreshold2 + +{-# INLINE cvThreshold #-} + +-- Use Otsu's method to determine an optimal threshold value which is +-- returned along with the thresholded image. +cvThresholdOtsu :: Inplace r M Word8 M Word8 => + Word8 -> CInt -> Image Monochromatic Word8 r -> + Image Monochromatic Word8 r +cvThresholdOtsu maxValue tType = cvThreshold 0 maxValue tType' + where otsu = 8 + tType' = tType .|. otsu +{-# INLINE cvThresholdOtsu #-} + +type M = Monochromatic + +-- |Binary thresholding. Parameters are the @threshold@ value, the +-- @maxValue@ passing pixels are mapped to, and the source +-- 'Image'. Each pixel greater than @threshold@ is mapped to +-- @maxValue@, while all others are mapped to zero. +thresholdBinary :: (SameOrByte d1 d2, ByteOrFloat d1, Inplace r M d1 M d2) => + d1 -> d1 -> + Image Monochromatic d1 r -> Image Monochromatic d2 r +thresholdBinary th maxValue = cvThreshold th maxValue (fromEnumC ThreshBinary) +{-# INLINE thresholdBinary #-} + +-- |Inverse binary thresholding. Parameters are the @threshold@ value, +-- the @maxValue@ passing pixels are mapped to, and the source +-- 'Image'. Each pixel greater than @threshold@ is mapped to zero, +-- while all others are mapped to @maxValue@. +thresholdBinaryInv :: (SameOrByte d1 d2, ByteOrFloat d1, Inplace r M d1 M d2) => + d1 -> d1 -> + Image Monochromatic d1 r -> Image Monochromatic d2 r +thresholdBinaryInv th maxValue = cvThreshold th maxValue tType + where tType = fromEnumC ThreshBinaryInv +{-# INLINE thresholdBinaryInv #-} + +-- |Truncation thresholding (i.e. clamping). Parameters are the +-- @threshold@ value and the source 'Image'. Maps pixels that are +-- greater than @threshold@ to the @threshold@ value; leaves all other +-- pixels unchanged. +thresholdTruncate :: (SameOrByte d1 d2, ByteOrFloat d1, Inplace r M d1 M d2) => + d1 -> Image Monochromatic d1 r -> Image Monochromatic d2 r +thresholdTruncate threshold = cvThreshold threshold 0 (fromEnumC ThreshTrunc) +{-# INLINE thresholdTruncate #-} + +-- |Maps pixels that are less than or equal to @threshold@ to zero; +-- leaves all other pixels unchanged. Parameters the @threshold@ value +-- and the source 'Image'. +thresholdToZero :: (SameOrByte d1 d2, ByteOrFloat d1, Inplace r M d1 M d2) => + d1 -> Image Monochromatic d1 r -> Image Monochromatic d2 r +thresholdToZero threshold = cvThreshold threshold 0 (fromEnumC ThreshToZero) +{-# INLINE thresholdToZero #-} + +-- |Maps pixels that are greater than @threshold@ to zero; leaves all +-- other pixels unchanged. Parameters the @threshold@ value and the +-- source 'Image'. +thresholdToZeroInv :: (SameOrByte d1 d2, ByteOrFloat d1, Inplace r M d1 M d2) => + d1 -> Image Monochromatic d1 r -> Image Monochromatic d2 r +thresholdToZeroInv threshold = cvThreshold threshold 0 tType + where tType = fromEnumC ThreshToZeroInv +{-# INLINE thresholdToZeroInv #-} + +-- |Binary thresholding using Otsu's method to determine an optimal +-- threshold value. The chosen value is returned along with the +-- thresholded image. Takes the @maxValue@ used to replace pixels that +-- pass the threshold with and the source 'Image'. +thresholdBinaryOtsu :: (Inplace r M Word8 M Word8) => + Word8 -> Image Monochromatic Word8 r -> + Image Monochromatic Word8 r +thresholdBinaryOtsu maxValue = cvThresholdOtsu maxValue tType + where tType = fromEnumC ThreshBinary +{-# INLINE thresholdBinaryOtsu #-} + +-- |Binary thresholding using Otsu's method to determine an optimal +-- threshold value. The chosen value is returned along with the +-- thresholded image. Takes the @maxValue@ to replace pixels that pass +-- the threshold with and the source 'Image'. The sense of the +-- thresholding operation is inverted, as in 'thresholdBinaryInv'. +thresholdBinaryOtsuInv :: (Inplace r M Word8 M Word8) => + Word8 -> Image Monochromatic Word8 r -> + Image Monochromatic Word8 r +thresholdBinaryOtsuInv maxValue = cvThresholdOtsu maxValue tType + where tType = fromEnumC ThreshBinaryInv +{-# INLINE thresholdBinaryOtsuInv #-} + +-- |Maps pixels that are greater than @threshold@ to the @threshold@ +-- value; leaves all other pixels unchanged. Takes the source +-- 'Image'; the @threshold@ value is chosen using Otsu's method +-- and returned along with the thresholded image. +thresholdTruncateOtsu :: (Inplace r M Word8 M Word8) => + Image Monochromatic Word8 r -> + Image Monochromatic Word8 r +thresholdTruncateOtsu = cvThresholdOtsu 0 (fromEnumC ThreshTrunc) +{-# INLINE thresholdTruncateOtsu #-} + +-- |Maps pixels that are less than or equal to @threshold@ to zero; +-- leaves all other pixels unchaged.The @threshold@ value is chosen +-- using Otsu's method and returned along with the thresholded image. +thresholdToZeroOtsu :: (Inplace r M Word8 M Word8) => + Image Monochromatic Word8 r -> + Image Monochromatic Word8 r +thresholdToZeroOtsu = cvThresholdOtsu 0 (fromEnumC ThreshToZero) +{-# INLINE thresholdToZeroOtsu #-} + +-- |Maps pixels that are greather than @threshold@ to zero; leaves all +-- other pixels unchaged.The @threshold@ value is chosen using Otsu's +-- method and returned along with the thresholded image. +thresholdToZeroOtsuInv :: (Inplace r M Word8 M Word8) => + Image Monochromatic Word8 r -> + Image Monochromatic Word8 r +thresholdToZeroOtsuInv = cvThresholdOtsu 0 (fromEnumC ThreshToZeroInv) +{-# INLINE thresholdToZeroOtsuInv #-} diff --git a/src/OpenCV/Video.hs b/src/OpenCV/Video.hs new file mode 100644 index 0000000..de032e7 --- /dev/null +++ b/src/OpenCV/Video.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} +-- |Interfaces for grabbing images from cameras and video files, and +-- for writing to video files. +module OpenCV.Video (createFileCapture, createFileCaptureLoop, + createCameraCapture, createVideoWriter, + FourCC, toFourCC, mpeg4CC) where +import Data.Maybe (fromMaybe) +import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) +import OpenCV.Core.CxCore +import OpenCV.Core.ImageUtil +import OpenCV.Core.HighGui + +-- |Raise an error if 'cvQueryFrame' returns 'Nothing'; otherwise +-- returns a 'Ptr' 'IplImage'. +queryError :: Ptr CvCapture -> IO (Ptr IplImage) +queryError = fmap (fromMaybe $ error "Unable to capture frame") . cvQueryFrame + +-- |If 'cvQueryFrame' returns 'Nothing', try rewinding the video and +-- querying again. If it still fails, raise an error. When a non-null +-- frame is obtained, return it. +queryFrameLoop :: Ptr CvCapture -> IO (Ptr IplImage) +queryFrameLoop cap = do f <- cvQueryFrame cap + case f of + Nothing -> do setCapturePos cap (PosFrames 0) + queryError cap + Just f' -> return f' + +-- |Open a capture stream from a movie file. The returned action may +-- be used to query for the next available frame. If no frame is +-- available either due to error or the end of the video sequence, +-- 'Nothing' is returned. +createFileCapture :: (HasDepth d, SingI c) => + FilePath -> IO (IO (Maybe (Image c d NoROI))) +createFileCapture fname = do capture <- createFileCaptureF fname + return (withForeignPtr capture $ \cap -> + do f <- cvQueryFrame cap + case f of + Nothing -> return Nothing + Just f' -> Just `fmap` peekIpl f') + +-- |Open a capture stream from a movie file. The returned action may +-- be used to query for the next available frame. The sequence of +-- frames will return to its beginning when the end of the video is +-- encountered. +createFileCaptureLoop :: (HasDepth d, SingI c) => + FilePath -> IO (IO (Image c d NoROI)) +createFileCaptureLoop fname = do capture <- createFileCaptureF fname + return (withForeignPtr capture $ + (>>= peekIpl) . queryFrameLoop) + + +-- |Open a capture stream from a connected camera. The parameter is +-- the index of the camera to be used, or 'Nothing' if it does not +-- matter what camera is used. The returned action may be used to +-- query for the next available frame. +createCameraCapture :: (HasDepth d, SingI c) => + Maybe Int -> IO (IO (Image c d NoROI)) +createCameraCapture cam = do cvInit + capture <- createCameraCaptureF cam' + return (withForeignPtr capture $ + (>>= peekIpl) . queryError) + where cam' = fromMaybe (-1) cam + +-- |4-character code for MPEG-4. +mpeg4CC :: FourCC +mpeg4CC = ('F','M','P','4') + +-- |Create a video file writer. The parameters are the file name, the +-- 4-character code (of the codec used to compress the frames +-- (e.g. @(\'F\',\'M\',\'P\',\'4\')@ for MPEG-4), the framerate of the +-- created video stream, and the size of the video frames. The +-- returned action may be used to add frames to the video stream. +createVideoWriter :: (HasDepth d, UpdateROI r) => + FilePath -> FourCC -> Double -> (Int,Int) -> + IO (Image Trichromatic d r -> IO ()) +createVideoWriter fname codec fps sz = + do writer <- createVideoWriterF fname codec fps sz + let writeFrame img = withForeignPtr writer $ \writer' -> + withIplImage img $ \img' -> + cvWriteFrame writer' img' + return writeFrame diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 index f348817..0000000 --- a/src/Test.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Main where - -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.C.Types - -import AI.CV.OpenCV.CxCore -import AI.CV.OpenCV.CV -import AI.CV.OpenCV.HighGui - -import Control.Monad(when) - -showFrames :: CInt -> Ptr IplImage -> Ptr CvCapture -> IO () -showFrames winNum targetImage cvcapture = do - frame <- cvQueryFrame cvcapture - cvConvertImage (fromArr frame) (fromArr targetImage) 0 - calcFrame targetImage - where calcFrame targetSmall = do - cvResize targetImage targetSmall CV_INTER_LINEAR - cvCanny targetSmall targetSmall 30 190 3 - showImage winNum targetSmall - key <- waitKey 5 - when (key == -1) (showFrames winNum targetImage cvcapture) - - -processImages :: Ptr CvCapture -> IO () -processImages capture = do - frame <- cvQueryFrame capture - let winNum = 0 - newWindow winNum True - target <- createImageF (cvGetSize frame) 1 iplDepth8u - withForeignPtr target $ (\target' -> showFrames winNum target' capture) - -main :: IO () -main = do - capture <- createCameraCaptureF 0 - withForeignPtr capture processImages - - - \ No newline at end of file diff --git a/src/Util/ColorConvEnum.hs b/src/Util/ColorConvEnum.hs new file mode 100644 index 0000000..66cf244 --- /dev/null +++ b/src/Util/ColorConvEnum.hs @@ -0,0 +1,19 @@ +-- A simple script for generating hsc2hs #enum syntax from a series of +-- C #define statements. Copy the relevant #define lines into the file +-- cconv.txt, then run this script which will output the hsc2hs macro +-- syntax to cconv.hsc. +import Control.Applicative ((<$>)) +import Data.List (intercalate) +import Data.Maybe (mapMaybe) +import Text.Regex.PCRE + +convertLine :: String -> Maybe String +convertLine ln = listToMaybe . mrSubList $ ln =~ "^#define\\s+CV_(\\w+)\\s+.*$" + where listToMaybe [] = Nothing + listToMaybe [x] = Just $ " , cv_"++x++" = CV_"++x + listToMaybe _ = error "Unexpected match result" + +main = do lines' <- mapMaybe convertLine . lines <$> readFile "cconv.txt" + let hsc = "#{enum ColorConversion, ColorConversion" : lines' ++ + [" }",""] + writeFile "cconv.hsc" $ intercalate "\n" hsc diff --git a/test/Makefile b/test/Makefile deleted file mode 100644 index e9bc41e..0000000 --- a/test/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -all: Test test-c test-cpp - -Test: Test.hs HOpenCV_c.c HOpenCV.h HOpenCV.chs - c2hs --cppopts='-I/usr/include/opencv' -l HOpenCV.chs - ghc --make Test.hs HOpenCV_c.c -lcv -lhighgui -I/usr/include/opencv -o Test -O2 - - -test-c: test.c HOpenCV_c.c HOpenCV.h - gcc test.c HOpenCV_c.c -lcv -lhighgui -lcxcore -I/usr/include/opencv -o test-c -O2 - -test-cpp: test2.cpp - gcc test2.cpp -lcv -lhighgui -lcxcore -I/usr/include/opencv -o test-cpp -O2 \ No newline at end of file diff --git a/test/haar.c b/test/haar.c deleted file mode 100644 index 9871b3f..0000000 --- a/test/haar.c +++ /dev/null @@ -1,62 +0,0 @@ -#include "cv.h" -#include "highgui.h" - -CvHaarClassifierCascade* load_object_detector( const char* cascade_path ) -{ - return (CvHaarClassifierCascade*)cvLoad( cascade_path ); -} - -void detect_and_draw_objects( IplImage* image, - CvHaarClassifierCascade* cascade, - int do_pyramids ) -{ - IplImage* small_image = image; - CvMemStorage* storage = cvCreateMemStorage(0); - CvSeq* faces; - int i, scale = 1; - - /* if the flag is specified, down-scale the input image to get a - performance boost w/o loosing quality (perhaps) */ - if( do_pyramids ) - { - small_image = cvCreateImage( cvSize(image->width/2,image->height/2), IPL_DEPTH_8U, 3 ); - cvPyrDown( image, small_image, CV_GAUSSIAN_5x5 ); - scale = 2; - } - - /* use the fastest variant */ - faces = cvHaarDetectObjects( small_image, cascade, storage, 1.2, 2, CV_HAAR_DO_CANNY_PRUNING ); - - /* draw all the rectangles */ - for( i = 0; i < faces->total; i++ ) - { - /* extract the rectanlges only */ - CvRect face_rect = *(CvRect*)cvGetSeqElem( faces, i ); - cvRectangle( image, cvPoint(face_rect.x*scale,face_rect.y*scale), - cvPoint((face_rect.x+face_rect.width)*scale, - (face_rect.y+face_rect.height)*scale), - CV_RGB(255,0,0), 3 ); - } - - if( small_image != image ) - cvReleaseImage( &small_image ); - cvReleaseMemStorage( &storage ); -} - -/* takes image filename and cascade path from the command line */ -int main( int argc, char** argv ) -{ - IplImage* image; - if( argc==3 && (image = cvLoadImage( argv[1], 1 )) != 0 ) - { - CvHaarClassifierCascade* cascade = load_object_detector(argv[2]); - detect_and_draw_objects( image, cascade, 1 ); - cvNamedWindow( "test", 0 ); - cvShowImage( "test", image ); - cvWaitKey(0); - cvReleaseHaarClassifierCascade( &cascade ); - cvReleaseImage( &image ); - } - - return 0; -} diff --git a/test/test.c b/test/test.c deleted file mode 100644 index b07be52..0000000 --- a/test/test.c +++ /dev/null @@ -1,35 +0,0 @@ -#include "HOpenCV.h" - -void lib_test() -{ - CvCapture *capture = new_capture(0); - IplImage *frame = NULL; - new_window(0,1); - - while (1) { - frame = cvQueryFrame(capture); - //show_image(0, frame); - wait_key(30); - } - - del_window(0); - del_capture(capture); -} - -void direct_test() -{ - CvCapture *capture = new_capture(0); - cvNamedWindow("blah",1); - - while (1) { - cvShowImage("blah", query_frame(capture)); - cvWaitKey(10); - } - -} - -int main(int argc, char *argv[]) -{ -// direct_test(); - lib_test(); -} diff --git a/test/test2.cpp b/test/test2.cpp deleted file mode 100644 index f812b1f..0000000 --- a/test/test2.cpp +++ /dev/null @@ -1,27 +0,0 @@ -#include "cv.h" -#include "highgui.h" - -using namespace cv; - -int main(int, char**) -{ - VideoCapture cap(0); // open the default camera - if(!cap.isOpened()) // check if we succeeded - return -1; - - Mat edges; - namedWindow("edges",1); - for(;;) - { - Mat frame; - cap >> frame; // get a new frame from camera - cvtColor(frame, edges, CV_BGR2GRAY); - GaussianBlur(edges, edges, Size(7,7), 1.5, 1.5); - Canny(edges, edges, 0, 30, 3); - imshow("edges", edges); - //imshow("edges", frame); - if(waitKey(30) >= 0) break; - } - // the camera will be deinitialized automatically in VideoCapture destructor - return 0; -}