module AI.CV.ImageProcessors
(ImageSink,
ImageSource,
ImageProcessor,
Image,
camera,
videoFile,
window,
resize,
dilate,
canny,
haarDetect,
drawRects,
runTill, runTillKeyPressed, keyPressed) where
import Control.Processor(runUntil, IOSink, IOSource, IOProcessor, processor)
import AI.CV.OpenCV.Types(PImage)
import qualified AI.CV.OpenCV.CV as CV
import qualified AI.CV.OpenCV.CxCore as CxCore
import qualified AI.CV.OpenCV.HighGui as HighGui
import AI.CV.OpenCV.CxCore(IplImage, CvSize, CvRect, CvMemStorage)
import AI.CV.OpenCV.CV(CvHaarClassifierCascade)
import Foreign.Ptr(Ptr)
type Image = PImage
type ImageSink = IOSink Image
type ImageSource = IOSource () Image
type ImageProcessor = IOProcessor Image Image
keyPressed :: Show a => a -> IO Bool
keyPressed _ = fmap (/= 1) $ HighGui.waitKey 3
runTill :: IOProcessor () b -> (b -> IO Bool) -> IO b
runTill = flip runUntil ()
runTillKeyPressed :: (Show a) => IOProcessor () a -> IO ()
runTillKeyPressed f = f `runTill` keyPressed >> (return ())
capture :: IO (Ptr HighGui.CvCapture) -> ImageSource
capture pCap = processor processQueryFrame allocateCamera fromState releaseNext
where processQueryFrame :: () -> (Ptr CxCore.IplImage, Ptr HighGui.CvCapture)
-> IO (Ptr CxCore.IplImage, Ptr HighGui.CvCapture)
processQueryFrame _ (_, cap) = do
newFrame <- HighGui.cvQueryFrame cap
return (newFrame, cap)
allocateCamera :: () -> IO (Ptr CxCore.IplImage, Ptr HighGui.CvCapture)
allocateCamera _ = do
cap <- pCap
newFrame <- HighGui.cvQueryFrame cap
return (newFrame, cap)
fromState (image, _) = return image
releaseNext (_, cap) = HighGui.cvReleaseCapture cap
camera :: Int -> ImageSource
camera index = capture (HighGui.cvCreateCameraCapture (fromIntegral index))
videoFile :: String -> ImageSource
videoFile fileName = capture (HighGui.cvCreateFileCapture fileName)
window :: Int -> ImageSink
window num = processor procFunc allocFunc return return
where procFunc :: (Image -> () -> IO ())
procFunc src x = HighGui.showImage (fromIntegral num) src >> return x
allocFunc :: (Image -> IO ())
allocFunc _ = HighGui.newWindow (fromIntegral num) True
imageProcessor :: (Image -> Image -> IO Image) -> (Image -> IO Image)
-> ImageProcessor
imageProcessor procFunc allocFunc = processor procFunc allocFunc return CxCore.cvReleaseImage
resize :: Int
-> Int
-> CV.InterpolationMethod -> ImageProcessor
resize width height interp = imageProcessor processResize allocateResize
where processResize src dst = do
CV.cvResize src dst interp
return dst
allocateResize src = do
nChans <- CxCore.getNumChannels src :: IO Int
depth <- CxCore.getDepth src
CxCore.cvCreateImage (CxCore.CvSize (fromIntegral width) (fromIntegral height)) (fromIntegral nChans) depth
dilate :: Int -> ImageProcessor
dilate iterations = imageProcessor procDilate CxCore.cvCloneImage
where procDilate src dst = do
CV.cvDilate src dst (fromIntegral iterations)
return dst
canny :: Int
-> Int
-> Int
-> ImageProcessor
canny thres1 thres2 size = processor processCanny allocateCanny convertState releaseState
where processCanny src (gray, dst) = do
HighGui.cvConvertImage src gray 0
CV.cvCanny gray dst (fromIntegral thres1) (fromIntegral thres2) (fromIntegral size)
return (gray, dst)
allocateCanny src = do
target <- CxCore.cvCreateImage (CxCore.cvGetSize src) 1 CxCore.iplDepth8u
gray <- CxCore.cvCreateImage (CxCore.cvGetSize src) 1 CxCore.iplDepth8u
return (gray, target)
convertState = return . snd
releaseState (gray, target) = do
CxCore.cvReleaseImage gray
CxCore.cvReleaseImage target
haarDetect :: String
-> Double
-> Int
-> CV.HaarDetectFlag
-> CvSize
-> IOProcessor Image [CvRect]
haarDetect cascadeFileName scaleFactor minNeighbors flags minSize = processor procFunc allocFunc convFunc freeFunc
where procFunc :: Image -> ([CvRect], (Ptr CvHaarClassifierCascade, Ptr CvMemStorage))
-> IO ([CvRect], (Ptr CvHaarClassifierCascade, Ptr CvMemStorage))
procFunc image (_, x@(cascade, storage)) = do
seqP <- CV.cvHaarDetectObjects image cascade storage (realToFrac scaleFactor) (fromIntegral minNeighbors) flags minSize
recs <- CxCore.seqToList seqP
return (recs, x)
allocFunc :: Image -> IO ([CvRect], (Ptr CvHaarClassifierCascade, Ptr CvMemStorage))
allocFunc _ = do
storage <- CxCore.cvCreateMemStorage 0
(cascade, name) <- CxCore.cvLoad cascadeFileName storage Nothing
print name
return ([], (cascade, storage))
convFunc = return . fst
freeFunc (_, (_, storage)) = do
CxCore.cvReleaseMemStorage storage
drawRects :: IOProcessor (Image, [CvRect]) Image
drawRects = processor procFunc (CxCore.cvCloneImage . fst) return CxCore.cvReleaseImage
where procFunc (src,rects) dst = do
CxCore.cvCopy src dst
mapM_ (CxCore.cvRectangle dst) rects
return dst