# LANGUAGE GADTs , Rank2Types ,  #
-- |
  Module       :   FRP.Animas
  Copyright    :   ( c )   and   , Yale University , 2003 .
                 Modifications by   and  
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  
-- Stability   :  provisional
  Portability :   non - portable ( GHC extensions )

module FRP.Animas (
    -- * Re-exported modules 
    module Control.Arrow,
    module FRP.Animas.VectorSpace,
    -- * Random-number classes  
    RandomGen(..),
    Random(..),
    -- * Convenience operators
    ( # ),
    dup,
    swap,
  * 
    Time,
    DTime,
    SF,	
    Event(..),
    -- * Pure signal functions
    arrPrim, arrEPrim,
    identity,
    constant,
    -- * Time signal functions
    localTime,
    time,
    -- * Initialization
    -- | These operators provide means of specifying the initial
    -- input or output of a signal function, overriding the signal function for
  the first cycle of animation
    (-->),
    (>--),
    (-=>),
    (>=-),
    initially,
    -- * Accumulator-based signal functions
    sscan,
    sscanPrim,
    -- * Events
    -- ** Basic event producers 
    never,
    now,
    after,
    repeatedly,
    afterEach,
    afterEachCat,
    edge,
    iEdge,
    edgeTag,
    edgeJust,
    edgeBy,
    once,
    noEvent,
    noEventFst,
    noEventSnd,
    -- ** Event manipulation
    delayEvent,
    delayEventCat,
    takeEvents,
    dropEvents,
    notYet,
    -- ** Stateful event processing
    old_hold,
    hold,
    dHold,
    trackAndHold,
    old_accum,
    old_accumBy,
    old_accumFilter,
    accum,
    accumHold,
    dAccumHold,
    accumBy,
    accumHoldBy,
    dAccumHoldBy,
    accumFilter,
    -- * Unlifted event functions
    event,
    fromEvent,
    isEvent,
    isNoEvent,
    tag,
    tagWith,
    attach,
    lMerge,
    rMerge,
    merge,
    mergeBy,
    mapMerge,
    mergeEvents,
    catEvents,
    joinE,
    splitE,
    filterE,
    mapFilterE,
    gate,
    -- * Switches
    -- | Switches provide run-time modification of the signal network. 
  Most switching combinators provided two varieties : an
  \"instantaneous\ " version and a \"decoupled version\ " . The difference
    -- lies in which signal function is used to produce the value at the instant
    -- of switching. For an instantaneous switch, the signal function being 
    -- switched in is used to produce the value. For a decoupled switch, that
    -- signal function is used to produce the value at the /next/ instant,
    -- while the signal function being switched out is still used to produce
    -- the value at the instant of switching. This is useful for (among other
    -- things) ensuring that looped signal functions are well-founded
    -- recursively. Decoupled varieties of switches are prefixed with a \"d\".
    
    -- ** Event-based switches
    switch,  dSwitch,	    
    rSwitch, drSwitch,	
    kSwitch, dkSwitch,
    -- ** Parallel switches (collections of signal functions)
    parB,		
    pSwitchB,dpSwitchB, 
    rpSwitchB,drpSwitchB,
    par,
    pSwitch, dpSwitch,
    rpSwitch,drpSwitch, 
    -- * Delays
    old_pre, old_iPre,
    pre,
    iPre,
    delay,
    -- * Calculus
    integral,
    derivative,
    imIntegral,
    -- * Looping
  | See also the ' loop ' combinator from the '  ' class .
    loopPre,
    loopIntegral,
    -- * Randomized signal functions
    noise,
    noiseR,
    occasionally,
    -- * Animation
    ReactHandle,
    reactimate,
    reactInit,
    react,
    embed,
    embedSynch,
    deltaEncode,
    deltaEncodeBy,
    Step,
    initStep,
    step
) 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.Animas.Diagnostics
import FRP.Animas.Miscellany (( # ), dup, swap)
import FRP.Animas.Event
import FRP.Animas.VectorSpace

import Data.IORef

infixr 0 -->, >--, -=>, >=-

  Time / DTime should be parameterized with a  class restriction
-- | Time representation for signal functions
type Time = Double

type DTime = Double

-- | A signal function
data SF a b = SF {sfTF :: a -> Transition a b}

data SF' a b where
    SFArr   :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b
    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
    SF' :: !(DTime -> a -> Transition a b) -> SF' a b
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

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

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')

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 :: (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)

data FunDesc a b where
    FDI :: FunDesc a a
    FDC :: b -> FunDesc a b
    FDE :: (Event a -> b) -> b -> FunDesc (Event a) b
    FDG :: (a -> b) -> FunDesc a b

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

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))

vfyNoEv :: Event a -> b -> b
vfyNoEv NoEvent b = b
vfyNoEv _       _  = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."

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

#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

  | Lifts a function to a pure signal function . Use ' arr ' from the ' Arrow '
--   class, rather than this function.
# NOINLINE arrPrim #
arrPrim :: (a -> b) -> SF a b
arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}


{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-}
-- | Lifts a function with an event input to a pure signal function
-- on events. Use 'arr' from the 'Arrow' class, rather than this function.
arrEPrim :: (Event a -> b) -> SF (Event a) b
arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}

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

cpXX :: SF' a b -> SF' b c -> SF' a c
cpXX (SFArr _ fd1)       sf2               = cpAX fd1 sf2
cpXX sf1                 (SFArr _ fd2)     = cpXA sf1 fd2
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)
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')
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."
cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =
    cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)
cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) =
    cpXX (cpXG sf1 f21) (cpXA sf22 fd23)
cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) =
    cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) 
cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
    cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23
cpXX sf1 sf2 = SF' tf    
  where
        tf dt a = (cpXX sf1' sf2', c)
	    where
	        (sf1', b) = (sfTF' sf1) dt a
		(sf2', c) = (sfTF' sf2) dt b

cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d
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
        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
	    where
		tf dt a = (cpAXAAux 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

cpCX :: b -> SF' b c -> SF' a c
cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)
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
    where
	tf dt _ = (cpCX 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
        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
	    where
		tf dt _ = (cpCXAAux 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)
        cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
	cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =
	    cpAXA (fdComp fd1 fd21) sf22 fd23
	cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI
	    where
		tf dt a = (cpGXAux 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
	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
	    where
		tf dt a = (cpXGAux 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
	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
	cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf 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)

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
	    where
		tf dt a = (cpXEAux fd2 f2 f2ne sf1',
                           case eb of NoEvent -> f2ne; _ -> f2 eb)
		    where
                        (sf1', eb) = (sfTF' sf1) dt a

firstPrim :: SF a b -> SF (a,c) (b,c)
firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
	    where
		(sf1, b0) = tf10 a0 

fpAux :: SF' a b -> SF' (a,c) (b,c)
fpAux (SFArr _ FDI)       = sfId
fpAux (SFArr _ (FDC b))   = sfArrG (\(~(_, c)) -> (b, c))
fpAux (SFArr _ fd1)       = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))
fpAux sf1 = SF' tf
    where
        tf dt ~(a, c) = (fpAux sf1', (b, c))
	    where
		(sf1', b) = (sfTF' sf1) dt a 

secondPrim :: SF a b -> SF (c,a) (c,b)
secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
	    where
		(sf1, b0) = tf10 a0 

spAux :: SF' a b -> SF' (c,a) (c,b)
spAux (SFArr _ FDI)       = sfId
spAux (SFArr _ (FDC b))   = sfArrG (\(~(c, _)) -> (c, b))
spAux (SFArr _ fd1)       = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))
spAux sf1 = SF' tf
    where
        tf dt ~(c, a) = (spAux sf1', (c, b))
	    where
		(sf1', b) = (sfTF' sf1) dt a 

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 

        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
	psXX (SFArr _ (FDC b))   sf2                 = psCX b sf2
	psXX (SFArr _ fd1)       sf2                 = psAX (fdFun fd1) sf2
        psXX sf1                 (SFArr _ FDI)       = fpAux sf1
	psXX sf1                 (SFArr _ (FDC d))   = psXC sf1 d
	psXX sf1                 (SFArr _ fd2)       = psXA sf1 (fdFun fd2)
	psXX sf1 sf2 = SF' tf
	    where
		tf dt ~(a, c) = (psXX 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
	    where
		tf dt ~(_, c) = (psCX 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
	    where
		tf dt ~(a, _) = (psXC 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
	    where
		tf dt ~(a, c) = (psAX 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
	    where
		tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))
		    where
			(sf1', b) = (sfTF' sf1) dt a

parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
	tf0 a0 = (pfoXX sf1 sf2, (b0, c0))
	    where
		(sf1, b0) = tf10 a0 
		(sf2, c0) = tf20 a0 
        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)
	pfoXX sf1 sf2 = SF' tf
	    where
		tf dt a = (pfoXX 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
	    where
		tf dt a = (pfoIX 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
	    where
		tf dt a = (pfoXI 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
	    where
		tf dt a = (pfoCX 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
	    where
		tf dt a = (pfoXC 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
	    where
		tf dt a = (pfoAX 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
	    where
		tf dt a = (pfoXA sf1' f2, (b, f2 a))
		    where
			(sf1', b) = (sfTF' sf1) dt a

instance ArrowLoop SF where
    loop = loopPrim

-- | Loop a signal function.
  Use the ' loop ' function from the '  ' class ,
-- rather than this function. 
  The second output is connected to the second input . This permits recursion
-- by making the output of a signal function available to itself. 
loopPrim :: SF (a,c) (b,c) -- ^ Signal function, producing output as which 
                           -- it will receive as input.
            -> SF a b -- ^ Looped signal function
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
	    where
		tf dt a = (loopAux sf1', b)
		    where
		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)

-- | The identity signal function. Use in place of 
--
-- > arr id
identity :: SF a a
identity = SF {sfTF = \a -> (sfId, a)}

-- | The constant signal function. Use 
--
-- > constant x
--
-- in place of
--
-- > arr $ const x
constant :: b -> SF a b
constant b = SF {sfTF = \_ -> (sfConst b, b)}

-- | The time of this part of the signal graph.
-- Note that if a signal function is switched in,
-- the time is relative to the moment of switching,
-- not the moment that animation started.
localTime :: SF a Time
localTime = constant 1.0 >>> integral

-- | identical to 'localTime'
time :: SF a Time
time = localTime

-- | Override the output value for a signal function
  at the first instant it is processed
> ) : : b - > SF a b - > SF a b
b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}

-- | Override the input value for a signal function at the
-- first instant it is processed.
) : : a - > SF a b - > SF a b
a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}

  | Apply a function to the output at the first instant of a signal function
(-=>) :: (b -> b) -> SF a b -> SF a b
f -=> (SF {sfTF = tf10}) =
    SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}

  | Apply a function to the input at the first instant of a signal function
(>=-) :: (a -> a) -> SF a b -> SF a b
f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}

  | Output a value at the first instant , and forever after pass the input
-- value through
  ^ Value at first instant
             -> SF a a
initially = (--> identity)

-- | Signal function:
-- apply a function to an accumulator at each instant. Note that 
-- the output value is the value of the accumulator at each instant.
sscan :: (b -> a -> b ) -- ^ Function from accumulator and input to accumulator
         -> b -- ^ Initial accumulator value
         -> SF a b -- ^ Accumulating scan signal function
sscan f b_init = sscanPrim f' b_init b_init
    where
        f' b a = let b' = f b a in Just (b', b')

-- | Never produce an event
never :: SF a (Event b)
never = SF {sfTF = \_ -> (sfNever, NoEvent)}

-- | Produce an event immediately (at the moment of switching in or animation)
-- and never again.
now :: b -- ^ Value for event
       -> SF a (Event b) -- ^ Signal function producing 
now b0 = (Event b0 --> never)

-- | Produce an event delayed by some time.
after :: Time -- ^ Time to wait before producing event
         -> b -- ^ Value for event
         -> SF a (Event b) -- ^ Signal function producing event after
                           -- specified period
after q x = afterEach [(q,x)]

-- | Produce event every so often (but not immediately)
repeatedly :: Time -- ^ Time between events
              -> b -- ^ Value for all events
              -> SF a (Event b) -- ^ Signal function producing repeated event
repeatedly q x | q > 0 = afterEach qxs
               | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."
    where
        qxs = (q,x):qxs        

-- | Takes a list of time delays and values to a signal function
-- producing events.
afterEach :: [(Time,b)] -- ^ Time since previous event or start and value for
                        -- event
             -> SF a (Event b)
afterEach qxs = afterEachCat qxs >>> arr (fmap head)

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
	    where
		tf dt _ | t' >= 0   = emitEventsScheduleNext t' [x] qxs
		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)
		    where
		        t' = t + dt

-- | Delay events passing through                        
delayEvent :: Time -- ^ Time to delay events
              -> SF (Event a) (Event a) -- ^ Signal function delaying events
delayEvent q | q < 0     = usrErr "AFRP" "delayEvent" "Negative delay."
             | q == 0    = identity
             | otherwise = delayEventCat q >>> arr (fmap head)


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
            where
                tf _ e = (case e of
                              NoEvent -> noPendingEvent
                              Event x -> pendingEvents (-q) [] [] (-q) x,
                          NoEvent)
				 
        pendingEvents t_last rqxs qxs t_next x = SF' tf
            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)

        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)
-- | Produce an event whenever the input goes from 'False' to 'True'
edge :: SF Bool (Event ())
edge = iEdge True


iEdge :: Bool -> SF Bool (Event ())
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

-- | Produce an event carrying a specified value whenever
-- the input goes from 'False' to 'True'
edgeTag :: a -- ^ Value for events
           -> SF Bool (Event a)
edgeTag a = edge >>> arr (`tag` a)

-- | Produce the value carried by the Maybe whenever the input goes
-- from 'Nothing' to 'Just'
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

-- | Compare the input at the current and previous instant 
-- and produce an event based on the comparison
edgeBy :: (a -> a -> Maybe b) -- ^ Comparison function.
                              -- An event will occur at any instant where the 
                              -- value of this function is 'Just'.
  ^ initial \"previous\ " instant .
          -> SF a (Event b)   -- ^ Signal function comparing instants
edgeBy isEdge a_init = SF {sfTF = tf0}
    where
	tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))

	ebAux a_prev = SF' tf
	    where
		tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))

-- | Suppress a possible event at the instant of animation or switching in
notYet :: SF (Event a) (Event a)
notYet = initially NoEvent

  | Suppress all but the first event passing through
once :: SF (Event a) (Event a)
once = takeEvents 1

-- | Only permit a certain number of events
takeEvents :: Int -- ^ Number of events to permit
              -> SF (Event a) (Event a) -- ^ Signal function only permitting
                                        -- that many events
