module AI.CV.ImageProcessors
(ImageSink,
ImageSource,
ImageProcessor,
Image,
camera,
videoFile,
window,
namedWindow,
resize,
dilate,
canny,
haarDetect,
drawRects,
runTill, runTillKeyPressed, keyPressed) where
import Control.Processor(runUntil, IOSink, IOSource, IOProcessor, processor)
import qualified AI.CV.OpenCV.CV as CV
import AI.CV.OpenCV.CV (HaarClassifierCascade)
import qualified AI.CV.OpenCV.CxCore as CxCore
import AI.CV.OpenCV.CxCore (CvSize, CvRect, MemStorage)
import qualified AI.CV.OpenCV.HighGui as HighGui
type Image = CxCore.IplImage
type ImageSink = IOSink Image
type ImageSource = IOSource () Image
type ImageProcessor = IOProcessor Image Image
keyPressed :: Show a => a -> IO Bool
keyPressed _ = fmap (/= Nothing) $ 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 HighGui.Capture -> ImageSource
capture getCap = processor processQueryFrame allocateCamera fromState releaseNext
where processQueryFrame :: () -> (Image, HighGui.Capture)
-> IO (Image, HighGui.Capture)
processQueryFrame _ (_, cap) = do
newFrame <- HighGui.queryFrame cap
return (newFrame, cap)
allocateCamera :: () -> IO (Image, HighGui.Capture)
allocateCamera _ = do
cap <- getCap
newFrame <- HighGui.queryFrame cap
return (newFrame, cap)
fromState (image, _) = return image
releaseNext (_, cap) = HighGui.releaseCapture cap
camera :: Int -> ImageSource
camera index = capture (HighGui.createCameraCapture (fromIntegral index))
videoFile :: String -> ImageSource
videoFile fileName = capture (HighGui.createFileCapture fileName)
window :: Int -> ImageSink
window num = namedWindow (show num) True
namedWindow :: String -> Bool -> ImageSink
namedWindow s a = processor procFunc allocFunc return return
where procFunc :: (Image -> () -> IO ())
procFunc src x = HighGui.showImage s src >> return x
allocFunc :: (Image -> IO ())
allocFunc _ = HighGui.namedWindow s a
imageProcessor :: (Image -> Image -> IO Image) -> (Image -> IO Image)
-> ImageProcessor
imageProcessor procFunc allocFunc = processor procFunc allocFunc return CxCore.releaseImage
resize :: Int
-> Int
-> CV.InterpolationMethod -> ImageProcessor
resize width height interp = imageProcessor processResize allocateResize
where processResize src dst = do
CV.resize src dst interp
return dst
allocateResize src = do
nChans <- CxCore.getNumChannels src :: IO Int
depth <- CxCore.getDepth src
CxCore.createImage (CxCore.CvSize (fromIntegral width) (fromIntegral height)) depth (fromIntegral nChans)
dilate :: Int -> ImageProcessor
dilate iterations = imageProcessor procDilate CxCore.cloneImage
where procDilate src dst = do
CV.dilate 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.convertImage src gray 0
CV.canny gray dst (fromIntegral thres1) (fromIntegral thres2) (fromIntegral size)
return (gray, dst)
allocateCanny src = do
srcSize <- CxCore.getSize src
target <- CxCore.createImage srcSize CxCore.iplDepth8u 1
gray <- CxCore.createImage srcSize CxCore.iplDepth8u 1
return (gray, target)
convertState = return . snd
releaseState (gray, target) = do
CxCore.releaseImage gray
CxCore.releaseImage 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], (HaarClassifierCascade, MemStorage))
-> IO ([CvRect], (HaarClassifierCascade, MemStorage))
procFunc image (_, x@(cascade, storage)) = do
seqP <- CV.haarDetectObjects image cascade storage (realToFrac scaleFactor) (fromIntegral minNeighbors) flags minSize
recs <- CxCore.seqToList seqP
return (recs, x)
allocFunc :: Image -> IO ([CvRect], (HaarClassifierCascade, MemStorage))
allocFunc _ = do
storage <- CxCore.createMemStorage 0
(cascade, name) <- CxCore.load cascadeFileName storage Nothing
print name
return ([], (cascade, storage))
convFunc = return . fst
freeFunc (_, (_, storage)) = do
CxCore.releaseMemStorage storage
drawRects :: IOProcessor (Image, [CvRect]) Image
drawRects = processor procFunc (CxCore.cloneImage . fst) return CxCore.releaseImage
where procFunc (src,rects) dst = do
CxCore.copy src dst
mapM_ (CxCore.rectangle dst) rects
return dst