module AI.CV.ImageProcessors where
import AI.CV.Processor
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
type ImageSink = IOSink (Ptr IplImage)
type ImageSource = IOSource () (Ptr IplImage)
type ImageProcessor = IOProcessor (Ptr IplImage) (Ptr IplImage)
keyPressed :: Show a => a -> IO Bool
keyPressed _ = do
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, _) = do
return image
releaseNext (_, cap) = do
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 (do return) (do return)
where procFunc :: (Ptr IplImage -> () -> IO ())
procFunc src x = (HighGui.showImage (fromIntegral num) src) >> (return x)
allocFunc :: (Ptr IplImage -> IO ())
allocFunc _ = HighGui.newWindow (fromIntegral num) True
imageProcessor :: (Ptr IplImage -> Ptr IplImage -> IO (Ptr IplImage)) -> (Ptr IplImage -> IO (Ptr IplImage))
-> ImageProcessor
imageProcessor procFunc allocFunc = processor procFunc allocFunc (do 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 = do return . snd
releaseState (gray, target) = do
CxCore.cvReleaseImage gray
CxCore.cvReleaseImage target
haarDetect :: String
-> Double
-> Int
-> CV.HaarDetectFlag
-> CvSize
-> IOProcessor (Ptr IplImage) [CvRect]
haarDetect cascadeFileName scaleFactor minNeighbors flags minSize = processor procFunc allocFunc convFunc freeFunc
where procFunc :: (Ptr IplImage) -> ([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 :: Ptr IplImage -> 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 = do return . fst
freeFunc (_, (_, storage)) = do
CxCore.cvReleaseMemStorage storage
drawRects :: IOProcessor (Ptr IplImage, [CvRect]) (Ptr IplImage)
drawRects = processor procFunc (CxCore.cvCloneImage . fst) (do return) CxCore.cvReleaseImage
where procFunc (src,rects) dst = do
CxCore.cvCopy src dst
mapM_ (CxCore.cvRectangle dst) rects
return dst