takeEvents n | n <= 0 = never
takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1)))

-- | Suppress a certain number of initial events
dropEvents :: Int -- ^ Number of events to suppress initially
              -> SF (Event a) (Event a) -- ^ Signal function suppressing
                                        -- That many events initially
dropEvents n | n <= 0  = identity
dropEvents n = dSwitch (never &&& identity)
                             (const (NoEvent >-- dropEvents (n - 1)))

-- | Switch in a new signal function produced from an event, at the instant
-- of that event.
switch :: SF a (b, Event c) -- ^ Signal function which may eventually produce 
                            -- an event.
          -> (c -> SF a b)  -- ^ Function producing a signal function from the
                            -- event value
          -> SF a b         -- ^ Signal function which may switch to
                            -- a new signal function.
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


        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
	    where
		tf dt a =
		    case (sfTF' sf1) dt a of
			(sf1', (b, NoEvent)) -> (switchAux sf1' k, b)
			(_,    (_, Event c)) -> sfTF (k c) a

        switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b
	switchAuxA1 f1 k = sf
	    where
		sf     = SF' tf
		tf _ a =
		    case f1 a of
			(b, NoEvent) -> (sf, b)
			(_, Event c) -> sfTF (k c) a

-- | Decoupled version of 'switch'.
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)

        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
	    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)

        dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b
	dSwitchAuxA1 f1 k = sf
	    where
		sf = SF' tf 
		tf _ a =
		    let (b, ec) = f1 a
                    in (case ec of
			    NoEvent -> sf
			    Event c -> fst (sfTF (k c) a),

			b)

-- | Switches in new signal functions carried by input events.
rSwitch :: SF a b                      -- ^ Initial signal function
           -> SF (a, Event (SF a b)) b -- ^ Signal function which may
                                       -- be changed by an event carrying a new
                                       -- signal function
rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)

-- | Decoupled version of 'rswitch'
drSwitch :: SF a b -> SF (a, Event (SF a b)) b
drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)

-- This is rather complicated and I'm not sure I understand it.
  I will document it once I 'm sure of how it works . Dr.  's
-- original comments also expressed skepticism about its correctness
-- and performance. Perhaps it should be removed?
-- | Continuation based switching (undocumented) 
kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
    where
        tf0 a0 =
	    let (sf1, b0) = tf10 a0
            in
	        case tfe0 (a0, b0) of
		    (sfe, NoEvent)  -> (kSwitchAux sf1 sfe, b0)
		    (_,   Event c0) -> sfTF (k sf10 c0) a0

        kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe
        kSwitchAux (SFArr _ fd1)     sfe = kSwitchAuxA1 (fdFun fd1) sfe
        kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1
        kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) 
        kSwitchAux sf1            sfe                 = SF' tf 
	    where
		tf dt a =
		    let	(sf1', b) = (sfTF' sf1) dt a
		    in
		        case (sfTF' sfe) dt (a, b) of
			    (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)
			    (_,    Event c) -> sfTF (k (freeze sf1 dt) c) a


        kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b
        kSwitchAuxC1 b (SFArr _ fde)        = kSwitchAuxC1AE b (fdFun fde)
        kSwitchAuxC1 b sfe                 = SF' tf 
	    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
        kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1
        kSwitchAuxA1 f1 (SFArr _ fde)        = kSwitchAuxA1AE f1 (fdFun fde)
        kSwitchAuxA1 f1 sfe                 = SF' tf 
	    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

        kSwitchAuxAE (SFArr _ (FDC b))  fe = kSwitchAuxC1AE b fe
        kSwitchAuxAE (SFArr _ fd1)   fe = kSwitchAuxA1AE (fdFun fd1) fe
        kSwitchAuxAE sf1            fe = SF' tf 
	    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

        kSwitchAuxC1AE b fe = SF' tf 
	    where
		tf _ a =
		    case fe (a, b) of
			NoEvent -> (kSwitchAuxC1AE b fe, b)
			Event c -> sfTF (k (constant b) c) a

        kSwitchAuxA1AE f1 fe = SF' tf 
	    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

-- | Decoupled version of '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 	    
          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)

-- | Pair a value with every value in a collection
broadcast :: Functor col => a -> col sf -> col (a, sf)
broadcast a sfs = fmap (\sf -> (a, sf)) sfs

-- | Broadcast the same output to a collection of signal functions,
-- producing a collection of outputs.
parB :: Functor col => col (SF a b) -> SF a (col b)
parB = par broadcast

-- | Take a single input and broadcast it to a collection of functions,
  until an event is triggered , then switch into another SF producing a
-- collection of outputs
pSwitchB :: Functor col =>
    col (SF a b) -- ^ Initial collection of signal functions
    -> SF (a, col b) (Event c) -- ^ Produces collection update events
                               -- based on the input and output of the parallel
  SF .
  ^ Produces the SF to replace
                                           -- the initial parallel sf
  upon event output from the SF
                                           -- above
    -> SF a (col b)
pSwitchB = pSwitch broadcast


-- | "pSwitchB", but switched output is visible on the sample frame
-- after the event occurs
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

-- | Broadcast intput to a collection of signal functions,
-- and transform that collection with mutator functions carried in events
rpSwitchB :: Functor col =>
    col (SF a b) -- ^ Initial collection of signal functions
    -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) 
    -- ^ Signal function taking input to broadcast and mutating events and
  producing the output of the collection of SFs
rpSwitchB = rpSwitch broadcast


-- | "rpSwitchB", but switched output is visible on the sample frame after
-- the event occurs
drpSwitchB :: Functor col =>
    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
drpSwitchB = drpSwitch broadcast


-- | Route input to a static collection of signal functions
par :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function, pair
                                               -- input values with signal functions
    -> col (SF b c) -- ^ Collection of signal functions
    -> 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)

parAux :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF' b c)
    -> SF' a (col c)
parAux rf sfs = SF' tf 
    where
	tf dt a = 
	    let bsfs  = rf a sfs
		sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
		sfs'  = fmap fst sfcs'
		cs    = fmap snd sfcs'
	    in
	        (parAux rf sfs', cs)

  | Like " par " , but takes an extra SF which looks at the input and output
  of the parallel switching combinator and switches in a new SF at that point
pSwitch :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function, pair
  output with SFs in the
                                               -- collection
  ^ Initial collection of SFs
  ^ Switching event SF , takes input and output
  of parallel SF and produces a switching event
    
  ^ Takes collection of SFs and
                                           -- value of switching event and
  produces SF to switch into
    -> 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
	    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


-- | "pSwitch", but the output from the switched-in signal function is visible
-- | in the sample frame after the event.
dpSwitch :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF b c)
    -> SF (a, col c) (Event d)
    -> (col (SF b c) -> d -> SF a (col c))
    -> SF a (col c)
dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
    where
	tf0 a0 =
	    let bsfs0 = rf a0 sfs0
		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
		cs0   = fmap snd sfcs0
	    in
		(case (sfTF sfe0) (a0, cs0) of
		     (sfe, NoEvent)  -> dpSwitchAux (fmap fst sfcs0) sfe
		     (_,   Event d0) -> fst (sfTF (k sfs0 d0) a0),
	         cs0)

	dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs
	dpSwitchAux sfs sfe = SF' tf 
	    where
		tf dt a =
		    let bsfs  = rf a sfs
			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
			cs    = fmap snd sfcs'
		    in
			(case (sfTF' sfe) dt (a, cs) of
			     (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')
							    sfe'
			     (_,    Event d) -> fst (sfTF (k (freezeCol sfs dt)
							     d)
							  a),
                         cs)

-- | Dynamic collections of signal functions with a routing function
rpSwitch :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function
    -> col (SF b c) -- ^ Initial collection of signal functions
    -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c) 
    -- ^ Signal function accepting events which mutate the collection
                     
rpSwitch rf sfs =
    pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
    noEventSnd >=- rpSwitch rf (f sfs')
    
    
  | " rpSwitch " , but the output of a switched - in SF is visible in the sample
-- frame after the switch
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')

-- | For backwards compatibility only.
old_hold :: a -> SF (Event a) a
old_hold a_init = switch (constant a_init &&& identity)
                         ((NoEvent >--) . old_hold)

-- | Output the initial value or the value of the last event.
hold :: a -- ^ Initial value
        -> SF (Event a) a -- ^ Signal function which constantly outputs
                       -- the value of the last event.
hold a_init = epPrim f () a_init
    where
        f _ a = ((), a, a)

-- | Decoupled version of 'hold'. Begins outputting event value the instant
-- after the event occurence.
dHold :: a -> SF (Event a) a
dHold a0 = hold a0 >>> iPre a0

-- | Hold the value of a 'Maybe' input.
trackAndHold :: a -- ^ Initial value
                -> SF (Maybe a) a -- ^ Output the initial value or
                                  -- the value of the most recent 'Just'
trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init

-- | For backwards compatability only.
old_accum :: a -> SF (Event (a -> a)) (Event a)
old_accum = accumBy (flip ($))

-- | Apply a function carried by an event to an accumulator, producing
-- an event with the new value of the accumulator.
accum :: a -- ^ Initial accumulator value.
         -> SF (Event (a -> a)) (Event a) -- ^ Signal function from events
                                          -- carrying functions to events with
                                          -- the value of those functions 
                                          -- applied to the accumulator
accum a_init = epPrim f a_init NoEvent
    where
        f a g = (a', Event a', NoEvent)
            where
                a' = g a

-- | As with 'accum' but output the value of the accumulator.
accumHold :: a -- ^ Initial value of accumulator
             -> SF (Event (a -> a)) a -- ^ Signal function from events
                                      -- carrying functions to events with
                                      -- the value of those functions applied
                                      -- to the accumulator
accumHold a_init = epPrim f a_init a_init
    where
        f a g = (a', a', a')
            where
                a' = g a

-- | Decoupled version of 'accumHold'. Updated accumulator values begin output 
-- at the instant /after/ the updating event.
dAccumHold :: a -> SF (Event (a -> a)) a
dAccumHold a_init = accumHold a_init >>> iPre a_init

-- | For backwards compatibility only.
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)

-- | Provide a function and initial accumulator to process events, produce
  each new accumulator  as an event .
accumBy :: (b -> a -> b) -- ^ Function from accumulator and event value to
                         -- accumulator.
           -> b          -- ^ Initial accumulator value
           -> SF (Event a) (Event b) -- ^ Signal function processing events
                                     -- with accumulator function
accumBy g b_init = epPrim f b_init NoEvent
    where
        f b a = (b', Event b', NoEvent)
            where
                b' = g b a

-- | As in 'accumBy' but produce the accumulator value as a continuous signal.
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

-- | Decoupled version of 'accumHoldBy'. Output signal changes at the instant
-- /after/ an event.
dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b
dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init

-- | For backwards compatibility only.
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)

-- | Filter events with an accumulator.
accumFilter :: (c -> a -> (c, Maybe b)) -- ^ Function from accumulator value and
                                        -- event value to new accumulator value
                                        -- and possible event value.
               -> c                     -- ^ Initial accumulator value.
               -> SF (Event a) (Event b) -- ^ Signal function filtering events.
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)

-- | For backwards compatibility only.
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
	    where
		tf _ a = (preAux a, a_prev)

-- | For backwards compatibility only.
old_iPre :: a -> SF a a
old_iPre = (--> old_pre)

  | Uninitialized one - instant delay .
pre :: SF a a
pre = sscanPrim f uninit uninit
    where
        f c a = Just (a, c)
        uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."

  | Iniitialized one - instant delay
  ^ Value of delayed function at first instant
  ^ One - instant delay
iPre = (--> pre)

-- | Delay a (non-event) signal by a specific time offsent. For events please
-- use 'delayEvent'.
delay :: Time      -- ^ Time offset to delay signal by
         -> a      -- ^ Initial value until time offset is reached
         -> SF a a -- ^ delayed signal function
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
            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
                
-- | Integrate a signal with respect to time.
# 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 
	    where
	        tf dt a = (integralAux igrl' a, igrl')
		    where
		       igrl' = igrl ^+^ realToFrac dt *^ a_prev


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'), b)

derivative :: VectorSpace a s => SF a a
derivative = SF {sfTF = tf0}
    where
	tf0 a0 = (derivativeAux a0, zeroVector)

	derivativeAux a_prev = SF' tf
	    where
	        tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)

loopPre :: c -> SF (a,c) (b,c) -> SF a b
loopPre c_init sf = loop (second (iPre c_init) >>> sf)

loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b
loopIntegral sf = loop (second integral >>> sf)

noise :: (RandomGen g, Random b) => g -> SF a b
noise g0 = streamToSF (randoms g0)

noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b
noiseR range g0 = streamToSF (randomRs range g0)

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!"
        stsfAux (b:bs) = SF' tf
	    where
		tf _ _ = (stsfAux bs, b)

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
    tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent)

    occAux [] = undefined
    occAux (r:rs) = SF' tf
        where
        tf dt _ = let p = 1 - exp (-(dt/t_avg))
                  in (occAux rs, if r < p then Event x else NoEvent)
reactimate :: IO a
	      -> (Bool -> IO (DTime, Maybe a))
	      -> (Bool -> b -> IO Bool)
              -> SF a b
	      -> IO ()

reactimate init sense actuate (SF {sfTF = tf0}) =
    do
        a0 <- init
        let (sf, b0) = tf0 a0
        loop sf a0 b0
    where
        loop sf a b = do
	    done <- actuate True b
            unless (a `seq` b `seq` done) $ do
	        (dt, ma') <- sense False
		let a' = maybe a id ma'
                    (sf', b') = (sfTF' sf) dt a'
		loop sf' a' b'

data ReactState a b = ReactState {
    rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,
    rsSF :: SF' a b,
    rsA :: a,
    rsB :: b
  }	      

type ReactHandle a b = IORef (ReactState a b)

reactInit :: IO a 
             -> (ReactHandle a b -> Bool -> b -> IO Bool) 
             -> SF a b
             -> IO (ReactHandle a b)
reactInit init actuate (SF {sfTF = tf0}) = 
  do a0 <- init
     let (sf,b0) = tf0 a0
     r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,
				rsA = a0, rsB = b0 })
     done <- actuate r True b0
     return r

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     

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

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!"
	esAux tp_prev tbtbs = SF' tf
	    where
		tf dt r | r < 0     = usrErr "AFRP" "embedSynch"
					     "Negative ratio."
			| otherwise = let tp = tp_prev + dt * r
					  (b, tbtbs') = advance tp tbtbs
				      in
					  (esAux tp tbtbs', b)
        advance _  tbtbs@[(_, b)] = (b, tbtbs)
        advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))
		    | tp <  t' = (b, tbtbtbs)
		    | t' <= tp = advance tp tbtbs
        advance _ _ = undefined

deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode _  []        = usrErr "AFRP" "deltaEncode" "Empty input list."
deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas


deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy _  _  []      = usrErr "AFRP" "deltaEncodeBy" "Empty input list."
deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))
    where
	debAux _      []                     = []
	debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as
                             | otherwise     = Just a  : debAux a as
                                               
-- | A step in evaluating a signal function
newtype Step a b = Step { stepSf :: SF' a b }

-- | Initialize a signal function for stepping through
  ^ Value at time 0
            -> SF a b -- ^ Signal function to animate
            -> (b, Step a b) -- ^ Output at time 0, next step
initStep x sf = 
  let (sf', x') = sfTF sf x in
  (x', Step sf')
  
-- | Go to the next step of a signal function
step :: DTime -- ^ Time offset
        -> a -- ^ Value at new time
        -> Step a b -- ^ Step to evaluate
        -> (b, Step a b) -- ^ output value at this time, and next step
step dt x (Step sf) = 
  let (sf', x') = sfTF' sf dt x in
  (x', Step sf')
  


 |
 License     :  BSD-style (see the LICENSE file in the distribution)

 Maintainer  :  
 Stability   :  provisional
 * Re-exported modules 
 * Random-number classes  
 * Convenience operators
 * Pure signal functions
 * Time signal functions
 * Initialization
 | These operators provide means of specifying the initial
 input or output of a signal function, overriding the signal function for
>),
),
 * Accumulator-based signal functions
 * Events
 ** Basic event producers 
 ** Event manipulation
 ** Stateful event processing
 * Unlifted event functions
 * Switches
 | Switches provide run-time modification of the signal network. 
 lies in which signal function is used to produce the value at the instant
 of switching. For an instantaneous switch, the signal function being 
 switched in is used to produce the value. For a decoupled switch, that
 signal function is used to produce the value at the /next/ instant,
 while the signal function being switched out is still used to produce
 the value at the instant of switching. This is useful for (among other
 things) ensuring that looped signal functions are well-founded
 recursively. Decoupled varieties of switches are prefixed with a \"d\".
 ** Event-based switches
 ** Parallel switches (collections of signal functions)
 * Delays
 * Calculus
 * Looping
 * Randomized signal functions
 * Animation
>, >--, -=>, >=-
 | Time representation for signal functions
 | A signal function
   class, rather than this function.
# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #
 | Lifts a function with an event input to a pure signal function
 on events. Use 'arr' from the 'Arrow' class, rather than this function.
 | Loop a signal function.
 rather than this function. 
 by making the output of a signal function available to itself. 
 ^ Signal function, producing output as which 
 it will receive as input.
 ^ Looped signal function
 | The identity signal function. Use in place of 

 > arr id
 | The constant signal function. Use 

 > constant x

 in place of

 > arr $ const x
 | The time of this part of the signal graph.
 Note that if a signal function is switched in,
 the time is relative to the moment of switching,
 not the moment that animation started.
 | identical to 'localTime'
 | Override the output value for a signal function
> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}
 | Override the input value for a signal function at the
 first instant it is processed.
 (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}
 value through
> identity)
 | Signal function:
 apply a function to an accumulator at each instant. Note that 
 the output value is the value of the accumulator at each instant.
 ^ Function from accumulator and input to accumulator
 ^ Initial accumulator value
 ^ Accumulating scan signal function
 | Never produce an event
 | Produce an event immediately (at the moment of switching in or animation)
 and never again.
 ^ Value for event
 ^ Signal function producing 
> never)
 | Produce an event delayed by some time.
 ^ Time to wait before producing event
 ^ Value for event
 ^ Signal function producing event after
 specified period
 | Produce event every so often (but not immediately)
 ^ Time between events
 ^ Value for all events
 ^ Signal function producing repeated event
 | Takes a list of time delays and values to a signal function
 producing events.
 ^ Time since previous event or start and value for
 event
 | Delay events passing through                        
 ^ Time to delay events
 ^ Signal function delaying events
 | Produce an event whenever the input goes from 'False' to 'True'
 | Produce an event carrying a specified value whenever
 the input goes from 'False' to 'True'
 ^ Value for events
 | Produce the value carried by the Maybe whenever the input goes
 from 'Nothing' to 'Just'
 | Compare the input at the current and previous instant 
 and produce an event based on the comparison
 ^ Comparison function.
 An event will occur at any instant where the 
 value of this function is 'Just'.
 ^ Signal function comparing instants
 | Suppress a possible event at the instant of animation or switching in
 | Only permit a certain number of events
 ^ Number of events to permit
 ^ Signal function only permitting
 that many events
 takeEvents (n - 1)))
 | Suppress a certain number of initial events
 ^ Number of events to suppress initially
 ^ Signal function suppressing
 That many events initially
 dropEvents (n - 1)))
 | Switch in a new signal function produced from an event, at the instant
 of that event.
 ^ Signal function which may eventually produce 
 an event.
 ^ Function producing a signal function from the
 event value
 ^ Signal function which may switch to
 a new signal function.
 | Decoupled version of 'switch'.
 | Switches in new signal functions carried by input events.
 ^ Initial signal function
 ^ Signal function which may
 be changed by an event carrying a new
 signal function
 | Decoupled version of 'rswitch'
 This is rather complicated and I'm not sure I understand it.
 original comments also expressed skepticism about its correctness
 and performance. Perhaps it should be removed?
 | Continuation based switching (undocumented) 
 | Decoupled version of 'kswitch'
 | Pair a value with every value in a collection
 | Broadcast the same output to a collection of signal functions,
 producing a collection of outputs.
 | Take a single input and broadcast it to a collection of functions,
 collection of outputs
 ^ Initial collection of signal functions
 ^ Produces collection update events
 based on the input and output of the parallel
 the initial parallel sf
 above
 | "pSwitchB", but switched output is visible on the sample frame
 after the event occurs
 | Broadcast intput to a collection of signal functions,
 and transform that collection with mutator functions carried in events
 ^ Initial collection of signal functions
 ^ Signal function taking input to broadcast and mutating events and
 | "rpSwitchB", but switched output is visible on the sample frame after
 the event occurs
 | Route input to a static collection of signal functions
 ^ Routing function, pair
 input values with signal functions
 ^ Collection of signal functions
 ^ Routing function, pair
 collection
 value of switching event and
 | "pSwitch", but the output from the switched-in signal function is visible
 | in the sample frame after the event.
 | Dynamic collections of signal functions with a routing function
 ^ Routing function
 ^ Initial collection of signal functions
 ^ Signal function accepting events which mutate the collection
 frame after the switch
 | For backwards compatibility only.
) . old_hold)
 | Output the initial value or the value of the last event.
 ^ Initial value
 ^ Signal function which constantly outputs
 the value of the last event.
 | Decoupled version of 'hold'. Begins outputting event value the instant
 after the event occurence.
 | Hold the value of a 'Maybe' input.
 ^ Initial value
 ^ Output the initial value or
 the value of the most recent 'Just'
 | For backwards compatability only.
 | Apply a function carried by an event to an accumulator, producing
 an event with the new value of the accumulator.
 ^ Initial accumulator value.
 ^ Signal function from events
 carrying functions to events with
 the value of those functions 
 applied to the accumulator
 | As with 'accum' but output the value of the accumulator.
 ^ Initial value of accumulator
 ^ Signal function from events
 carrying functions to events with
 the value of those functions applied
 to the accumulator
 | Decoupled version of 'accumHold'. Updated accumulator values begin output 
 at the instant /after/ the updating event.
 | For backwards compatibility only.
 | Provide a function and initial accumulator to process events, produce
 ^ Function from accumulator and event value to
 accumulator.
 ^ Initial accumulator value
 ^ Signal function processing events
 with accumulator function
 | As in 'accumBy' but produce the accumulator value as a continuous signal.
 | Decoupled version of 'accumHoldBy'. Output signal changes at the instant
 /after/ an event.
 | For backwards compatibility only.
 | Filter events with an accumulator.
 ^ Function from accumulator value and
 event value to new accumulator value
 and possible event value.
 ^ Initial accumulator value.
 ^ Signal function filtering events.
 | For backwards compatibility only.
 | For backwards compatibility only.
