{-# LANGUAGE GADTs, Rank2Types, CPP #-} ----------------------------------------------------------------------------------------- -- | -- Module : FRP.Yampa -- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : ivan.perez@keera.co.uk -- Stability : provisional -- Portability : non-portable (GHC extensions) -- -- -- Domain-specific language embedded in Haskell for programming hybrid (mixed -- discrete-time and continuous-time) systems. Yampa is based on the concepts -- of Functional Reactive Programming (FRP) and is structured using arrow -- combinators. -- -- You can find examples, tutorials and documentation on Yampa here: -- -- <www.haskell.org/haskellwiki/Yampa> -- -- Structuring a hybrid system in Yampa is done based on two main concepts: -- -- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions, -- which are functions from a typed input signal to a typed output signal. -- Conceptually, signals are functions from Time to Value, where time are the -- real numbers and, computationally, a very dense approximation (Double) is -- used. -- -- * Events: 'Event'. Values that may or may not occur (and would probably -- occur rarely). It is often used for incoming network messages, mouse -- clicks, etc. Events are used as values carried by signals. -- -- A complete Yampa system is defined as one Signal Function from some -- type @a@ to a type @b@. The execution of this signal transformer -- with specific input can be accomplished by means of two functions: -- 'reactimate' (which needs an initialization action, -- an input sensing action and an actuation/consumer action and executes -- until explicitly stopped), and 'react' (which executes only one cycle). -- -- Apart from using normal functions and arrow syntax to define 'SF's, you -- can also use several combinators. See [<#g:4>] for basic signals combinators, -- [<#g:11>] for ways of switching from one signal transformation to another, -- and [<#g:16>] for ways of transforming Event-carrying signals into continuous -- signals, [<#g:19>] for ways of delaying signals, and [<#g:21>] for ways to -- feed a signal back to the same signal transformer. -- -- Ways to define Event-carrying signals are given in [<#g:7>], and -- "FRP.Yampa.Event" defines events and event-manipulation functions. -- -- Finally, see [<#g:26>] for sources of randomness (useful in games). -- -- CHANGELOG: -- -- * Adds (most) documentation. -- -- * New version using GADTs. -- -- ToDo: -- -- * Specialize def. of repeatedly. Could have an impact on invaders. -- -- * New defs for accs using SFAcc -- -- * Make sure opt worked: e.g. -- -- > repeatedly >>> count >>> arr (fmap sqr) -- -- * Introduce SFAccHld. -- -- * See if possible to unify AccHld wity Acc??? They are so close. -- -- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would -- have been possible without GADTs??? -- -- * Look into pairs. At least pairing of SScan ought to be interesting. -- -- * Would be nice if we could get rid of first & second with impunity -- thanks to Id optimizations. That's a clear win, with or without -- an explicit pair combinator. -- -- * delayEventCat is a bit complicated ... -- -- -- Random ideas: -- -- * What if one used rules to optimize -- - (arr :: SF a ()) to (constant ()) -- - (arr :: SF a a) to identity -- But inspection of invader source code seem to indicate that -- these are not very common cases at all. -- -- * It would be nice if it was possible to come up with opt. rules -- that are invariant of how signal function expressions are -- parenthesized. Right now, we have e.g. -- arr f >>> (constant c >>> sf) -- being optimized to -- cpAuxA1 f (cpAuxC1 c sf) -- whereas it clearly should be possible to optimize to just -- cpAuxC1 c sf -- What if we didn't use SF' but -- SFComp :: <tfun> -> SF' a b -> SF' b c -> SF' a c -- ??? -- -- * The transition function would still be optimized in (pretty much) -- the current way, but it would still be possible to look "inside" -- composed signal functions for lost optimization opts. -- Seems to me this could be done without too much extra effort/no dupl. -- work. -- E.g. new cpAux, the general case: -- -- @ -- cpAux sf1 sf2 = SFComp tf sf1 sf2 -- where -- tf dt a = (cpAux sf1' sf2', c) -- where -- (sf1', b) = (sfTF' sf1) dt a -- (sf2', c) = (sfTF' sf2) dt b -- @ -- -- * The ONLY change was changing the constructor from SF' to SFComp and -- adding sf1 and sf2 to the constructor app.! -- -- * An optimized case: -- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 -- So cpAuxC1 gets an extra arg, and we change the constructor. -- But how to exploit without writing 1000s of rules??? -- Maybe define predicates on SFComp to see if the first or second -- sf are "interesting", and if so, make "reassociate" and make a -- recursive call? E.g. we're in the arr case, and the first sf is another -- arr, so we'd like to combine the two. -- -- * It would also be intersting, then, to know when to STOP playing this -- game, due to the overhead involved. -- -- * Why don't we have a "SWITCH" constructor that indicates that the -- structure will change, and thus that it is worthwile to keep -- looking for opt. opportunities, whereas a plain "SF'" would -- indicate that things NEVER are going to change, and thus we can just -- as well give up? ----------------------------------------------------------------------------------------- module FRP.Yampa ( -- Re-exported module, classes, and types module Control.Arrow, module FRP.Yampa.VectorSpace, RandomGen(..), Random(..), -- * Basic definitions Time, -- [s] Both for time w.r.t. some reference and intervals. DTime, -- [s] Sampling interval, always > 0. SF, -- Signal Function. Event(..), -- Events; conceptually similar to Maybe (but abstract). -- Temporray! -- SF(..), sfTF', -- 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 -- ** Lifting arrPrim, arrEPrim, -- For optimization -- * Signal functions -- ** 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 -- ** Simple, stateful signal processing sscan, -- :: (b -> a -> b) -> b -> SF a b sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b -- * Events -- ** 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) afterEachCat, -- :: [(Time,b)] -> SF a (Event [b]) delayEvent, -- :: Time -> SF (Event a) (Event a) delayEventCat, -- :: Time -> SF (Event a) (Event [a]) 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) -- ** 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 tagWith, -- :: b -> Event a -> Event b, 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 -- * Switching -- ** 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 -- *** 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) -- * Discrete to continuous-time signal functions -- ** Wave-form generation old_hold, -- :: a -> SF (Event a) a hold, -- :: a -> SF (Event a) a dHold, -- :: a -> SF (Event a) a trackAndHold, -- :: a -> SF (Maybe a) a -- ** Accumulators accum, -- :: a -> SF (Event (a -> a)) (Event a) accumHold, -- :: a -> SF (Event (a -> a)) a dAccumHold, -- :: a -> SF (Event (a -> a)) a accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b) accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c -- -> SF (Event a) (Event b) old_accum, -- :: a -> SF (Event (a -> a)) (Event a) old_accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b) old_accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c -- * Delays -- ** Basic delays pre, -- :: SF a a iPre, -- :: a -> SF a a old_pre, old_iPre, -- ** Timed delays delay, -- :: Time -> a -> SF a a -- ** Variable delay pause, -- :: b -> SF a b -> SF a Bool -> SF a b -- * State keeping combinators -- ** 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 -- ** 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 -- Temporarily hidden, but will eventually be made public. -- iterFrom, -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b -- * Noise (random signal) sources and stochastic event sources noise, -- :: noise :: (RandomGen g, Random b) => -- g -> SF a b noiseR, -- :: noise :: (RandomGen g, Random b) => -- (b,b) -> g -> SF a b occasionally, -- :: RandomGen g => g -> Time -> b -> SF a (Event b) -- * 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) 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)]) -- * Auxiliary definitions -- Reverse function composition and arrow plumbing aids ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9 dup, -- :: a -> (a,a) swap, -- :: (a,b) -> (b,a) ) where import Control.Monad (unless) import System.Random (RandomGen(..), Random(..)) #if __GLASGOW_HASKELL__ >= 610 import qualified Control.Category (Category(..)) #else #endif import Control.Arrow import FRP.Yampa.Diagnostics import FRP.Yampa.Miscellany (( # ), dup, swap) import FRP.Yampa.Event import FRP.Yampa.VectorSpace 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 might be to pick a reasonable resolution -- and represent time and time intervals by Integer (giving the number of -- "ticks"). -- -- That might also improve the timing of time-based event sources. -- One might actually pick the overall resolution in reactimate, -- to be passed down, possibly in the form of a global parameter -- record, to all signal functions on initialization. (I think only -- switch would need to remember the record, since it is the only place -- where signal functions get started. So it wouldn't cost all that much. -- | 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.) -- | Signal function that transforms a signal carrying values of some type 'a' -- into a signal carrying values of some type 'b'. You can think of it as -- (Signal a -> Signal b). A signal is, conceptually, a -- function from 'Time' to value. data SF a b = SF {sfTF :: a -> Transition a b} -- Representation of signal function in "running" state. -- -- Possibly better design for Inv. -- Problem: tension between on the one hand making use of the -- invariant property, and on the other keeping track of how something -- has been constructed (SFCpAXA, in particular). -- Idea: Add a boolean field to SFCpAXA and SF' that classifies -- a signal function as being invarying. -- A function sfIsInv computes to True for SFArr, SFAcc (and SFSScan, -- possibly more), extracts the field in other cases. -- -- Motivation for using a function (Event a -> b) in SFArrE -- rather than (a -> Event b) or (a -> b) or even (Event a -> Event b). -- The result type should be just "b" as opposed to "Event b" for -- increased flexibility (e.g. matching "routing functions"). -- When the result type actually IS (Event b), and this fact is -- exploitable, we'll be in a context where is it clear that -- this is a fact, so we don't lose anything. -- Since the idea is that the function is only going to be applied -- when the there is an event, one could imagine the input type -- just "a". But that's not the type of function we're given, -- so it would have to be "massaged" a bit (precomposing with Event) -- to fit. This will gain nothing, and potentially we will lose if -- we actually need to recover the original function. -- In fact, we sometimes really need to recover the original function -- (e.g. currently in switch), and to do it correctly (also handling -- NoEvent), we'd have to work quite hard introducing further -- inefficiencies. -- Summary: Make use of what we are given and only wrap things up later -- when it is clear whatthe need is going to be, thus avoiding costly -- "unwrapping". -- GADTs needed in particular for SFEP, but also e.g. SFSScan -- exploits them since there are more type vars than in the type con. -- But one could use existentials for those. data SF' a b where SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b -- The b is intentionally unstrict as the initial output sometimes -- is undefined (e.g. when defining pre). In any case, it isn't -- necessarily used and should thus not be forced. SFSScan :: !(DTime -> a -> Transition a b) -> !(c -> a -> Maybe (c, b)) -> !c -> b -> SF' a b SFEP :: !(DTime -> Event a -> Transition (Event a) b) -> !(c -> a -> (c, b, b)) -> !c -> b -> SF' (Event a) b SFCpAXA :: !(DTime -> a -> Transition a d) -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d) -> SF' a d -- SFPair :: ... SF' :: !(DTime -> a -> Transition a b) -> SF' 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) sfTF' :: SF' a b -> (DTime -> a -> Transition a b) sfTF' (SFArr tf _) = tf sfTF' (SFSScan tf _ _ _) = tf sfTF' (SFEP tf _ _ _) = tf sfTF' (SFCpAXA tf _ _ _) = tf sfTF' (SF' tf) = tf -- !!! 2005-06-30 -- Unclear why, but the isInv mechanism seems to do more -- harm than good. -- Disable completely and see what happens. {- sfIsInv :: SF' a b -> Bool -- sfIsInv _ = False sfIsInv (SFArr _ _) = True -- sfIsInv (SFAcc _ _ _ _) = True sfIsInv (SFEP _ _ _ _) = True -- sfIsInv (SFSScan ...) = True sfIsInv (SFCpAXA _ inv _ _ _) = inv sfIsInv (SF' _ inv) = inv -} -- "Smart" constructors. The corresponding "raw" constructors should not -- be used directly for construction. sfArr :: FunDesc a b -> SF' a b sfArr FDI = sfId sfArr (FDC b) = sfConst b sfArr (FDE f fne) = sfArrE f fne sfArr (FDG f) = sfArrG f sfId :: SF' a a sfId = sf where sf = SFArr (\_ a -> (sf, a)) FDI sfConst :: b -> SF' a b sfConst b = sf where sf = SFArr (\_ _ -> (sf, b)) (FDC b) sfNever :: SF' a (Event b) sfNever = sfConst NoEvent -- Assumption: fne = f NoEvent sfArrE :: (Event a -> b) -> b -> SF' (Event a) b sfArrE f fne = sf where sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea)) (FDE f fne) sfArrG :: (a -> b) -> SF' a b sfArrG f = sf where sf = SFArr (\_ a -> (sf, f a)) (FDG f) sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b sfSScan f c b = sf where sf = SFSScan tf f c b tf _ a = case f c a of Nothing -> (sf, b) Just (c', b') -> (sfSScan f c' b', b') sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b sscanPrim f c_init b_init = SF {sfTF = tf0} where tf0 a0 = case f c_init a0 of Nothing -> (sfSScan f c_init b_init, b_init) Just (c', b') -> (sfSScan f c' b', b') -- The event-processing function *could* accept the present NoEvent -- output as an extra state argument. That would facilitate composition -- of event-processing functions somewhat, but would presumably incur an -- extra cost for the more common and simple case of non-composed event -- processors. -- sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b sfEP f c bne = sf where sf = SFEP (\_ ea -> case ea of NoEvent -> (sf, bne) Event a -> let (c', b, bne') = f c a in (sfEP f c' bne', b)) f c bne -- epPrim is used to define hold, accum, and other event-processing -- functions. epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b epPrim f c bne = SF {sfTF = tf0} where tf0 NoEvent = (sfEP f c bne, bne) tf0 (Event a) = let (c', b, bne') = f c a in (sfEP f c' bne', b) {- -- !!! Maybe something like this? -- !!! But one problem is that the invarying marking would be lost -- !!! if the signal function is taken apart and re-constructed from -- !!! the function description and subordinate signal function in -- !!! cases like SFCpAXA. sfMkInv :: SF a b -> SF a b sfMkInv sf = SF {sfTF = ...} sfMkInvAux :: SF' a b -> SF' a b sfMkInvAux sf@(SFArr _ _) = sf -- sfMkInvAux sf@(SFAcc _ _ _ _) = sf sfMkInvAux sf@(SFEP _ _ _ _) = sf sfMkInvAux sf@(SFCpAXA tf inv fd1 sf2 fd3) | inv = sf | otherwise = SFCpAXA tf' True fd1 sf2 fd3 where tf' = \dt a -> let (sf', b) = tf dt a in (sfMkInvAux sf', b) sfMkInvAux sf@(SF' tf inv) | inv = sf | otherwise = SF' tf' True tf' = -} -- Motivation for event-processing function type -- (alternative would be function of type a->b plus ensuring that it -- only ever gets invoked on events): -- * Now we need to be consistent with other kinds of arrows. -- * We still want to be able to get hold of the original function. -- 2005-02-30: OK, for FDE, invarant is that the field of type b = -- f NoEvent. data FunDesc a b where FDI :: FunDesc a a -- Identity function FDC :: b -> FunDesc a b -- Constant function FDE :: (Event a -> b) -> b -> FunDesc (Event a) b -- Event-processing fun FDG :: (a -> b) -> FunDesc a b -- General function fdFun :: FunDesc a b -> (a -> b) fdFun FDI = id fdFun (FDC b) = const b fdFun (FDE f _) = f fdFun (FDG f) = f fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c fdComp FDI fd2 = fd2 fdComp fd1 FDI = fd1 fdComp (FDC b) fd2 = FDC ((fdFun fd2) b) fdComp _ (FDC c) = FDC c -- Hardly worth the effort? -- 2005-03-30: No, not only not worth the effort as the only thing saved -- would be an application of f2. Also wrong since current invariant does -- not imply that f1ne = NoEvent. Moreover, we cannot really adopt that -- invariant as it is not totally impossible for a user to create a function -- that breaks it. -- fdComp (FDE f1 f1ne) (FDE f2 f2ne) = -- FDE (f2 . f1) (vfyNoEvent (f1 NoEvent) f2ne) fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne) where f2 = fdFun fd2 fdComp (FDG f1) (FDE f2 f2ne) = FDG f where f a = case f1 a of NoEvent -> f2ne f1a -> f2 f1a fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1) fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d) fdPar FDI FDI = FDI fdPar FDI (FDC d) = FDG (\(~(a, _)) -> (a, d)) fdPar FDI fd2 = FDG (\(~(a, c)) -> (a, (fdFun fd2) c)) fdPar (FDC b) FDI = FDG (\(~(_, c)) -> (b, c)) fdPar (FDC b) (FDC d) = FDC (b, d) fdPar (FDC b) fd2 = FDG (\(~(_, c)) -> (b, (fdFun fd2) c)) fdPar fd1 fd2 = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c)) fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c) fdFanOut FDI FDI = FDG dup fdFanOut FDI (FDC c) = FDG (\a -> (a, c)) fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a)) fdFanOut (FDC b) FDI = FDG (\a -> (b, a)) fdFanOut (FDC b) (FDC c) = FDC (b, c) fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a)) fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne where f1f2 NoEvent = f1f2ne f1f2 ea@(Event _) = (f1 ea, f2 ea) f1f2ne = (f1ne, f2ne) fdFanOut fd1 fd2 = FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a)) -- Verifies that the first argument is NoEvent. Returns the value of the -- second argument that is the case. Raises an error otherwise. -- Used to check that functions on events do not map NoEvent to Event -- wherever that assumption is exploited. vfyNoEv :: Event a -> b -> b vfyNoEv NoEvent b = b vfyNoEv _ _ = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event." -- 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 ------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ >= 610 instance Control.Category.Category SF where (.) = flip compPrim id = SF $ \x -> (sfId,x) #else #endif instance Arrow SF where arr = arrPrim first = firstPrim second = secondPrim (***) = parSplitPrim (&&&) = parFanOutPrim #if __GLASGOW_HASKELL__ >= 610 #else (>>>) = compPrim #endif -- Lifting. -- | Lifts a pure function into a signal function (applied pointwise). {-# NOINLINE arrPrim #-} arrPrim :: (a -> b) -> SF a b arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)} -- | Lifts a pure function into a signal function applied to events -- (applied pointwise). {-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-} arrEPrim :: (Event a -> b) -> SF (Event a) b arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)} -- Composition. -- The definition exploits the following identities: -- sf >>> identity = sf -- New -- identity >>> sf = sf -- New -- sf >>> constant c = constant c -- constant c >>> arr f = constant (f c) -- arr f >>> arr g = arr (g . f) -- -- !!! Notes/Questions: -- !!! How do we know that the optimizations terminate? -- !!! Probably by some kind of size argument on the SF tree. -- !!! E.g. (Hopefully) all compPrim optimizations are such that -- !!! the number of compose nodes decrease. -- !!! Should verify this! -- -- !!! There is a tension between using SFInv to signal to superior -- !!! signal functions that the subordinate signal function will not -- !!! change form, and using SFCpAXA to allow fusion in the context -- !!! of some suitable superior signal function. compPrim :: SF a b -> SF b c -> SF a c compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} where tf0 a0 = (cpXX sf1 sf2, c0) where (sf1, b0) = tf10 a0 (sf2, c0) = tf20 b0 -- The following defs are not local to compPrim because cpAXA needs to be -- called from parSplitPrim. -- Naming convention: cp<X><Y> where <X> and <Y> is one of: -- X - arbitrary signal function -- A - arbitrary pure arrow -- C - constant arrow -- E - event-processing arrow -- G - arrow known not to be identity, constant (C) or -- event-processing (E). cpXX :: SF' a b -> SF' b c -> SF' a c cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 {- -- !!! 2005-07-07: Too strict. -- !!! But the question is if it is worth to define pre in terms of sscan ... -- !!! It is slower than the simplest possible pre, and the kind of coding -- !!! required to ensure that the laziness props of the second SF are -- !!! preserved might just slow things down further ... cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = sfSScan f (s1, b, s2, c) c where f (s1, b, s2, c) a = case f1 s1 a of Nothing -> case f2 s2 b of Nothing -> Nothing Just (s2', c') -> Just ((s1, b, s2', c'), c') Just (s1', b') -> case f2 s2 b' of Nothing -> Just ((s1', b', s2, c), c) Just (s2', c') -> Just ((s1', b', s2', c'), c') -} -- !!! 2005-07-07: Indeed, this is a bit slower than the code above (14%). -- !!! But both are better than not composing (35% faster and 26% faster)! cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = sfSScan f (s1, b, s2, c) c where f (s1, b, s2, c) a = let (u, s1', b') = case f1 s1 a of Nothing -> (True, s1, b) Just (s1',b') -> (False, s1', b') in case f2 s2 b' of Nothing | u -> Nothing | otherwise -> Just ((s1', b', s2, c), c) Just (s2', c') -> Just ((s1', b', s2', c'), c') cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) = sfSScan f (s1, eb, s2, cne) cne where f (s1, eb, s2, cne) a = case f1 s1 a of Nothing -> case eb of NoEvent -> Nothing Event b -> let (s2', c, cne') = f2 s2 b in Just ((s1, eb, s2', cne'), c) Just (s1', eb') -> case eb' of NoEvent -> Just ((s1', eb', s2, cne), cne) Event b -> let (s2', c, cne') = f2 s2 b in Just ((s1', eb', s2', cne'), c) -- !!! 2005-07-09: This seems to yield only a VERY marginal speedup -- !!! without seq. With seq, substantial speedup! cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) = sfSScan f (s1, bne, s2, c) c where f (s1, bne, s2, c) ea = let (u, s1', b', bne') = case ea of NoEvent -> (True, s1, bne, bne) Event a -> let (s1', b, bne') = f1 s1 a in (False, s1', b, bne') in case f2 s2 b' of Nothing | u -> Nothing | otherwise -> Just (seq s1' (s1', bne', s2, c), c) Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c') -- The function "f" is invoked whenever an event is to be processed. It then -- computes the output, the new state, and the new NoEvent output. -- However, when sequencing event processors, the ones in the latter -- part of the chain may not get invoked since previous ones may -- decide not to "fire". But a "new" NoEvent output still has to be -- produced, i.e. the old one retained. Since it cannot be computed by -- invoking the last event-processing function in the chain, it has to -- be remembered. Since the composite event-processing function remains -- constant/unchanged, the NoEvent output has to be part of the state. -- An alternarive would be to make the event-processing function take an -- extra argument. But that is likely to make the simple case more -- expensive. See note at sfEP. cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) = sfEP f (s1, s2, cne) (vfyNoEv bne cne) where f (s1, s2, cne) a = case f1 s1 a of (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne) (s1', Event b, NoEvent) -> let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne') _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event." -- !!! 2005-06-28: Why isn't SFCpAXA (FDC ...) checked for? -- !!! No invariant rules that out, and it would allow to drop the -- !!! event processor ... Does that happen elsewhere? cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) = cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23) -- f21 will (hopefully) be invoked less frequently if merged with the -- event processor. cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) = cpXX (cpXG sf1 f21) (cpXA sf22 fd23) -- Only functions whose domain is known to be Event can be merged -- from the left with event processors. cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) = cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) -- !!! Other cases to look out for: -- !!! any sf >>> SFCpAXA = SFCpAXA if first arr is const. -- !!! But the following will presumably not work due to type restrictions. -- !!! Need to reconstruct sf2 I think. -- cpXX sf1 sf2@(SFCpAXA _ _ (FDC b) sf22 fd23) = sf2 cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = -- Termination: The first argument to cpXX is no larger than -- the current first argument, and the second is smaller. cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23 -- !!! 2005-06-27: The if below accounts for a significant slowdown. -- !!! One would really like a cheme where opts only take place -- !!! after a structural change ... -- cpXX sf1 sf2 = cpXXInv sf1 sf2 -- cpXX sf1 sf2 = cpXXAux sf1 sf2 cpXX sf1 sf2 = SF' tf -- False -- if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False where tf dt a = (cpXX sf1' sf2', c) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt b {- cpXXAux sf1@(SF' _ _) sf2@(SF' _ _) = SF' tf False where tf dt a = (cpXXAux sf1' sf2', c) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt b cpXXAux sf1 sf2 = SF' tf False where tf dt a = (cpXXAux sf1' sf2', c) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt b -} {- cpXXAux sf1 sf2 | unsimplifiable sf1 sf2 = SF' tf False | otherwise = cpXX sf1 sf2 where tf dt a = (cpXXAux sf1' sf2', c) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt b unsimplifiable sf1@(SF' _ _) sf2@(SF' _ _) = True unsimplifiable sf1 sf2 = True -} {- -- wrong ... cpXXAux sf1@(SF' _ False) sf2 = SF' tf False cpXXAux sf1@(SFCpAXA _ False _ _ _) sf2 = SF' tf False cpXXAux sf1 sf2@(SF' _ False) = SF' tf False cpXXAux sf1 sf2@(SFCpAXA _ False _ _ _) = SF' tf False cpXXAux sf1 sf2 = if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False where tf dt a = (cpXXAux sf1' sf2', c) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt b -} {- cpXXInv sf1 sf2 = SF' tf True where tf dt a = sf1 `seq` sf2 `seq` (cpXXInv sf1' sf2', c) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt b -} -- !!! No. We need local defs. Keep fd1 and fd2. Extract f1 and f2 -- !!! once and fo all. Get rid of FDI and FDC at the top level. -- !!! First local def. analyse sf2. SFArr, SFAcc etc. tf in -- !!! recursive case just make use of f1 and f3. -- !!! if sf2 is SFInv, that's delegated to a second local -- !!! recursive def. that does not analyse sf2. cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d -- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2 -- is SFCpAXA, and then on the embedded sf and hence on a smaller arg. cpAXA FDI sf2 fd3 = cpXA sf2 fd3 cpAXA fd1 sf2 FDI = cpAX fd1 sf2 cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3 cpAXA _ _ (FDC d) = sfConst d cpAXA fd1 sf2 fd3 = cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2 where -- Really: cpAXAAux :: SF' b c -> SF' a d -- Note: Event cases are not optimized (EXA etc.) cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d) -> SF' b c -> SF' a d cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) = sfArr (fdComp (fdComp fd1 fd2) fd3) cpAXAAux fd1 _ fd3 _ sf2@(SFSScan _ _ _ _) = cpAX fd1 (cpXA sf2 fd3) cpAXAAux fd1 _ fd3 _ sf2@(SFEP _ _ _ _) = cpAX fd1 (cpXA sf2 fd3) cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) = cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3) cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 {- if sfIsInv sf2 then cpAXAInv fd1 f1 fd3 f3 sf2 else SFCpAXA tf False fd1 sf2 fd3 -} where tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c) where (sf2', c) = (sfTF' sf2) dt (f1 a) {- cpAXAInv fd1 f1 fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 where tf dt a = sf2 `seq` (cpAXAInv fd1 f1 fd3 f3 sf2', f3 c) where (sf2', c) = (sfTF' sf2) dt (f1 a) -} cpAX :: FunDesc a b -> SF' b c -> SF' a c cpAX FDI sf2 = sf2 cpAX (FDC b) sf2 = cpCX b sf2 cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2 cpAX (FDG f1) sf2 = cpGX f1 sf2 cpXA :: SF' a b -> FunDesc b c -> SF' a c cpXA sf1 FDI = sf1 cpXA _ (FDC c) = sfConst c cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne cpXA sf1 (FDG f2) = cpXG sf1 f2 -- Don't forget that the remaining signal function, if it is -- SF', later could turn into something else, like SFId. cpCX :: b -> SF' b c -> SF' a c cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b) -- 2005-07-01: If we were serious about the semantics of sscan being required -- to be independent of the sampling interval, I guess one could argue for a -- fixed-point computation here ... Or maybe not. -- cpCX b (SFSScan _ _ _ _) = sfConst <fixed point comp> cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne) cpCX b (SFCpAXA _ fd21 sf22 fd23) = cpCXA ((fdFun fd21) b) sf22 fd23 cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI {- if sfIsInv sf2 then cpCXInv b sf2 else SFCpAXA tf False (FDC b) sf2 FDI -} where tf dt _ = (cpCX b sf2', c) where (sf2', c) = (sfTF' sf2) dt b {- cpCXInv b sf2 = SFCpAXA tf True (FDC b) sf2 FDI where tf dt _ = sf2 `seq` (cpCXInv b sf2', c) where (sf2', c) = (sfTF' sf2) dt b -} cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d cpCXA b sf2 FDI = cpCX b sf2 cpCXA _ _ (FDC c) = sfConst c cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2 where -- fd1 = FDC b -- f3 = fdFun fd3 -- Really: SF' b c -> SF' a d cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d) -> SF' b c -> SF' a d cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b)) cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c) where f' s _ = case f s b of Nothing -> Nothing Just (s', c') -> Just (s', f3 c') cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne)) cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) = cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3) cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 {- if sfIsInv sf2 then cpCXAInv fd1 b fd3 f3 sf2 else SFCpAXA tf False fd1 sf2 fd3 -} where tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c) where (sf2', c) = (sfTF' sf2) dt b {- -- For some reason, seq on sf2' in tf is faster than making -- cpCXAInv strict in sf2 by seq-ing on the top level (which would -- be similar to pattern matching on sf2). cpCXAInv fd1 b fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 where tf dt _ = sf2 `seq` (cpCXAInv fd1 b fd3 f3 sf2', f3 c) where (sf2', c) = (sfTF' sf2) dt b -} cpGX :: (a -> b) -> SF' b c -> SF' a c cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2 where cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) -- We actually do know that (fdComp (FDG f1) fd21) is going to -- result in an FDG. So we *could* call a cpGXA here. But the -- price is "inlining" of part of fdComp. cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c -- We really shouldn't see an EP here, as that would mean -- an arrow INTRODUCING events ... cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) = cpAXA (fdComp fd1 fd21) sf22 fd23 cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI {- if sfIsInv sf2 then cpGXInv fd1 f1 sf2 else SFCpAXA tf False fd1 sf2 FDI -} where tf dt a = (cpGXAux fd1 f1 sf2', c) where (sf2', c) = (sfTF' sf2) dt (f1 a) {- cpGXInv fd1 f1 sf2 = SFCpAXA tf True fd1 sf2 FDI where tf dt a = sf2 `seq` (cpGXInv fd1 f1 sf2', c) where (sf2', c) = (sfTF' sf2) dt (f1 a) -} cpXG :: SF' a b -> (b -> c) -> SF' a c cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1 where -- Really: cpXGAux :: SF' a b -> SF' a c cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b) where f' s a = case f s a of Nothing -> Nothing Just (s', b') -> Just (s', f2 b') cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne) where f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne') cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) = cpAXA fd11 sf12 (fdComp fd22 fd2) cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2 {- if sfIsInv sf1 then cpXGInv fd2 f2 sf1 else SFCpAXA tf False FDI sf1 fd2 -} where tf dt a = (cpXGAux fd2 f2 sf1', f2 b) where (sf1', b) = (sfTF' sf1) dt a {- cpXGInv fd2 f2 sf1 = SFCpAXA tf True FDI sf1 fd2 where tf dt a = (cpXGInv fd2 f2 sf1', f2 b) where (sf1', b) = (sfTF' sf1) dt a -} cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2 where cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b -> SF' b c -> SF' (Event a) c cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c -- We must not capture cne in the f closure since cne can change! -- See cpXX the SFEP/SFEP case for a similar situation. However, -- FDE represent a state-less signal function, so *its* NoEvent -- value never changes. Hence we only need to verify that it is -- NoEvent once. cpEXAux _ f1 f1ne (SFEP _ f2 s cne) = sfEP f (s, cne) (vfyNoEv f1ne cne) where f scne@(s, cne) a = case (f1 (Event a)) of NoEvent -> (scne, cne, cne) Event b -> let (s', c, cne') = f2 s b in ((s', cne'), c, cne') cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) = cpAXA (fdComp fd1 fd21) sf22 fd23 -- The rationale for the following is that the case analysis -- is typically not going to be more expensive than applying -- the function and possibly a bit cheaper. Thus if events -- are sparse, we might win, and if not, we don't loose to -- much. cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI {- if sfIsInv sf2 then cpEXInv fd1 f1 f1ne sf2 else SFCpAXA tf False fd1 sf2 FDI -} where tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c) where (sf2', c) = case ea of NoEvent -> (sfTF' sf2) dt f1ne _ -> (sfTF' sf2) dt (f1 ea) {- cpEXInv fd1 f1 f1ne sf2 = SFCpAXA tf True fd1 sf2 FDI where tf dt ea = sf2 `seq` (cpEXInv fd1 f1 f1ne sf2', c) where (sf2', c) = case ea of NoEvent -> (sfTF' sf2) dt f1ne _ -> (sfTF' sf2) dt (f1 ea) -} cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1 where cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c -> SF' a (Event b) -> SF' a c cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb) where f' s a = case f s a of Nothing -> Nothing Just (s', NoEvent) -> Just (s', f2ne) Just (s', eb') -> Just (s', f2 eb') cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) = sfEP f s (vfyNoEv ebne f2ne) where f s a = case f1 s a of (s', NoEvent, NoEvent) -> (s', f2ne, f2ne) (s', eb, NoEvent) -> (s', f2 eb, f2ne) _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event." cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) = cpAXA fd11 sf12 (fdComp fd13 fd2) cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2 {- if sfIsInv sf1 then cpXEInv fd2 f2 f2ne sf1 else SFCpAXA tf False FDI sf1 fd2 -} where tf dt a = (cpXEAux fd2 f2 f2ne sf1', case eb of NoEvent -> f2ne; _ -> f2 eb) where (sf1', eb) = (sfTF' sf1) dt a {- cpXEInv fd2 f2 f2ne sf1 = SFCpAXA tf True FDI sf1 fd2 where tf dt a = sf1 `seq` (cpXEInv fd2 f2 f2ne sf1', case eb of NoEvent -> f2ne; _ -> f2 eb) where (sf1', eb) = (sfTF' sf1) dt a -} -- Widening. -- The definition exploits the following identities: -- first identity = identity -- New -- first (constant b) = arr (\(_, c) -> (b, c)) -- (first (arr f)) = arr (\(a, c) -> (f a, c)) 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 -- Also used in parSplitPrim fpAux :: SF' a b -> SF' (a,c) (b,c) fpAux (SFArr _ FDI) = sfId -- New fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c)) fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c)) fpAux sf1 = SF' tf -- if sfIsInv sf1 then fpInv sf1 else SF' tf False where tf dt ~(a, c) = (fpAux sf1', (b, c)) where (sf1', b) = (sfTF' sf1) dt a {- fpInv :: SF' a b -> SF' (a,c) (b,c) fpInv sf1 = SF' tf True where tf dt ~(a, c) = sf1 `seq` (fpInv 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 -- Also used in parSplitPrim spAux :: SF' a b -> SF' (c,a) (c,b) spAux (SFArr _ FDI) = sfId -- New spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b)) spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a)) spAux sf1 = SF' tf -- if sfIsInv sf1 then spInv sf1 else SF' tf False where tf dt ~(c, a) = (spAux sf1', (c, b)) where (sf1', b) = (sfTF' sf1) dt a {- spInv :: SF' a b -> SF' (c,a) (c,b) spInv sf1 = SF' tf True where tf dt ~(c, a) = sf1 `seq` (spInv sf1', (c, b)) where (sf1', b) = (sfTF' sf1) dt a -} -- Parallel composition. -- The definition exploits the following identities (that hold for SF): -- identity *** identity = identity -- New -- sf *** identity = first sf -- New -- identity *** sf = second sf -- New -- 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) = (psXX sf1 sf2, (b0, d0)) where (sf1, b0) = tf10 a0 (sf2, d0) = tf20 c0 -- Naming convention: ps<X><Y> where <X> and <Y> is one of: -- X - arbitrary signal function -- A - arbitrary pure arrow -- C - constant arrow psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d) psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) psXX (SFArr _ FDI) sf2 = spAux sf2 -- New psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) -- !!! Unclear if this really is a gain. -- !!! potentially unnecessary tupling and untupling. -- !!! To be investigated. -- !!! 2005-07-01: At least for MEP 6, the corresponding opt for -- !!! &&& was harmfull. On that basis, disable it here too. -- psXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = -- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) psXX sf1 sf2 = SF' tf {- if sfIsInv sf1 && sfIsInv sf2 then psXXInv sf1 sf2 else SF' tf False -} where tf dt ~(a, c) = (psXX sf1' sf2', (b, d)) where (sf1', b) = (sfTF' sf1) dt a (sf2', d) = (sfTF' sf2) dt c {- psXXInv :: SF' a b -> SF' c d -> SF' (a,c) (b,d) psXXInv sf1 sf2 = SF' tf True where tf dt ~(a, c) = sf1 `seq` sf2 `seq` (psXXInv sf1' sf2', (b, d)) where (sf1', b) = (sfTF' sf1) dt a (sf2', d) = (sfTF' sf2) dt c -} psCX :: b -> SF' c d -> SF' (a,c) (b,d) psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2) psCX b sf2 = SF' tf {- if sfIsInv sf2 then psCXInv b sf2 else SF' tf False -} where tf dt ~(_, c) = (psCX b sf2', (b, d)) where (sf2', d) = (sfTF' sf2) dt c {- psCXInv :: b -> SF' c d -> SF' (a,c) (b,d) psCXInv b sf2 = SF' tf True where tf dt ~(_, c) = sf2 `seq` (psCXInv b sf2', (b, d)) where (sf2', d) = (sfTF' sf2) dt c -} psXC :: SF' a b -> d -> SF' (a,c) (b,d) psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d)) psXC sf1 d = SF' tf {- if sfIsInv sf1 then psXCInv sf1 d else SF' tf False -} where tf dt ~(a, _) = (psXC sf1' d, (b, d)) where (sf1', b) = (sfTF' sf1) dt a {- psXCInv :: SF' a b -> d -> SF' (a,c) (b,d) psXCInv sf1 d = SF' tf True where tf dt ~(a, _) = sf1 `seq` (psXCInv sf1' d, (b, d)) where (sf1', b) = (sfTF' sf1) dt a -} psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2) psAX f1 sf2 = SF' tf {- if sfIsInv sf2 then psAXInv f1 sf2 else SF' tf False -} where tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d)) where (sf2', d) = (sfTF' sf2) dt c {- psAXInv :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) psAXInv f1 sf2 = SF' tf True where tf dt ~(a, c) = sf2 `seq` (psAXInv f1 sf2', (f1 a, d)) where (sf2', d) = (sfTF' sf2) dt c -} psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2)) psXA sf1 f2 = SF' tf {- if sfIsInv sf1 then psXAInv sf1 f2 else SF' tf False -} where tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c)) where (sf1', b) = (sfTF' sf1) dt a {- psXAInv :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) psXAInv sf1 f2 = SF' tf True where tf dt ~(a, c) = sf1 `seq` (psXAInv sf1' f2, (b, f2 c)) where (sf1', b) = (sfTF' sf1) dt a -} -- !!! Hmmm. Why don't we optimize the FDE cases here??? -- !!! Seems pretty obvious that we should! -- !!! It should also be possible to optimize an event processor in -- !!! parallel with another event processor or an Arr FDE. parFanOutPrim :: SF a b -> SF a c -> SF a (b, c) parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} where tf0 a0 = (pfoXX sf1 sf2, (b0, c0)) where (sf1, b0) = tf10 a0 (sf2, c0) = tf20 a0 -- Naming convention: pfo<X><Y> where <X> and <Y> is one of: -- X - arbitrary signal function -- A - arbitrary pure arrow -- I - identity arrow -- C - constant arrow pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c) pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) -- !!! Unclear if this really would be a gain -- !!! 2005-07-01: NOT a win for MEP 6. -- pfoXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = -- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) pfoXX sf1 sf2 = SF' tf {- if sfIsInv sf1 && sfIsInv sf2 then pfoXXInv sf1 sf2 else SF' tf False -} where tf dt a = (pfoXX sf1' sf2', (b, c)) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt a {- pfoXXInv :: SF' a b -> SF' a c -> SF' a (b ,c) pfoXXInv sf1 sf2 = SF' tf True where tf dt a = sf1 `seq` sf2 `seq` (pfoXXInv sf1' sf2', (b, c)) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt a -} pfoIX :: SF' a c -> SF' a (a ,c) pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2) pfoIX sf2 = SF' tf {- if sfIsInv sf2 then pfoIXInv sf2 else SF' tf False -} where tf dt a = (pfoIX sf2', (a, c)) where (sf2', c) = (sfTF' sf2) dt a {- pfoIXInv :: SF' a c -> SF' a (a ,c) pfoIXInv sf2 = SF' tf True where tf dt a = sf2 `seq` (pfoIXInv sf2', (a, c)) where (sf2', c) = (sfTF' sf2) dt a -} pfoXI :: SF' a b -> SF' a (b ,a) pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI) pfoXI sf1 = SF' tf {- if sfIsInv sf1 then pfoXIInv sf1 else SF' tf False -} where tf dt a = (pfoXI sf1', (b, a)) where (sf1', b) = (sfTF' sf1) dt a {- pfoXIInv :: SF' a b -> SF' a (b ,a) pfoXIInv sf1 = SF' tf True where tf dt a = sf1 `seq` (pfoXIInv sf1', (b, a)) where (sf1', b) = (sfTF' sf1) dt a -} pfoCX :: b -> SF' a c -> SF' a (b ,c) pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2) pfoCX b sf2 = SF' tf {- if sfIsInv sf2 then pfoCXInv b sf2 else SF' tf False -} where tf dt a = (pfoCX b sf2', (b, c)) where (sf2', c) = (sfTF' sf2) dt a {- pfoCXInv :: b -> SF' a c -> SF' a (b ,c) pfoCXInv b sf2 = SF' tf True where tf dt a = sf2 `seq` (pfoCXInv b sf2', (b, c)) where (sf2', c) = (sfTF' sf2) dt a -} pfoXC :: SF' a b -> c -> SF' a (b ,c) pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c)) pfoXC sf1 c = SF' tf {- if sfIsInv sf1 then pfoXCInv sf1 c else SF' tf False -} where tf dt a = (pfoXC sf1' c, (b, c)) where (sf1', b) = (sfTF' sf1) dt a {- pfoXCInv :: SF' a b -> c -> SF' a (b ,c) pfoXCInv sf1 c = SF' tf True where tf dt a = sf1 `seq` (pfoXCInv sf1' c, (b, c)) where (sf1', b) = (sfTF' sf1) dt a -} pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c) pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2) pfoAX f1 sf2 = SF' tf {- if sfIsInv sf2 then pfoAXInv f1 sf2 else SF' tf False -} where tf dt a = (pfoAX f1 sf2', (f1 a, c)) where (sf2', c) = (sfTF' sf2) dt a {- pfoAXInv :: (a -> b) -> SF' a c -> SF' a (b ,c) pfoAXInv f1 sf2 = SF' tf True where tf dt a = sf2 `seq` (pfoAXInv f1 sf2', (f1 a, c)) where (sf2', c) = (sfTF' sf2) dt a -} pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c) pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2)) pfoXA sf1 f2 = SF' tf {- if sfIsInv sf1 then pfoXAInv sf1 f2 else SF' tf False -} where tf dt a = (pfoXA sf1' f2, (b, f2 a)) where (sf1', b) = (sfTF' sf1) dt a {- pfoXAInv :: SF' a b -> (a -> c) -> SF' a (b ,c) pfoXAInv sf1 f2 = SF' tf True where tf dt a = sf1 `seq` (pfoXAInv sf1' f2, (b, f2 a)) where (sf1', b) = (sfTF' sf1) 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 :: SF' (a,c) (b,c) -> SF' a b loopAux (SFArr _ FDI) = sfId loopAux (SFArr _ (FDC (b, _))) = sfConst b loopAux (SFArr _ fd1) = sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b) loopAux sf1 = SF' tf {- if sfIsInv sf1 then loopInv sf1 else SF' tf False -} where tf dt a = (loopAux sf1', b) where (sf1', (b, c)) = (sfTF' sf1) dt (a, c) {- loopInv :: SF' (a,c) (b,c) -> SF' a b loopInv sf1 = SF' tf True where tf dt a = sf1 `seq` (loopInv sf1', b) where (sf1', (b, c)) = (sfTF' sf1) dt (a, c) -} ------------------------------------------------------------------------------ -- Basic signal functions ------------------------------------------------------------------------------ -- | Identity: identity = arr id -- -- Using 'identity' is preferred over lifting id, since the arrow combinators -- know how to optimise certain networks based on the transformations being -- applied. identity :: SF a a identity = SF {sfTF = \a -> (sfId, a)} -- | Identity: constant b = arr (const b) -- -- Using 'constant' is preferred over lifting const, since the arrow combinators -- know how to optimise certain networks based on the transformations being -- applied. 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). -- -- The output at time zero is the first argument, and from -- that point on it behaves like the signal function passed as -- second argument. (-->) :: b -> SF a b -> SF a b b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)} -- | Input initialization operator. -- -- The input at time zero is the first argument, and from -- that point on it behaves like the signal function passed as -- second argument. (>--) :: a -> SF a b -> SF a b a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0} -- | Transform initial output value. -- -- Applies a transformation 'f' only to the first output value at -- time zero. (-=>) :: (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. -- -- Applies a transformation 'f' only to the first input value at -- time zero. (>=-) :: (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) ------------------------------------------------------------------------------ -- Simple, stateful signal processing ------------------------------------------------------------------------------ -- New sscan primitive. It should be possible to define lots of functions -- in terms of this one. Eventually a new constructor will be introduced if -- this works out. sscan :: (b -> a -> b) -> b -> SF a b sscan f b_init = sscanPrim f' b_init b_init where f' b a = let b' = f b a in Just (b', b') {- sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b sscanPrim f c_init b_init = SF {sfTF = tf0} where tf0 a0 = case f c_init a0 of Nothing -> (spAux f c_init b_init, b_init) Just (c', b') -> (spAux f c' b', b') spAux :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b spAux f c b = sf where -- sf = SF' tf True sf = SF' tf tf _ a = case f c a of Nothing -> (sf, b) Just (c', b') -> (spAux f c' b', b') -} ------------------------------------------------------------------------------ -- Basic event sources ------------------------------------------------------------------------------ -- | Event source that 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 -- ^ The time /q/ after which the event should be produced -> b -- ^ Value to produce at that time -> 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. -- !!! 2005-03-30: This is potentially a bit inefficient since we KNOW -- !!! (at this level) that the SF is going to be invarying. But afterEach -- !!! does NOT know this as the argument list may well be finite. -- !!! We could use sfMkInv, but that's not without problems. -- !!! We're probably better off specializing afterEachCat here. 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 = SF' {sfTF' = tf} where tf dt _ | t' >= 0 = (scheduleNextEvent t' qxs, Event x) | otherwise = (awaitNextEvent t' x qxs, NoEvent) where t' = t + dt -} -- | 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. -- After all, after, repeatedly etc. are defined in terms of afterEach. afterEach :: [(Time,b)] -> SF a (Event b) afterEach qxs = afterEachCat qxs >>> arr (fmap head) -- | Event source with consecutive occurrences at the given intervals. -- Should more than one event be scheduled to occur in any sampling interval, -- the output list will contain all events produced during that interval. -- Guaranteed not to miss any events. afterEachCat :: [(Time,b)] -> SF a (Event [b]) afterEachCat [] = never afterEachCat ((q,x):qxs) | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period." | otherwise = SF {sfTF = tf0} where tf0 _ = if q <= 0 then emitEventsScheduleNext 0.0 [x] qxs else (awaitNextEvent (-q) x qxs, NoEvent) emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs)) emitEventsScheduleNext t xs ((q,x):qxs) | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period." | t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs)) where t' = t - q awaitNextEvent t x qxs = SF' tf -- False where tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs | otherwise = (awaitNextEvent t' x qxs, NoEvent) where t' = t + dt -- | Delay for events. (Consider it a triggered after, hence /basic/.) -- Can be implemented fairly cheaply as long as the events are sparse. -- It is a question of rescheduling events for later. Not unlike "afterEach". -- -- It is not exactly the case that delayEvent t = delay t NoEvent -- since the rules for dropping/extrapolating samples are different. -- A single event occurrence will never be duplicated. -- If there is an event occurrence, one will be output as soon as -- possible after the given delay time, but not necessarily that -- one. See delayEventCat. delayEvent :: Time -> SF (Event a) (Event a) delayEvent q | q < 0 = usrErr "AFRP" "delayEvent" "Negative delay." | q == 0 = identity | otherwise = delayEventCat q >>> arr (fmap head) -- There is no *guarantee* above that every event actually will be -- rescheduled since the sampling frequency (temporarily) might drop. -- The following interface would allow ALL scheduled events to occur -- as soon as possible: -- (Read "delay event and catenate events that occur so closely so as to be -- inseparable".) -- The events in the list are ordered temporally to the extent possible. {- -- This version is too strict! delayEventCat :: Time -> SF (Event a) (Event [a]) delayEventCat q | q < 0 = usrErr "AFRP" "delayEventCat" "Negative delay." | q == 0 = arr (fmap (:[])) | otherwise = SF {sfTF = tf0} where tf0 NoEvent = (noPendingEvent, NoEvent) tf0 (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent) noPendingEvent = SF' tf -- True where tf _ NoEvent = (noPendingEvent, NoEvent) tf _ (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent) -- t_next is the present time w.r.t. the next scheduled event. -- t_last is the present time w.r.t. the last scheduled event. -- In the event queues, events are associated with their time -- w.r.t. to preceding event (positive). pendingEvents t_last rqxs qxs t_next x = SF' tf -- True where tf dt NoEvent = tf1 (t_last + dt) rqxs (t_next + dt) tf dt (Event x') = tf1 (-q) ((q', x') : rqxs) t_next' where t_next' = t_next + dt t_last' = t_last + dt q' = t_last' + q tf1 t_last' rqxs' t_next' | t_next' >= 0 = emitEventsScheduleNext t_last' rqxs' qxs t_next' [x] | otherwise = (pendingEvents t_last' rqxs' qxs t_next' x, NoEvent) -- t_next is the present time w.r.t. the *scheduled* time of the -- event that is about to be emitted (i.e. >= 0). -- The time associated with any event at the head of the event -- queue is also given w.r.t. the event that is about to be emitted. -- Thus, t_next - q' is the present time w.r.t. the event at the head -- of the event queue. emitEventsScheduleNext t_last [] [] t_next rxs = (noPendingEvent, Event (reverse rxs)) emitEventsScheduleNext t_last rqxs [] t_next rxs = emitEventsScheduleNext t_last [] (reverse rqxs) t_next rxs emitEventsScheduleNext t_last rqxs ((q', x') : qxs') t_next rxs | q' > t_next = (pendingEvents t_last rqxs qxs' (t_next - q') x', Event (reverse rxs)) | otherwise = emitEventsScheduleNext t_last rqxs qxs' (t_next-q') (x' : rxs) -} -- | Delay an event by a given delta and catenate events that occur so closely -- so as to be /inseparable/. delayEventCat :: Time -> SF (Event a) (Event [a]) delayEventCat q | q < 0 = usrErr "AFRP" "delayEventCat" "Negative delay." | q == 0 = arr (fmap (:[])) | otherwise = SF {sfTF = tf0} where tf0 e = (case e of NoEvent -> noPendingEvent Event x -> pendingEvents (-q) [] [] (-q) x, NoEvent) noPendingEvent = SF' tf -- True where tf _ e = (case e of NoEvent -> noPendingEvent Event x -> pendingEvents (-q) [] [] (-q) x, NoEvent) -- t_next is the present time w.r.t. the next scheduled event. -- t_last is the present time w.r.t. the last scheduled event. -- In the event queues, events are associated with their time -- w.r.t. to preceding event (positive). pendingEvents t_last rqxs qxs t_next x = SF' tf -- True where tf dt e | t_next' >= 0 = emitEventsScheduleNext e t_last' rqxs qxs t_next' [x] | otherwise = (pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent) where t_next' = t_next + dt t_last' = t_last + dt (t_last'', rqxs') = case e of NoEvent -> (t_last', rqxs) Event x' -> (-q, (t_last'+q,x') : rqxs) -- t_next is the present time w.r.t. the *scheduled* time of the -- event that is about to be emitted (i.e. >= 0). -- The time associated with any event at the head of the event -- queue is also given w.r.t. the event that is about to be emitted. -- Thus, t_next - q' is the present time w.r.t. the event at the head -- of the event queue. emitEventsScheduleNext e _ [] [] _ rxs = (case e of NoEvent -> noPendingEvent Event x -> pendingEvents (-q) [] [] (-q) x, Event (reverse rxs)) emitEventsScheduleNext e t_last rqxs [] t_next rxs = emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs | q' > t_next = (case e of NoEvent -> pendingEvents t_last rqxs qxs' (t_next - q') x' Event x'' -> pendingEvents (-q) ((t_last+q, x'') : rqxs) qxs' (t_next - q') x', Event (reverse rxs)) | otherwise = emitEventsScheduleNext e t_last rqxs qxs' (t_next - q') (x' : rxs) -- | A rising edge detector. Useful for things like detecting key presses. -- It is initialised as /up/, meaning that events occuring at time 0 will -- not be detected. -- 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 -- | A rising edge detector that can be initialized as up ('True', meaning -- that events occurring at time 0 will not be detected) or down -- ('False', meaning that events ocurring at time 0 will be detected). iEdge :: Bool -> SF Bool (Event ()) -- iEdge i = edgeBy (isBoolRaisingEdge ()) i iEdge b = sscanPrim f (if b then 2 else 0) NoEvent where f :: Int -> Bool -> Maybe (Int, Event ()) f 0 False = Nothing f 0 True = Just (1, Event ()) f 1 False = Just (0, NoEvent) f 1 True = Just (2, NoEvent) f 2 False = Just (0, NoEvent) f 2 True = Nothing f _ _ = undefined -- | Like 'edge', but parameterized on the tag value. edgeTag :: a -> SF Bool (Event a) -- edgeTag a = edgeBy (isBoolRaisingEdge a) True edgeTag a = edge >>> arr (`tag` a) -- 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 -- | Edge detector particularized for detecting transtitions -- on a 'Maybe' signal from 'Nothing' to 'Just'. -- !!! 2005-07-09: To be done or eliminated -- !!! Maybe could be kept as is, but could be easy to implement directly -- !!! in terms of sscan? 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. -- !!! 2005-07-09: To be done. 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 = SF' tf -- True where tf _ 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 the first event. once :: SF (Event a) (Event a) once = takeEvents 1 -- | Suppress all but the first n events. takeEvents :: Int -> SF (Event a) (Event a) takeEvents n | n <= 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 n | n <= 0 = identity dropEvents n = dSwitch (never &&& identity) (const (NoEvent >-- dropEvents (n - 1))) ------------------------------------------------------------------------------ -- Basic switchers ------------------------------------------------------------------------------ -- !!! Interesting case. It seems we need scoped type variables -- !!! to be able to write down the local type signatures. -- !!! On the other hand, the scoped type variables seem to -- !!! prohibit the kind of unification that is needed for GADTs??? -- !!! Maybe this could be made to wok if it actually WAS known -- !!! that scoped type variables indeed corresponds to universally -- !!! quantified variables? Or if one were to keep track of those -- !!! scoped type variables that actually do? -- !!! -- !!! Find a simpler case to experiment further. For now, elim. -- !!! the free variable. {- -- Basic switch. switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b switch (SF {sfTF = tf10} :: SF a (b, Event c)) (k :: c -> SF a b) = SF {sfTF = tf0} where tf0 a0 = case tf10 a0 of (sf1, (b0, NoEvent)) -> (switchAux sf1, b0) (_, (_, Event c0)) -> sfTF (k c0) a0 -- It would be nice to optimize further here. E.g. if it would be -- possible to observe the event source only. switchAux :: SF' a (b, Event c) -> SF' a b switchAux (SFId _) = switchAuxA1 id -- New switchAux (SFConst _ (b, NoEvent)) = sfConst b switchAux (SFArr _ f1) = switchAuxA1 f1 switchAux sf1 = SF' tf where tf dt a = case (sfTF' sf1) dt a of (sf1', (b, NoEvent)) -> (switchAux sf1', b) (_, (_, Event c)) -> sfTF (k c) a -- Could be optimized a little bit further by having a case for -- identity, switchAuxI1 -- Note: While switch behaves as a stateless arrow at this point, that -- could change after a switch. Hence, SF' overall. switchAuxA1 :: (a -> (b, Event c)) -> SF' a b switchAuxA1 f1 = sf where sf = SF' tf tf _ a = case f1 a of (b, NoEvent) -> (sf, b) (_, Event c) -> sfTF (k c) a -} -- | Basic switch. -- -- By default, the first signal function is applied. -- -- Whenever the second value in the pair actually is an event, -- the value carried by the event is used to obtain a new signal -- function to be applied *at that time and at future times*. -- -- Until that happens, the first value in the pair is produced -- in the output signal. -- -- Important note: at the time of switching, the second -- signal function is applied immediately. If that second -- SF can also switch at time zero, then a double (nested) -- switch might take place. If the second SF refers to the -- first one, the switch might take place infinitely many -- times and never be resolved. -- -- Remember: The continuation is evaluated strictly at the time -- of switching! 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 k, b0) (_, (_, Event c0)) -> sfTF (k c0) a0 -- It would be nice to optimize further here. E.g. if it would be -- possible to observe the event source only. switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b switchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b switchAux (SFArr _ fd1) k = switchAuxA1 (fdFun fd1) k switchAux sf1 k = SF' tf {- if sfIsInv sf1 then switchInv sf1 k else SF' tf False -} where tf dt a = case (sfTF' sf1) dt a of (sf1', (b, NoEvent)) -> (switchAux sf1' k, b) (_, (_, Event c)) -> sfTF (k c) a {- -- Note: subordinate signal function being invariant does NOT -- imply that the overall signal function is. switchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b switchInv sf1 k = SF' tf False where tf dt a = case (sfTF' sf1) dt a of (sf1', (b, NoEvent)) -> (switchInv sf1' k, b) (_, (_, Event c)) -> sfTF (k c) a -} -- !!! Could be optimized a little bit further by having a case for -- !!! identity, switchAuxI1. But I'd expect identity is so unlikely -- !!! that there is no point. -- Note: While switch behaves as a stateless arrow at this point, that -- could change after a switch. Hence, SF' overall. switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b switchAuxA1 f1 k = sf where sf = SF' tf -- False tf _ a = case f1 a of (b, NoEvent) -> (sf, b) (_, Event c) -> sfTF (k c) a -- | Switch with delayed observation. -- -- By default, the first signal function is applied. -- -- Whenever the second value in the pair actually is an event, -- the value carried by the event is used to obtain a new signal -- function to be applied *at future times*. -- -- Until that happens, the first value in the pair is produced -- in the output signal. -- -- Important note: at the time of switching, the second -- signal function is used immediately, but the current -- input is fed by it (even though the actual output signal -- value at time 0 is discarded). -- -- If that second SF can also switch at time zero, then a -- double (nested) -- switch might take place. If the second SF refers to the -- first one, the switch might take place infinitely many times and never be -- resolved. -- -- Remember: The continuation is evaluated strictly at the time -- of switching! -- Alternative name: "decoupled switch"? -- (The SFId optimization is highly unlikley to be of much use, but it -- does raise an interesting typing issue.) 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 k Event c0 -> fst (sfTF (k c0) a0), b0) -- It would be nice to optimize further here. E.g. if it would be -- possible to observe the event source only. dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k dSwitchAux sf1 k = SF' tf {- if sfIsInv sf1 then dSwitchInv sf1 k else SF' tf False -} where tf dt a = let (sf1', (b, ec)) = (sfTF' sf1) dt a in (case ec of NoEvent -> dSwitchAux sf1' k Event c -> fst (sfTF (k c) a), b) {- -- Note: that the subordinate signal function is invariant does NOT -- imply that the overall signal function is. dSwitchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b dSwitchInv sf1 k = SF' tf False where tf dt a = let (sf1', (b, ec)) = (sfTF' sf1) dt a in (case ec of NoEvent -> dSwitchInv sf1' k Event c -> fst (sfTF (k c) a), b) -} -- !!! Could be optimized a little bit further by having a case for -- !!! identity, switchAuxI1 -- Note: While dSwitch behaves as a stateless arrow at this point, that -- could change after a switch. Hence, SF' overall. dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b dSwitchAuxA1 f1 k = sf where sf = SF' tf -- False tf _ a = let (b, ec) = f1 a in (case ec of NoEvent -> sf Event c -> fst (sfTF (k c) a), b) -- | Recurring switch. -- -- See <http://www.haskell.org/haskellwiki/Yampa#Switches> for more -- information on how this switch works. -- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is -- !!! being invoked recursively on a switch. In fact, we don't even care -- !!! whether the subordinate signal function is invarying or not. -- !!! We could make use of a signal function transformer sfInv to -- !!! mark the constructor as invarying. Would that make sense? -- !!! The price would be an extra loop with case analysis. -- !!! The potential gain is fewer case analyses in superior loops. 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. -- -- See <http://www.haskell.org/haskellwiki/Yampa#Switches> for more -- information on how this switch works. 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. -- -- See <http://www.haskell.org/haskellwiki/Yampa#Switches> for more -- information on how this switch works. -- !!! Has not been optimized properly. -- !!! Nor has opts been tested! -- !!! Don't forget Inv opts! 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 -- Same problem as above: must pass k explicitly??? -- kSwitchAux (SFId _) sfe = kSwitchAuxI1 sfe kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe -- kSwitchAux (SFArrE _ f1) sfe = kSwitchAuxA1 f1 sfe -- kSwitchAux (SFArrEE _ f1) sfe = kSwitchAuxA1 f1 sfe kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) -- kSwitchAux sf1 (SFArrE _ fe) = kSwitchAuxAE sf1 fe -- kSwitchAux sf1 (SFArrEE _ fe) = kSwitchAuxAE sf1 fe kSwitchAux sf1 sfe = SF' tf -- False 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 {- -- !!! Untested optimization! kSwitchAuxI1 (SFConst _ NoEvent) = sfId kSwitchAuxI1 (SFArr _ fe) = kSwitchAuxI1AE fe kSwitchAuxI1 sfe = SF' tf where tf dt a = case (sfTF' sfe) dt (a, a) of (sfe', NoEvent) -> (kSwitchAuxI1 sfe', a) (_, Event c) -> sfTF (k identity c) a -} -- !!! Untested optimization! kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde) -- kSwitchAuxC1 b (SFArrE _ fe) = kSwitchAuxC1AE b fe -- kSwitchAuxC1 b (SFArrEE _ fe) = kSwitchAuxC1AE b fe kSwitchAuxC1 b sfe = SF' tf -- False where tf dt a = case (sfTF' sfe) dt (a, b) of (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b) (_, Event c) -> sfTF (k (constant b) c) a -- !!! Untested optimization! kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1 kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde) -- kSwitchAuxA1 f1 (SFArrE _ fe) = kSwitchAuxA1AE f1 fe -- kSwitchAuxA1 f1 (SFArrEE _ fe) = kSwitchAuxA1AE f1 fe kSwitchAuxA1 f1 sfe = SF' tf -- False where tf dt a = let b = f1 a in case (sfTF' sfe) dt (a, b) of (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b) (_, Event c) -> sfTF (k (arr f1) c) a -- !!! Untested optimization! -- kSwitchAuxAE (SFId _) fe = kSwitchAuxI1AE fe kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe -- kSwitchAuxAE (SFArrE _ f1) fe = kSwitchAuxA1AE f1 fe -- kSwitchAuxAE (SFArrEE _ f1) fe = kSwitchAuxA1AE f1 fe kSwitchAuxAE sf1 fe = SF' tf -- False where tf dt a = let (sf1', b) = (sfTF' sf1) dt a in case fe (a, b) of NoEvent -> (kSwitchAuxAE sf1' fe, b) Event c -> sfTF (k (freeze sf1 dt) c) a {- -- !!! Untested optimization! kSwitchAuxI1AE fe = SF' tf -- False where tf dt a = case fe (a, a) of NoEvent -> (kSwitchAuxI1AE fe, a) Event c -> sfTF (k identity c) a -} -- !!! Untested optimization! kSwitchAuxC1AE b fe = SF' tf -- False where tf _ a = case fe (a, b) of NoEvent -> (kSwitchAuxC1AE b fe, b) Event c -> sfTF (k (constant b) c) a -- !!! Untested optimization! kSwitchAuxA1AE f1 fe = SF' tf -- False where tf _ a = let b = f1 a in case fe (a, b) of NoEvent -> (kSwitchAuxA1AE f1 fe, b) Event c -> sfTF (k (arr f1) c) a -- | 'kSwitch' with delayed observation. -- -- See <http://www.haskell.org/haskellwiki/Yampa#Switches> for more -- information on how this switch works. -- !!! Has not been optimized properly. Should be like kSwitch. 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 (SFArr _ (FDC NoEvent)) = sf1 dkSwitchAux sf1 sfe = SF' tf -- False 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 ------------------------------------------------------------------------------ -- | Tuple a value up with every element of a collection of signal -- functions. broadcast :: Functor col => a -> col sf -> col (a, sf) broadcast a sfs = fmap (\sf -> (a, sf)) sfs -- !!! Hmm. We should really optimize here. -- !!! Check for Arr in parallel! -- !!! Check for Arr FDE in parallel!!! -- !!! Check for EP in parallel!!!!! -- !!! Cf &&&. -- !!! But how??? All we know is that the collection is a functor ... -- !!! Maybe that kind of generality does not make much sense for -- !!! par and parB? (Although it is niceto be able to switch into a -- !!! par or parB from within a pSwitch[B].) -- !!! If we had a parBList, that could be defined in terms of &&&, surely? -- !!! E.g. -- !!! parBList [] = constant [] -- !!! parBList (sf:sfs) = sf &&& parBList sfs >>> arr (\(x,xs) -> x:xs) -- !!! -- !!! This ought to optimize quite well. E.g. -- !!! parBList [arr1,arr2,arr3] -- !!! = arr1 &&& parBList [arr2,arr3] >>> arrX -- !!! = arr1 &&& (arr2 &&& parBList [arr3] >>> arrX) >>> arrX -- !!! = arr1 &&& (arr2 &&& (arr3 &&& parBList [] >>> arrX) >>> arrX) >>> arrX -- !!! = arr1 &&& (arr2 &&& (arr3C >>> arrX) >>> arrX) >>> arrX -- !!! = arr1 &&& (arr2 &&& (arr3CcpX) >>> arrX) >>> arrX -- !!! = arr1 &&& (arr23CcpX >>> arrX) >>> arrX -- !!! = arr1 &&& (arr23CcpXcpX) >>> arrX -- !!! = arr123CcpXcpXcpX -- | Spatial parallel composition of a signal function collection. -- Given a collection of signal functions, it returns a signal -- function that 'broadcast's its input signal to every element -- of the collection, to return a signal carrying a collection -- of outputs. See 'par'. -- -- For more information on how parallel composition works, check -- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf> 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). See 'pSwitch'. -- -- For more information on how parallel composition works, check -- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf> 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 -- | Delayed parallel switch with broadcasting (dynamic collection of -- signal functions spatially composed in parallel). See 'dpSwitch'. -- -- For more information on how parallel composition works, check -- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf> 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 -- For more information on how parallel composition works, check -- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf> rpSwitchB :: Functor col => col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) rpSwitchB = rpSwitch broadcast -- For more information on how parallel composition works, check -- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf> 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. -- par :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) -- ^ Determines the input to each signal function -- in the collection. IMPORTANT! The routing function MUST -- preserve the structure of the signal function collection. -> col (SF b c) -- ^ Signal function collection. -> 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 = SF' tf -- True 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. -- -- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE pSwitch :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) -- ^ 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. -> col (SF b c) -- ^ Signal function collection. -> SF (a, col c) (Event d) -- ^ Signal function generating the switching event. -> (col (SF b c) -> d -> SF a (col c)) -- ^ Continuation to be invoked once event occurs. -> 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 (SFArr _ (FDC NoEvent)) = parAux rf sfs pSwitchAux sfs sfe = SF' tf -- False 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. -- -- The collection argument to the function invoked on the -- switching event is of particular interest: it captures the -- continuations of the signal functions running in the collection -- maintained by 'dpSwitch' at the time of the switching event, -- thus making it possible to preserve their state across a switch. -- Since the continuations are plain, ordinary signal functions, -- they can be resumed, discarded, stored, or combined with -- other signal functions. -- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE. -- dpSwitch :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function. Its purpose is -- to pair up each running signal function in the collection -- maintained by 'dpSwitch' with the input it is going to see -- at each point in time. All the routing function can do is specify -- how the input is distributed. -> col (SF b c) -- ^ Initial collection of signal functions. -> SF (a, col c) (Event d) -- ^ Signal function that observes the external -- input signal and the output signals from the collection in order -- to produce a switching event. -> (col (SF b c) -> d -> SF a (col c)) -- ^ The fourth argument is a function that is invoked when the -- switching event occurs, yielding a new signal function to switch -- into based on the collection of signal functions previously -- running and the value carried by the switching event. This -- allows the collection to be updated and then switched back -- in, typically by employing 'dpSwitch' again. -> 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 (SFArr _ (FDC NoEvent)) = parAux rf sfs dpSwitchAux sfs sfe = SF' tf -- False 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. -- !!! Should be redone using SFSScan? -- !!! Otherwise, we are missing an invarying case. old_hold :: a -> SF (Event a) a old_hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . old_hold) -- | Zero-order hold. hold :: a -> SF (Event a) a hold a_init = epPrim f () a_init where f _ a = ((), a, a) -- !!! -- !!! 2005-04-10: I DO NO LONGER THINK THIS IS CORRECT! -- !!! CAN ONE POSSIBLY GET THE DESIRED STRICTNESS PROPERTIES -- !!! ("DECOUPLING") this way??? -- !!! Also applies to the other "d" functions that were tentatively -- !!! defined using only epPrim. -- !!! -- !!! 2005-06-13: Yes, indeed wrong! (But it's subtle, one has to -- !!! make sure that the incoming event (and not just the payload -- !!! of the event) is control dependent on the output of "dHold" -- !!! to observe it. -- !!! -- !!! 2005-06-09: But if iPre can be defined in terms of sscan, -- !!! and ep + sscan = sscan, then things might work, and -- !!! it might be possible to define dHold simply as hold >>> iPre -- !!! without any performance penalty. -- | Zero-order hold with delay. -- -- Identity: dHold a0 = hold a0 >>> iPre a0). dHold :: a -> SF (Event a) a dHold a0 = hold a0 >>> iPre a0 {- -- THIS IS WRONG! SEE ABOVE. dHold a_init = epPrim f a_init a_init where f a' a = (a, a', a) -} -- | Tracks input signal when available, holds last value when disappears. -- -- !!! DANGER!!! Event used inside arr! Probably OK because arr will not be -- !!! optimized to arrE. But still. Maybe rewrite this using, say, scan? -- !!! or switch? Switching (in hold) for every input sample does not -- !!! seem like such a great idea anyway. trackAndHold :: a -> SF (Maybe a) a trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init ------------------------------------------------------------------------------ -- Accumulators ------------------------------------------------------------------------------ -- | See 'accum'. old_accum :: a -> SF (Event (a -> a)) (Event a) old_accum = accumBy (flip ($)) -- | Given an initial value in an accumulator, -- it returns a signal function that processes -- an event carrying transformation functions. -- Every time an 'Event' is received, the function -- inside it is applied to the accumulator, -- whose new value is outputted in an 'Event'. -- accum :: a -> SF (Event (a -> a)) (Event a) accum a_init = epPrim f a_init NoEvent where f a g = (a', Event a', NoEvent) -- Accumulator, output if Event, output if no event where a' = g a -- | Zero-order hold accumulator (always produces the last outputted value -- until an event arrives). accumHold :: a -> SF (Event (a -> a)) a accumHold a_init = epPrim f a_init a_init where f a g = (a', a', a') -- Accumulator, output if Event, output if no event where a' = g a -- | Zero-order hold accumulator with delayed initialization (always produces -- the last outputted value until an event arrives, but the very initial output -- is always the given accumulator). dAccumHold :: a -> SF (Event (a -> a)) a dAccumHold a_init = accumHold a_init >>> iPre a_init {- -- WRONG! -- epPrim DOES and MUST patternmatch -- on the input at every time step. -- Test case to check for this added! dAccumHold a_init = epPrim f a_init a_init where f a g = (a', a, a') where a' = g a -} -- | See 'accumBy'. old_accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) old_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) -- | Accumulator parameterized by the accumulation function. accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) accumBy g b_init = epPrim f b_init NoEvent where f b a = (b', Event b', NoEvent) where b' = g b a -- | Zero-order hold accumulator parameterized by the accumulation function. accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b accumHoldBy g b_init = epPrim f b_init b_init where f b a = (b', b', b') where b' = g b a -- !!! This cannot be right since epPrim DOES and MUST patternmatch -- !!! on the input at every time step. -- !!! Add a test case to check for this! -- | Zero-order hold accumulator parameterized by the accumulation function -- with delayed initialization (initial output sample is always the -- given accumulator). dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init {- -- WRONG! -- epPrim DOES and MUST patternmatch -- on the input at every time step. -- Test case to check for this added! dAccumHoldBy g b_init = epPrim f b_init b_init where f b a = (b', b, b') where b' = g b a -} {- Untested: accumBy f b = switch (never &&& identity) $ \a -> let b' = f b a in NoEvent >-- Event b' --> accumBy f b' But no real improvement in clarity anyway. -} -- accumBy f b = accumFilter (\b -> a -> let b' = f b a in (b', Event b')) b {- -- 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 = SF' {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 = SF' {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) -} -- | See 'accumFilter'. old_accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) old_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) -- | Accumulator parameterized by the accumulator function with filtering, -- possibly discarding some of the input events based on whether the second -- component of the result of applying the accumulation function is -- 'Nothing' or 'Just' x for some x. accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) accumFilter g c_init = epPrim f c_init NoEvent where f c a = case g c a of (c', Nothing) -> (c', NoEvent, NoEvent) (c', Just b) -> (c', Event b, NoEvent) ------------------------------------------------------------------------------ -- Delays ------------------------------------------------------------------------------ -- | Uninitialized delay operator (old implementation). -- !!! 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? -- old_pre :: SF a a old_pre = SF {sfTF = tf0} where tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.") preAux a_prev = SF' tf -- True where tf _ a = {- a_prev `seq` -} (preAux a, a_prev) -- | Initialized delay operator (old implementation). old_iPre :: a -> SF a a old_iPre = (--> old_pre) -- | Uninitialized delay operator. -- !!! Redefined using SFSScan -- !!! About 20% slower than old_pre on its own. pre :: SF a a pre = sscanPrim f uninit uninit where f c a = Just (a, c) uninit = usrErr "AFRP" "pre" "Uninitialized pre operator." -- | Initialized delay operator. iPre :: a -> SF a a iPre = (--> pre) ------------------------------------------------------------------------------ -- Timed delays ------------------------------------------------------------------------------ -- | Delay a signal by a fixed time 't', using the second parameter -- to fill in the initial 't' seconds. -- Invariants: -- t_diff measure the time since the latest output sample ideally -- should have been output. Whenever that equals or exceeds the -- time delta for the next buffered sample, it is time to output a -- new sample (although not necessarily the one first in the queue: -- it might be necessary to "catch up" by discarding samples. -- 0 <= t_diff < bdt, where bdt is the buffered time delta for the -- sample on the front of the buffer queue. -- -- Sum of time deltas in the queue >= q. -- !!! PROBLEM! -- Since input samples sometimes need to be duplicated, it is not a -- good idea use a delay on things like events since we then could -- end up with duplication of event occurrences. -- (Thus, we actually NEED delayEvent.) delay :: Time -> a -> SF a a delay q a_init | q < 0 = usrErr "AFRP" "delay" "Negative delay." | q == 0 = identity | otherwise = SF {sfTF = tf0} where tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init) delayAux _ [] _ _ = undefined delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf -- True where tf dt a | t_diff' < bdt = (delayAux rbuf' buf t_diff' a_prev, a_prev) | otherwise = nextSmpl rbuf' buf' (t_diff' - bdt) ba where t_diff' = t_diff + dt rbuf' = (dt, a) : rbuf nextSmpl rbuf [] t_diff a = nextSmpl [] (reverse rbuf) t_diff a nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a | t_diff < bdt = (delayAux rbuf buf t_diff a, a) | otherwise = nextSmpl rbuf buf' (t_diff-bdt) ba -- !!! Hmm. Not so easy to do efficiently, it seems ... -- varDelay :: Time -> a -> SF (a, Time) a -- varDelay = undefined ------------------------------------------------------------------------------ -- Variable pause in signal ------------------------------------------------------------------------------ -- | Given a value in an accumulator (b), a predicate signal function (sfC), -- and a second signal function (sf), pause will produce the accumulator b -- if sfC input is True, and will transform the signal using sf otherwise. -- It acts as a pause with an accumulator for the moments when the -- transformation is paused. pause :: b -> SF a Bool -> SF a b -> SF a b pause b_init (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0} where -- Initial transformation (no time delta): -- If the condition is True, return the accumulator b_init) -- Otherwise transform the input normally and recurse. tf0 a0 = case tfP a0 of (c, True) -> (pauseInit b_init tf10 c, b_init) (c, False) -> let (k, b0) = tf10 a0 in (pause' b0 k c, b0) -- Similar deal, but with a time delta pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b pauseInit b_init' tf10' c = SF' tf0' where tf0' dt a = case (sfTF' c) dt a of (c', True) -> (pauseInit b_init' tf10' c', b_init') (c', False) -> let (k, b0) = tf10' a in (pause' b0 k c', b0) -- Very same deal (almost alpha-renameable) pause' :: b -> SF' a b -> SF' a Bool -> SF' a b pause' b_init' tf10' tfP' = SF' tf0' where tf0' dt a = case (sfTF' tfP') dt a of (tfP'', True) -> (pause' b_init' tf10' tfP'', b_init') (tfP'', False) -> let (tf10'', b0') = (sfTF' tf10') dt a in (pause' b0' tf10'' tfP'', b0') -- if_then_else :: SF a Bool -> SF a b -> SF a b -> SF a b -- if_then_else condSF sfThen sfElse = proc (i) -> do -- cond <- condSF -< i -- ok <- sfThen -< i -- notOk <- sfElse -< i -- returnA -< if cond then ok else notOk ------------------------------------------------------------------------------ -- Integration and differentiation ------------------------------------------------------------------------------ -- | Integration using the rectangle rule. {-# INLINE integral #-} integral :: VectorSpace a s => SF a a integral = SF {sfTF = tf0} where igrl0 = zeroVector tf0 a0 = (integralAux igrl0 a0, igrl0) integralAux igrl a_prev = SF' tf -- True 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 :: VectorSpace a s => 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 = (SF' (\ dt a' -> iterAux (f a a' dt b) a') True, b) iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b) -- | A very crude version of a derivative. It simply divides the -- value difference by the time difference. As such, it is very -- crude. Use at your own risk. derivative :: VectorSpace a s => SF a a derivative = SF {sfTF = tf0} where tf0 a0 = (derivativeAux a0, zeroVector) derivativeAux a_prev = SF' tf -- True where tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt) ------------------------------------------------------------------------------ -- Loops with guaranteed well-defined feedback ------------------------------------------------------------------------------ -- | Loop with an initial value for the signal being fed back. loopPre :: c -> SF (a,c) (b,c) -> SF a b loopPre c_init sf = loop (second (iPre c_init) >>> sf) -- | Loop by integrating the second value in the pair and feeding the -- result back. Because the integral at time 0 is zero, this is always -- well defined. loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b loopIntegral sf = loop (second integral >>> sf) ------------------------------------------------------------------------------ -- Noise (i.e. random signal generators) and stochastic processes ------------------------------------------------------------------------------ -- | Noise (random signal) with default range for type in question; -- based on "randoms". noise :: (RandomGen g, Random b) => g -> SF a b noise g0 = streamToSF (randoms g0) -- | Noise (random signal) with specified range; based on "randomRs". noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b noiseR range g0 = streamToSF (randomRs range g0) -- Internal. Not very useful for other purposes since we do not have any -- control over the intervals between each "sample". Or? A version with -- time-stamped samples would be similar to embedSynch (applied to identity). -- The list argument must be a stream (infinite list) at present. streamToSF :: [b] -> SF a b streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!" streamToSF (b:bs) = SF {sfTF = tf0} where tf0 _ = (stsfAux bs, b) stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!" -- Invarying since stsfAux [] is an error. stsfAux (b:bs) = SF' tf -- True where tf _ _ = (stsfAux bs, b) {- New def, untested: streamToSF = sscan2 f where f [] _ = intErr "AFRP" "streamToSF" "Empty list!" f (b:bs) _ = (bs, b) -} -- | Stochastic event source with events occurring on average once every t_avg -- seconds. However, no more than one event results from any one sampling -- interval in the case of relatively sparse sampling, thus avoiding an -- "event backlog" should sampling become more frequent at some later -- point in time. -- !!! Maybe it would better to give a frequency? But like this to make -- !!! consitent with "repeatedly". occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b) occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0} | otherwise = usrErr "AFRP" "occasionally" "Non-positive average interval." where -- Generally, if events occur with an average frequency of f, the -- probability of at least one event occurring in an interval of t -- is given by (1 - exp (-f*t)). The goal in the following is to -- decide whether at least one event occurred in the interval of size -- dt preceding the current sample point. For the first point, -- we can think of the preceding interval as being 0, implying -- no probability of an event occurring. tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent) occAux [] = undefined occAux (r:rs) = SF' tf -- True where tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at least one event. in (occAux rs, if r < p then Event x else NoEvent) ------------------------------------------------------------------------------ -- 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. -- | Convenience function to run a signal function indefinitely, using -- a IO actions to obtain new input and process the output. -- -- This function first runs the initialization action, which provides the -- initial input for the signal transformer at time 0. -- -- Afterwards, an input sensing action is used to obtain new input (if any) and -- the time since the last iteration. The argument to the input sensing function -- indicates if it can block. If no new input is received, it is assumed to be -- the same as in the last iteration. -- -- After applying the signal function to the input, the actuation IO action -- is executed. The first argument indicates if the output has changed, the second -- gives the actual output). Actuation functions may choose to ignore the first -- argument altogether. This action should return True if the reactimation -- must stop, and False if it should continue. -- -- Note that this becomes the program's /main loop/, which makes using this -- function incompatible with GLUT, Gtk and other graphics libraries. It may also -- impose a sizeable constraint in larger projects in which different subparts run -- at different time steps. If you need to control the main -- loop yourself for these or other reasons, use 'reactInit' and 'react'. reactimate :: IO a -- ^ IO initialization action -> (Bool -> IO (DTime, Maybe a)) -- ^ IO input sensing action -> (Bool -> b -> IO Bool) -- ^ IO actuaction (output processing) action -> SF a b -- ^ Signal function -> 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 } -- | A reference to reactimate's state, maintained across samples. type ReactHandle a b = IORef (ReactState a b) -- | Initialize a 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 }) _ <- 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) -- -- Maybe it should be called "subSample", since that's the only thing -- that can be achieved. At least does not have the problem with missing -- events when supersampling. -- -- subSampleSynch :: SF a b -> SF (Event a) (Event b) -- Time progresses at the same rate in the embedded system. -- But it is only sampled on the events. -- E.g. -- repeatedly 0.1 () >>> subSampleSynch sf >>> hold -- -- subSample :: DTime -> SF a b -> SF (Event a) (Event b) -- Time advanced by dt for each event, not synchronized with the outer clock. -- | Given a signal function and a pair with an initial -- input sample for the input signal, and a list of sampling -- times, possibly with new input samples at those times, -- it produces a list of output samples. -- -- This is a simplified, purely-functional version of 'reactimate'. 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 _ _ [] = [] 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. -- What about running an embedded signal function at a fixed (guaranteed) -- sampling frequency? E.g. super sampling if the outer sampling is slower, -- subsampling otherwise. AS WELL as at a given ratio to the outer one. -- -- Ah, but that's more or less what embedSync does. -- So just simplify the interface. But maybe it should also be possible -- to feed in input from the enclosing system. -- !!! 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 _ = (esAux 0 (zip tts bbs), b) esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!" -- Invarying below since esAux [] is an error. esAux tp_prev tbtbs = SF' tf -- True 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 _ tbtbs@[(_, b)] = (b, tbtbs) advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _)) | tp < t' = (b, tbtbtbs) | t' <= tp = advance tp tbtbs advance _ _ = undefined -- | Spaces a list of samples by a fixed time delta, avoiding -- unnecessary samples when the input has not changed since -- the last sample. deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list." deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas -- | 'deltaEncode' parameterized by the equality test. 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 _ [] = [] debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as | otherwise = Just a : debAux a as -- Embedding and missing events. -- Suppose a subsystem is super sampled. Then some of the output -- samples will have to be dropped. If we are unlycky, the dropped -- samples could be occurring events that we'd rather not miss. -- This is a real problem. -- Similarly, when feeding input into a super-sampled system, -- we may need to extrapolate the input, assuming that it is -- constant. But if (part of) the input is an occurring event, we'd -- rather not duplicate that!!! -- This suggests that: -- * output samples should be merged through a user-supplied merge -- function. -- * input samples should be extrapolated if necessary through a -- user-supplied extrapolation function. -- -- Possible signature: -- -- resample :: Time -> (c -> [a]) -> SF a b -> ([b] -> d) -> SF c d -- -- But what do we do if the inner system runs more slowly than the -- outer one? Then we need to extrapolate the output from the -- inner system, and we have the same problem with events AGAIN! -- Vim modeline -- vim:set tabstop=8 expandtab: