diff --git a/cv-combinators.cabal b/cv-combinators.cabal --- a/cv-combinators.cabal +++ b/cv-combinators.cabal @@ -1,15 +1,17 @@ name: cv-combinators -version: 0.1.1 +version: 0.1.2 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 the HOpenCV package as a backend. + Initial version; using the "HOpenCV" package as a backend. . Provides a functional combinator library, naturally expressed as Arrow instances (but also Category, Functor and Applicative). . + Online documentation, if not built below, can be found at . + . Read the module docs for more information. See the test program (@src/Test.hs@) for example usage. . @@ -22,7 +24,7 @@ exposed-modules: AI.CV.Processor, AI.CV.ImageProcessors hs-Source-Dirs: src - build-depends: base >= 3 && < 5, HOpenCV + build-depends: base >= 3 && < 5, HOpenCV >= 0.1.2 ghc-options: -Wall executable test-cv-combinators diff --git a/src/AI/CV/ImageProcessors.hs b/src/AI/CV/ImageProcessors.hs --- a/src/AI/CV/ImageProcessors.hs +++ b/src/AI/CV/ImageProcessors.hs @@ -20,7 +20,9 @@ -- > 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. +-- > test = cam >>> edge >>> win +-- +-- The last expression is a processor that captures frames from camera and displays edge-detected version in the window. -------------------------------------------------------------- module AI.CV.ImageProcessors where @@ -35,9 +37,9 @@ import Foreign.Ptr -type ImageSink = Processor IO (Ptr IplImage) () -type ImageSource = Processor IO () (Ptr IplImage) -type ImageProcessor = Processor IO (Ptr IplImage) (Ptr IplImage) +type ImageSink = IOSink (Ptr IplImage) +type ImageSource = IOSource () (Ptr IplImage) +type ImageProcessor = IOProcessor (Ptr IplImage) (Ptr IplImage) @@ -51,21 +53,16 @@ -- | 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 :: IOProcessor () b -> (b -> IO Bool) -> IO b runTill = flip runUntil () -- | Name (and type) says it all. -runTillKeyPressed :: (Show a) => Processor IO () a -> IO () +runTillKeyPressed :: (Show a) => IOProcessor () 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 +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 @@ -74,7 +71,7 @@ allocateCamera :: () -> IO (Ptr CxCore.IplImage, Ptr HighGui.CvCapture) allocateCamera _ = do - cap <- HighGui.cvCreateCameraCapture (fromIntegral index) + cap <- pCap newFrame <- HighGui.cvQueryFrame cap return (newFrame, cap) @@ -83,6 +80,17 @@ releaseNext (_, cap) = do HighGui.cvReleaseCapture $ cap + + +-- | 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 = capture (HighGui.cvCreateCameraCapture (fromIntegral index)) + +videoFile :: String -> ImageSource +videoFile fileName = capture (HighGui.cvCreateFileCapture fileName) + ------------------------------------------------------------------ -- GUI stuff @@ -155,7 +163,7 @@ -> Int -- ^ min neighbors -> CV.HaarDetectFlag -- ^ flags -> CvSize -- ^ min size - -> Processor IO (Ptr IplImage) [CvRect] + -> 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)) @@ -184,7 +192,7 @@ -- 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 :: 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 diff --git a/src/AI/CV/Processor.hs b/src/AI/CV/Processor.hs --- a/src/AI/CV/Processor.hs +++ b/src/AI/CV/Processor.hs @@ -8,23 +8,26 @@ -- Stability : experimental -- Portability : tested on GHC only -- --- Framework for expressing monadic actions that require initialization and finalizers. +-- Framework for expressing IO 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); +-- > 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. +-- +-- In addition to the general type @'Processor' m a b@, this module also defines the semantic model +-- for @'Processor' IO a b@, which has synonym @'IOProcessor' a b@. module AI.CV.Processor where @@ -38,18 +41,9 @@ -- | 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 +-- * x = type of internal state (existentially quantified) -- -- The arguments to the constructor are: -- @@ -64,13 +58,58 @@ 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) => +-- | The semantic model for 'IOProcessor' is a function: +-- +-- > [[ 'IOProcessor' a b ]] = a -> b +-- +-- And the following laws: +-- +-- 1. The processing function (@a -> x -> m x@) must act as if purely, so that indeed for a given input the +-- output is always the same. One particular thing to be careful with is that the output does not depend +-- on time (for example, you shouldn't use IOProcessor to implement an input device). The @IOSource@ type +-- is defined exactly for time-dependent processors. For pointer typed inputs and outputs, see next law. +-- +-- 2. For processors that work on pointers, @[[ Ptr t ]] = t@. This is guaranteed by the following +-- implementation constraints for @IOProcessor a b@: +-- +-- 1. If `a` is a pointer type (@a = Ptr p@), then the processor must NOT write (modify) the referenced data. +-- +-- 2. If `b` is a pointer, the memory it points to (and its allocation status) is only allowed to change +-- by the processor that created it (in the processing and releasing functions). In a way this +-- generalizes the first constraint. +-- +-- Note, that unlike "Yampa", this model does not allow transformations of the type @(Time -> a) -> (Time -> +-- b)@. The reason is that I want to prevent arbitrary time access (whether causal or not). This limitation +-- means that everything is essentially "point-wise" in time. To allow memory-full operations under this +-- model, 'scanlT' is defined. See for more about +-- arbitrary time access. +type IOProcessor a b = Processor IO a b + +-- | @'IOSource' a b@ is the type of time-dependent processors, such that: +-- +-- > [[ 'IOSource' a b ]] = (a, Time) -> b +-- +-- Thus, it is ok to implement a processing action that outputs arbitrary time-dependent values during runtime +-- regardless of input. (Although the more useful case is to calculate something from the input @a@ that is +-- also time-dependent. The @a@ input is often not required and in those cases @a = ()@ is used. +-- +-- Notice that this means that IOSource doesn't qualify as an 'IOProcessor'. However, currently the +-- implementation /does NOT/ enforce this, i.e. IOSource is not a newtype; I don't know how to implement it +-- correctly. Also, one question is whether primitives like "chain" will have to disallow placing 'IOSource' +-- as the second element in a chain. Maybe they should, maybe they shouldn't. +type IOSource a b = Processor IO a b + +-- | TODO: What's the semantic model for @'IOSink' a@? +type IOSink a = IOProcessor a () + +-- | TODO: do we need this? we're exporting the data constructor anyway for now, so maybe we don't. +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 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 @@ -94,7 +133,7 @@ -- | 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 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 @@ -120,29 +159,31 @@ -- -- Semantic meaning, using Arrow's (&&&) operator: -- [[ forkJoin ]] = &&& --- Or, considering the Monad instance of functions (which are the semantic meanings of a processor): --- [[ forkJoin ]] = liftM2 (,) +-- Or, considering the Applicative instance of functions (which are the semantic meanings of a processor): +-- [[ forkJoin ]] = liftA2 (,) -- 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 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 + where --pf3 :: a -> (x1,x2) -> m (x1,x2) + pf3 a (x1,x2) = do x1' <- pf1 a x1 x2' <- pf2 a x2 return (x1', x2') + --af3 :: a -> m (x1, x2) af3 a = do x1 <- af1 a x2 <- af2 a return (x1,x2) - + + --cf3 :: (x1,x2) -> m (b,b') cf3 (x1,x2) = do - b <- cf1 x1 + b <- cf1 x1 b' <- cf2 x2 return (b,b') - - rf3 (x1,x2) = do - rf2 x2 - rf1 x1 + + --rf3 :: (x1,x2) -> m () + rf3 (x1,x2) = rf2 x2 >> rf1 x1 ------------------------------------------------------------- @@ -167,18 +208,7 @@ 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 +instance Monad m => Applicative (Processor m a) where -- | -- > [[ pure ]] = const pure b = processor pf af cf rf @@ -222,15 +252,29 @@ first = (*** id) second = (id ***) + ------------------------------------------------------------- + +-- | 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) = 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 --< + + +------------------------------------------------------------- -- | Runs the processor once: allocates, processes, converts to output, and deallocates. -run :: (Monad m) => Processor m a b -> a -> m b +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 :: 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 @@ -250,4 +294,51 @@ b' <- f (pf a x >>= cf) rf x return b' + + +------------------------------------------------------------- +type DTime = Double + +type Clock m = m Double + +-- | scanlT provides the primitive for performing memory-full operations on time-dependent processors, as described in . +-- +-- /Untested/. +scanlT :: Clock IO -> (b -> b -> DTime -> c -> c) -> c -> IOSource a b -> IOSource a c +scanlT clock transFunc initOut (Processor pf af cf rf) = processor procFunc allocFunc convFunc releaseFunc + where procFunc curIn' (prevIn, prevTime, prevOut, x) = do + x' <- pf curIn' x + curIn <- cf x' + curTime <- clock + let dtime = curTime - prevTime + curOut = transFunc prevIn curIn dtime prevOut + return (curIn, curTime, curOut, x') + + allocFunc firstIn' = do + x <- af firstIn' + firstIn <- cf x + curTime <- clock + return (firstIn, curTime, initOut, x) + + convFunc (_, _, curOut, _) = return curOut + + releaseFunc (_, _, _, x') = rf x' + + +-- | Differentiate using scanlT. TODO: test, and also generalize for any monad (trivial change of types). +differentiate :: (Real b) => Clock IO -> IOSource a b -> IOSource a Double +differentiate clock = scanlT clock diffFunc 0 + where diffFunc y' y dt _ = (realToFrac (y' - y)) / dt -- horrible approximation! + +integrate :: (Real b) => Clock IO -> IOSource a b -> IOSource a Double +integrate clock p = scanlT clock intFunc 0 p + where intFunc y' y dt prevSum = prevSum + (realToFrac (y' + y)) * dt / 2 -- horrible approximation! + +max_ :: Ord b => Clock IO -> b -> IOSource a b -> IOSource a b +max_ clock minVal = scanlT clock maxFunc minVal + where maxFunc y' y _ _ = max y' y + +min_ :: Ord b => Clock IO -> b -> IOSource a b -> IOSource a b +min_ clock maxVal = scanlT clock minFunc maxVal + where minFunc y' y _ _ = min y' y diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -19,12 +19,18 @@ 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) +faceDetect :: Processor.IOProcessor PImage [CvRect] +faceDetect = haarDetect "/usr/share/opencv/haarcascades/haarcascade_frontalface_alt.xml" 1.1 3 CV.cvHaarFlagNone (CvSize 20 20) +captureDev :: ImageSource +captureDev = videoFile "/tmp/video.flv" -- Many formats are supported, not just flv (FFMPEG-based, normally). +-- If you have a webcam, uncomment this, and comment the other definition. +-- captureDev = camera 0 + main :: IO () -main = runTillKeyPressed (camera 0 --< (second faceDetect) >>> drawRects >>> window 0) +main = runTillKeyPressed (captureDev >>> resizer --< (faces *** edges) >>> (window 0 *** window 1)) + where faces = (id &&& faceDetect) >>> drawRects -- Shows the camera output in two windows (same images in both). --main = runTillKeyPressed ((camera 0) --< (window 0 *** window 1))