packages feed

cv-combinators (empty) → 0.1

raw patch · 5 files changed

+507/−0 lines, 5 filesdep +HOpenCVdep +basesetup-changed

Dependencies added: HOpenCV, base

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cv-combinators.cabal view
@@ -0,0 +1,28 @@+name: cv-combinators+version: 0.1+license: BSD3+maintainer: Noam Lewis <jones.noamle@gmail.com>+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++
+ src/AI/CV/ImageProcessors.hs view
@@ -0,0 +1,194 @@++--------------------------------------------------------------+-- | +-- Module      : AI.CV.ImageProcessors+-- Copyright   : (c) Noam Lewis 2010+-- License     : BSD3+--+-- Maintainer  : Noam Lewis <jones.noamle@gmail.com>+-- 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+            +
+ src/AI/CV/Processor.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE RankNTypes, GADTs, NoMonomorphismRestriction #-}+-- | +-- Module      : AI.CV.Processor+-- Copyright   : (c) Noam Lewis, 2010+-- License     : BSD3+--+-- Maintainer  : Noam Lewis <jones.noamle@gmail.com>+-- 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'+
+ src/Test.hs view
@@ -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))