packages feed

Yampa 0.9.6 → 0.9.6.1

raw patch · 16 files changed

+3625/−3604 lines, 16 filesdep ~basePVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

+ FRP.Yampa.Task: instance Applicative (Task a b)
+ FRP.Yampa.Task: instance Functor (Task a b)

Files

CHANGELOG view
@@ -1,6 +1,15 @@+2015-03-30 Ivan Perez <ivan.perez@keera.co.uk>+        * src/FRP/Yampa/Task.hs: Adds Functor and Applicative instances,+          for compatibility with base >= 4.8 (issue #7, pull request by+          Ryan Scott).+        * Yampa.cabal: version bump (0.9.6.1).++2015-03-04 Ivan Perez <ivan.perez@keera.co.uk>+        * src/: Coding style improvements.+ 2014-08-29 Ivan Perez <ivan.perez@keera.co.uk> -        * Yampa.cabal: version bump (0.9.6)+        * Yampa.cabal: version bump (0.9.6).         * src/: Adds a substantial amount of documentation.         * src/FRP/Yampa.hs: Adds a new pause combinator. @@ -10,14 +19,14 @@  2014-04-26 Ivan Perez <ivan.perez@keera.es> -        * Yampa.cabal: version bump (0.9.5)-        * Adds CHANGELOG to cabal file+        * Yampa.cabal: version bump (0.9.5).+        * Adds CHANGELOG to cabal file.  2014-04-07 Ivan Perez <ivan.perez@keera.es>          * Yampa.cabal: new maintainer, version bump (0.9.4).-        * src/: documentation is exposed so that Haddock can process it-        * No interface changes+        * src/: documentation is exposed so that Haddock can process it.+        * No interface changes.  Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. All rights reserved.
Yampa.cabal view
@@ -1,5 +1,5 @@ name: Yampa-version: 0.9.6+version: 0.9.6.1 cabal-version: >= 1.6 license: BSD3 license-file: LICENSE
src/FRP/Yampa.hs view
@@ -148,3458 +148,3458 @@     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+    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.Arrow+#if __GLASGOW_HASKELL__ >= 610+import qualified Control.Category (Category(..))+#else+#endif+import Control.Monad (unless)+import Data.IORef+import Data.Maybe (fromMaybe)+import System.Random (RandomGen(..), Random(..))+++import FRP.Yampa.Diagnostics+import FRP.Yampa.Miscellany (( # ), dup, swap)+import FRP.Yampa.Event+import FRP.Yampa.VectorSpace++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' = fromMaybe a 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.
src/FRP/Yampa/Event.hs view
@@ -249,8 +249,8 @@ -- merging the results. The first three arguments are mapping functions, -- the third of which will only be used when both events are present. -- Therefore, 'mergeBy' = 'mapMerge' 'id' 'id'-mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c) -	    -> Event a -> Event b -> Event c+mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)+            -> Event a -> Event b -> Event c mapMerge _  _  _   NoEvent   NoEvent   = NoEvent mapMerge lf _  _   (Event l) NoEvent   = Event (lf l) mapMerge _  rf _   NoEvent   (Event r) = Event (rf r)@@ -263,8 +263,8 @@ -- | Collect simultaneous event occurrences; no event if none. catEvents :: [Event a] -> Event [a] catEvents eas = case [ a | Event a <- eas ] of-		    [] -> NoEvent-		    as -> Event as+                    [] -> NoEvent+                    as -> Event as  -- | Join (conjunction) of two events. Only produces an event -- if both events exist.@@ -295,8 +295,8 @@ mapFilterE :: (a -> Maybe b) -> Event a -> Event b mapFilterE _ NoEvent   = NoEvent mapFilterE f (Event a) = case f a of-			    Nothing -> NoEvent-			    Just b  -> Event b+                            Nothing -> NoEvent+                            Just b  -> Event b   -- | Enable/disable event occurences based on an external condition.
src/FRP/Yampa/MergeableRecord.hs view
@@ -53,7 +53,7 @@  module FRP.Yampa.MergeableRecord (     MergeableRecord(..),-    MR,			-- Abstract+    MR,                 -- Abstract     mrMake,     (~+~),     mrMerge,
src/FRP/Yampa/Miscellany.hs view
@@ -20,15 +20,15 @@  module FRP.Yampa.Miscellany ( -- Reverse function composition-    ( # ),	-- :: (a -> b) -> (b -> c) -> (a -> c),	infixl 9+    ( # ),      -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9  -- Arrow plumbing aids-    dup,	-- :: a -> (a,a)-    swap,	-- :: (a,b) -> (b,a)+    dup,        -- :: a -> (a,a)+    swap,       -- :: (a,b) -> (b,a)  -- Maps over lists of pairs-    mapFst,	-- :: (a -> b) -> [(a,c)] -> [(b,c)]-    mapSnd,	-- :: (a -> b) -> [(c,a)] -> [(c,b)]+    mapFst,     -- :: (a -> b) -> [(a,c)] -> [(b,c)]+    mapSnd,     -- :: (a -> b) -> [(c,a)] -> [(c,b)]  -- Generalized tuple selectors     sel3_1, sel3_2, sel3_3,@@ -36,9 +36,9 @@     sel5_1, sel5_2, sel5_3, sel5_4, sel5_5,  -- Floating point utilities-    fDiv,	-- :: (RealFrac a, Integral b) => a -> a -> b-    fMod,	-- :: RealFrac a => a -> a -> a-    fDivMod	-- :: (RealFrac a, Integral b) => a -> a -> (b, a)+    fDiv,       -- :: (RealFrac a, Integral b) => a -> a -> b+    fMod,       -- :: RealFrac a => a -> a -> a+    fDivMod     -- :: (RealFrac a, Integral b) => a -> a -> (b, a) ) where  infixl 9 #@@ -73,12 +73,10 @@ ------------------------------------------------------------------------------  mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]-mapFst _ []             = []-mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys+mapFst f = map (\(x,y) -> (f x, y))  mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]-mapSnd _ []             = []-mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys+mapSnd f = map (\(x,y) -> (x, f y))   ------------------------------------------------------------------------------
src/FRP/Yampa/Point2.hs view
@@ -19,9 +19,9 @@     -- module AFRPVectorSpace,     -- module AFRPAffineSpace,     -- module AFRPVector2,-    Point2(..),	-- Non-abstract, instance of AffineSpace-    point2X,	-- :: RealFloat a => Point2 a -> a-    point2Y	-- :: RealFloat a => Point2 a -> a+    Point2(..), -- Non-abstract, instance of AffineSpace+    point2X,    -- :: RealFloat a => Point2 a -> a+    point2Y     -- :: RealFloat a => Point2 a -> a ) where  import FRP.Yampa.VectorSpace ()
src/FRP/Yampa/Point3.hs view
@@ -17,10 +17,10 @@     -- module AFRPVectorSpace,     -- module AFRPAffineSpace,     -- module AFRPVector3,-    Point3(..),	-- Non-abstract, instance of AffineSpace-    point3X,	-- :: RealFloat a => Point3 a -> a-    point3Y,	-- :: RealFloat a => Point3 a -> a-    point3Z	-- :: RealFloat a => Point3 a -> a+    Point3(..), -- Non-abstract, instance of AffineSpace+    point3X,    -- :: RealFloat a => Point3 a -> a+    point3Y,    -- :: RealFloat a => Point3 a -> a+    point3Z     -- :: RealFloat a => Point3 a -> a ) where  import FRP.Yampa.VectorSpace ()@@ -52,13 +52,13 @@     origin = Point3 0 0 0      (Point3 x y z) .+^ v =-	Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)+        Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)      (Point3 x y z) .-^ v =-	Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)+        Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)      (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) =-	vector3 (x1 - x2) (y1 - y2) (z1 - z2)+        vector3 (x1 - x2) (y1 - y2) (z1 - z2)   ------------------------------------------------------------------------------
src/FRP/Yampa/Task.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP, Rank2Types #-} ----------------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Task@@ -15,21 +15,26 @@  module FRP.Yampa.Task (     Task,-    mkTask,	-- :: SF a (b, Event c) -> Task a b c-    runTask,	-- :: Task a b c -> SF a (Either b c)	-- Might change.-    runTask_,	-- :: Task a b c -> SF a b-    taskToSF,	-- :: Task a b c -> SF a (b, Event c)	-- Might change.-    constT,	-- :: b -> Task a b c-    sleepT, 	-- :: Time -> b -> Task a b ()-    snapT, 	-- :: Task a b a-    timeOut, 	-- :: Task a b c -> Time -> Task a b (Maybe c)-    abortWhen, 	-- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+    mkTask,     -- :: SF a (b, Event c) -> Task a b c+    runTask,    -- :: Task a b c -> SF a (Either b c)	-- Might change.+    runTask_,   -- :: Task a b c -> SF a b+    taskToSF,   -- :: Task a b c -> SF a (b, Event c)	-- Might change.+    constT,     -- :: b -> Task a b c+    sleepT,     -- :: Time -> b -> Task a b ()+    snapT,      -- :: Task a b a+    timeOut,    -- :: Task a b c -> Time -> Task a b (Maybe c)+    abortWhen,  -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)     repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a-    for, 	-- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()-    forAll, 	-- :: Monad m => [a] -> (a -> m b) -> m ()-    forEver 	-- :: Monad m => m a -> m b+    for,        -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+    forAll,     -- :: Monad m => [a] -> (a -> m b) -> m ()+    forEver     -- :: Monad m => m a -> m b ) where +import Control.Monad (when, forM_)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..))+#endif+ import FRP.Yampa import FRP.Yampa.Utilities (snap) import FRP.Yampa.Diagnostics@@ -62,7 +67,7 @@ -- running. Once the task has terminated, the output goes constant with -- the value Right x, where x is the value of the terminating event. runTask :: Task a b c -> SF a (Either b c)-runTask tk = (unTask tk) (\c -> constant (Right c))+runTask tk = (unTask tk) (constant . Right)   -- Runs a task. The output becomes undefined once the underlying task has@@ -78,20 +83,27 @@ -- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.) taskToSF :: Task a b c -> SF a (b, Event c) taskToSF tk = runTask tk-	      >>> (arr (either id ((usrErr "AFRPTask" "runTask_"-                                           "Task terminated!")))-		   &&& edgeBy isEdge (Left undefined))+              >>> (arr (either id (usrErr "AFRPTask" "runTask_"+                                          "Task terminated!"))+                   &&& edgeBy isEdge (Left undefined))     where         isEdge (Left _)  (Left _)  = Nothing-	isEdge (Left _)  (Right c) = Just c-	isEdge (Right _) (Right _) = Nothing-	isEdge (Right _) (Left _)  = Nothing+        isEdge (Left _)  (Right c) = Just c+        isEdge (Right _) (Right _) = Nothing+        isEdge (Right _) (Left _)  = Nothing   --------------------------------------------------------------------------------- Monad instance+-- Functor, Applicative, and Monad instances ------------------------------------------------------------------------------ +instance Functor (Task a b) where+    fmap f tk = Task (\k -> unTask tk (k . f))++instance Applicative (Task a b) where+    pure x  = Task (\k -> k x)+    f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c)))+ instance Monad (Task a b) where     tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))     return x = Task (\k -> k x)@@ -162,7 +174,7 @@ tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)     where         aux ((b, ec), et) = (b, (lMerge (fmap Just ec)-					(fmap (const Nothing) et)))+                                (fmap (const Nothing) et)))   -- Run a "guarding" event source (SF a (Event b)) in parallel with a@@ -193,12 +205,12 @@ -- C-style for-loop. -- Example: for 0 (+1) (>=10) ... for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()-for i f p m = if p i then m >> for (f i) f p m else return ()+for i f p m = when (p i) $ m >> for (f i) f p m   -- Perform the monadic operation for each element in the list. forAll :: Monad m => [a] -> (a -> m b) -> m ()-forAll = flip mapM_+forAll = forM_   -- Repeat m for ever.
src/FRP/Yampa/Utilities.hs view
@@ -37,60 +37,60 @@ module FRP.Yampa.Utilities ( -- Now defined in Control.Arrow -- General arrow utilities-    (^>>),		-- :: Arrow a => (b -> c) -> a c d -> a b d-    (>>^),		-- :: Arrow a => a b c -> (c -> d) -> a b d-    (^<<),		-- :: Arrow a => (c -> d) -> a b c -> a b d -    (<<^),		-- :: Arrow a => a c d -> (b -> c) -> a b d+    (^>>),              -- :: Arrow a => (b -> c) -> a c d -> a b d+    (>>^),              -- :: Arrow a => a b c -> (c -> d) -> a b d+    (^<<),              -- :: Arrow a => (c -> d) -> a b c -> a b d +    (<<^),              -- :: Arrow a => a c d -> (b -> c) -> a b d  -- Liftings-    arr2,		-- :: Arrow a => (b->c->d) -> a (b,c) d-    arr3,		-- :: Arrow a => (b->c->d->e) -> a (b,c,d) e-    arr4,		-- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f-    arr5,		-- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g-    lift0,		-- :: Arrow a => c -> a b c-    lift1,		-- :: Arrow a => (c->d) -> (a b c->a b d)-    lift2,		-- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)-    lift3,		-- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)-    lift4,		-- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)-    lift5,		-- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)+    arr2,               -- :: Arrow a => (b->c->d) -> a (b,c) d+    arr3,               -- :: Arrow a => (b->c->d->e) -> a (b,c,d) e+    arr4,               -- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f+    arr5,               -- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g+    lift0,              -- :: Arrow a => c -> a b c+    lift1,              -- :: Arrow a => (c->d) -> (a b c->a b d)+    lift2,              -- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)+    lift3,              -- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)+    lift4,              -- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)+    lift5,              -- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)  -- Event sources-    snap,		-- :: SF a (Event a)-    snapAfter,		-- :: Time -> SF a (Event a)-    sample,		-- :: Time -> SF a (Event a)-    recur,		-- :: SF a (Event b) -> SF a (Event b)+    snap,               -- :: SF a (Event a)+    snapAfter,          -- :: Time -> SF a (Event a)+    sample,             -- :: Time -> SF a (Event a)+    recur,              -- :: SF a (Event b) -> SF a (Event b)     andThen,            -- :: SF a (Event b)->SF a (Event b)->SF a (Event b)-    sampleWindow,	-- :: Int -> Time -> SF a (Event [a])+    sampleWindow,       -- :: Int -> Time -> SF a (Event [a])  -- Parallel composition/switchers with "zip" routing-    parZ,		-- [SF a b] -> SF [a] [b]-    pSwitchZ,		-- [SF a b] -> SF ([a],[b]) (Event c)-			-- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]-    dpSwitchZ,		-- [SF a b] -> SF ([a],[b]) (Event c)-			-- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]-    rpSwitchZ,		-- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]-    drpSwitchZ,		-- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]+    parZ,               -- [SF a b] -> SF [a] [b]+    pSwitchZ,           -- [SF a b] -> SF ([a],[b]) (Event c)+                        -- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]+    dpSwitchZ,          -- [SF a b] -> SF ([a],[b]) (Event c)+                        -- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]+    rpSwitchZ,          -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]+    drpSwitchZ,         -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]  -- Guards and automata-oriented combinators-    provided,		-- :: (a -> Bool) -> SF a b -> SF a b -> SF a b+    provided,           -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b  -- Wave-form generation-    old_dHold,		-- :: a -> SF (Event a) a-    dTrackAndHold,	-- :: a -> SF (Maybe a) a+    old_dHold,          -- :: a -> SF (Event a) a+    dTrackAndHold,      -- :: a -> SF (Maybe a) a  -- Accumulators-    old_accumHold,	-- :: a -> SF (Event (a -> a)) a-    old_dAccumHold,	-- :: a -> SF (Event (a -> a)) a-    old_accumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b-    old_dAccumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b-    count,		-- :: Integral b => SF (Event a) (Event b)+    old_accumHold,      -- :: a -> SF (Event (a -> a)) a+    old_dAccumHold,     -- :: a -> SF (Event (a -> a)) a+    old_accumHoldBy,    -- :: (b -> a -> b) -> b -> SF (Event a) b+    old_dAccumHoldBy,   -- :: (b -> a -> b) -> b -> SF (Event a) b+    count,              -- :: Integral b => SF (Event a) (Event b)  -- Delays-    fby,		-- :: b -> SF a b -> SF a b,	infixr 0+    fby,                -- :: b -> SF a b -> SF a b,	infixr 0  -- Integrals-    impulseIntegral,	-- :: VectorSpace a k => SF (a, Event a) a-    old_impulseIntegral	-- :: VectorSpace a k => SF (a, Event a) a+    impulseIntegral,    -- :: VectorSpace a k => SF (a, Event a) a+    old_impulseIntegral -- :: VectorSpace a k => SF (a, Event a) a ) where  import FRP.Yampa.Diagnostics@@ -186,9 +186,9 @@ -- that time. snapAfter :: Time -> SF a (Event a) snapAfter t_ev = switch (never-			 &&& (identity-			      &&& after t_ev () >>^ \(a, e) -> e `tag` a))-			now+                         &&& (identity+                              &&& after t_ev () >>^ \(a, e) -> e `tag` a))+                        now   -- Sample a signal at regular intervals.@@ -234,7 +234,7 @@     where         updateWindow w as = drop (max (length w' - wl) 0) w'             where-	        w' = w ++ as+                w' = w ++ as   ------------------------------------------------------------------------------@@ -244,16 +244,16 @@ safeZip :: String -> [a] -> [b] -> [(a,b)] safeZip fn as bs = safeZip' as bs     where-	safeZip' _  []     = []-	safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs+        safeZip' _  []     = []+        safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs -	head' []    = err-	head' (a:_) = a+        head' []    = err+        head' (a:_) = a -	tail' []     = err-	tail' (_:as) = as+        tail' []     = err+        tail' (_:as) = as -	err = usrErr "AFRPUtilities" fn "Input list too short."+        err = usrErr "AFRPUtilities" fn "Input list too short."   parZ :: [SF a b] -> SF [a] [b]@@ -288,7 +288,7 @@     switch (constant undefined &&& snap) $ \a0 ->     if p a0 then stt else stf     where-	stt = switch (sft &&& (not . p ^>> edge)) (const stf)+        stt = switch (sft &&& (not . p ^>> edge)) (const stf)         stf = switch (sff &&& (p ^>> edge)) (const stt)  @@ -301,7 +301,7 @@ old_dHold :: a -> SF (Event a) a old_dHold a0 = dSwitch (constant a0 &&& identity) dHold'     where-	dHold' a = dSwitch (constant a &&& notYet) dHold'+        dHold' a = dSwitch (constant a &&& notYet) dHold'   dTrackAndHold :: a -> SF (Maybe a) a
src/FRP/Yampa/Vector2.hs view
@@ -16,16 +16,16 @@  module FRP.Yampa.Vector2 (     -- module AFRPVectorSpace,-    Vector2,		-- Abstract, instance of VectorSpace-    vector2,		-- :: RealFloat a => a -> a -> Vector2 a-    vector2X,		-- :: RealFloat a => Vector2 a -> a-    vector2Y,		-- :: RealFloat a => Vector2 a -> a-    vector2XY,		-- :: RealFloat a => Vector2 a -> (a, a)-    vector2Polar,	-- :: RealFloat a => a -> a -> Vector2 a-    vector2Rho,		-- :: RealFloat a => Vector2 a -> a-    vector2Theta,	-- :: RealFloat a => Vector2 a -> a-    vector2RhoTheta,	-- :: RealFloat a => Vector2 a -> (a, a)-    vector2Rotate 	-- :: RealFloat a => a -> Vector2 a -> Vector2 a+    Vector2,            -- Abstract, instance of VectorSpace+    vector2,            -- :: RealFloat a => a -> a -> Vector2 a+    vector2X,           -- :: RealFloat a => Vector2 a -> a+    vector2Y,           -- :: RealFloat a => Vector2 a -> a+    vector2XY,          -- :: RealFloat a => Vector2 a -> (a, a)+    vector2Polar,       -- :: RealFloat a => a -> a -> Vector2 a+    vector2Rho,         -- :: RealFloat a => Vector2 a -> a+    vector2Theta,       -- :: RealFloat a => Vector2 a -> a+    vector2RhoTheta,    -- :: RealFloat a => Vector2 a -> (a, a)+    vector2Rotate       -- :: RealFloat a => a -> Vector2 a -> Vector2 a ) where  import FRP.Yampa.VectorSpace
src/FRP/Yampa/Vector3.hs view
@@ -16,18 +16,18 @@  module FRP.Yampa.Vector3 (     -- module AFRPVectorSpace,-    Vector3,		-- Abstract, instance of VectorSpace-    vector3,		-- :: RealFloat a => a -> a -> a -> Vector3 a-    vector3X,		-- :: RealFloat a => Vector3 a -> a-    vector3Y,		-- :: RealFloat a => Vector3 a -> a-    vector3Z,		-- :: RealFloat a => Vector3 a -> a-    vector3XYZ,		-- :: RealFloat a => Vector3 a -> (a, a, a)-    vector3Spherical,	-- :: RealFloat a => a -> a -> a -> Vector3 a-    vector3Rho,		-- :: RealFloat a => Vector3 a -> a-    vector3Theta,	-- :: RealFloat a => Vector3 a -> a-    vector3Phi,		-- :: RealFloat a => Vector3 a -> a-    vector3RhoThetaPhi,	-- :: RealFloat a => Vector3 a -> (a, a, a)-    vector3Rotate 	-- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+    Vector3,            -- Abstract, instance of VectorSpace+    vector3,            -- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3X,           -- :: RealFloat a => Vector3 a -> a+    vector3Y,           -- :: RealFloat a => Vector3 a -> a+    vector3Z,           -- :: RealFloat a => Vector3 a -> a+    vector3XYZ,         -- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Spherical,   -- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3Rho,         -- :: RealFloat a => Vector3 a -> a+    vector3Theta,       -- :: RealFloat a => Vector3 a -> a+    vector3Phi,         -- :: RealFloat a => Vector3 a -> a+    vector3RhoThetaPhi, -- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Rotate       -- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a ) where  import FRP.Yampa.VectorSpace@@ -63,7 +63,7 @@ vector3Spherical rho theta phi =     Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)     where-	rhoSinPhi = rho * sin phi+        rhoSinPhi = rho * sin phi  vector3Rho :: RealFloat a => Vector3 a -> a vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)@@ -79,7 +79,7 @@     where         rho   = sqrt (x * x + y * y + z * z)         theta = atan2 y x-	phi   = acos (z / rho)+        phi   = acos (z / rho)   ------------------------------------------------------------------------------@@ -109,8 +109,8 @@ vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a vector3Rotate theta' phi' v =     vector3Spherical (vector3Rho v)-		     (vector3Theta v + theta')-		     (vector3Phi v + phi')+                     (vector3Theta v + theta')+                     (vector3Phi v + phi')   ------------------------------------------------------------------------------
src/FRP/Yampa/VectorSpace.hs view
@@ -37,8 +37,8 @@     (^+^)        :: v -> v -> v     (^-^)        :: v -> v -> v     dot          :: v -> v -> a-    norm	 :: v -> a-    normalize	 :: v -> v+    norm         :: v -> a+    normalize    :: v -> v      v ^/ a = (1/a) *^ v @@ -50,7 +50,7 @@      normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"         where-	    nv = norm v+            nv = norm v  ------------------------------------------------------------------------------ -- Vector space instances for Float and Double
tests/AFRPTestsCommon.hs view
@@ -17,7 +17,6 @@ import Data.IORef (newIORef, writeIORef, readIORef)  import FRP.Yampa-import FRP.Yampa.Internals (Event(NoEvent, Event))  ------------------------------------------------------------------------------ -- Rough equality with instances@@ -70,6 +69,7 @@ 				           && x2 ~= y2 				           && x3 ~= y3 				           && x4 ~= y4+				           && x5 ~= y5  instance REq a => REq (Maybe a) where     Nothing ~= Nothing   = True@@ -105,7 +105,7 @@     where 	-- The initial 0.0 is just for result compatibility with an older 	-- version.-	input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] ]+	input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] :: [Int] ] 	freq = 5  @@ -148,18 +148,20 @@ 	    return (0.25, Just input') 	actuate _ output = do 	    writeIORef outputr output-	    input <- readIORef inputr-	    count <- readIORef countr+	    _input <- readIORef inputr+	    count  <- readIORef countr 	    return (count >= n)     reactimate init sense actuate sf-    output <- readIORef outputr-    return output +    -- return output+    readIORef outputr  ------------------------------------------------------------------------------ -- Some utilities used for testing laws ------------------------------------------------------------------------------ -fun_prod f g = \(x,y) -> (f x, g y)+assoc :: ((a,b),c) -> (a,(b,c)) assoc ((a,b),c) = (a,(b,c))-assoc_inv (a,(b,c)) = ((a,b),c)++assocInv :: (a,(b,c)) -> ((a,b),c)+assocInv (a,(b,c)) = ((a,b),c)
tests/AFRPTestsLaws.hs view
@@ -49,7 +49,7 @@ laws_t4_lhs :: [(Double, Double)] laws_t4_lhs = testSF1 (arr dup >>> first (arr (*2.5))) laws_t4_rhs :: [(Double, Double)]-laws_t4_rhs = testSF1 (arr dup >>> arr (fun_prod (*2.5) id))+laws_t4_rhs = testSF1 (arr dup >>> arr ((*2.5) *** id))  laws_t5_lhs :: [(Double, Double)] laws_t5_lhs = testSF1 (arr dup >>> (first (integral >>> arr (+3.0))))@@ -57,9 +57,9 @@ laws_t5_rhs = testSF1 (arr dup >>> (first integral >>> first (arr (+3.0))))  laws_t6_lhs :: [(Double, Double)]-laws_t6_lhs = testSF1 (arr dup >>> (first integral>>>arr (fun_prod id (+3.0))))+laws_t6_lhs = testSF1 (arr dup >>> (first integral >>> arr (id *** (+3.0)))) laws_t6_rhs :: [(Double, Double)]-laws_t6_rhs = testSF1 (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral))+laws_t6_rhs = testSF1 (arr dup >>> (arr (id *** (+3.0)) >>> first integral))  laws_t7_lhs :: [Double] laws_t7_lhs = testSF1 (arr dup >>> (first integral >>> arr fst))
tests/AFRPTestsLoopLaws.hs view
@@ -56,7 +56,7 @@ -- Used to work with only signature t2_f :: Fractional a -> SF a a looplaws_t2_f :: SF (Double, Double) (Double, Double) looplaws_t2_f = integral-looplaws_t2_k = fun_prod id (+42.0)+looplaws_t2_k = id *** (+42.0) looplaws_t2_lhs :: [Double] looplaws_t2_lhs = testSF1 (loop (looplaws_t2_f >>> arr looplaws_t2_k)) looplaws_t2_rhs :: [Double]@@ -74,7 +74,7 @@ looplaws_t3_lhs :: [Double] looplaws_t3_lhs = testSF1 (loop (loop looplaws_t3_f)) looplaws_t3_rhs :: [Double]-looplaws_t3_rhs = testSF1 (loop (arr assoc_inv >>> looplaws_t3_f >>>arr assoc))+looplaws_t3_rhs = testSF1 (loop (arr assocInv >>> looplaws_t3_f >>> arr assoc))   -- Superposing@@ -84,7 +84,7 @@ looplaws_t4_rhs :: [(Double, Double)] looplaws_t4_rhs = testSF1 (arr dup >>> (loop (arr assoc 				        >>> second looplaws_t4_f-				        >>> arr assoc_inv)))+				        >>> arr assocInv)))   -- Extension