> old_pre)
> pre)
 | Delay a (non-event) signal by a specific time offsent. For events please
 use 'delayEvent'.
 ^ Time offset to delay signal by
 ^ Initial value until time offset is reached
 ^ delayed signal function
 | Integrate a signal with respect to time.
 | A step in evaluating a signal function
 | Initialize a signal function for stepping through
 ^ Signal function to animate
 ^ Output at time 0, next step
 | Go to the next step of a signal function
 ^ Time offset
 ^ Value at new time
 ^ Step to evaluate
 ^ output value at this time, and next step
# LANGUAGE GADTs , Rank2Types ,  #
  Module       :   FRP.Animas
  Copyright    :   ( c )   and   , Yale University , 2003 .
                 Modifications by   and  
  Portability :   non - portable ( GHC extensions )

module FRP.Animas (
    module Control.Arrow,
    module FRP.Animas.VectorSpace,
    RandomGen(..),
    Random(..),
    ( # ),
    dup,
    swap,
  * 
    Time,
    DTime,
    SF,	
    Event(..),
    arrPrim, arrEPrim,
    identity,
    constant,
    localTime,
    time,
  the first cycle of animation
    (-=>),
    (>=-),
    initially,
    sscan,
    sscanPrim,
    never,
    now,
    after,
    repeatedly,
    afterEach,
    afterEachCat,
    edge,
    iEdge,
    edgeTag,
    edgeJust,
    edgeBy,
    once,
    noEvent,
    noEventFst,
    noEventSnd,
    delayEvent,
    delayEventCat,
    takeEvents,
    dropEvents,
    notYet,
    old_hold,
    hold,
    dHold,
    trackAndHold,
    old_accum,
    old_accumBy,
    old_accumFilter,
    accum,
    accumHold,
    dAccumHold,
    accumBy,
    accumHoldBy,
    dAccumHoldBy,
    accumFilter,
    event,
    fromEvent,
    isEvent,
    isNoEvent,
    tag,
    tagWith,
    attach,
    lMerge,
    rMerge,
    merge,
    mergeBy,
    mapMerge,
    mergeEvents,
    catEvents,
    joinE,
    splitE,
    filterE,
    mapFilterE,
    gate,
  Most switching combinators provided two varieties : an
  \"instantaneous\ " version and a \"decoupled version\ " . The difference
    
    switch,  dSwitch,	    
    rSwitch, drSwitch,	
    kSwitch, dkSwitch,
    parB,		
    pSwitchB,dpSwitchB, 
    rpSwitchB,drpSwitchB,
    par,
    pSwitch, dpSwitch,
    rpSwitch,drpSwitch, 
    old_pre, old_iPre,
    pre,
    iPre,
    delay,
    integral,
    derivative,
    imIntegral,
  | See also the ' loop ' combinator from the '  ' class .
    loopPre,
    loopIntegral,
    noise,
    noiseR,
    occasionally,
    ReactHandle,
    reactimate,
    reactInit,
    react,
    embed,
    embedSynch,
    deltaEncode,
    deltaEncodeBy,
    Step,
    initStep,
    step
) 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.Animas.Diagnostics
import FRP.Animas.Miscellany (( # ), dup, swap)
import FRP.Animas.Event
import FRP.Animas.VectorSpace

import Data.IORef


  Time / DTime should be parameterized with a  class restriction
type Time = Double

type DTime = Double

data SF a b = SF {sfTF :: a -> Transition a b}

data SF' a b where
    SFArr   :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b
    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
    SF' :: !(DTime -> a -> Transition a b) -> SF' a b
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

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

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')

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 :: (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)

data FunDesc a b where
    FDI :: FunDesc a a
    FDC :: b -> FunDesc a b
    FDE :: (Event a -> b) -> b -> FunDesc (Event a) b
    FDG :: (a -> b) -> FunDesc a b

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

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))

vfyNoEv :: Event a -> b -> b
vfyNoEv NoEvent b = b
vfyNoEv _       _  = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."

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

#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

  | Lifts a function to a pure signal function . Use ' arr ' from the ' Arrow '
# NOINLINE arrPrim #
arrPrim :: (a -> b) -> SF a b
arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}


arrEPrim :: (Event a -> b) -> SF (Event a) b
arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}

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

cpXX :: SF' a b -> SF' b c -> SF' a c
cpXX (SFArr _ fd1)       sf2               = cpAX fd1 sf2
cpXX sf1                 (SFArr _ fd2)     = cpXA sf1 fd2
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)
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')
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."
cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =
    cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)
cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) =
    cpXX (cpXG sf1 f21) (cpXA sf22 fd23)
cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) =
    cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) 
cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
    cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23
cpXX sf1 sf2 = SF' tf    
  where
        tf dt a = (cpXX sf1' sf2', c)
	    where
	        (sf1', b) = (sfTF' sf1) dt a
		(sf2', c) = (sfTF' sf2) dt b

cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d
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
        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
	    where
		tf dt a = (cpAXAAux 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

cpCX :: b -> SF' b c -> SF' a c
cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)
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
    where
	tf dt _ = (cpCX 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
        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
	    where
		tf dt _ = (cpCXAAux 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)
        cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
	cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =
	    cpAXA (fdComp fd1 fd21) sf22 fd23
	cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI
	    where
		tf dt a = (cpGXAux 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
	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
	    where
		tf dt a = (cpXGAux 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
	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
	cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf 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)

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
	    where
		tf dt a = (cpXEAux fd2 f2 f2ne sf1',
                           case eb of NoEvent -> f2ne; _ -> f2 eb)
		    where
                        (sf1', eb) = (sfTF' sf1) dt a

firstPrim :: SF a b -> SF (a,c) (b,c)
firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
	    where
		(sf1, b0) = tf10 a0 

fpAux :: SF' a b -> SF' (a,c) (b,c)
fpAux (SFArr _ FDI)       = sfId
fpAux (SFArr _ (FDC b))   = sfArrG (\(~(_, c)) -> (b, c))
fpAux (SFArr _ fd1)       = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))
fpAux sf1 = SF' tf
    where
        tf dt ~(a, c) = (fpAux sf1', (b, c))
	    where
		(sf1', b) = (sfTF' sf1) dt a 

secondPrim :: SF a b -> SF (c,a) (c,b)
secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
	    where
		(sf1, b0) = tf10 a0 

spAux :: SF' a b -> SF' (c,a) (c,b)
spAux (SFArr _ FDI)       = sfId
spAux (SFArr _ (FDC b))   = sfArrG (\(~(c, _)) -> (c, b))
spAux (SFArr _ fd1)       = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))
spAux sf1 = SF' tf
    where
        tf dt ~(c, a) = (spAux sf1', (c, b))
	    where
		(sf1', b) = (sfTF' sf1) dt a 

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 

        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
	psXX (SFArr _ (FDC b))   sf2                 = psCX b sf2
	psXX (SFArr _ fd1)       sf2                 = psAX (fdFun fd1) sf2
        psXX sf1                 (SFArr _ FDI)       = fpAux sf1
	psXX sf1                 (SFArr _ (FDC d))   = psXC sf1 d
	psXX sf1                 (SFArr _ fd2)       = psXA sf1 (fdFun fd2)
	psXX sf1 sf2 = SF' tf
	    where
		tf dt ~(a, c) = (psXX 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
	    where
		tf dt ~(_, c) = (psCX 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
	    where
		tf dt ~(a, _) = (psXC 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
	    where
		tf dt ~(a, c) = (psAX 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
	    where
		tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))
		    where
			(sf1', b) = (sfTF' sf1) dt a

parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
	tf0 a0 = (pfoXX sf1 sf2, (b0, c0))
	    where
		(sf1, b0) = tf10 a0 
		(sf2, c0) = tf20 a0 
        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)
	pfoXX sf1 sf2 = SF' tf
	    where
		tf dt a = (pfoXX 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
	    where
		tf dt a = (pfoIX 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
	    where
		tf dt a = (pfoXI 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
	    where
		tf dt a = (pfoCX 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
	    where
		tf dt a = (pfoXC 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
	    where
		tf dt a = (pfoAX 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
	    where
		tf dt a = (pfoXA sf1' f2, (b, f2 a))
		    where
			(sf1', b) = (sfTF' sf1) dt a

instance ArrowLoop SF where
    loop = loopPrim

  Use the ' loop ' function from the '  ' class ,
  The second output is connected to the second input . This permits recursion
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
	    where
		tf dt a = (loopAux sf1', b)
		    where
		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)

identity :: SF a a
identity = SF {sfTF = \a -> (sfId, a)}

constant :: b -> SF a b
constant b = SF {sfTF = \_ -> (sfConst b, b)}

localTime :: SF a Time
localTime = constant 1.0 >>> integral

time :: SF a Time
time = localTime

  at the first instant it is processed
> ) : : b - > SF a b - > SF a b

) : : a - > SF a b - > SF a b

  | Apply a function to the output at the first instant of a signal function
(-=>) :: (b -> b) -> SF a b -> SF a b
f -=> (SF {sfTF = tf10}) =
    SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}

  | Apply a function to the input at the first instant of a signal function
(>=-) :: (a -> a) -> SF a b -> SF a b
f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}

  | Output a value at the first instant , and forever after pass the input
  ^ Value at first instant
             -> SF a a

sscan f b_init = sscanPrim f' b_init b_init
    where
        f' b a = let b' = f b a in Just (b', b')

never :: SF a (Event b)
never = SF {sfTF = \_ -> (sfNever, NoEvent)}


after q x = afterEach [(q,x)]

repeatedly q x | q > 0 = afterEach qxs
               | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."
    where
        qxs = (q,x):qxs        

             -> SF a (Event b)
afterEach qxs = afterEachCat qxs >>> arr (fmap head)

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
	    where
		tf dt _ | t' >= 0   = emitEventsScheduleNext t' [x] qxs
		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)
		    where
		        t' = t + dt

delayEvent q | q < 0     = usrErr "AFRP" "delayEvent" "Negative delay."
             | q == 0    = identity
             | otherwise = delayEventCat q >>> arr (fmap head)


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
            where
                tf _ e = (case e of
                              NoEvent -> noPendingEvent
                              Event x -> pendingEvents (-q) [] [] (-q) x,
                          NoEvent)
				 
        pendingEvents t_last rqxs qxs t_next x = SF' tf
            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)

        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)
edge :: SF Bool (Event ())
edge = iEdge True


iEdge :: Bool -> SF Bool (Event ())
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

           -> SF Bool (Event a)
edgeTag a = edge >>> arr (`tag` a)

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

  ^ initial \"previous\ " instant .
edgeBy isEdge a_init = SF {sfTF = tf0}
    where
	tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))

	ebAux a_prev = SF' tf
	    where
		tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))

notYet :: SF (Event a) (Event a)
notYet = initially NoEvent

  | Suppress all but the first event passing through
once :: SF (Event a) (Event a)
once = takeEvents 1

takeEvents n | n <= 0 = never

dropEvents n | n <= 0  = identity
dropEvents n = dSwitch (never &&& identity)

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


        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
	    where
		tf dt a =
		    case (sfTF' sf1) dt a of
			(sf1', (b, NoEvent)) -> (switchAux sf1' k, b)
			(_,    (_, Event c)) -> sfTF (k c) a

        switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b
	switchAuxA1 f1 k = sf
	    where
		sf     = SF' tf
		tf _ a =
		    case f1 a of
			(b, NoEvent) -> (sf, b)
			(_, Event c) -> sfTF (k c) a

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)

        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
	    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)

        dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b
	dSwitchAuxA1 f1 k = sf
	    where
		sf = SF' tf 
		tf _ a =
		    let (b, ec) = f1 a
                    in (case ec of
			    NoEvent -> sf
			    Event c -> fst (sfTF (k c) a),

			b)

rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)

drSwitch :: SF a b -> SF (a, Event (SF a b)) b
drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)

  I will document it once I 'm sure of how it works . Dr.  's
kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
    where
        tf0 a0 =
	    let (sf1, b0) = tf10 a0
            in
	        case tfe0 (a0, b0) of
		    (sfe, NoEvent)  -> (kSwitchAux sf1 sfe, b0)
		    (_,   Event c0) -> sfTF (k sf10 c0) a0

        kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe
        kSwitchAux (SFArr _ fd1)     sfe = kSwitchAuxA1 (fdFun fd1) sfe
        kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1
        kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) 
        kSwitchAux sf1            sfe                 = SF' tf 
	    where
		tf dt a =
		    let	(sf1', b) = (sfTF' sf1) dt a
		    in
		        case (sfTF' sfe) dt (a, b) of
			    (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)
			    (_,    Event c) -> sfTF (k (freeze sf1 dt) c) a


        kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b
        kSwitchAuxC1 b (SFArr _ fde)        = kSwitchAuxC1AE b (fdFun fde)
        kSwitchAuxC1 b sfe                 = SF' tf 
	    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
        kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1
        kSwitchAuxA1 f1 (SFArr _ fde)        = kSwitchAuxA1AE f1 (fdFun fde)
        kSwitchAuxA1 f1 sfe                 = SF' tf 
	    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

        kSwitchAuxAE (SFArr _ (FDC b))  fe = kSwitchAuxC1AE b fe
        kSwitchAuxAE (SFArr _ fd1)   fe = kSwitchAuxA1AE (fdFun fd1) fe
        kSwitchAuxAE sf1            fe = SF' tf 
	    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

        kSwitchAuxC1AE b fe = SF' tf 
	    where
		tf _ a =
		    case fe (a, b) of
			NoEvent -> (kSwitchAuxC1AE b fe, b)
			Event c -> sfTF (k (constant b) c) a

        kSwitchAuxA1AE f1 fe = SF' tf 
	    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

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 	    
          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)

broadcast :: Functor col => a -> col sf -> col (a, sf)
broadcast a sfs = fmap (\sf -> (a, sf)) sfs

