{-# 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 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);
--
-- 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
import Prelude hiding ((.),id)
import Control.Category
import Control.Applicative hiding (empty)
import Control.Arrow
import Control.Monad(liftM, join)
-- | The type of Processors
--
-- * a, b = the input and output types of the processor (think a -> b)
--
-- * x = type of internal state (existentially quantified)
--
-- 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)
-- | 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 :: 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 :: 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 Applicative instance of functions (which are the semantic meanings of a processor):
-- [[ forkJoin ]] = liftA2 (,)
-- Alternative implementation to consider: f &&& g = (,) <&> f <*> g
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) -> 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' <- cf2 x2
return (b,b')
--rf3 :: (x1,x2) -> m ()
rf3 (x1,x2) = 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)
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 ***)
-------------------------------------------------------------
-- | 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 = 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'
-------------------------------------------------------------
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