Skip to content
Browse files

Initial commit

  • Loading branch information...
0 parents commit 14e97719ef4fe5731bf38dff95f363745f70c527 @serras serras committed with Alejandro Dec 8, 2010
Showing with 2,701 additions and 0 deletions.
  1. +1,476 −0 AFRP.hs
  2. +18 −0 AFRPDiagnostics.hs
  3. +286 −0 AFRPEvent.hs
  4. +75 −0 AFRPForceable.hs
  5. +36 −0 AFRPInternals.hs
  6. +77 −0 AFRPMergeableRecord.hs
  7. +120 −0 AFRPMiscellany.hs
  8. +218 −0 AFRPTask.hs
  9. +277 −0 AFRPUtilities.hs
  10. +118 −0 Example.hs
1,476 AFRP.hs
@@ -0,0 +1,1476 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRP
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- The AFRP core.
+--
+-- ToDo:
+-- * Check embedSynch for space leaks. It might be a good idea to force
+-- "dropped frames".
+-- * The internal "streamToSignal" is interesting, and a version somehow
+-- accepting a time stamped stream/assuming equidistant samples, possibly
+-- with an interpolation function, might be even more interesting. Perhaps
+-- consider a version that applies "cycle" to the supplied list? Note that
+-- there is a relation to "embedSynch" since a partial application of
+-- "embedSynch" to "identity" would yield something similar. Or it is
+-- in some sense the inverse of "embed".
+-- * It seems the use of VectorSpace-based integrals causes more ambiguity
+-- problems than before. Investigate (comments in AFRPTest.hs).
+-- * Maybe "now", "after", "repeatedly" should return ().
+-- There could be a bunch of utilities "nowTag", "afterTag", "repeatedlyTag",
+-- and "edgeTag". Decide based on API consistency. E.g. edge already
+-- returns ().
+-- * Reconsider the semantics of "edgeBy". Does not disallow an edge
+-- condition that persists between consecutive samples. OTOH, consider
+-- a signal that alternates between two discrete values (True, False, say).
+-- Surely we could then see edges on every sample. It's not really for us
+-- to say whether the edge detecting function does a good job or not?
+-- * We should probably introduce a type synonym Frequency here.
+-- It might be most natural to give some parameters in terms of frequency
+-- (like for "repeatedly" and "occasionally"). On the other hand, there
+-- is "after", and it would be good if "after" and "repeatedly" are
+-- mutually consitent, if "repeatedly" and "occsaionally" are consitent,
+-- and if the user knows that "Time" is the only dimension he or she needs
+-- to worry about.
+-- * Here's an argument for why "now", "after", etc. should return "()".
+-- The event value has to be a static entity anyway in these cases. So,
+-- if we need them to something DYNAMIC, then the extra argument is useless.
+-- Or if we don't care. If it is decided to change the interface in that
+-- way, I guess we could also change Time to Frequency where that makes
+-- sense. On the other hand, what's the point of "now" always returning
+-- "()"? Would one not usually want to say what to return? If yes, then
+-- There is something to be said for making "after" consitent with "now".
+-- After all, we should have "now = after 0".
+-- * Maybe "reactimate" should be parameterized on the monad type?
+-- * Revisit the "reactimate" interfaces along with embedding.
+-- * Revisit integration and differentiation. Valery suggests:
+--
+-- integral :: VectorSpace a s => SF a a
+-- integral = (\ a _ dt v -> v ^+^ realToFrac dt *^ a) `iterFrom`
+-- zeroVector
+--
+-- -- non-delayed integration (using the function's value at the current
+-- -- time)
+-- ndIntegral :: VectorSpace a s => SF a a
+-- ndIntegral = (\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`
+-- zeroVector
+--
+-- derivative :: VectorSpace a s => SF a a
+-- derivative = (\ a a' dt _ -> (a' ^-^ a) ^/ realToFrac dt) `iterFrom`
+-- zeroVector
+--
+-- iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b
+-- f `iterFrom` b = SF (iterAux b) where
+-- iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)
+-- See also the original e-mail discussion.
+
+module AFRP (
+-- Re-exported module, classes, and types
+ module Control.Arrow,
+
+-- Reverse function composition and arrow plumbing aids
+ ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9
+ dup, -- :: a -> (a,a)
+ swap, -- :: (a,b) -> (b,a)
+
+-- Main types
+ Time, -- [s] Both for time w.r.t. some reference and intervals.
+ SF, -- Signal Function.
+ Event(..), -- Events; conceptually similar to Maybe (but abstract).
+
+-- Main instances
+ -- SF is an instance of Arrow and ArrowLoop. Method instances:
+ -- arr :: (a -> b) -> SF a b
+ -- (>>>) :: SF a b -> SF b c -> SF a c
+ -- (<<<) :: SF b c -> SF a b -> SF a c
+ -- first :: SF a b -> SF (a,c) (b,c)
+ -- second :: SF a b -> SF (c,a) (c,b)
+ -- (***) :: SF a b -> SF a' b' -> SF (a,a') (b,b')
+ -- (&&&) :: SF a b -> SF a b' -> SF a (b,b')
+ -- returnA :: SF a a
+ -- loop :: SF (a,c) (b,c) -> SF a b
+
+ -- Event is an instance of Functor, Eq, and Ord. Some method instances:
+ -- fmap :: (a -> b) -> Event a -> Event b
+ -- (==) :: Event a -> Event a -> Bool
+ -- (<=) :: Event a -> Event a -> Bool
+
+-- Basic signal functions
+ identity, -- :: SF a a
+ constant, -- :: b -> SF a b
+ localTime, -- :: SF a Time
+ time, -- :: SF a Time, Other name for localTime.
+
+-- Initialization
+ (-->), -- :: b -> SF a b -> SF a b, infixr 0
+ (>--), -- :: a -> SF a b -> SF a b, infixr 0
+ (-=>), -- :: (b -> b) -> SF a b -> SF a b infixr 0
+ (>=-), -- :: (a -> a) -> SF a b -> SF a b infixr 0
+ initially, -- :: a -> SF a a
+
+-- Basic event sources
+ never, -- :: SF a (Event b)
+ now, -- :: b -> SF a (Event b)
+ after, -- :: Time -> b -> SF a (Event b)
+ repeatedly, -- :: Time -> b -> SF a (Event b)
+ afterEach, -- :: [(Time,b)] -> SF a (Event b)
+ edge, -- :: SF Bool (Event ())
+ iEdge, -- :: Bool -> SF Bool (Event ())
+ edgeTag, -- :: a -> SF Bool (Event a)
+ edgeJust, -- :: SF (Maybe a) (Event a)
+ edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)
+
+-- Stateful event suppression
+ notYet, -- :: SF (Event a) (Event a)
+ once, -- :: SF (Event a) (Event a)
+ takeEvents, -- :: Int -> SF (Event a) (Event a)
+ dropEvents, -- :: Int -> SF (Event a) (Event a)
+
+-- Basic switchers
+ switch, dSwitch, -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
+ rSwitch, drSwitch, -- :: SF a b -> SF (a,Event (SF a b)) b
+ kSwitch, dkSwitch, -- :: SF a b
+ -- -> SF (a,b) (Event c)
+ -- -> (SF a b -> c -> SF a b)
+ -- -> SF a b
+
+-- Parallel composition and switching over collections with broadcasting
+ parB, -- :: Functor col => col (SF a b) -> SF a (col b)
+ pSwitchB,dpSwitchB, -- :: Functor col =>
+ -- col (SF a b)
+ -- -> SF (a, col b) (Event c)
+ -- -> (col (SF a b) -> c -> SF a (col b))
+ -- -> SF a (col b)
+ rpSwitchB,drpSwitchB,-- :: Functor col =>
+ -- col (SF a b)
+ -- -> SF (a, Event (col (SF a b)->col (SF a b)))
+ -- (col b)
+
+-- Parallel composition and switching over collections with general routing
+ par, -- Functor col =>
+ -- (forall sf . (a -> col sf -> col (b, sf)))
+ -- -> col (SF b c)
+ -- -> SF a (col c)
+ pSwitch, dpSwitch, -- pSwitch :: Functor col =>
+ -- (forall sf . (a -> col sf -> col (b, sf)))
+ -- -> col (SF b c)
+ -- -> SF (a, col c) (Event d)
+ -- -> (col (SF b c) -> d -> SF a (col c))
+ -- -> SF a (col c)
+ rpSwitch,drpSwitch, -- Functor col =>
+ -- (forall sf . (a -> col sf -> col (b, sf)))
+ -- -> col (SF b c)
+ -- -> SF (a, Event (col (SF b c) -> col (SF b c)))
+ -- (col c)
+
+-- Wave-form generation
+ hold, -- :: a -> SF (Event a) a
+ trackAndHold, -- :: a -> SF (Maybe a) a
+
+-- Accumulators
+ accum, -- :: a -> SF (Event (a -> a)) (Event a)
+ accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b)
+ accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c
+ -- -> SF (Event a) (Event b)
+
+-- Delays
+ pre, -- :: SF a a
+ iPre, -- :: a -> SF a a
+
+-- Integration and differentiation
+ integral, -- :: VectorSpace a s => SF a a
+ derivative, -- :: VectorSpace a s => SF a a -- Crude!
+ imIntegral, -- :: VectorSpace a s => a -> SF a a
+
+-- Loops with guaranteed well-defined feedback
+ loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b
+ loopIntegral, -- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b
+
+-- Pointwise functions on events
+ noEvent, -- :: Event a
+ noEventFst, -- :: (Event a, b) -> (Event c, b)
+ noEventSnd, -- :: (a, Event b) -> (a, Event c)
+ event, -- :: a -> (b -> a) -> Event b -> a
+ fromEvent, -- :: Event a -> a
+ isEvent, -- :: Event a -> Bool
+ isNoEvent, -- :: Event a -> Bool
+ tag, -- :: Event a -> b -> Event b, infixl 8
+ attach, -- :: Event a -> b -> Event (a, b), infixl 8
+ lMerge, -- :: Event a -> Event a -> Event a, infixl 6
+ rMerge, -- :: Event a -> Event a -> Event a, infixl 6
+ merge, -- :: Event a -> Event a -> Event a, infixl 6
+ mergeBy, -- :: (a -> a -> a) -> Event a -> Event a -> Event a
+ mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c)
+ -- -> Event a -> Event b -> Event c
+ mergeEvents, -- :: [Event a] -> Event a
+ catEvents, -- :: [Event a] -> Event [a]
+ joinE, -- :: Event a -> Event b -> Event (a,b),infixl 7
+ splitE, -- :: Event (a,b) -> (Event a, Event b)
+ filterE, -- :: (a -> Bool) -> Event a -> Event a
+ mapFilterE, -- :: (a -> Maybe b) -> Event a -> Event b
+ gate, -- :: Event a -> Bool -> Event a, infixl 8
+
+-- Reactimation
+ reactimate, -- :: IO a
+ -- -> (Bool -> IO (DTime, Maybe a))
+ -- -> (Bool -> b -> IO Bool)
+ -- -> SF a b
+ -- -> IO ()
+ ReactHandle,
+ reactInit, -- IO a -- init
+ -- -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
+ -- -> SF a b
+ -- -> IO (ReactHandle a b)
+-- process a single input sample:
+ react, -- ReactHandle a b
+ -- -> (DTime,Maybe a)
+ -- -> IO Bool
+
+-- Embedding (tentative: will be revisited)
+ DTime, -- [s] Sampling interval, always > 0.
+ embed, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
+ embedSynch, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
+ deltaEncode, -- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
+ deltaEncodeBy -- :: (a -> a -> Bool) -> DTime -> [a]
+ -- -> (a, [(DTime, Maybe a)])
+) where
+
+import Monad (unless)
+
+import Control.Arrow
+import qualified Control.Category
+import AFRPDiagnostics
+import AFRPMiscellany (( # ), dup, swap)
+import AFRPEvent
+
+import Data.IORef
+
+infixr 0 -->, >--, -=>, >=-
+
+------------------------------------------------------------------------------
+-- Basic type definitions with associated utilities
+------------------------------------------------------------------------------
+
+-- The time type is really a bit boguous, since, as time passes, the minimal
+-- interval between two consecutive floating-point-represented time points
+-- increases. A better approach is probably to pick a reasonable resolution
+-- and represent time and time intervals by Integer (giving the number of
+-- "ticks").
+
+-- Time is used both for time intervals (duration), and time w.r.t. some
+-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0
+-- or even negative.
+type Time = Double -- [s]
+
+
+-- DTime is the time type for lengths of sample intervals. Conceptually,
+-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the
+-- same representation.
+
+type DTime = Double -- [s]
+
+
+-- Representation of signal function in initial state.
+-- (Naming: "TF" stands for Transition Function.)
+
+data SF a b = SF {sfTF :: a -> Transition a b}
+
+
+-- Representation of signal function in running state.
+-- It would have been nice to have a constructor SFId representing (arr id):
+--
+-- SFId {sfTF' :: DTime -> a -> Transition a b}
+--
+-- But it seems as if we need dependent types as soon as we try to exploit
+-- that constructor (note that the type above is too general!), and a
+-- work-around based on keeping around an extra function as a "proof" that we
+-- can do the required coersions, yields codde which is no more efficient
+-- than using SFArr in the first place.
+-- (Naming: "TIVar" stands for "time-input-variable".)
+
+data SF' a b
+ = SFConst {sfTF' :: DTime -> a -> Transition a b, sfCVal :: b}
+ | SFArr {sfTF' :: DTime -> a -> Transition a b, sfAFun :: a -> b}
+ | SFTIVar {sfTF' :: DTime -> a -> Transition a b}
+
+
+-- A transition is a pair of the next state (in the form of a signal
+-- function) and the output at the present time step.
+
+type Transition a b = (SF' a b, b)
+
+
+-- "Smart" constructors. The corresponding "raw" constructors should not
+-- be used directly for construction.
+
+sfConst :: b -> SF' a b
+sfConst b = sf
+ where
+ sf = SFConst {sfTF' = \_ _ -> (sf, b), sfCVal = b}
+
+
+sfNever :: SF' a (Event b)
+sfNever = sfConst NoEvent
+
+
+sfId :: SF' a a
+sfId = sf
+ where
+ sf = SFArr {sfTF' = \_ a -> (sf, a), sfAFun = id}
+
+
+sfArr :: (a -> b) -> SF' a b
+sfArr f = sf
+ where
+ sf = SFArr {sfTF' = \_ a -> (sf, f a), sfAFun = f}
+
+
+-- Freezes a "running" signal function, i.e., turns it into a continuation in
+-- the form of a plain signal function.
+freeze :: SF' a b -> DTime -> SF a b
+freeze sf dt = SF {sfTF = (sfTF' sf) dt}
+
+
+freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)
+freezeCol sfs dt = fmap (flip freeze dt) sfs
+
+
+------------------------------------------------------------------------------
+-- Arrow instance and implementation
+------------------------------------------------------------------------------
+
+instance Control.Category.Category SF where
+ id = arrPrim id
+ (.) = flip compPrim
+
+instance Arrow SF where
+ arr = arrPrim
+ -- (>>>) = compPrim
+ first = firstPrim
+ second = secondPrim
+ (***) = parSplitPrim
+ (&&&) = parFanOutPrim
+
+
+-- Lifting.
+arrPrim :: (a -> b) -> SF a b
+arrPrim f = SF {sfTF = \a -> (sfArr f, f a)}
+
+
+-- Composition.
+-- The definition exploits the following identities:
+-- sf >>> constant c = constant c
+-- constant c >>> arr f = constant (f c)
+-- arr f >>> arr g = arr (g . f)
+-- (It would have been nice to explit e.g. identity >>> sf = sf, but it would
+-- seem that we need dependent types for that.)
+compPrim :: SF a b -> SF b c -> SF a c
+compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
+ where
+ tf0 a0 = (cpAux sf1 sf2, c0)
+ where
+ (sf1, b0) = tf10 a0
+ (sf2, c0) = tf20 b0
+
+ cpAux _ sf2@(SFConst {}) = sfConst (sfCVal sf2)
+ cpAux sf1@(SFConst {}) sf2 = cpAuxC1 (sfCVal sf1) sf2
+ cpAux sf1@(SFArr {}) sf2 = cpAuxA1 (sfAFun sf1) sf2
+ cpAux sf1 sf2@(SFArr {}) = cpAuxA2 sf1 (sfAFun sf2)
+ cpAux sf1 sf2 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (cpAux sf1' sf2', c)
+ where
+ (sf1', b) = (sfTF' sf1) dt a
+ (sf2', c) = (sfTF' sf2) dt b
+
+ cpAuxC1 _ (SFConst {sfCVal = c}) = sfConst c
+ cpAuxC1 b (SFArr {sfAFun = f2}) = sfConst (f2 b)
+ cpAuxC1 b (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}
+ where
+ tf dt _ = (cpAuxC1 b sf2', c)
+ where
+ (sf2', c) = tf2 dt b
+
+ cpAuxA1 _ (SFConst {sfCVal = c}) = sfConst c
+ cpAuxA1 f1 (SFArr {sfAFun = f2}) = sfArr (f2 . f1)
+ cpAuxA1 f1 (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (cpAuxA1 f1 sf2', c)
+ where
+ (sf2', c) = tf2 dt (f1 a)
+
+ cpAuxA2 (SFConst {sfCVal = b}) f2 = sfConst (f2 b)
+ cpAuxA2 (SFArr {sfAFun = f1}) f2 = sfArr (f2 . f1)
+ cpAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (cpAuxA2 sf1' f2, f2 b)
+ where
+ (sf1', b) = tf1 dt a
+
+
+-- Widening.
+-- The definition exploits the following identities:
+-- first (constant b) = arr (\(_, c) -> (b, c))
+-- (first (arr f)) = arr (\(a, c) -> (f a, c))
+-- (It would have been nice to exploit first identity = identity, but it would
+-- seem that we need dependent types for that.)
+firstPrim :: SF a b -> SF (a,c) (b,c)
+firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
+ where
+ tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
+ where
+ (sf1, b0) = tf10 a0
+
+ fpAux (SFConst {sfCVal = b}) = sfArr (\(~(_, c)) -> (b, c))
+ fpAux (SFArr {sfAFun = f}) = sfArr (\(~(a, c)) -> (f a, c))
+ fpAux sf1 = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(a, c) = (fpAux sf1', (b, c))
+ where
+ (sf1', b) = (sfTF' sf1) dt a
+
+
+-- Mirror image of first.
+secondPrim :: SF a b -> SF (c,a) (c,b)
+secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
+ where
+ tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
+ where
+ (sf1, b0) = tf10 a0
+
+ spAux (SFConst {sfCVal = b}) = sfArr (\(~(c, _)) -> (c, b))
+ spAux (SFArr {sfAFun = f}) = sfArr (\(~(c, a)) -> (c, f a))
+ spAux sf1 = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(c, a) = (spAux sf1', (c, b))
+ where
+ (sf1', b) = (sfTF' sf1) dt a
+
+
+-- Parallel composition.
+-- The definition exploits the following identities (which hold for SF):
+-- constant b *** constant d = constant (b, d)
+-- constant b *** arr f2 = arr (\(_, c) -> (b, f2 c)
+-- arr f1 *** constant d = arr (\(a, _) -> (f1 a, d)
+-- arr f1 *** arr f2 = arr (\(a, b) -> (f1 a, f2 b)
+parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d)
+parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
+ where
+ tf0 ~(a0, c0) = (psAux sf1 sf2, (b0, d0))
+ where
+ (sf1, b0) = tf10 a0
+ (sf2, d0) = tf20 c0
+
+ psAux sf1@(SFConst {}) sf2 = psAuxC1 (sfCVal sf1) sf2
+ psAux sf1 sf2@(SFConst {}) = psAuxC2 sf1 (sfCVal sf2)
+ psAux sf1@(SFArr {}) sf2 = psAuxA1 (sfAFun sf1) sf2
+ psAux sf1 sf2@(SFArr {}) = psAuxA2 sf1 (sfAFun sf2)
+ psAux sf1 sf2 = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(a, c) = (psAux sf1' sf2', (b, d))
+ where
+ (sf1', b) = (sfTF' sf1) dt a
+ (sf2', d) = (sfTF' sf2) dt c
+
+ psAuxC1 b (SFConst {sfCVal = d}) = sfConst (b, d)
+ psAuxC1 b (SFArr {sfAFun = f2}) = sfArr (\(~(_, c)) -> (b, f2 c))
+ psAuxC1 b (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(_, c) = (psAuxC1 b sf2', (b, d))
+ where
+ (sf2', d) = tf2 dt c
+
+ psAuxC2 (SFConst {sfCVal = b}) d = sfConst (b, d)
+ psAuxC2 (SFArr {sfAFun = f1}) d = sfArr (\(~(a, _)) -> (f1 a, d))
+ psAuxC2 (SFTIVar {sfTF' = tf1}) d = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(a, _) = (psAuxC2 sf1' d, (b, d))
+ where
+ (sf1', b) = tf1 dt a
+
+ psAuxA1 f1 (SFConst {sfCVal = d}) = sfArr (\(~(a,_)) -> (f1 a, d))
+ psAuxA1 f1 (SFArr {sfAFun = f2}) = sfArr (\(~(a,c)) -> (f1 a, f2 c))
+ psAuxA1 f1 (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(a, c) = (psAuxA1 f1 sf2', (f1 a, d))
+ where
+ (sf2', d) = tf2 dt c
+
+ psAuxA2 (SFConst {sfCVal = b}) f2 = sfArr (\(~(_,c)) -> (b, f2 c))
+ psAuxA2 (SFArr {sfAFun = f1}) f2 = sfArr (\(~(a,c)) -> (f1 a, f2 c))
+ psAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}
+ where
+ tf dt ~(a, c) = (psAuxA2 sf1' f2, (b, f2 c))
+ where
+ (sf1', b) = tf1 dt a
+
+
+parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
+parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
+ where
+ tf0 a0 = (pfoAux sf1 sf2, (b0, c0))
+ where
+ (sf1, b0) = tf10 a0
+ (sf2, c0) = tf20 a0
+
+ pfoAux sf1@(SFConst {}) sf2 = pfoAuxC1 (sfCVal sf1) sf2
+ pfoAux sf1 sf2@(SFConst {}) = pfoAuxC2 sf1 (sfCVal sf2)
+ pfoAux sf1@(SFArr {}) sf2 = pfoAuxA1 (sfAFun sf1) sf2
+ pfoAux sf1 sf2@(SFArr {}) = pfoAuxA2 sf1 (sfAFun sf2)
+ pfoAux sf1 sf2 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (pfoAux sf1' sf2', (b, c))
+ where
+ (sf1', b) = (sfTF' sf1) dt a
+ (sf2', c) = (sfTF' sf2) dt a
+
+ pfoAuxC1 b (SFConst {sfCVal = c}) = sfConst (b, c)
+ pfoAuxC1 b (SFArr {sfAFun = f2}) = sfArr (\a -> (b, f2 a))
+ pfoAuxC1 b (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (pfoAuxC1 b sf2', (b, c))
+ where
+ (sf2', c) = tf2 dt a
+
+ pfoAuxC2 (SFConst {sfCVal = b}) c = sfConst (b, c)
+ pfoAuxC2 (SFArr {sfAFun = f1}) c = sfArr (\a -> (f1 a, c))
+ pfoAuxC2 (SFTIVar {sfTF' = tf1}) c = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (pfoAuxC2 sf1' c, (b, c))
+ where
+ (sf1', b) = tf1 dt a
+
+ pfoAuxA1 f1 (SFConst {sfCVal = c}) = sfArr (\a -> (f1 a, c))
+ pfoAuxA1 f1 (SFArr {sfAFun = f2}) = sfArr (\a -> (f1 a ,f2 a))
+ pfoAuxA1 f1 (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (pfoAuxA1 f1 sf2', (f1 a, c))
+ where
+ (sf2', c) = tf2 dt a
+
+ pfoAuxA2 (SFConst {sfCVal = b}) f2 = sfArr (\a -> (b, f2 a))
+ pfoAuxA2 (SFArr {sfAFun = f1}) f2 = sfArr (\a -> (f1 a, f2 a))
+ pfoAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (pfoAuxA2 sf1' f2, (b, f2 a))
+ where
+ (sf1', b) = tf1 dt a
+
+
+------------------------------------------------------------------------------
+-- ArrowLoop instance and implementation
+------------------------------------------------------------------------------
+
+instance ArrowLoop SF where
+ loop = loopPrim
+
+
+loopPrim :: SF (a,c) (b,c) -> SF a b
+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
+ where
+ tf0 a0 = (loopAux sf1, b0)
+ where
+ (sf1, (b0, c0)) = tf10 (a0, c0)
+
+ loopAux (SFConst {sfCVal = (b, _)}) = sfConst b
+ loopAux (SFArr {sfAFun = f1}) = sfArr (\a -> let (b,c) = f1 (a,c)
+ in b)
+ loopAux sf1 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (loopAux sf1', b)
+ where
+ (sf1', (b, c)) = (sfTF' sf1) dt (a, c)
+
+
+------------------------------------------------------------------------------
+-- Basic signal functions
+------------------------------------------------------------------------------
+
+-- Identity: identity = arr id
+identity :: SF a a
+identity = SF {sfTF = \a -> (sfId, a)}
+
+
+-- Identity: constant b = arr (const b)
+constant :: b -> SF a b
+constant b = SF {sfTF = \_ -> (sfConst b, b)}
+
+
+-- Outputs the time passed since the signal function instance was started.
+localTime :: SF a Time
+localTime = constant 1.0 >>> integral
+
+
+-- Alternative name for localTime.
+time :: SF a Time
+time = localTime
+
+
+------------------------------------------------------------------------------
+-- Initialization
+------------------------------------------------------------------------------
+
+-- Initialization operator (cf. Lustre/Lucid Synchrone).
+(-->) :: b -> SF a b -> SF a b
+b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}
+
+
+-- Input initialization operator.
+(>--) :: a -> SF a b -> SF a b
+a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}
+
+
+-- Transform initial output value.
+(-=>) :: (b -> b) -> SF a b -> SF a b
+f -=> (SF {sfTF = tf10}) =
+ SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}
+
+
+-- Transform initial input value.
+(>=-) :: (a -> a) -> SF a b -> SF a b
+f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}
+
+
+-- Override initial value of input signal.
+initially :: a -> SF a a
+initially = (--> identity)
+
+
+------------------------------------------------------------------------------
+-- Basic event sources
+------------------------------------------------------------------------------
+
+-- Event source which never occurs.
+never :: SF a (Event b)
+never = SF {sfTF = \_ -> (sfNever, NoEvent)}
+
+
+-- Event source with a single occurrence at time 0. The value of the event
+-- is given by the function argument.
+now :: b -> SF a (Event b)
+now b0 = (Event b0 --> never)
+
+
+-- Event source with a single occurrence at or as soon after (local) time q
+-- as possible.
+after :: Time -> b -> SF a (Event b)
+after q x = afterEach [(q,x)]
+
+
+-- Event source with repeated occurrences with interval q.
+-- Note: If the interval is too short w.r.t. the sampling intervals,
+-- the result will be that events occur at every sample. However, no more
+-- than one event results from any sampling interval, thus avoiding an
+-- "event backlog" should sampling become more frequent at some later
+-- point in time.
+repeatedly :: Time -> b -> SF a (Event b)
+repeatedly q x | q > 0 = afterEach qxs
+ | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."
+ where
+ qxs = (q,x):qxs
+
+
+-- Event source with consecutive occurrences at the given intervals.
+-- Should more than one event be scheduled to occur in any sampling interval,
+-- only the first will in fact occur to avoid an event backlog.
+-- Question: Should positive periods except for the first one be required?
+-- Note that periods of length 0 will always be skipped except for the first.
+-- Right now, periods of length 0 is allowed on the grounds that no attempt
+-- is made to forbid simultaneous events elsewhere.
+afterEach :: [(Time,b)] -> SF a (Event b)
+afterEach [] = never
+afterEach ((q,x):qxs)
+ | q < 0 = usrErr "AFRP" "afterEach" "Negative period."
+ | otherwise = SF {sfTF = tf0}
+ where
+ tf0 _ = if q <= 0 then
+ (scheduleNextEvent 0.0 qxs, Event x)
+ else
+ (awaitNextEvent (-q) x qxs, NoEvent)
+
+ scheduleNextEvent t [] = sfNever
+ scheduleNextEvent t ((q,x):qxs)
+ | q < 0 = usrErr "AFRP" "afterEach" "Negative period."
+ | t' >= 0 = scheduleNextEvent t' qxs
+ | otherwise = awaitNextEvent t' x qxs
+ where
+ t' = t - q
+ awaitNextEvent t x qxs = SFTIVar {sfTF' = tf}
+ where
+ tf dt _ | t' >= 0 = (scheduleNextEvent t' qxs, Event x)
+ | otherwise = (awaitNextEvent t' x qxs, NoEvent)
+ where
+ t' = t + dt
+
+
+-- A rising edge detector. Useful for things like detecting key presses.
+-- Note that we initialize the loop with state set to True so that there
+-- will not be an occurence at t0 in the logical time frame in which
+-- this is started.
+edge :: SF Bool (Event ())
+edge = iEdge True
+
+
+iEdge :: Bool -> SF Bool (Event ())
+iEdge i = edgeBy (isBoolRaisingEdge ()) i
+
+
+-- Like edge, but parameterized on the tag value.
+edgeTag :: a -> SF Bool (Event a)
+edgeTag a = edgeBy (isBoolRaisingEdge a) True
+
+
+-- Internal utility.
+isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a
+isBoolRaisingEdge _ False False = Nothing
+isBoolRaisingEdge a False True = Just a
+isBoolRaisingEdge _ True True = Nothing
+isBoolRaisingEdge _ True False = Nothing
+
+
+-- Detects an edge where a maybe signal is changing from nothing to something.
+edgeJust :: SF (Maybe a) (Event a)
+edgeJust = edgeBy isJustEdge (Just undefined)
+ where
+ isJustEdge Nothing Nothing = Nothing
+ isJustEdge Nothing ma@(Just _) = ma
+ isJustEdge (Just _) (Just _) = Nothing
+ isJustEdge (Just _) Nothing = Nothing
+
+
+-- Edge detector parameterized on the edge detection function and initial
+-- state, i.e., the previous input sample. The first argument to the
+-- edge detection function is the previous sample, the second the current one.
+
+-- !!! Is this broken!?! Does not disallow an edge condition that persists
+-- !!! between consecutive samples. See discussion in ToDo list above.
+
+edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)
+edgeBy isEdge a_init = SF {sfTF = tf0}
+ where
+ tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))
+
+ ebAux a_prev = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (ebAux a, maybeToEvent (isEdge a_prev a))
+
+
+------------------------------------------------------------------------------
+-- Stateful event suppression
+------------------------------------------------------------------------------
+
+-- Suppression of initial (at local time 0) event.
+notYet :: SF (Event a) (Event a)
+notYet = initially NoEvent
+
+
+-- Suppress all but first event.
+once :: SF (Event a) (Event a)
+once = takeEvents 1
+
+
+-- Suppress all but first n events.
+takeEvents :: Int -> SF (Event a) (Event a)
+takeEvents 0 = never
+takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1)))
+
+
+{-
+-- More complicated using "switch" that "dSwitch".
+takeEvents :: Int -> SF (Event a) (Event a)
+takeEvents 0 = never
+takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)
+ where
+ takeEvents' 0 a = now a
+ takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)
+-}
+
+
+-- Suppress first n events.
+-- Here dSwitch or switch does not really matter.
+dropEvents :: Int -> SF (Event a) (Event a)
+dropEvents 0 = identity
+dropEvents n = dSwitch (never &&& identity)
+ (const (NoEvent >-- dropEvents (n - 1)))
+
+
+------------------------------------------------------------------------------
+-- Basic switchers
+------------------------------------------------------------------------------
+
+-- Basic switch.
+switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
+switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ case tf10 a0 of
+ (sf1, (b0, NoEvent)) -> (switchAux sf1, b0)
+ (_, (_, Event c0)) -> sfTF (k c0) a0
+
+ switchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b
+ switchAux (SFArr {sfAFun = f1}) = switchAuxA1 f1
+ switchAux sf1 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ case (sfTF' sf1) dt a of
+ (sf1', (b, NoEvent)) -> (switchAux sf1', b)
+ (_, (_, Event c)) -> sfTF (k c) a
+
+ -- Note: While switch behaves as a stateless arrow at this point, that
+ -- could change after a switch. Hence, SFTIVar overall.
+ switchAuxA1 f1 = sf
+ where
+ sf = SFTIVar {sfTF' = tf}
+ tf _ a =
+ case f1 a of
+ (b, NoEvent) -> (sf, b)
+ (_, Event c) -> sfTF (k c) a
+
+
+-- Switch with delayed observation.
+dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
+dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ let (sf1, (b0, ec0)) = tf10 a0
+ in (case ec0 of
+ NoEvent -> dSwitchAux sf1
+ Event c0 -> fst (sfTF (k c0) a0),
+ b0)
+
+ dSwitchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b
+ dSwitchAux (SFArr {sfAFun = f1}) = dSwitchAuxA1 f1
+ dSwitchAux sf1 = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ let (sf1', (b, ec)) = (sfTF' sf1) dt a
+ in (case ec of
+ NoEvent -> dSwitchAux sf1'
+ Event c -> fst (sfTF (k c) a),
+
+ b)
+
+ -- Note: While dSwitch behaves as a stateless arrow at this point, that
+ -- could change after a switch. Hence, SFTIVar overall.
+ dSwitchAuxA1 f1 = sf
+ where
+ sf = SFTIVar {sfTF' = tf}
+ tf _ a =
+ let (b, ec) = f1 a
+ in (case ec of
+ NoEvent -> sf
+ Event c -> fst (sfTF (k c) a),
+
+ b)
+
+
+-- Recurring switch.
+rSwitch :: SF a b -> SF (a, Event (SF a b)) b
+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)
+
+{-
+-- Old version. New is more efficient. Which one is clearer?
+rSwitch :: SF a b -> SF (a, Event (SF a b)) b
+rSwitch sf = switch (first sf) rSwitch'
+ where
+ rSwitch' sf = switch (sf *** notYet) rSwitch'
+-}
+
+
+-- Recurring switch with delayed observation.
+drSwitch :: SF a b -> SF (a, Event (SF a b)) b
+drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)
+
+{-
+-- Old version. New is more efficient. Which one is clearer?
+drSwitch :: SF a b -> SF (a, Event (SF a b)) b
+drSwitch sf = dSwitch (first sf) drSwitch'
+ where
+ drSwitch' sf = dSwitch (sf *** notYet) drSwitch'
+-}
+
+
+-- "Call-with-current-continuation" switch.
+kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
+kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ let (sf1, b0) = tf10 a0
+ in
+ case tfe0 (a0, b0) of
+ (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0)
+ (_, Event c0) -> sfTF (k sf10 c0) a0
+
+ kSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1
+ kSwitchAux sf1 sfe = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ let (sf1', b) = (sfTF' sf1) dt a
+ in
+ case (sfTF' sfe) dt (a, b) of
+ (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)
+ (_, Event c) -> sfTF (k (freeze sf1 dt) c) a
+
+
+-- kSwitch with delayed observation.
+dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
+dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ let (sf1, b0) = tf10 a0
+ in (case tfe0 (a0, b0) of
+ (sfe, NoEvent) -> dkSwitchAux sf1 sfe
+ (_, Event c0) -> fst (sfTF (k sf10 c0) a0),
+ b0)
+
+ dkSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1
+ dkSwitchAux sf1 sfe = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ let (sf1', b) = (sfTF' sf1) dt a
+ in (case (sfTF' sfe) dt (a, b) of
+ (sfe', NoEvent) -> dkSwitchAux sf1' sfe'
+ (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),
+ b)
+
+
+------------------------------------------------------------------------------
+-- Parallel composition and switching over collections with broadcasting
+------------------------------------------------------------------------------
+
+broadcast :: Functor col => a -> col sf -> col (a, sf)
+broadcast a sfs = fmap (\sf -> (a, sf)) sfs
+
+
+-- Spatial parallel composition of a signal function collection.
+parB :: Functor col => col (SF a b) -> SF a (col b)
+parB = par broadcast
+
+
+-- Parallel switch (dynamic collection of signal functions spatially composed
+-- in parallel).
+pSwitchB :: Functor col =>
+ col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))
+ -> SF a (col b)
+pSwitchB = pSwitch broadcast
+
+
+dpSwitchB :: Functor col =>
+ col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b))
+ -> SF a (col b)
+dpSwitchB = dpSwitch broadcast
+
+
+rpSwitchB :: Functor col =>
+ col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
+rpSwitchB = rpSwitch broadcast
+
+
+drpSwitchB :: Functor col =>
+ col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
+drpSwitchB = drpSwitch broadcast
+
+
+------------------------------------------------------------------------------
+-- Parallel composition and switching over collections with general routing
+------------------------------------------------------------------------------
+
+-- Spatial parallel composition of a signal function collection parameterized
+-- on the routing function.
+-- rf ......... Routing function: determines the input to each signal function
+-- in the collection. IMPORTANT! The routing function MUST
+-- preserve the structure of the signal function collection.
+-- sfs0 ....... Signal function collection.
+-- Returns the spatial parallel composition of the supplied signal functions.
+
+par :: Functor col =>
+ (forall sf . (a -> col sf -> col (b, sf)))
+ -> col (SF b c)
+ -> SF a (col c)
+par rf sfs0 = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ let bsfs0 = rf a0 sfs0
+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
+ sfs = fmap fst sfcs0
+ cs0 = fmap snd sfcs0
+ in
+ (parAux rf sfs, cs0)
+
+
+-- Internal definition. Also used in parallel swithers.
+parAux :: Functor col =>
+ (forall sf . (a -> col sf -> col (b, sf)))
+ -> col (SF' b c)
+ -> SF' a (col c)
+parAux rf sfs = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ let bsfs = rf a sfs
+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
+ sfs' = fmap fst sfcs'
+ cs = fmap snd sfcs'
+ in
+ (parAux rf sfs', cs)
+
+
+-- Parallel switch parameterized on the routing function. This is the most
+-- general switch from which all other (non-delayed) switches in principle
+-- can be derived. The signal function collection is spatially composed in
+-- parallel and run until the event signal function has an occurrence. Once
+-- the switching event occurs, all signal function are "frozen" and their
+-- continuations are passed to the continuation function, along with the
+-- event value.
+-- rf ......... Routing function: determines the input to each signal function
+-- in the collection. IMPORTANT! The routing function has an
+-- obligation to preserve the structure of the signal function
+-- collection.
+-- sfs0 ....... Signal function collection.
+-- sfe0 ....... Signal function generating the switching event.
+-- k .......... Continuation to be invoked once event occurs.
+-- Returns the resulting signal function.
+
+pSwitch :: Functor col =>
+ (forall sf . (a -> col sf -> col (b, sf)))
+ -> col (SF b c)
+ -> SF (a, col c) (Event d)
+ -> (col (SF b c) -> d -> SF a (col c))
+ -> SF a (col c)
+pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ let bsfs0 = rf a0 sfs0
+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
+ sfs = fmap fst sfcs0
+ cs0 = fmap snd sfcs0
+ in
+ case (sfTF sfe0) (a0, cs0) of
+ (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0)
+ (_, Event d0) -> sfTF (k sfs0 d0) a0
+
+ pSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs
+ pSwitchAux sfs sfe = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ let bsfs = rf a sfs
+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
+ sfs' = fmap fst sfcs'
+ cs = fmap snd sfcs'
+ in
+ case (sfTF' sfe) dt (a, cs) of
+ (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)
+ (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a
+
+
+-- Parallel switch with delayed observation parameterized on the routing
+-- function.
+dpSwitch :: Functor col =>
+ (forall sf . (a -> col sf -> col (b, sf)))
+ -> col (SF b c)
+ -> SF (a, col c) (Event d)
+ -> (col (SF b c) -> d -> SF a (col c))
+ -> SF a (col c)
+dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
+ where
+ tf0 a0 =
+ let bsfs0 = rf a0 sfs0
+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
+ cs0 = fmap snd sfcs0
+ in
+ (case (sfTF sfe0) (a0, cs0) of
+ (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe
+ (_, Event d0) -> fst (sfTF (k sfs0 d0) a0),
+ cs0)
+
+ dpSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs
+ dpSwitchAux sfs sfe = SFTIVar {sfTF' = tf}
+ where
+ tf dt a =
+ let bsfs = rf a sfs
+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
+ cs = fmap snd sfcs'
+ in
+ (case (sfTF' sfe) dt (a, cs) of
+ (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')
+ sfe'
+ (_, Event d) -> fst (sfTF (k (freezeCol sfs dt)
+ d)
+ a),
+ cs)
+
+
+-- Recurring parallel switch parameterized on the routing function.
+-- rf ......... Routing function: determines the input to each signal function
+-- in the collection. IMPORTANT! The routing function has an
+-- obligation to preserve the structure of the signal function
+-- collection.
+-- sfs ........ Initial signal function collection.
+-- Returns the resulting signal function.
+
+rpSwitch :: Functor col =>
+ (forall sf . (a -> col sf -> col (b, sf)))
+ -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
+rpSwitch rf sfs =
+ pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
+ noEventSnd >=- rpSwitch rf (f sfs')
+
+
+{-
+rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k
+ where
+ k sfs f = rpSwitch' (f sfs)
+ rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k
+-}
+
+-- Recurring parallel switch with delayed observation parameterized on the
+-- routing function.
+drpSwitch :: Functor col =>
+ (forall sf . (a -> col sf -> col (b, sf)))
+ -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
+drpSwitch rf sfs =
+ dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
+ noEventSnd >=- drpSwitch rf (f sfs')
+
+{-
+drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k
+ where
+ k sfs f = drpSwitch' (f sfs)
+ drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k
+-}
+
+------------------------------------------------------------------------------
+-- Wave-form generation
+------------------------------------------------------------------------------
+
+-- Zero-order hold.
+hold :: a -> SF (Event a) a
+hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . hold)
+
+
+-- Tracks input signal when available, holds last value when disappears.
+trackAndHold :: a -> SF (Maybe a) a
+trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init
+
+
+------------------------------------------------------------------------------
+-- Accumulators
+------------------------------------------------------------------------------
+
+accum :: a -> SF (Event (a -> a)) (Event a)
+accum = accumBy (flip ($))
+
+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
+accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)
+ where
+ abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)
+
+
+{-
+-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))
+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
+accumBy f b_init = SF {sfTF = tf0}
+ where
+ tf0 NoEvent = (abAux b_init, NoEvent)
+ tf0 (Event a0) = let b' = f b_init a0
+ in (abAux b', Event b')
+
+ abAux b = SFTIVar {sfTF' = tf}
+ where
+ tf _ NoEvent = (abAux b, NoEvent)
+ tf _ (Event a) = let b' = f b a
+ in (abAux b', Event b')
+-}
+
+{-
+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
+accumFilter f c_init = SF {sfTF = tf0}
+ where
+ tf0 NoEvent = (afAux c_init, NoEvent)
+ tf0 (Event a0) = case f c_init a0 of
+ (c', Nothing) -> (afAux c', NoEvent)
+ (c', Just b0) -> (afAux c', Event b0)
+
+ afAux c = SFTIVar {sfTF' = tf}
+ where
+ tf _ NoEvent = (afAux c, NoEvent)
+ tf _ (Event a) = case f c a of
+ (c', Nothing) -> (afAux c', NoEvent)
+ (c', Just b) -> (afAux c', Event b)
+-}
+
+
+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
+accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)
+ where
+ afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)
+ afAux (c, Just b) = switch (now b &&& notYet) $ \a -> afAux (f c a)
+
+
+------------------------------------------------------------------------------
+-- Delays
+------------------------------------------------------------------------------
+
+-- Uninitialized delay operator.
+-- !!! The seq helps in the dynamic delay line example. But is it a good
+-- !!! idea in general? Are there other accumulators which should be seq'ed
+-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying
+-- !!! design principle? What can the user assume?
+pre = SF {sfTF = tf0}
+ where
+ tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")
+
+ preAux a_prev = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = {- a_prev `seq` -} (preAux a, a_prev)
+
+
+-- Initialized delay operator.
+iPre :: a -> SF a a
+iPre = (--> pre)
+
+
+------------------------------------------------------------------------------
+-- Integraltion and differentiation
+------------------------------------------------------------------------------
+
+-- Integration using the rectangle rule.
+integral :: Fractional a => SF a a
+integral = SF {sfTF = tf0}
+ where
+ igrl0 = 0
+
+ tf0 a0 = (integralAux igrl0 a0, igrl0)
+
+ integralAux igrl a_prev = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (integralAux igrl' a, igrl')
+ where
+ igrl' = igrl + realToFrac dt * a_prev
+
+
+
+-- "immediate" integration (using the function's value at the current time)
+imIntegral :: Fractional a => a -> SF a a
+imIntegral = ((\ _ a' dt v -> v + realToFrac dt * a') `iterFrom`)
+
+iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b
+f `iterFrom` b = SF (iterAux b) where
+ iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)
+
+{-
+integral :: Fractional a => SF a a
+integral = SF {sfTF = tf0}
+ where
+ igrl0 = 0.0
+
+ tf0 a0 = (integralAux igrl0 a0, igrl0)
+
+ integralAux igrl a_prev = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (integralAux igrl' a, igrl')
+ where
+ igrl' = igrl + a_prev * realToFrac dt
+-}
+
+-- This is extremely crude. Use at your own risk.
+derivative :: Fractional a => SF a a
+derivative = SF {sfTF = tf0}
+ where
+ tf0 a0 = (derivativeAux a0, 0)
+
+ derivativeAux a_prev = SFTIVar {sfTF' = tf}
+ where
+ tf dt a = (derivativeAux a, (a - a_prev) / realToFrac dt)
+
+
+------------------------------------------------------------------------------
+-- Loops with guaranteed well-defined feedback
+------------------------------------------------------------------------------
+
+loopPre :: c -> SF (a,c) (b,c) -> SF a b
+loopPre c_init sf = loop (second (iPre c_init) >>> sf)
+
+
+
+loopIntegral :: Fractional c => SF (a,c) (b,c) -> SF a b
+loopIntegral sf = loop (second integral >>> sf)
+
+
+------------------------------------------------------------------------------
+-- Reactimation
+------------------------------------------------------------------------------
+
+-- Reactimation of a signal function.
+-- init ....... IO action for initialization. Will only be invoked once,
+-- at (logical) time 0, before first call to "sense".
+-- Expected to return the value of input at time 0.
+-- sense ...... IO action for sensing of system input.
+-- arg. #1 ....... True: action may block, waiting for an OS event.
+-- False: action must not block.
+-- res. #1 ....... Time interval since previous invocation of the sensing
+-- action (or, the first time round, the init action),
+-- returned. The interval must be _strictly_ greater
+-- than 0. Thus even a non-blocking invocation must
+-- ensure that time progresses.
+-- res. #2 ....... Nothing: input is unchanged w.r.t. the previously
+-- returned input sample.
+-- Just i: the input is currently i.
+-- It is OK to always return "Just", even if input is
+-- unchanged.
+-- actuate .... IO action for outputting the system output.
+-- arg. #1 ....... True: output may have changed from previous output
+-- sample.
+-- False: output is definitely unchanged from previous
+-- output sample.
+-- It is OK to ignore argument #1 and assume that the
+-- the output has always changed.
+-- arg. #2 ....... Current output sample.
+-- result ....... Termination flag. Once True, reactimate will exit
+-- the reactimation loop and return to its caller.
+-- sf ......... Signal function to reactimate.
+
+reactimate :: IO a
+ -> (Bool -> IO (DTime, Maybe a))
+ -> (Bool -> b -> IO Bool)
+ -> SF a b
+ -> IO ()
+reactimate init sense actuate (SF {sfTF = tf0}) =
+ do
+ a0 <- init
+ let (sf, b0) = tf0 a0
+ loop sf a0 b0
+ where
+ loop sf a b = do
+ done <- actuate True b
+ unless (a `seq` b `seq` done) $ do
+ (dt, ma') <- sense False
+ let a' = maybe a id ma'
+ (sf', b') = (sfTF' sf) dt a'
+ loop sf' a' b'
+
+-- An API for animating a signal function when some other library
+-- needs to own the top-level control flow:
+
+-- reactimate's state, maintained across samples:
+data ReactState a b = ReactState {
+ rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,
+ rsSF :: SF' a b,
+ rsA :: a,
+ rsB :: b
+ }
+
+type ReactHandle a b = IORef (ReactState a b)
+
+-- initialize top-level reaction handle
+reactInit :: IO a -- init
+ -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
+ -> SF a b
+ -> IO (ReactHandle a b)
+reactInit init actuate (SF {sfTF = tf0}) =
+ do a0 <- init
+ let (sf,b0) = tf0 a0
+ -- TODO: really need to fix this interface, since right now we
+ -- just ignore termination at time 0:
+ r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf, rsA = a0, rsB = b0 })
+ done <- actuate r True b0
+ return r
+
+-- process a single input sample:
+react :: ReactHandle a b
+ -> (DTime,Maybe a)
+ -> IO Bool
+react rh (dt,ma') =
+ do rs@(ReactState {rsActuate = actuate,
+ rsSF = sf,
+ rsA = a,
+ rsB = b }) <- readIORef rh
+ let a' = maybe a id ma'
+ (sf',b') = (sfTF' sf) dt a'
+ writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})
+ done <- actuate rh True b'
+ return done
+
+
+------------------------------------------------------------------------------
+-- Embedding
+------------------------------------------------------------------------------
+
+-- New embed interface. We will probably have to revisit this. To run an
+-- embedded signal function while retaining full control (e.g. start and
+-- stop at will), one would probably need a continuation based interface
+-- (as well as a continuation based underlying implementation).
+--
+-- E.g. here are interesting alternative (or maybe complementary)
+-- signatures:
+--
+-- sample :: SF a b -> SF (Event a) (Event b)
+-- sample' :: SF a b -> SF (Event (DTime, a)) (Event b)
+
+embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
+embed sf0 (a0, dtas) = b0 : loop a0 sf dtas
+ where
+ (sf, b0) = (sfTF sf0) a0
+
+ loop a_prev sf [] = []
+ loop a_prev sf ((dt, ma) : dtas) =
+ b : (a `seq` b `seq` (loop a sf' dtas))
+ where
+ a = maybe a_prev id ma
+ (sf', b) = (sfTF' sf) dt a
+
+
+-- Synchronous embedding. The embedded signal function is run on the supplied
+-- input and time stream at a given (but variable) ratio >= 0 to the outer
+-- time flow. When the ratio is 0, the embedded signal function is paused.
+
+-- !!! Should "dropped frames" be forced to avoid space leaks?
+-- !!! It's kind of hard to se why, but "frame dropping" was a problem
+-- !!! in the old robot simulator. Try to find an example!
+
+embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
+embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}
+ where
+ tts = scanl (\t (dt, _) -> t + dt) 0 dtas
+ bbs@(b:_) = embed sf0 (a0, dtas)
+
+ tf0 r = (esAux 0 (zip tts bbs), b)
+
+ esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!"
+ esAux tp_prev tbtbs = SFTIVar {sfTF' = tf}
+ where
+ tf dt r | r < 0 = usrErr "AFRP" "embedSynch"
+ "Negative ratio."
+ | otherwise = let tp = tp_prev + dt * r
+ (b, tbtbs') = advance tp tbtbs
+ in
+ (esAux tp tbtbs', b)
+
+ -- Advance the time stamped stream to the perceived time tp.
+ -- Under the assumption that the perceived time never goes
+ -- backwards (non-negative ratio), advance maintains the
+ -- invariant that the perceived time is always >= the first
+ -- time stamp.
+ advance tp tbtbs@[(t, b)] = (b, tbtbs)
+ advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))
+ | tp < t' = (b, tbtbtbs)
+ | t' <= tp = advance tp tbtbs
+
+
+deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
+deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list."
+deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas
+
+
+deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
+deltaEncodeBy _ _ [] = usrErr "AFRP" "deltaEncodeBy" "Empty input list."
+deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))
+ where
+ debAux a_prev [] = []
+ debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as
+ | otherwise = Just a : debAux a as
18 AFRPDiagnostics.hs
@@ -0,0 +1,18 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPDiagnostics
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Standardized error-reporting for AFRP
+--
+module AFRPDiagnostics where
+
+usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)
+
+intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "
+ ++ msg)
286 AFRPEvent.hs
@@ -0,0 +1,286 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPEvent
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Definition of AFRP Event type.
+--
+{-
+-- Note on naming conventions used in this module.
+--
+-- Names here might have to be rethought. It's really a bit messy.
+-- In general, the aim has been short and convenient names (like "tag",
+-- "attach", "lMerge") and thus we have tried to stay away from suffixing/
+-- prefixing conventions. E.g. "Event" as a common suffix would be very
+-- verbose.
+--
+-- However, part of the names come from a desire to stay close to similar
+-- functions for the Maybe type. e.g. "event", "fromEvent", "isEvent".
+-- In many cases, this use of "Event" can could understood to refer to the
+-- *constructor* "Event", not to the type name "Event". Thus this use of
+-- event should not be seen as a suffixing-with-type-name convention. But
+-- that is obviously not easy to see, and, more over, interpreting "Event"
+-- as the name of the type might make equally good or better sense. E.g.
+-- "fromEvent" can also be seen as a function taking an event signal,
+-- which is a *partial* function on time, to a normal signal. The latter is
+-- then undefined when the source event function is undefined.
+--
+-- In other cases, it has been necessary to somehow stay out of the way of
+-- names used by the prelude or other commonly imported modules/modules
+-- which could be expected to be used heavily in AFRP code. In those cases
+-- a suffix "E" have been added. Examples are "filterE" (exists in Prelude)
+-- and "joinE" (exists in Monad). Maybe the suffix isn't necessary in the
+-- last case.
+--
+-- Some functions (actually only one currently, mapFilterE") have got an "E"
+-- suffix just because they're closely related (by name or semantics) to one
+-- which already has an "E" suffix. Another candidate would be "splitE" to
+-- complement "joinE". But events carrying pairs could obviously have other
+-- sources than a "joinE", so currently it is called "split".
+--
+-- 2003-05-19: Actually, have now changed to "splitE" to avoid a clash
+-- with the method "split" in the class RandomGen.
+--
+-- 2003-05-19: What about "gate"? Stands out compared to e.g. "filterE".
+--
+-- Currently the "E" suffix is considered an exception. Maybe we should use
+-- completely different names to avoid the "E" suffix. If the functions
+-- are not used that often, "Event" might be approriate. Alternatively the
+-- suffix "E" should be adopted globaly (except if the name already contains
+-- "event" in some form?).
+--
+-- Arguably, having both a type "Event" and a constructor "Event" is confusing
+-- since there are more than one constructor. But the name "Event" for the
+-- constructor is quite apt. It's really the type name that is wrong. But
+-- no one has found a better name, and changing it would be a really major
+-- undertaking. Yes, the constructor "Event" is not exported, but we still
+-- need to talk conceptually about them. On the other hand, if we consider
+-- Event-signals as partial functions on time, maybe it isn't so confusing:
+-- they just don't have a value between events, so "NoEvent" does not really
+-- exist conceptually.
+--
+-- ToDo:
+-- - Either: reveal NoEvent and Event
+-- or: introcuce "event = Event", call what's now "event" "fromEvent",
+-- and call what's now called "fromEvent" something else, like
+-- "unsafeFromEvent"??? Better, dump it! After all, using current
+-- names, "fromEvent = event undefined"!
+-}
+module AFRPEvent where
+
+import AFRPDiagnostics
+import AFRPForceable
+
+
+infixl 8 `tag`, `attach`, `gate`
+infixl 7 `joinE`
+infixl 6 `lMerge`, `rMerge`, `merge`
+
+
+------------------------------------------------------------------------------
+-- The Event type
+------------------------------------------------------------------------------
+
+-- The type Event represents a single possible event occurrence.
+-- It is isomorphic to Maybe, but its constructors are not exposed outside
+-- the AFRP implementation.
+-- There could possibly be further constructors, but note that the NeverEvent-
+-- idea does not work, at least not in the current AFRP implementation.
+-- Also note that it unfortunately is possible to partially break the
+-- abstractions through judicious use of e.g. snap and switching.
+
+data Event a = NoEvent
+ | Event a
+
+
+-- Make the NoEvent constructor available. Useful e.g. for initialization,
+-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []).
+noEvent :: Event a
+noEvent = NoEvent
+
+
+-- Suppress any event in the first component of a pair.
+noEventFst :: (Event a, b) -> (Event c, b)
+noEventFst (_, b) = (NoEvent, b)
+
+
+-- Suppress any event in the second component of a pair.
+noEventSnd :: (a, Event b) -> (a, Event c)
+noEventSnd (a, _) = (a, NoEvent)
+
+
+------------------------------------------------------------------------------
+-- Eq instance
+------------------------------------------------------------------------------
+
+-- Right now, we could derive this instance. But that could possibly change.
+
+instance Eq a => Eq (Event a) where
+ NoEvent == NoEvent = True
+ (Event x) == (Event y) = x == y
+ _ == _ = False
+
+
+------------------------------------------------------------------------------
+-- Ord instance
+------------------------------------------------------------------------------
+
+instance Ord a => Ord (Event a) where
+ compare NoEvent NoEvent = EQ
+ compare NoEvent (Event _) = LT
+ compare (Event _) NoEvent = GT
+ compare (Event x) (Event y) = compare x y
+
+
+------------------------------------------------------------------------------
+-- Functor instance
+------------------------------------------------------------------------------
+
+instance Functor Event where
+ fmap f NoEvent = NoEvent
+ fmap f (Event a) = Event (f a)
+
+
+------------------------------------------------------------------------------
+-- Forceable instance
+------------------------------------------------------------------------------
+
+instance Forceable a => Forceable (Event a) where
+ force ea@NoEvent = ea
+ force ea@(Event a) = force a `seq` ea
+
+
+------------------------------------------------------------------------------
+-- Internal utilities for event construction
+------------------------------------------------------------------------------
+
+-- These utilities are to be considered strictly internal to AFRP for the
+-- time being.
+
+maybeToEvent :: Maybe a -> Event a
+maybeToEvent Nothing = NoEvent
+maybeToEvent (Just a) = Event a
+
+
+------------------------------------------------------------------------------
+-- Utility functions similar to those available for Maybe
+------------------------------------------------------------------------------
+
+-- An event-based version of the maybe function.
+event :: a -> (b -> a) -> Event b -> a
+event a _ NoEvent = a
+event _ f (Event b) = f b
+
+fromEvent :: Event a -> a
+fromEvent (Event a) = a
+fromEvent NoEvent = usrErr "AFRP" "fromEvent" "Not an event."
+
+isEvent :: Event a -> Bool
+isEvent NoEvent = False
+isEvent (Event _) = True
+
+isNoEvent :: Event a -> Bool
+isNoEvent = not . isEvent
+
+
+------------------------------------------------------------------------------
+-- Event tagging
+------------------------------------------------------------------------------
+
+-- Tags an (occurring) event with a value ("replacing" the old value).
+tag :: Event a -> b -> Event b
+e `tag` b = fmap (const b) e
+
+
+-- Attaches an extra value to the value of an occurring event.
+attach :: Event a -> b -> Event (a, b)
+e `attach` b = fmap (\a -> (a, b)) e
+
+
+------------------------------------------------------------------------------
+-- Event merging (disjunction) and joining (conjunction)
+------------------------------------------------------------------------------
+
+-- Left-biased event merge.
+lMerge :: Event a -> Event a -> Event a
+le `lMerge` re = event re Event le
+
+
+-- Right-biased event merge.
+rMerge :: Event a -> Event a -> Event a
+le `rMerge` re = event le Event re
+
+
+-- Unbiased event merge: simultaneous occurrence is an error.
+merge :: Event a -> Event a -> Event a
+merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.")
+
+
+-- Event merge paramterezied on the conflict resolution function.
+mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
+mergeBy _ NoEvent NoEvent = NoEvent
+mergeBy _ le@(Event _) NoEvent = le
+mergeBy _ NoEvent re@(Event _) = re
+mergeBy resolve (Event l) (Event r) = Event (resolve l r)
+
+
+-- A generic event merge utility:
+mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)
+ -> Event a -> Event b -> Event c
+mapMerge _ _ _ NoEvent NoEvent = NoEvent
+mapMerge lf _ _ (Event l) NoEvent = Event (lf l)
+mapMerge _ rf _ NoEvent (Event r) = Event (rf r)
+mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r)
+
+-- Merging of a list of events; foremost event has priority.
+mergeEvents :: [Event a] -> Event a
+mergeEvents = foldr lMerge NoEvent
+
+
+-- Collects simultaneous event occurrences; no event if none.
+catEvents :: [Event a] -> Event [a]
+catEvents eas = case [ a | Event a <- eas ] of
+ [] -> NoEvent
+ as -> Event as
+
+
+-- Join (conjucntion) of two events.
+joinE :: Event a -> Event b -> Event (a,b)
+joinE NoEvent _ = NoEvent
+joinE _ NoEvent = NoEvent
+joinE (Event l) (Event r) = Event (l,r)
+
+
+-- Split event carrying pairs into two events.
+splitE :: Event (a,b) -> (Event a, Event b)
+splitE NoEvent = (NoEvent, NoEvent)
+splitE (Event (a,b)) = (Event a, Event b)
+
+
+------------------------------------------------------------------------------
+-- Event filtering
+------------------------------------------------------------------------------
+
+-- Filter out events that don't satisfy some predicate.
+filterE :: (a -> Bool) -> Event a -> Event a
+filterE p e@(Event a) = if (p a) then e else NoEvent
+filterE _ NoEvent = NoEvent
+
+
+-- Combined event mapping and filtering.
+mapFilterE :: (a -> Maybe b) -> Event a -> Event b
+mapFilterE _ NoEvent = NoEvent
+mapFilterE f (Event a) = case f a of
+ Nothing -> NoEvent
+ Just b -> Event b
+
+
+-- Enable/disable event occurences based on an external condition.
+gate :: Event a -> Bool -> Event a
+_ `gate` False = NoEvent
+e `gate` True = e
75 AFRPForceable.hs
@@ -0,0 +1,75 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPForceable
+-- Copyright : (c) Zhanyong Wan, Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Hyperstrict evaluation.
+--
+module AFRPForceable where
+
+
+class Forceable a where
+ force :: a -> a
+
+
+instance Forceable Int where
+ force = id
+
+
+instance Forceable Integer where
+ force = id
+
+
+instance Forceable Double where
+ force = id
+
+
+instance Forceable Float where
+ force = id
+
+
+instance Forceable Bool where
+ force = id
+
+
+instance Forceable () where
+ force = id
+
+
+instance Forceable Char where
+ force = id
+
+
+instance (Forceable a, Forceable b) => Forceable (a, b) where
+ force p@(a, b) = force a `seq` force b `seq` p
+
+
+instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where
+ force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p
+
+
+instance (Forceable a, Forceable b, Forceable c, Forceable d) =>
+ Forceable (a, b, c, d) where
+ force p@(a, b, c, d) =
+ force a `seq` force b `seq` force c `seq` force d `seq` p
+
+
+instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) =>
+ Forceable (a, b, c, d, e) where
+ force p@(a, b, c, d, e) =
+ force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p
+
+
+instance (Forceable a) => Forceable [a] where
+ force nil@[] = nil
+ force xs@(x:xs') = force x `seq` force xs' `seq` xs
+
+
+instance (Forceable a) => Forceable (Maybe a) where
+ force mx@Nothing = mx
+ force mx@(Just x) = force x `seq` mx
36 AFRPInternals.hs
@@ -0,0 +1,36 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPInternals
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- An interface giving access to some of the internal
+-- details of the AFRP implementation.
+--
+-- This interface is indended to be used when the need arises to break
+-- abstraction barriers, e.g. for interfacing AFRP to the real world, for
+-- debugging purposes, or the like. Be aware that the internal details
+-- may change. Relying on this interface means that your code is not
+-- insulated against such changes.
+
+module AFRPInternals (
+ Event(..) -- The event type, its constructors, and instances.
+) where
+
+import AFRPEvent
+
+
+------------------------------------------------------------------------------
+-- Extra Event instances
+------------------------------------------------------------------------------
+
+instance Show a => Show (Event a) where
+ showsPrec d NoEvent = showString "NoEvent"
+ showsPrec d (Event a) = showParen (d >= 10)
+ (showString "Event " . showsPrec 10 a)
+
+
77 AFRPMergeableRecord.hs
@@ -0,0 +1,77 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPMergeableRecord
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Framework for record merging.
+--
+-- Idea:
+-- MergeableRecord is intended to be a super class for classes providing
+-- update operations on records. The ADT induced by such a set of operations
+-- can be considered a "mergeable record", which can be merged into larger
+-- mergeable records essentially by function composition. Finalization turns
+-- a mergeable record into a record.
+--
+-- Typical use:
+-- Given
+--
+-- data Foo = Foo {l1 :: T1, l2 :: T2}
+--
+-- one define a mergeable record type (MR Foo) by the following instance:
+--
+-- instance MergeableRecord Foo where
+-- mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt}
+--
+-- Typically, one would also provide definitions for setting the fields,
+-- possibly (but not necessarily) overloaded:
+--
+-- instance HasL1 Foo where
+-- setL1 v = mrMake (\foo -> foo {l1 = v})
+--
+-- Now Foo records can be created as follows:
+--
+-- let foo1 = setL1 v1
+-- ...
+-- let foo2 = setL2 v2 ~+~ foo1
+-- ...
+-- let foo<N> = setL1 vN ~+~ foo<N-1>
+-- let fooFinal = mrFinalize foo<N>
+
+module AFRPMergeableRecord (
+ MergeableRecord(..),
+ MR, -- Abstract
+ mrMake,
+ (~+~),
+ mrMerge,
+ mrFinalize
+) where
+
+class MergeableRecord a where
+ mrDefault :: a
+
+
+-- Type constructor for mergeable records.
+newtype MergeableRecord a => MR a = MR (a -> a)
+
+
+-- Construction of a mergeable record.
+mrMake :: MergeableRecord a => (a -> a) -> MR a
+mrMake f = (MR f)
+
+
+-- Merge two mergeable records. Left "overrides" in case of conflict.
+(~+~) :: MergeableRecord a => MR a -> MR a -> MR a
+(MR f1) ~+~ (MR f2) = MR (f1 . f2)
+
+mrMerge :: MergeableRecord a => MR a -> MR a -> MR a
+mrMerge = (~+~)
+
+
+-- Finalization: turn a mergeable record into a record.
+mrFinalize :: MergeableRecord a => MR a -> a
+mrFinalize (MR f) = f mrDefault
120 AFRPMiscellany.hs
@@ -0,0 +1,120 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPMiscellany
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Collection of entities that really should be part
+-- the Haskell 98 prelude or simply have no better
+-- home.
+--
+module AFRPMiscellany (
+-- Reverse function composition
+ ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9
+
+-- Arrow plumbing aids
+ dup, -- :: a -> (a,a)
+ swap, -- :: (a,b) -> (b,a)
+
+-- Maps over lists of pairs
+ mapFst, -- :: (a -> b) -> [(a,c)] -> [(b,c)]
+ mapSnd, -- :: (a -> b) -> [(c,a)] -> [(c,b)]
+
+-- Generalized tuple selectors
+ sel3_1, sel3_2, sel3_3,
+ sel4_1, sel4_2, sel4_3, sel4_4,
+ sel5_1, sel5_2, sel5_3, sel5_4, sel5_5,
+
+-- Floating point utilities
+ fDiv, -- :: (RealFrac a, Integral b) => a -> a -> b
+ fMod, -- :: RealFrac a => a -> a -> a
+ fDivMod -- :: (RealFrac a, Integral b) => a -> a -> (b, a)
+) where
+
+infixl 9 #
+infixl 7 `fDiv`, `fMod`
+
+
+------------------------------------------------------------------------------
+-- Reverse function composition
+------------------------------------------------------------------------------
+
+( # ) :: (a -> b) -> (b -> c) -> (a -> c)
+f # g = g . f
+
+
+------------------------------------------------------------------------------
+-- Arrow plumbing aids
+------------------------------------------------------------------------------
+
+dup :: a -> (a,a)
+dup x = (x,x)
+
+swap :: (a,b) -> (b,a)
+swap ~(x,y) = (y,x)
+
+
+------------------------------------------------------------------------------
+-- Maps over lists of pairs
+------------------------------------------------------------------------------
+
+mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]
+mapFst f [] = []
+mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys
+
+mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]
+mapSnd f [] = []
+mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys
+
+
+------------------------------------------------------------------------------
+-- Generalized tuple selectors
+------------------------------------------------------------------------------
+
+-- Triples
+
+sel3_1 (x,_,_) = x
+sel3_2 (_,x,_) = x
+sel3_3 (_,_,x) = x
+
+
+-- 4-tuples
+
+sel4_1 (x,_,_,_) = x
+sel4_2 (_,x,_,_) = x
+sel4_3 (_,_,x,_) = x
+sel4_4 (_,_,_,x) = x
+
+
+-- 5-tuples
+
+sel5_1 (x,_,_,_,_) = x
+sel5_2 (_,x,_,_,_) = x
+sel5_3 (_,_,x,_,_) = x
+sel5_4 (_,_,_,x,_) = x
+sel5_5 (_,_,_,_,x) = x
+
+
+------------------------------------------------------------------------------
+-- Floating point utilities
+------------------------------------------------------------------------------
+
+-- Floating-point div and modulo operators.
+
+fDiv :: (RealFrac a, Integral b) => a -> a -> b
+fDiv x y = fst (fDivMod x y)
+
+
+fMod :: RealFrac a => a -> a -> a
+fMod x y = snd (fDivMod x y)
+
+
+fDivMod :: (RealFrac a, Integral b) => a -> a -> (b, a)
+fDivMod x y = (q, r)
+ where
+ q = (floor (x/y))
+ r = x - fromIntegral q * y
218 AFRPTask.hs
@@ -0,0 +1,218 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPTask
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Task abstraction on top of signal transformers.
+--
+module AFRPTask (
+ Task,
+ mkTask, -- :: SF a (b, Event c) -> Task a b c
+ runTask, -- :: Task a b c -> SF a (Either b c) -- Might change.
+ runTask_, -- :: Task a b c -> SF a b
+ taskToSF, -- :: Task a b c -> SF a (b, Event c) -- Might change.
+ constT, -- :: b -> Task a b c
+ sleepT, -- :: Time -> b -> Task a b ()
+ snapT, -- :: Task a b a
+ timeOut, -- :: Task a b c -> Time -> Task a b (Maybe c)
+ abortWhen, -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
+ repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a
+ for, -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
+ forAll, -- :: Monad m => [a] -> (a -> m b) -> m ()
+ forEver -- :: Monad m => m a -> m b
+) where
+
+import AFRP
+import AFRPUtilities (snap)
+import AFRPDiagnostics
+
+infixl 0 `timeOut`, `abortWhen`, `repeatUntil`
+
+
+------------------------------------------------------------------------------
+-- The Task type
+------------------------------------------------------------------------------
+
+-- CPS-based representation allowing a termination to be detected.
+-- (Note the rank 2 polymorphic type!)
+-- The representation can be changed if necessary, but the Monad laws
+-- follow trivially in this case.
+newtype Task a b c =
+ Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))
+
+
+unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))
+unTask (Task f) = f
+
+
+mkTask :: SF a (b, Event c) -> Task a b c
+mkTask st = Task (switch (st >>> first (arr Left)))
+
+
+-- "Runs" a task (unusually bad name?). The output from the resulting
+-- signal transformer is tagged with Left while the underlying task is
+-- running. Once the task has terminated, the output goes constant with
+-- the value Right x, where x is the value of the terminating event.
+runTask :: Task a b c -> SF a (Either b c)
+runTask tk = (unTask tk) (\c -> constant (Right c))
+
+
+-- Runs a task. The output becomes undefined once the underlying task has
+-- terminated. Convenient e.g. for tasks which are known not to terminate.
+runTask_ :: Task a b c -> SF a b
+runTask_ tk = runTask tk
+ >>> arr (either id (usrErr "AFRPTask" "runTask_"
+ "Task terminated!"))
+
+
+-- Seems as if the following is convenient after all. Suitable name???
+-- Maybe that implies a representation change for Tasks?
+-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)
+taskToSF :: Task a b c -> SF a (b, Event c)
+taskToSF tk = runTask tk
+ >>> (arr (either id ((usrErr "AFRPTask" "runTask_"
+ "Task terminated!")))
+ &&& edgeBy isEdge (Left undefined))
+ where
+ isEdge (Left _) (Left _) = Nothing
+ isEdge (Left _) (Right c) = Just c
+ isEdge (Right _) (Right _) = Nothing
+ isEdge (Right _) (Left _) = Nothing
+
+
+------------------------------------------------------------------------------
+-- Monad instance
+------------------------------------------------------------------------------
+
+instance Monad (Task a b) where
+ tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))
+ return x = Task (\k -> k x)
+
+{-
+Let's check the monad laws:
+
+ t >>= return
+ = \k -> t (\c -> return c k)
+ = \k -> t (\c -> (\x -> \k -> k x) c k)
+ = \k -> t (\c -> (\x -> \k' -> k' x) c k)
+ = \k -> t (\c -> k c)
+ = \k -> t k
+ = t
+ QED
+
+ return x >>= f
+ = \k -> (return x) (\c -> f c k)
+ = \k -> (\k -> k x) (\c -> f c k)
+ = \k -> (\k' -> k' x) (\c -> f c k)
+ = \k -> (\c -> f c k) x
+ = \k -> f x k
+ = f x
+ QED
+
+ (t >>= f) >>= g
+ = \k -> (t >>= f) (\c -> g c k)
+ = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)
+ = \k -> t (\c' -> f c' (\c -> g c k))
+ = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)
+ = \k -> t (\c' -> (\x -> f x >>= g) c' k)
+ = t >>= (\x -> f x >>= g)
+ QED
+
+No surprises (obviously, since this is essentially just the CPS monad).
+-}
+
+
+------------------------------------------------------------------------------
+-- Basic tasks
+------------------------------------------------------------------------------
+
+-- Non-terminating task with constant output b.
+constT :: b -> Task a b c
+constT b = mkTask (constant b &&& never)
+
+
+-- "Sleeps" for t seconds with constant output b.
+sleepT :: Time -> b -> Task a b ()
+sleepT t b = mkTask (constant b &&& after t ())
+
+
+-- Takes a "snapshot" of the input and terminates immediately with the input
+-- value as the result. No time passes; law:
+--
+-- snapT >> snapT = snapT
+--
+snapT :: Task a b a
+snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)
+
+
+------------------------------------------------------------------------------
+-- Basic tasks combinators
+------------------------------------------------------------------------------
+
+-- Impose a time out on a task.
+timeOut :: Task a b c -> Time -> Task a b (Maybe c)
+tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)
+ where
+ aux ((b, ec), et) = (b, (lMerge (fmap Just ec)
+ (fmap (const Nothing) et)))
+
+
+-- Run a "guarding" event source (SF a (Event b)) in parallel with a
+-- (possibly non-terminating) task. The task will be aborted at the
+-- first occurrence of the event source (if it has not terminated itself
+-- before that). Useful for separating sequencing and termination concerns.
+-- E.g. we can do something "useful", but in parallel watch for a (exceptional)
+-- condition which should terminate that activity, whithout having to check
+-- for that condition explicitly during each and every phase of the activity.
+-- Example: tsk `abortWhen` lbp
+abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
+tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)
+ where
+ aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))
+
+
+------------------------------------------------------------------------------
+-- Loops
+------------------------------------------------------------------------------
+
+-- These are general monadic combinators. Maybe they don't really belong here.
+
+-- Repeat m until result satisfies the predicate p
+repeatUntil :: Monad m => m a -> (a -> Bool) -> m a
+m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x
+
+
+-- C-style for-loop.
+-- Example: for 0 (+1) (>=10) ...
+for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
+for i f p m = if p i then m >> for (f i) f p m else return ()
+
+
+-- Perform the monadic operation for each element in the list.
+forAll :: Monad m => [a] -> (a -> m b) -> m ()
+forAll = flip mapM_
+
+
+-- Repeat m for ever.
+forEver :: Monad m => m a -> m b
+forEver m = m >> forEver m
+
+
+-- Alternatives/other potentially useful signatures:
+-- until :: a -> (a -> M a) -> (a -> Bool) -> M a
+-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b
+-- while??? It could be:
+-- while :: a -> (a -> Bool) -> (a -> M a) -> M a
+
+
+------------------------------------------------------------------------------
+-- Monad transformers?
+------------------------------------------------------------------------------
+
+-- What about monad transformers if we want to compose this monad with
+-- other capabilities???
277 AFRPUtilities.hs
@@ -0,0 +1,277 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : AFRPUtilities
+-- Copyright : (c) Yale University, 2003
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : antony@apocalypse.org
+-- Stability : provisional
+-- Portability : non-portable (uses GHC extensions)
+--
+-- Derived utility definitions.
+--
+-- ToDo:
+-- * Possibly add
+-- impulse :: VectorSpace a k => a -> Event a
+-- But to do that, we need access to Event, which we currently do not have.
+-- * The general arrow utilities should be moved to a module
+-- AFRPArrowUtilities.
+-- * I'm not sure structuring the AFRP "core" according to what is
+-- core functionality and what's not is all that useful. There are
+-- many cases where we want to implement combinators that fairly
+-- easily could be implemented in terms of others as primitives simply
+-- because we expect that that implementation is going to be much more
+-- efficient, and that the combinators are used sufficiently often to
+-- warrant doing this. E.g. "switch" should be a primitive, even though
+-- it could be derived from "pSwitch".
+-- * Reconsider "recur". If an event source has an immediate occurrence,
+-- we'll get into a loop. For example: recur now. Maybe suppress
+-- initial occurrences? Initial occurrences are rather pointless in this
+-- case anyway.
+
+
+module AFRPUtilities (
+
+-- Liftings
+ arr2, -- :: Arrow a => (b->c->d) -> a (b,c) d
+ arr3, -- :: Arrow a => (b->c->d->e) -> a (b,c,d) e
+ arr4, -- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f
+ arr5, -- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g
+ lift0, -- :: Arrow a => c -> a b c
+ lift1, -- :: Arrow a => (c->d) -> (a b c->a b d)
+ lift2, -- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)
+ lift3, -- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)
+ lift4, -- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)
+ lift5, -- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)
+
+-- Event sources
+ snap, -- :: SF a (Event a)
+ snapAfter, -- :: Time -> SF a (Event a)
+ sample, -- :: Time -> SF a (Event a)
+ recur, -- :: SF a (Event b) -> SF a (Event b)
+
+-- Parallel composition/switchers with "zip" routing
+ parZ, -- [SF a b] -> SF [a] [b]
+ pSwitchZ, -- [SF a b] -> SF ([a],[b]) (Event c)
+ -- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]
+ dpSwitchZ, -- [SF a b] -> SF ([a],[b]) (Event c)
+ -- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]
+ rpSwitchZ, -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]
+ drpSwitchZ, -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]
+
+-- Guards and automata-oriented combinators
+ provided, -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b
+
+-- Wave-form generation
+ dHold, -- :: a -> SF (Event a) a
+ dTrackAndHold, -- :: a -> SF (Maybe a) a
+
+-- Accumulators
+ accumHold, -- :: a -> SF (Event (a -> a)) a
+ dAccumHold, -- :: a -> SF (Event (a -> a)) a
+ accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b
+ dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b
+ count, -- :: Integral b => SF (Event a) (Event b)
+
+-- Delays
+ fby, -- :: b -> SF a b -> SF a b, infixr 0
+
+-- Integrals
+ impulseIntegral -- :: VectorSpace a k => SF (a, Event a) a
+) where
+