parB :: Functor col => col (SF a b) -> SF a (col b)
parB = par broadcast

  until an event is triggered , then switch into another SF producing a
pSwitchB :: Functor col =>
  SF .
  ^ Produces the SF to replace
  upon event output from the SF
    -> SF a (col b)
pSwitchB = pSwitch broadcast


dpSwitchB :: Functor col =>
    col (SF a b) 
    -> SF (a,col b) (Event c) 
    -> (col (SF a b) -> c -> SF a (col b))
    -> SF a (col b)
dpSwitchB = dpSwitch broadcast

rpSwitchB :: Functor col =>
    -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) 
  producing the output of the collection of SFs
rpSwitchB = rpSwitch broadcast


drpSwitchB :: Functor col =>
    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
drpSwitchB = drpSwitch broadcast


par :: Functor col =>
    -> 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)

parAux :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF' b c)
    -> SF' a (col c)
parAux rf sfs = SF' tf 
    where
	tf dt a = 
	    let bsfs  = rf a sfs
		sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
		sfs'  = fmap fst sfcs'
		cs    = fmap snd sfcs'
	    in
	        (parAux rf sfs', cs)

  | Like " par " , but takes an extra SF which looks at the input and output
  of the parallel switching combinator and switches in a new SF at that point
pSwitch :: Functor col =>
  output with SFs in the
  ^ Initial collection of SFs
  ^ Switching event SF , takes input and output
  of parallel SF and produces a switching event
    
  ^ Takes collection of SFs and
  produces SF to switch into
    -> 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
	    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


dpSwitch :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF b c)
    -> SF (a, col c) (Event d)
    -> (col (SF b c) -> d -> SF a (col c))
    -> SF a (col c)
dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
    where
	tf0 a0 =
	    let bsfs0 = rf a0 sfs0
		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
		cs0   = fmap snd sfcs0
	    in
		(case (sfTF sfe0) (a0, cs0) of
		     (sfe, NoEvent)  -> dpSwitchAux (fmap fst sfcs0) sfe
		     (_,   Event d0) -> fst (sfTF (k sfs0 d0) a0),
	         cs0)

	dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs
	dpSwitchAux sfs sfe = SF' tf 
	    where
		tf dt a =
		    let bsfs  = rf a sfs
			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
			cs    = fmap snd sfcs'
		    in
			(case (sfTF' sfe) dt (a, cs) of
			     (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')
							    sfe'
			     (_,    Event d) -> fst (sfTF (k (freezeCol sfs dt)
							     d)
							  a),
                         cs)

rpSwitch :: Functor col =>
    -> 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 " , but the output of a switched - in SF is visible in the sample
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')

old_hold :: a -> SF (Event a) a
old_hold a_init = switch (constant a_init &&& identity)

hold a_init = epPrim f () a_init
    where
        f _ a = ((), a, a)

dHold :: a -> SF (Event a) a
dHold a0 = hold a0 >>> iPre a0

trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init

old_accum :: a -> SF (Event (a -> a)) (Event a)
old_accum = accumBy (flip ($))

accum a_init = epPrim f a_init NoEvent
    where
        f a g = (a', Event a', NoEvent)
            where
                a' = g a

accumHold a_init = epPrim f a_init a_init
    where
        f a g = (a', a', a')
            where
                a' = g a

dAccumHold :: a -> SF (Event (a -> a)) a
dAccumHold a_init = accumHold a_init >>> iPre a_init

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)

  each new accumulator  as an event .
accumBy g b_init = epPrim f b_init NoEvent
    where
        f b a = (b', Event b', NoEvent)
            where
                b' = g b a

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

dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b
dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init

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)

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)

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
	    where
		tf _ a = (preAux a, a_prev)

old_iPre :: a -> SF a a

  | Uninitialized one - instant delay .
pre :: SF a a
pre = sscanPrim f uninit uninit
    where
        f c a = Just (a, c)
        uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."

  | Iniitialized one - instant delay
  ^ Value of delayed function at first instant
  ^ One - instant delay

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
            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
                
# 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 
	    where
	        tf dt a = (integralAux igrl' a, igrl')
		    where
		       igrl' = igrl ^+^ realToFrac dt *^ a_prev


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'), b)

derivative :: VectorSpace a s => SF a a
derivative = SF {sfTF = tf0}
    where
	tf0 a0 = (derivativeAux a0, zeroVector)

	derivativeAux a_prev = SF' tf
	    where
	        tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)

loopPre :: c -> SF (a,c) (b,c) -> SF a b
loopPre c_init sf = loop (second (iPre c_init) >>> sf)

loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b
loopIntegral sf = loop (second integral >>> sf)

noise :: (RandomGen g, Random b) => g -> SF a b
noise g0 = streamToSF (randoms g0)

noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b
noiseR range g0 = streamToSF (randomRs range g0)

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!"
        stsfAux (b:bs) = SF' tf
	    where
		tf _ _ = (stsfAux bs, b)

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
    tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent)

    occAux [] = undefined
    occAux (r:rs) = SF' tf
        where
        tf dt _ = let p = 1 - exp (-(dt/t_avg))
                  in (occAux rs, if r < p then Event x else NoEvent)
reactimate :: IO a
	      -> (Bool -> IO (DTime, Maybe a))
	      -> (Bool -> b -> IO Bool)
              -> SF a b
	      -> IO ()

reactimate init sense actuate (SF {sfTF = tf0}) =
    do
        a0 <- init
        let (sf, b0) = tf0 a0
        loop sf a0 b0
    where
        loop sf a b = do
	    done <- actuate True b
            unless (a `seq` b `seq` done) $ do
	        (dt, ma') <- sense False
		let a' = maybe a id ma'
                    (sf', b') = (sfTF' sf) dt a'
		loop sf' a' b'

data ReactState a b = ReactState {
    rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,
    rsSF :: SF' a b,
    rsA :: a,
    rsB :: b
  }	      

type ReactHandle a b = IORef (ReactState a b)

reactInit :: IO a 
             -> (ReactHandle a b -> Bool -> b -> IO Bool) 
             -> SF a b
             -> IO (ReactHandle a b)
reactInit init actuate (SF {sfTF = tf0}) = 
  do a0 <- init
     let (sf,b0) = tf0 a0
     r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,
				rsA = a0, rsB = b0 })
     done <- actuate r True b0
     return r

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     

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

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!"
	esAux tp_prev tbtbs = SF' tf
	    where
		tf dt r | r < 0     = usrErr "AFRP" "embedSynch"
					     "Negative ratio."
			| otherwise = let tp = tp_prev + dt * r
					  (b, tbtbs') = advance tp tbtbs
				      in
					  (esAux tp tbtbs', b)
        advance _  tbtbs@[(_, b)] = (b, tbtbs)
        advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))
		    | tp <  t' = (b, tbtbtbs)
		    | t' <= tp = advance tp tbtbs
        advance _ _ = undefined

deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode _  []        = usrErr "AFRP" "deltaEncode" "Empty input list."
deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas


deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy _  _  []      = usrErr "AFRP" "deltaEncodeBy" "Empty input list."
deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))
    where
	debAux _      []                     = []
	debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as
                             | otherwise     = Just a  : debAux a as
                                               
newtype Step a b = Step { stepSf :: SF' a b }

  ^ Value at time 0
initStep x sf = 
  let (sf', x') = sfTF sf x in
  (x', Step sf')
  
step dt x (Step sf) = 
  let (sf', x') = sfTF' sf dt x in
  (x', Step sf')
  

