diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cv-combinators.cabal b/cv-combinators.cabal new file mode 100644 --- /dev/null +++ b/cv-combinators.cabal @@ -0,0 +1,28 @@ +name: cv-combinators +version: 0.1 +license: BSD3 +maintainer: Noam Lewis +bug-reports: mailto:jones.noamle@gmail.com +category: AI, Graphics +synopsis: Functional Combinators for Computer Vision +description: + Initial version; using HOpenCV as a backend +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: AI.CV.Processor, + AI.CV.ImageProcessors + hs-Source-Dirs: src + build-depends: base >= 3 && < 5, HOpenCV + ghc-options: -Wall + +executable test-cv-combinators + hs-source-dirs: src + Build-Depends: base >= 4 + main-is: Test.hs + Ghc-Options: -Wall + Ghc-Prof-Options: -prof -auto-all + other-modules: AI.CV.Processor, AI.CV.ImageProcessors + + diff --git a/src/AI/CV/ImageProcessors.hs b/src/AI/CV/ImageProcessors.hs new file mode 100644 --- /dev/null +++ b/src/AI/CV/ImageProcessors.hs @@ -0,0 +1,194 @@ + +-------------------------------------------------------------- +-- | +-- Module : AI.CV.ImageProcessors +-- Copyright : (c) Noam Lewis 2010 +-- License : BSD3 +-- +-- Maintainer : Noam Lewis +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- ImageProcessors is a functional (Processor-based) interface to computer vision using OpenCV. +-- +-- The Processor interface allows the primitives in this library to take care of all the allocation / deallocation +-- of resources and other setup/teardown requirements, and to appropriately nest them when combining primitives. +-- +-- Simple example: +-- +-- > win = window 0 -- The number is essentially a label for the window +-- > cam = camera 0 -- Autodetect camera +-- > edge = canny 30 190 3 -- Edge detecting processor using canny operator +-- > +-- > test = win . edge . cam -- A processor that captures frames from camera and displays edge-detected version in the window. +-------------------------------------------------------------- +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 = Processor IO (Ptr IplImage) () +type ImageSource = Processor IO () (Ptr IplImage) +type ImageProcessor = Processor IO (Ptr IplImage) (Ptr IplImage) + + + +------------------------------------------------------------------ +-- | Some general utility functions for use with Processors and OpenCV + +-- | Predicate for pressed keys +keyPressed :: Show a => a -> IO Bool +keyPressed _ = do + fmap (/= -1) $ HighGui.waitKey 3 + +-- | Runs the processor until a predicate is true, for predicates, and processors that take () as input +-- (such as chains that start with a camera). +runTill :: Monad m => Processor m () b -> (b -> m Bool) -> m b +runTill = flip runUntil () + +-- | Name (and type) says it all. +runTillKeyPressed :: (Show a) => Processor IO () a -> IO () +runTillKeyPressed f = (f `runTill` keyPressed) >> (return ()) + +------------------------------------------------------------------ + + +-- | A capture device, using OpenCV's HighGui lib's cvCreateCameraCapture +-- should work with most webcames. See OpenCV's docs for information. +-- This processor outputs the latest image from the camera at each invocation. +camera :: Int -> ImageSource +camera index = 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 <- HighGui.cvCreateCameraCapture (fromIntegral index) + newFrame <- HighGui.cvQueryFrame cap + return (newFrame, cap) + + fromState (image, _) = do + return image + + releaseNext (_, cap) = do + HighGui.cvReleaseCapture $ cap +------------------------------------------------------------------ +-- GUI stuff + +-- | A window that displays images. +-- Note: windows with the same index will be the same window....is this ok? +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 + +------------------------------------------------------------------ +-- | A convenience function for constructing a common type of processors that work exclusively on images +imageProcessor :: (Ptr IplImage -> Ptr IplImage -> IO (Ptr IplImage)) -> (Ptr IplImage -> IO (Ptr IplImage)) + -> ImageProcessor +imageProcessor procFunc allocFunc = processor procFunc allocFunc (do return) (CxCore.cvReleaseImage) + +-- | OpenCV's cvResize +resize :: Int -- Width + -> Int -- Height + -> 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 + +-- | OpenCV's cvDilate +dilate :: Int -> ImageProcessor +dilate iterations = imageProcessor procDilate CxCore.cvCloneImage + where procDilate src dst = do + CV.cvDilate src dst (fromIntegral iterations) + return dst + + +-- todo: Int is not really correct here, because it's really CInt. should we just expose CInt? +-- | OpenCV's cvCanny +canny :: Int -- ^ Threshold 1 + -> Int -- ^ Threshold 2 + -> Int -- ^ Size + -> 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 + +------------------------------------------------------------------ + +-- | Wrapper for OpenCV's cvHaarDetectObjects and the surrounding required things (mem storage, cascade loading, etc). +haarDetect :: String -- ^ Cascade filename (OpenCV comes with several, including ones for face detection) + -> Double -- ^ scale factor + -> Int -- ^ min neighbors + -> CV.HaarDetectFlag -- ^ flags + -> CvSize -- ^ min size + -> Processor IO (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 -- todo verify that this is a haar cascade + return ([], (cascade, storage)) + + convFunc = do return . fst + + freeFunc (_, (_, storage)) = do + CxCore.cvReleaseMemStorage storage + -- todo release the cascade usign cvReleaseHaarClassifierCascade + + +----------------------------------------------------------------------------- + +-- Add a processor that takes a list of any shape (rect, ellipse, etc.) and draws them all on the image? +-- need a datatype that combines the shape types for that. + +-- | OpenCV's cvRectangle, currently without width, color or line type control +drawRects :: Processor IO (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 + + diff --git a/src/AI/CV/Processor.hs b/src/AI/CV/Processor.hs new file mode 100644 --- /dev/null +++ b/src/AI/CV/Processor.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE RankNTypes, GADTs, NoMonomorphismRestriction #-} +-- | +-- Module : AI.CV.Processor +-- Copyright : (c) Noam Lewis, 2010 +-- License : BSD3 +-- +-- Maintainer : Noam Lewis +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Framework for expressing monadic actions that require initialization and finalizers. +-- This module provides a *functional* interface for defining and chaining a series of processors. +-- +-- Motivating example: bindings to C libraries that use functions such as: f(foo *src, foo *dst), +-- where the pointer `dst` must be pre-allocated. In this case we normally do: +-- +-- foo *dst = allocateFoo(); +-- ... +-- while (something) { +-- f(src, dst); +-- ... +-- } +-- releaseFoo(dst); +-- +-- You can use the 'runUntil' function below to emulate that loop. +-- +-- Processor is an instance of Category, Functor, Applicative and Arrow. + +module AI.CV.Processor where + +import Prelude hiding ((.),id) + +import Control.Category +import Control.Applicative hiding (empty) +import Control.Arrow + +import Control.Monad(liftM, join) + +-- | The type of Processors +-- +-- The semantic model is: +-- +-- > [[ Processor m o a b ]] = a -> b +-- +-- The idea is that the monad m is usually IO, and that a and b are usually pointers. +-- It is meant for functions that require a pre-allocated output pointer to operate. +-- +-- * a, b = the input and output types of the processor (think a -> b) +-- +-- * m = monad in which the processor operates +-- +-- * x = type of internal state +-- +-- The arguments to the constructor are: +-- +-- 1. Processing function: Takes input and internal state, and returns new internal state. +-- +-- 2. Allocator for internal state (this is run only once): Takes (usually the first) input, and returns initial internal state. +-- +-- 3. Convertor from state x to output b: Takes internal state and returns the output. +-- +-- 4. Releaser for internal state (finalizer, run once): Run after processor is done being used, to release the internal state. +-- +data Processor m a b where + Processor :: Monad m => (a -> x -> m x) -> (a -> m x) -> (x -> m b) -> (x -> m ()) -> (Processor m a b) + +processor :: (Monad m) => + (a -> x -> m x) -> (a -> m x) -> (x -> m b) -> (x -> m ()) + -> Processor m a b +processor = Processor + +-- | Chains two processors serially, so one feeds the next. +chain :: (Monad m) => Processor m a b' -> Processor m b' b -> Processor m a b +chain (Processor pf1 af1 cf1 rf1) (Processor pf2 af2 cf2 rf2) = processor pf3 af3 cf3 rf3 + where pf3 a (x1,x2) = do + x1' <- pf1 a x1 + b' <- cf1 x1 + x2' <- pf2 b' x2 + return (x1', x2') + + af3 a = do + x1 <- af1 a + b' <- cf1 x1 + x2 <- af2 b' + return (x1,x2) + + cf3 (_,x2) = do + b <- cf2 x2 + return b + + rf3 (x1,x2) = do + rf2 x2 + rf1 x1 + +-- | A processor that represents two sub-processors in parallel (although the current implementation runs them +-- sequentially, but that may change in the future) +parallel :: (Monad m) => Processor m a b -> Processor m c d -> Processor m (a,c) (b,d) +parallel (Processor pf1 af1 cf1 rf1) (Processor pf2 af2 cf2 rf2) = processor pf3 af3 cf3 rf3 + where pf3 (a,c) (x1,x2) = do + x1' <- pf1 a x1 + x2' <- pf2 c x2 + return (x1', x2') + + af3 (a,c) = do + x1 <- af1 a + x2 <- af2 c + return (x1,x2) + + cf3 (x1,x2) = do + b <- cf1 x1 + d <- cf2 x2 + return (b,d) + + rf3 (x1,x2) = do + rf2 x2 + rf1 x1 + +-- | Constructs a processor that: given two processors, gives source as input to both processors and runs them +-- independently, and after both have have finished, outputs their combined outputs. +-- +-- Semantic meaning, using Arrow's (&&&) operator: +-- [[ forkJoin ]] = &&& +-- Or, considering the Monad instance of functions (which are the semantic meanings of a processor): +-- [[ forkJoin ]] = liftM2 (,) +-- Alternative implementation to consider: f &&& g = (,) <&> f <*> g +forkJoin :: (Monad m) => Processor m a b -> Processor m a b' -> Processor m a (b,b') +forkJoin (Processor pf1 af1 cf1 rf1) (Processor pf2 af2 cf2 rf2) = processor pf3 af3 cf3 rf3 + where pf3 a (x1,x2) = do + x1' <- pf1 a x1 + x2' <- pf2 a x2 + return (x1', x2') + + af3 a = do + x1 <- af1 a + x2 <- af2 a + return (x1,x2) + + cf3 (x1,x2) = do + b <- cf1 x1 + b' <- cf2 x2 + return (b,b') + + rf3 (x1,x2) = do + rf2 x2 + rf1 x1 + + +------------------------------------------------------------- +-- | The identity processor: output = input. Semantically, [[ empty ]] = id +empty :: Monad m => Processor m a a +empty = processor pf af cf rf + where pf _ = do return + af = do return + cf = do return + rf _ = do return () + +instance Monad m => Category (Processor m) where + (.) = flip chain + id = empty + +instance Monad m => Functor (Processor m a) where + -- | + -- > [[ fmap ]] = (.) + -- + -- This could have used fmap internally as a Type Class Morphism, but monads + -- don't neccesary implement the obvious: fmap = liftM. + fmap f (Processor pf af cf rf) = processor pf af cf' rf + where cf' x = liftM f (cf x) + +-- | Splits (duplicates) the output of a functor, or on this case a processor. +split :: Functor f => f a -> f (a,a) +split = (join (,) <$>) + +-- | 'f --< g' means: split f and feed it into g. Useful for feeding parallelized (***'d) processors. +-- For example, a --< (b &&& c) +(--<) :: (Functor (cat a), Category cat) => cat a a1 -> cat (a1, a1) c -> cat a c +f --< g = split f >>> g +infixr 1 --< + + +instance (Monad m) => Applicative (Processor m a) where + -- | + -- > [[ pure ]] = const + pure b = processor pf af cf rf + where pf _ = do return + af _ = do return () + cf _ = do return b + rf _ = do return () + + -- | + -- [[ pf <*> px ]] = \a -> ([[ pf ]] a) ([[ px ]] a) + -- (same as '(<*>)' on functions) + (<*>) (Processor pf af cf rf) (Processor px ax cx rx) = processor py ay cy ry + where py a (stateF, stateX) = do + f' <- pf a stateF + x' <- px a stateX + return (f', x') + + ay a = do + stateF <- af a + stateX <- ax a + return (stateF, stateX) + + -- this is the only part that seems specific to <*> + cy (stateF, stateX) = do + b2c <- cf stateF + b <- cx stateX + return (b2c b) + + ry (stateF, stateX) = do + rx stateX + rf stateF + +-- | A few tricks by Saizan from #haskell to perhaps use here: +-- first f = (,) <$> (arr fst >>> f) <*> arr snd +-- arr f = f <$> id +-- f *** g = (arr fst >>> f) &&& (arr snd >>> g) +instance Monad m => Arrow (Processor m) where + arr = flip liftA id + (&&&) = forkJoin + (***) = parallel + first = (*** id) + second = (id ***) + +------------------------------------------------------------- + +-- | Runs the processor once: allocates, processes, converts to output, and deallocates. +run :: (Monad m) => Processor m a b -> a -> m b +run = runWith id + +-- | Keeps running the processing function in a loop until a predicate on the output is true. +-- Useful for processors whose main function is after the allocation and before deallocation. +runUntil :: (Monad m) => Processor m a b -> a -> (b -> m Bool) -> m b +runUntil (Processor pf af cf rf) a untilF = do + x <- af a + let repeatF y = do + y' <- pf a y + b <- cf y' + b' <- untilF b + if b' then return b else repeatF y' + d <- repeatF x + rf x + return d + + +-- | Runs the processor once, but passes the processing + conversion action to the given function. +runWith :: Monad m => (m b -> m b') -> Processor m a b -> a -> m b' +runWith f (Processor pf af cf rf) a = do + x <- af a + b' <- f (pf a x >>= cf) + rf x + return b' + diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,30 @@ +module Main where + + +import AI.CV.ImageProcessors + +import qualified AI.CV.OpenCV.CV as CV +import qualified AI.CV.Processor as Processor +import AI.CV.Processor((--<)) +import AI.CV.OpenCV.Types +import AI.CV.OpenCV.CxCore(CvRect(..), CvSize(..)) + +import Prelude hiding ((.),id) +import Control.Arrow +import Control.Category + +resizer :: ImageProcessor +resizer = resize 320 240 CV.CV_INTER_LINEAR + +edges :: ImageProcessor +edges = canny 30 190 3 + +faceDetect :: Processor.Processor IO PImage [CvRect] +faceDetect = haarDetect "/usr/share/opencv/haarcascades/haarcascade_frontalface_default.xml" 1.2 3 CV.cvHaarDoCannyPruning (CvSize 50 50) + + +main :: IO () +main = runTillKeyPressed (camera 0 --< (second faceDetect) >>> drawRects >>> window 0) + +-- Shows the camera output in two windows (same images in both). +--main = runTillKeyPressed ((camera 0) --< (window 0 *** window 1))