{-
******************************************************************************
*                                  A F R P                                   *
*                                                                            *
*       Module:         AFRP                                                 *
*       Purpose:        The AFRP core.					     *
*	Authors:	Henrik Nilsson and Antony Courtney		     *
*                                                                            *
*             Copyright (c) Yale University, 2003                            *
*                                                                            *
******************************************************************************

Modified by Andreas Voellmy (andreas.voellmy@yale.edu) as follows:
* Update some definitions (Arrow, Category, etc.) to fix compilation problems.
* Added liftE as a synonym for fmap on Event.
* Expose Event constructors
* Add strictness annotations to integral to improve performance
* Added evalSF and initDelay functions (see haddock comments).

-}



{-# LANGUAGE BangPatterns, RankNTypes #-}

module Nettle.FRPControl.AFRP (
-- Re-exported module, classes, and types
    module Control.Arrow,
    module Nettle.FRPControl.AFRPVectorSpace,
    RandomGen(..),
    Random(..),

-- Reverse function composition and arrow plumbing aids
    ( # ),		-- :: (a -> b) -> (b -> c) -> (a -> c),	infixl 9
    dup,		-- :: a -> (a,a)
    swap,		-- :: (a,b) -> (b,a)

-- Main types
    Time,	-- [s] Both for time w.r.t. some reference and intervals.
    SF,		-- Signal Function.
    Event(..),	-- Events; conceptually similar to Maybe (but abstract).

-- Main instances
    -- SF is an instance of Arrow and ArrowLoop. Method instances:
    -- arr	:: (a -> b) -> SF a b
    -- (>>>)	:: SF a b -> SF b c -> SF a c
    -- (<<<)	:: SF b c -> SF a b -> SF a c
    -- first	:: SF a b -> SF (a,c) (b,c)
    -- second	:: SF a b -> SF (c,a) (c,b)
    -- (***)	:: SF a b -> SF a' b' -> SF (a,a') (b,b')
    -- (&&&)	:: SF a b -> SF a b' -> SF a (b,b')
    -- returnA	:: SF a a
    -- loop	:: SF (a,c) (b,c) -> SF a b

    -- Event is an instance of Functor, Eq, and Ord. Some method instances:
    -- fmap	:: (a -> b) -> Event a -> Event b
    -- (==)     :: Event a -> Event a -> Bool
    -- (<=)	:: Event a -> Event a -> Bool

-- Basic signal functions
    identity,		-- :: SF a a
    constant,		-- :: b -> SF a b
    localTime,		-- :: SF a Time
    time,               -- :: SF a Time,	Other name for localTime.

-- Initialization
    (-->),		-- :: b -> SF a b -> SF a b,		infixr 0
    (>--),		-- :: a -> SF a b -> SF a b,		infixr 0
    (-=>),              -- :: (b -> b) -> SF a b -> SF a b      infixr 0
    (>=-),              -- :: (a -> a) -> SF a b -> SF a b      infixr 0
    initially,		-- :: a -> SF a a

-- Basic event sources
    never, 		-- :: SF a (Event b)
    now,		-- :: b -> SF a (Event b)
    after,		-- :: Time -> b -> SF a (Event b)
    repeatedly,		-- :: Time -> b -> SF a (Event b)
    afterEach,		-- :: [(Time,b)] -> SF a (Event b)
    edge,		-- :: SF Bool (Event ())
    iEdge,		-- :: Bool -> SF Bool (Event ())
    edgeTag,		-- :: a -> SF Bool (Event a)
    edgeJust,		-- :: SF (Maybe a) (Event a)
    edgeBy,		-- :: (a -> a -> Maybe b) -> a -> SF a (Event b)

-- Stateful event suppression
    notYet,		-- :: SF (Event a) (Event a)
    once,		-- :: SF (Event a) (Event a)
    takeEvents,		-- :: Int -> SF (Event a) (Event a)
    dropEvents,		-- :: Int -> SF (Event a) (Event a)

-- Basic switchers
    switch,  dSwitch,	-- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
    rSwitch, drSwitch,	-- :: SF a b -> SF (a,Event (SF a b)) b
    kSwitch, dkSwitch,	-- :: SF a b
			--    -> SF (a,b) (Event c)
			--    -> (SF a b -> c -> SF a b)
			--    -> SF a b

-- Parallel composition and switching over collections with broadcasting
    parB,		-- :: Functor col => col (SF a b) -> SF a (col b)
    pSwitchB,dpSwitchB, -- :: Functor col =>
			--        col (SF a b)
			--	  -> SF (a, col b) (Event c)
			--	  -> (col (SF a b) -> c -> SF a (col b))
			--	  -> SF a (col b)
    rpSwitchB,drpSwitchB,-- :: Functor col =>
			--        col (SF a b)
			--	  -> SF (a, Event (col (SF a b)->col (SF a b)))
			--	        (col b)

-- Parallel composition and switching over collections with general routing
    par,		-- Functor col =>
    			--     (forall sf . (a -> col sf -> col (b, sf)))
    			--     -> col (SF b c)
    			--     -> SF a (col c)
    pSwitch, dpSwitch,  -- pSwitch :: Functor col =>
			--     (forall sf . (a -> col sf -> col (b, sf)))
			--     -> col (SF b c)
			--     -> SF (a, col c) (Event d)
			--     -> (col (SF b c) -> d -> SF a (col c))
			--     -> SF a (col c)
    rpSwitch,drpSwitch, -- Functor col =>
			--    (forall sf . (a -> col sf -> col (b, sf)))
    			--    -> col (SF b c)
			--    -> SF (a, Event (col (SF b c) -> col (SF b c)))
			--	    (col c)

-- Wave-form generation
    hold,		-- :: a -> SF (Event a) a
    trackAndHold,	-- :: a -> SF (Maybe a) a

-- Accumulators
    accum,		-- :: a -> SF (Event (a -> a)) (Event a)
    accumBy,		-- :: (b -> a -> b) -> b -> SF (Event a) (Event b)
    accumFilter,	-- :: (c -> a -> (c, Maybe b)) -> c
			--    -> SF (Event a) (Event b)

-- Delays
    pre,		-- :: SF a a
    iPre,		-- :: a -> SF a a

-- Integration and differentiation
    integral,		-- :: VectorSpace a s => SF a a
    derivative,		-- :: VectorSpace a s => SF a a		-- Crude!
    imIntegral,		-- :: VectorSpace a s => a -> SF a a

-- Loops with guaranteed well-defined feedback
    loopPre, 		-- :: c -> SF (a,c) (b,c) -> SF a b
    loopIntegral,	-- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b

-- Pointwise functions on events
    noEvent,		-- :: Event a
    noEventFst,		-- :: (Event a, b) -> (Event c, b)
    noEventSnd,		-- :: (a, Event b) -> (a, Event c)
    liftE,              -- :: (a -> b) -> Event a -> Event b    
    event, 		-- :: a -> (b -> a) -> Event b -> a
    fromEvent,		-- :: Monoid a => Event a -> a
    isEvent,		-- :: Event a -> Bool
    isNoEvent,		-- :: Event a -> Bool
    tag, 		-- :: Event a -> b -> Event b,		infixl 8
    attach,		-- :: Event a -> b -> Event (a, b),	infixl 8
    lMerge, 		-- :: Event a -> Event a -> Event a,	infixl 6
    rMerge,		-- :: Event a -> Event a -> Event a,	infixl 6
    merge,		-- :: Event a -> Event a -> Event a,	infixl 6
    mergeBy,		-- :: (a -> a -> a) -> Event a -> Event a -> Event a
    mapMerge,           -- :: (a -> c) -> (b -> c) -> (a -> b -> c) 
                        --    -> Event a -> Event b -> Event c
    mergeEvents,        -- :: [Event a] -> Event a
    mergeEventsBy,      -- :: (a -> a -> a) -> [Event a] -> Event a    
    catEvents,		-- :: [Event a] -> Event [a]
    joinE,		-- :: Event a -> Event b -> Event (a,b),infixl 7
    splitE,		-- :: Event (a,b) -> (Event a, Event b)
    filterE,	 	-- :: (a -> Bool) -> Event a -> Event a
    mapFilterE,		-- :: (a -> Maybe b) -> Event a -> Event b
    gate,		-- :: Event a -> Bool -> Event a,	infixl 8
    maybeToEvent,       -- :: Maybe a -> Event a    

-- Noise (random signal) sources and stochastic event sources
    noise,		-- :: noise :: (RandomGen g, Random b) =>
			--        g -> SF a b
    noiseR,		-- :: noise :: (RandomGen g, Random b) =>
			--        (b,b) -> g -> SF a b
    occasionally,	-- :: RandomGen g => g -> Time -> b -> SF a (Event b)

-- Reactimation
    reactimate,		-- :: IO a
	      		--    -> (Bool -> IO (DTime, Maybe a))
	      		--    -> (Bool -> b -> IO Bool)
              		--    -> SF a b
	      		--    -> IO ()
    ReactHandle,
    reactInit,          --    IO a -- init
                        --    -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
                        --    -> SF a b
                        --    -> IO (ReactHandle a b)
-- process a single input sample:
    react,              --    ReactHandle a b
                        --    -> (DTime,Maybe a)
                        --    -> IO Bool

-- Embedding (tentative: will be revisited)
    DTime,		-- [s] Sampling interval, always > 0.
    embed,		-- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
    embedSynch,		-- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
    deltaEncode,	-- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
    deltaEncodeBy 	-- :: (a -> a -> Bool) -> DTime -> [a]
			--    -> (a, [(DTime, Maybe a)])
    , evalSF            -- :: evalSF :: SF a b -> (a, [(DTime,a)]) -> [(DTime,b)]
    , initDelay         -- :: initDelay :: [a] -> SF a a 
) where

import Control.Monad (unless)
import System.Random (RandomGen(..), Random(..), randoms, randomRs)

import Control.Category (Category)
import qualified Control.Category as Cat
import Control.Arrow hiding ((<+>))
import Nettle.FRPControl.AFRPDiagnostics
import Nettle.FRPControl.AFRPMiscellany (( # ), dup, swap)
import Nettle.FRPControl.AFRPEvent
import Nettle.FRPControl.AFRPVectorSpace

import Data.IORef

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

------------------------------------------------------------------------------
-- Basic type definitions with associated utilities
------------------------------------------------------------------------------

-- The time type is really a bit boguous, since, as time passes, the minimal
-- interval between two consecutive floating-point-represented time points
-- increases. A better approach is probably to pick a reasonable resolution
-- and represent time and time intervals by Integer (giving the number of
-- "ticks").

-- Time is used both for time intervals (duration), and time w.r.t. some
-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0
-- or even negative.
type Time = Double	-- [s]


-- DTime is the time type for lengths of sample intervals. Conceptually,
-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the
-- same representation.

type DTime = Double	-- [s]


-- Representation of signal function in initial state.
-- (Naming: "TF" stands for Transition Function.)

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


-- Representation of signal function in running state.
-- It would have been nice to have a constructor SFId representing (arr id):
--
--     SFId {sfTF' :: DTime -> a -> Transition a b}
--
-- But it seems as if we need dependent types as soon as we try to exploit
-- that constructor (note that the type above is too general!), and a
-- work-around based on keeping around an extra function as a "proof" that we
-- can do the required coersions, yields codde which is no more efficient
-- than using SFArr in the first place.
-- (Naming: "TIVar" stands for "time-input-variable".)

data SF' a b 
    = SFConst {sfTF' :: DTime -> a -> Transition a b, sfCVal :: b}
    | SFArr   {sfTF' :: DTime -> a -> Transition a b, sfAFun :: a -> b}
    | SFTIVar {sfTF' :: DTime -> a -> Transition a b}


-- A transition is a pair of the next state (in the form of a signal
-- function) and the output at the present time step.

type Transition a b = (SF' a b, b)


-- "Smart" constructors. The corresponding "raw" constructors should not
-- be used directly for construction.

sfConst :: b -> SF' a b
sfConst b = sf
    where
	sf = SFConst {sfTF' = \_ _ -> (sf, b), sfCVal = b}


sfNever :: SF' a (Event b)
sfNever = sfConst NoEvent


sfId :: SF' a a
sfId = sf
    where
	sf = SFArr {sfTF' = \_ a -> (sf, a), sfAFun = id}


sfArr :: (a -> b) -> SF' a b
sfArr f = sf
    where
	sf = SFArr {sfTF' = \_ a -> (sf, f a), sfAFun = f}


-- Freezes a "running" signal function, i.e., turns it into a continuation in
-- the form of a plain signal function.
freeze :: SF' a b -> DTime -> SF a b
freeze sf dt = SF {sfTF = (sfTF' sf) dt}


freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)
freezeCol sfs dt = fmap (flip freeze dt) sfs


------------------------------------------------------------------------------
-- Arrow instance and implementation
------------------------------------------------------------------------------

instance Category SF where
    id = arrPrim id
    f . g = g `compPrim` f

instance Arrow SF where
    arr    = arrPrim
    first  = firstPrim
    second = secondPrim
    (***)  = parSplitPrim
    (&&&)  = parFanOutPrim

-- Lifting.
arrPrim :: (a -> b) -> SF a b
arrPrim f = SF {sfTF = \a -> (sfArr f, f a)}


-- Composition.
-- The definition exploits the following identities:
--     sf         >>> constant c = constant c
--     constant c >>> arr f      = constant (f c)
--     arr f      >>> arr g      = arr (g . f)
-- (It would have been nice to explit e.g. identity >>> sf = sf, but it would
-- seem that we need dependent types for that.)
compPrim :: SF a b -> SF b c -> SF a c
compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
	tf0 a0 = (cpAux sf1 sf2, c0)
	    where
		(sf1, b0) = tf10 a0
		(sf2, c0) = tf20 b0

	cpAux _ 	       sf2@(SFConst {}) = sfConst (sfCVal sf2)
	cpAux sf1@(SFConst {}) sf2              = cpAuxC1 (sfCVal sf1) sf2
	cpAux sf1@(SFArr {})   sf2              = cpAuxA1 (sfAFun sf1) sf2
	cpAux sf1              sf2@(SFArr {})   = cpAuxA2 sf1 (sfAFun sf2)
	cpAux sf1              sf2              = SFTIVar {sfTF' = tf}
	    where
	        tf dt a = (cpAux sf1' sf2', c)
		    where
		        (sf1', b) = (sfTF' sf1) dt a
			(sf2', c) = (sfTF' sf2) dt b

	cpAuxC1 _ (SFConst {sfCVal = c})   = sfConst c
	cpAuxC1 b (SFArr   {sfAFun = f2})  = sfConst (f2 b)
	cpAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
	    where
		tf dt _ = (cpAuxC1 b sf2', c)
		    where
			(sf2', c) = tf2 dt b

	cpAuxA1 _  (SFConst {sfCVal = c})   = sfConst c
	cpAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (f2 . f1)
	cpAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (cpAuxA1 f1 sf2', c)
		    where
			(sf2', c) = tf2 dt (f1 a)

	cpAuxA2 (SFConst {sfCVal = b})   f2 = sfConst (f2 b)
	cpAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (f2 . f1)
	cpAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (cpAuxA2 sf1' f2, f2 b)
		    where
			(sf1', b) = tf1 dt a


-- Widening.
-- The definition exploits the following identities:
--     first (constant b) = arr (\(_, c) -> (b, c))
--     (first (arr f))    = arr (\(a, c) -> (f a, c))
-- (It would have been nice to exploit first identity = identity, but it would
-- seem that we need dependent types for that.)
firstPrim :: SF a b -> SF (a,c) (b,c)
firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
	    where
		(sf1, b0) = tf10 a0 

	fpAux (SFConst {sfCVal = b}) = sfArr (\(~(_, c)) -> (b, c))
	fpAux (SFArr   {sfAFun = f}) = sfArr (\(~(a, c)) -> (f a, c))
	fpAux sf1                    = SFTIVar {sfTF' = tf}
	    where
	        tf dt ~(a, c) = (fpAux sf1', (b, c))
		    where
			(sf1', b) = (sfTF' sf1) dt a 


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

	spAux (SFConst {sfCVal = b}) = sfArr (\(~(c, _)) -> (c, b))
	spAux (SFArr   {sfAFun = f}) = sfArr (\(~(c, a)) -> (c, f a))
	spAux sf1                    = SFTIVar {sfTF' = tf}
	    where
	        tf dt ~(c, a) = (spAux sf1', (c, b))
		    where
			(sf1', b) = (sfTF' sf1) dt a 


-- Parallel composition.
-- The definition exploits the following identities (which hold for SF):
--     constant b *** constant d = constant (b, d)
--     constant b *** arr f2     = arr (\(_, c) -> (b, f2 c)
--     arr f1     *** constant d = arr (\(a, _) -> (f1 a, d)
--     arr f1     *** arr f2     = arr (\(a, b) -> (f1 a, f2 b)
parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)
parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
	tf0 ~(a0, c0) = (psAux sf1 sf2, (b0, d0))
	    where
		(sf1, b0) = tf10 a0 
		(sf2, d0) = tf20 c0 

	psAux sf1@(SFConst {}) sf2              = psAuxC1 (sfCVal sf1) sf2
	psAux sf1              sf2@(SFConst {}) = psAuxC2 sf1 (sfCVal sf2)
	psAux sf1@(SFArr {})   sf2              = psAuxA1 (sfAFun sf1) sf2
	psAux sf1              sf2@(SFArr   {}) = psAuxA2 sf1 (sfAFun sf2)
	psAux sf1	       sf2		= SFTIVar {sfTF' = tf}
	    where
		tf dt ~(a, c) = (psAux sf1' sf2', (b, d))
		    where
		        (sf1', b) = (sfTF' sf1) dt a
			(sf2', d) = (sfTF' sf2) dt c

	psAuxC1 b (SFConst {sfCVal = d})   = sfConst (b, d)
	psAuxC1 b (SFArr   {sfAFun = f2})  = sfArr (\(~(_, c)) -> (b, f2 c))
	psAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
	    where
		tf dt ~(_, c) = (psAuxC1 b sf2', (b, d))
		    where
			(sf2', d) = tf2 dt c

	psAuxC2 (SFConst {sfCVal = b})   d = sfConst (b, d)
	psAuxC2 (SFArr   {sfAFun = f1})  d = sfArr (\(~(a, _)) -> (f1 a, d))
	psAuxC2 (SFTIVar {sfTF'  = tf1}) d = SFTIVar {sfTF' = tf}
	    where
		tf dt ~(a, _) = (psAuxC2 sf1' d, (b, d))
		    where
			(sf1', b) = tf1 dt a

	psAuxA1 f1 (SFConst {sfCVal = d})   = sfArr (\(~(a,_)) -> (f1 a, d))
	psAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (\(~(a,c)) -> (f1 a, f2 c))
	psAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
	    where
		tf dt ~(a, c) = (psAuxA1 f1 sf2', (f1 a, d))
		    where
			(sf2', d) = tf2 dt c

	psAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\(~(_,c)) -> (b, f2 c))
	psAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\(~(a,c)) -> (f1 a, f2 c))
	psAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}
	    where
		tf dt ~(a, c) = (psAuxA2 sf1' f2, (b, f2 c))
		    where
			(sf1', b) = tf1 dt a


parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
	tf0 a0 = (pfoAux sf1 sf2, (b0, c0))
	    where
		(sf1, b0) = tf10 a0 
		(sf2, c0) = tf20 a0 

	pfoAux sf1@(SFConst {}) sf2              = pfoAuxC1 (sfCVal sf1) sf2
	pfoAux sf1              sf2@(SFConst {}) = pfoAuxC2 sf1 (sfCVal sf2)
	pfoAux sf1@(SFArr {})   sf2              = pfoAuxA1 (sfAFun sf1) sf2
	pfoAux sf1              sf2@(SFArr   {}) = pfoAuxA2 sf1 (sfAFun sf2)
	pfoAux sf1	        sf2		 = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (pfoAux sf1' sf2', (b, c))
		    where
		        (sf1', b) = (sfTF' sf1) dt a
			(sf2', c) = (sfTF' sf2) dt a

	pfoAuxC1 b (SFConst {sfCVal = c})   = sfConst (b, c)
	pfoAuxC1 b (SFArr   {sfAFun = f2})  = sfArr (\a -> (b, f2 a))
	pfoAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (pfoAuxC1 b sf2', (b, c))
		    where
			(sf2', c) = tf2 dt a

	pfoAuxC2 (SFConst {sfCVal = b})   c = sfConst (b, c)
	pfoAuxC2 (SFArr   {sfAFun = f1})  c = sfArr (\a -> (f1 a, c))
	pfoAuxC2 (SFTIVar {sfTF'  = tf1}) c = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (pfoAuxC2 sf1' c, (b, c))
		    where
			(sf1', b) = tf1 dt a

	pfoAuxA1 f1 (SFConst {sfCVal = c})   = sfArr (\a -> (f1 a, c))
	pfoAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (\a -> (f1 a ,f2 a))
	pfoAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (pfoAuxA1 f1 sf2', (f1 a, c))
		    where
			(sf2', c) = tf2 dt a

	pfoAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\a -> (b, f2 a))
	pfoAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\a -> (f1 a, f2 a))
	pfoAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (pfoAuxA2 sf1' f2, (b, f2 a))
		    where
			(sf1', b) = tf1 dt a


------------------------------------------------------------------------------
-- ArrowLoop instance and implementation
------------------------------------------------------------------------------

instance ArrowLoop SF where
    loop = loopPrim


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

        loopAux (SFConst {sfCVal = (b, _)}) = sfConst b
	loopAux (SFArr   {sfAFun = f1})     = sfArr (\a -> let (b,c) = f1 (a,c)
                                                           in b)
	loopAux sf1                         = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (loopAux sf1', b)
		    where
		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)


------------------------------------------------------------------------------
-- Basic signal functions
------------------------------------------------------------------------------

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


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


-- Outputs the time passed since the signal function instance was started.
localTime :: SF a Time
localTime = constant 1.0 >>> integral


-- Alternative name for localTime.
time :: SF a Time
time = localTime


------------------------------------------------------------------------------
-- Initialization
------------------------------------------------------------------------------

-- Initialization operator (cf. Lustre/Lucid Synchrone).
(-->) :: b -> SF a b -> SF a b
b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}


-- Input initialization operator.
(>--) :: a -> SF a b -> SF a b
a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}


-- Transform initial output value.
(-=>) :: (b -> b) -> SF a b -> SF a b
f -=> (SF {sfTF = tf10}) =
    SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}


-- Transform initial input value.
(>=-) :: (a -> a) -> SF a b -> SF a b
f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}


-- Override initial value of input signal.
initially :: a -> SF a a
initially = (--> identity)


------------------------------------------------------------------------------
-- Basic event sources
------------------------------------------------------------------------------

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


-- Event source with a single occurrence at time 0. The value of the event
-- is given by the function argument.
now :: b -> SF a (Event b)
now b0 = (Event b0 --> never)


-- Event source with a single occurrence at or as soon after (local) time q
-- as possible.
after :: Time -> b -> SF a (Event b)
after q x = afterEach [(q,x)]


-- Event source with repeated occurrences with interval q.
-- Note: If the interval is too short w.r.t. the sampling intervals,
-- the result will be that events occur at every sample. However, no more
-- than one event results from any sampling interval, thus avoiding an
-- "event backlog" should sampling become more frequent at some later
-- point in time.
repeatedly :: Time -> b -> SF a (Event b)
repeatedly q x | q > 0 = afterEach qxs
               | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."
    where
        qxs = (q,x):qxs        


-- Event source with consecutive occurrences at the given intervals.
-- Should more than one event be scheduled to occur in any sampling interval,
-- only the first will in fact occur to avoid an event backlog.
-- Question: Should positive periods except for the first one be required?
-- Note that periods of length 0 will always be skipped except for the first.
-- Right now, periods of length 0 is allowed on the grounds that no attempt
-- is made to forbid simultaneous events elsewhere.
afterEach :: [(Time,b)] -> SF a (Event b)
afterEach [] = never
afterEach ((q,x):qxs)
    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."
    | otherwise = SF {sfTF = tf0}
    where
	tf0 _ = if q <= 0 then
                    (scheduleNextEvent 0.0 qxs, Event x)
                else
		    (awaitNextEvent (-q) x qxs, NoEvent)

	scheduleNextEvent t [] = sfNever
        scheduleNextEvent t ((q,x):qxs)
	    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."
	    | t' >= 0   = scheduleNextEvent t' qxs
	    | otherwise = awaitNextEvent t' x qxs
	    where
	        t' = t - q
	awaitNextEvent t x qxs = SFTIVar {sfTF' = tf}
	    where
		tf dt _ | t' >= 0   = (scheduleNextEvent t' qxs, Event x)
		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)
		    where
		        t' = t + dt


-- A rising edge detector. Useful for things like detecting key presses.
-- Note that we initialize the loop with state set to True so that there
-- will not be an occurence at t0 in the logical time frame in which
-- this is started.
edge :: SF Bool (Event ())
edge = iEdge True


iEdge :: Bool -> SF Bool (Event ())
iEdge i = edgeBy (isBoolRaisingEdge ()) i


-- Like edge, but parameterized on the tag value.
edgeTag :: a -> SF Bool (Event a)
edgeTag a = edgeBy (isBoolRaisingEdge a) True


-- Internal utility.
isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a
isBoolRaisingEdge _ False False = Nothing
isBoolRaisingEdge a False True  = Just a
isBoolRaisingEdge _ True  True  = Nothing
isBoolRaisingEdge _ True  False = Nothing


-- Detects an edge where a maybe signal is changing from nothing to something.
edgeJust :: SF (Maybe a) (Event a)
edgeJust = edgeBy isJustEdge (Just undefined)
    where
        isJustEdge Nothing  Nothing     = Nothing
        isJustEdge Nothing  ma@(Just _) = ma
        isJustEdge (Just _) (Just _)    = Nothing
        isJustEdge (Just _) Nothing     = Nothing


-- Edge detector parameterized on the edge detection function and initial
-- state, i.e., the previous input sample. The first argument to the
-- edge detection function is the previous sample, the second the current one.

-- !!! Is this broken!?! Does not disallow an edge condition that persists
-- !!! between consecutive samples. See discussion in ToDo list above.

edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)
edgeBy isEdge a_init = SF {sfTF = tf0}
    where
	tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))

	ebAux a_prev = SFTIVar {sfTF' = tf}
	    where
		tf dt a = (ebAux a, maybeToEvent (isEdge a_prev a))


------------------------------------------------------------------------------
-- Stateful event suppression
------------------------------------------------------------------------------

-- Suppression of initial (at local time 0) event.
notYet :: SF (Event a) (Event a)
notYet = initially NoEvent


-- Suppress all but first event.
once :: SF (Event a) (Event a)
once = takeEvents 1


-- Suppress all but first n events.
takeEvents :: Int -> SF (Event a) (Event a)
takeEvents 0       = never
takeEvents (n + 1) = dSwitch (arr dup) (const (NoEvent >-- takeEvents n))


{-
-- More complicated using "switch" that "dSwitch".
takeEvents :: Int -> SF (Event a) (Event a)
takeEvents 0       = never
takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)
    where
        takeEvents' 0       a = now a
        takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)
-}


-- Suppress first n events.
-- Here dSwitch or switch does not really matter.
dropEvents :: Int -> SF (Event a) (Event a)
dropEvents 0       = identity
dropEvents (n + 1) = dSwitch (never &&& identity)
                             (const (NoEvent >-- dropEvents n))


------------------------------------------------------------------------------
-- Basic switchers
------------------------------------------------------------------------------

-- Basic switch.
switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
    where
	tf0 a0 =
	    case tf10 a0 of
	    	(sf1, (b0, NoEvent))  -> (switchAux sf1, b0)
		(_,   (_,  Event c0)) -> sfTF (k c0) a0

	switchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b
	switchAux (SFArr   {sfAFun = f1})           = switchAuxA1 f1
	switchAux sf1                               = SFTIVar {sfTF' = tf}
	    where
		tf dt a =
		    case (sfTF' sf1) dt a of
			(sf1', (b, NoEvent)) -> (switchAux sf1', b)
			(_,    (_, Event c)) -> sfTF (k c) a

	-- Note: While switch behaves as a stateless arrow at this point, that
	-- could change after a switch. Hence, SFTIVar overall.
	switchAuxA1 f1 = sf
	    where
		sf     = SFTIVar {sfTF' = tf}
		tf _ a =
		    case f1 a of
			(b, NoEvent) -> (sf, b)
			(_, Event c) -> sfTF (k c) a


-- Switch with delayed observation.
dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
    where
	tf0 a0 =
	    let (sf1, (b0, ec0)) = tf10 a0
            in (case ec0 of
                    NoEvent  -> dSwitchAux sf1
		    Event c0 -> fst (sfTF (k c0) a0),
                b0)

	dSwitchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b
	dSwitchAux (SFArr   {sfAFun = f1})           = dSwitchAuxA1 f1
	dSwitchAux sf1                               = SFTIVar {sfTF' = tf}
	    where
		tf dt a =
		    let (sf1', (b, ec)) = (sfTF' sf1) dt a
                    in (case ec of
			    NoEvent -> dSwitchAux sf1'
			    Event c -> fst (sfTF (k c) a),

			b)

	-- Note: While dSwitch behaves as a stateless arrow at this point, that
	-- could change after a switch. Hence, SFTIVar overall.
	dSwitchAuxA1 f1 = sf
	    where
		sf = SFTIVar {sfTF' = tf}
		tf _ a =
		    let (b, ec) = f1 a
                    in (case ec of
			    NoEvent -> sf
			    Event c -> fst (sfTF (k c) a),

			b)


-- Recurring switch.
rSwitch :: SF a b -> SF (a, Event (SF a b)) b
rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)

{-
-- Old version. New is more efficient. Which one is clearer?
rSwitch :: SF a b -> SF (a, Event (SF a b)) b
rSwitch sf = switch (first sf) rSwitch'
    where
        rSwitch' sf = switch (sf *** notYet) rSwitch'
-}


-- Recurring switch with delayed observation.
drSwitch :: SF a b -> SF (a, Event (SF a b)) b
drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)

{-
-- Old version. New is more efficient. Which one is clearer?
drSwitch :: SF a b -> SF (a, Event (SF a b)) b
drSwitch sf = dSwitch (first sf) drSwitch'
    where
        drSwitch' sf = dSwitch (sf *** notYet) drSwitch'
-}


-- "Call-with-current-continuation" switch.
kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
    where
        tf0 a0 =
	    let (sf1, b0) = tf10 a0
            in
	        case tfe0 (a0, b0) of
		    (sfe, NoEvent)  -> (kSwitchAux sf1 sfe, b0)
		    (_,   Event c0) -> sfTF (k sf10 c0) a0

        kSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1
        kSwitchAux sf1 sfe                          = SFTIVar {sfTF' = tf}
	    where
		tf dt a =
		    let	(sf1', b) = (sfTF' sf1) dt a
		    in
		        case (sfTF' sfe) dt (a, b) of
			    (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)
			    (_,    Event c) -> sfTF (k (freeze sf1 dt) c) a


-- kSwitch with delayed observation.
dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
    where
        tf0 a0 =
	    let (sf1, b0) = tf10 a0
            in (case tfe0 (a0, b0) of
		    (sfe, NoEvent)  -> dkSwitchAux sf1 sfe
		    (_,   Event c0) -> fst (sfTF (k sf10 c0) a0),
                b0)

        dkSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1
        dkSwitchAux sf1 sfe                          = SFTIVar {sfTF' = tf}
	    where
		tf dt a =
		    let	(sf1', b) = (sfTF' sf1) dt a
		    in (case (sfTF' sfe) dt (a, b) of
			    (sfe', NoEvent) -> dkSwitchAux sf1' sfe'
			    (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),
		        b)


------------------------------------------------------------------------------
-- Parallel composition and switching over collections with broadcasting
------------------------------------------------------------------------------

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


-- Spatial parallel composition of a signal function collection.
parB :: Functor col => col (SF a b) -> SF a (col b)
parB = par broadcast


-- Parallel switch (dynamic collection of signal functions spatially composed
-- in parallel).
pSwitchB :: Functor col =>
    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))
    -> SF a (col b)
pSwitchB = pSwitch broadcast


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


rpSwitchB :: Functor col =>
    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
rpSwitchB = rpSwitch broadcast


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


------------------------------------------------------------------------------
-- Parallel composition and switching over collections with general routing
------------------------------------------------------------------------------

-- Spatial parallel composition of a signal function collection parameterized
-- on the routing function.
-- rf .........	Routing function: determines the input to each signal function
--		in the collection. IMPORTANT! The routing function MUST
--		preserve the structure of the signal function collection.
-- sfs0 .......	Signal function collection.
-- Returns the spatial parallel composition of the supplied signal functions.

par :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF b c)
    -> SF a (col c)
par rf sfs0 = SF {sfTF = tf0}
    where
	tf0 a0 =
	    let bsfs0 = rf a0 sfs0
		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
		sfs   = fmap fst sfcs0
		cs0   = fmap snd sfcs0
	    in
		(parAux rf sfs, cs0)


-- Internal definition. Also used in parallel swithers.
parAux :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF' b c)
    -> SF' a (col c)
parAux rf sfs = SFTIVar {sfTF' = tf}
    where
	tf dt a = 
	    let bsfs  = rf a sfs
		sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
		sfs'  = fmap fst sfcs'
		cs    = fmap snd sfcs'
	    in
	        (parAux rf sfs', cs)


-- Parallel switch parameterized on the routing function. This is the most
-- general switch from which all other (non-delayed) switches in principle
-- can be derived. The signal function collection is spatially composed in
-- parallel and run until the event signal function has an occurrence. Once
-- the switching event occurs, all signal function are "frozen" and their
-- continuations are passed to the continuation function, along with the
-- event value.
-- rf .........	Routing function: determines the input to each signal function
--		in the collection. IMPORTANT! The routing function has an
--		obligation to preserve the structure of the signal function
--		collection.
-- sfs0 .......	Signal function collection.
-- sfe0 .......	Signal function generating the switching event.
-- k .......... Continuation to be invoked once event occurs.
-- Returns the resulting signal function.

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

	pSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs
	pSwitchAux sfs sfe = SFTIVar {sfTF' = tf}
	    where
		tf dt a =
		    let bsfs  = rf a sfs
			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
			sfs'  = fmap fst sfcs'
			cs    = fmap snd sfcs'
		    in
			case (sfTF' sfe) dt (a, cs) of
			    (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)
			    (_,    Event d) -> sfTF (k (freezeCol sfs dt) d) a


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

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


-- Recurring parallel switch parameterized on the routing function.
-- rf .........	Routing function: determines the input to each signal function
--		in the collection. IMPORTANT! The routing function has an
--		obligation to preserve the structure of the signal function
--		collection.
-- sfs ........	Initial signal function collection.
-- Returns the resulting signal function.

rpSwitch :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
rpSwitch rf sfs =
    pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
    noEventSnd >=- rpSwitch rf (f sfs')


{-
rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k
    where
	k sfs f = rpSwitch' (f sfs)
	rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k
-}

-- Recurring parallel switch with delayed observation parameterized on the
-- routing function.
drpSwitch :: Functor col =>
    (forall sf . (a -> col sf -> col (b, sf)))
    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
drpSwitch rf sfs =
    dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
    noEventSnd >=- drpSwitch rf (f sfs')

{-
drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k
    where
	k sfs f = drpSwitch' (f sfs)
	drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k
-}

------------------------------------------------------------------------------
-- Wave-form generation
------------------------------------------------------------------------------

-- Zero-order hold.
hold :: a -> SF (Event a) a
hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . hold)


-- Tracks input signal when available, holds last value when disappears.
trackAndHold :: a -> SF (Maybe a) a
trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init


------------------------------------------------------------------------------
-- Accumulators
------------------------------------------------------------------------------

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

accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)
    where
        abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)


{-
-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))
accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
accumBy f b_init = SF {sfTF = tf0}
    where
        tf0 NoEvent    = (abAux b_init, NoEvent) 
        tf0 (Event a0) = let b' = f b_init a0
		         in (abAux b', Event b')

        abAux b = SFTIVar {sfTF' = tf}
	    where
		tf _ NoEvent   = (abAux b, NoEvent)
		tf _ (Event a) = let b' = f b a
			         in (abAux b', Event b')
-}

{-
accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
accumFilter f c_init = SF {sfTF = tf0}
    where
        tf0 NoEvent    = (afAux c_init, NoEvent) 
        tf0 (Event a0) = case f c_init a0 of
		             (c', Nothing) -> (afAux c', NoEvent)
			     (c', Just b0) -> (afAux c', Event b0)

        afAux c = SFTIVar {sfTF' = tf}
	    where
		tf _ NoEvent   = (afAux c, NoEvent)
		tf _ (Event a) = case f c a of
			             (c', Nothing) -> (afAux c', NoEvent)
				     (c', Just b)  -> (afAux c', Event b)
-}


accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)
    where
        afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)
        afAux (c, Just b)  = switch (now b &&& notYet) $ \a -> afAux (f c a)


------------------------------------------------------------------------------
-- Delays
------------------------------------------------------------------------------

-- Uninitialized delay operator.
-- !!! The seq helps in the dynamic delay line example. But is it a good
-- !!! idea in general? Are there other accumulators which should be seq'ed
-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying
-- !!! design principle? What can the user assume?
pre = SF {sfTF = tf0}
    where
        tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")

	preAux a_prev = SFTIVar {sfTF' = tf}
	    where
		tf dt a = {- a_prev `seq` -} (preAux a, a_prev)


-- Initialized delay operator.
iPre :: a -> SF a a
iPre = (--> pre)


------------------------------------------------------------------------------
-- Integraltion and differentiation
------------------------------------------------------------------------------

-- Integration using the rectangle rule.
integral :: VectorSpace a s => SF a a
integral = SF {sfTF = tf0}
    where
        igrl0  = zeroVector

	tf0 a0 = (integralAux igrl0 a0, igrl0)

	integralAux !igrl !a_prev = SFTIVar {sfTF' = tf}
	    where
	        tf dt a = (integralAux igrl' a, igrl')
		    where
		       igrl' = igrl ^+^ realToFrac dt *^ a_prev



-- "immediate" integration (using the function's value at the current time)
imIntegral :: 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 = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)

{-
integral :: Fractional a => SF a a
integral = SF {sfTF = tf0}
    where
        igrl0  = 0.0

	tf0 a0 = (integralAux igrl0 a0, igrl0)

	integralAux igrl a_prev = SFTIVar {sfTF' = tf}
	    where
	        tf dt a = (integralAux igrl' a, igrl')
		    where
		       igrl' = igrl + a_prev * realToFrac dt
-}

-- This is extremely crude. Use at your own risk.
derivative :: VectorSpace a s => SF a a
derivative = SF {sfTF = tf0}
    where
	tf0 a0 = (derivativeAux a0, zeroVector)

	derivativeAux a_prev = SFTIVar {sfTF' = tf}
	    where
	        tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)


------------------------------------------------------------------------------
-- Loops with guaranteed well-defined feedback
------------------------------------------------------------------------------

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



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


------------------------------------------------------------------------------
-- Noise (i.e. random signal generators) and stochastic processes
------------------------------------------------------------------------------

-- Noise (random signal) with default range for type in question;
-- based on "randoms".
noise :: (RandomGen g, Random b) => g -> SF a b
noise g0 = streamToSF (randoms g0)


-- Noise (random signal) with specified range; based on "randomRs".
noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b
noiseR range g0 = streamToSF (randomRs range g0)


-- Internal. Not very useful for other purposes since we do not have any
-- control over the intervals between each "sample". Or? A version with
-- time-stamped samples would be similar to embedSynch (applied to identity).
-- The list argument must be a stream (infinite list) at present.

streamToSF :: [b] -> SF a b
streamToSF []     = intErr "AFRP" "streamToSF" "Empty list!"
streamToSF (b:bs) = SF {sfTF = tf0}
    where
        tf0 _ = (stsfAux bs, b)

        stsfAux []     = intErr "AFRP" "streamToSF" "Empty list!"
        stsfAux (b:bs) = SFTIVar {sfTF' = tf}
	    where
		tf _ _ = (stsfAux bs, b)


-- Stochastic event source with events occurring on average once every t_avg
-- seconds. However, no more than one event results from any one sampling
-- interval in the case of relatively sparse sampling, thus avoiding an
-- "event backlog" should sampling become more frequent at some later
-- point in time.
-- !!! Maybe it would better to give a frequency? But like this to make
-- !!! consitent with "repeatedly".
occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)
occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}
                       | otherwise = usrErr "AFRP" "occasionally"
				            "Non-positive average interval."
    where
	-- Generally, if events occur with an average frequency of f, the
	-- probability of at least one event occurring in an interval of t
        -- is given by (1 - exp (-f*t)). The goal in the following is to
	-- decide whether at least one event occurred in the interval of size
	-- dt preceding the current sample point. For the first point,
	-- we can think of the preceding interval as being 0, implying
	-- no probability of an event occurring.

	tf0 _ = (occAux ((randoms g) :: [Double]), NoEvent)

	occAux (r:rs) = SFTIVar {sfTF' = tf}
	    where
		tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at
			  in				-- least one event.
			      (occAux rs, if r < p then Event x else NoEvent)


------------------------------------------------------------------------------
-- Reactimation
------------------------------------------------------------------------------

-- Reactimation of a signal function.
-- init .......	IO action for initialization. Will only be invoked once,
--		at (logical) time 0, before first call to "sense".
--		Expected to return the value of input at time 0.
-- sense ......	IO action for sensing of system input.
--	arg. #1 .......	True: action may block, waiting for an OS event.
--			False: action must not block.
--	res. #1 .......	Time interval since previous invocation of the sensing
--			action (or, the first time round, the init action),
--			returned. The interval must be _strictly_ greater
--			than 0. Thus even a non-blocking invocation must
--			ensure that time progresses.
--	res. #2 .......	Nothing: input is unchanged w.r.t. the previously
--			returned input sample.
--			Just i: the input is currently i.
--			It is OK to always return "Just", even if input is
--			unchanged.
-- actuate ....	IO action for outputting the system output.
--	arg. #1 .......	True: output may have changed from previous output
--			sample.
--			False: output is definitely unchanged from previous
--			output sample.
--			It is OK to ignore argument #1 and assume that the
--			the output has always changed.
--	arg. #2 .......	Current output sample.
--	result .......	Termination flag. Once True, reactimate will exit
--			the reactimation loop and return to its caller.
-- sf .........	Signal function to reactimate.

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

-- An API for animating a signal function when some other library
-- needs to own the top-level control flow:

-- reactimate's state, maintained across samples:
data ReactState a b = ReactState {
    rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,
    rsSF :: SF' a b,
    rsA :: a,
    rsB :: b
  }	      

type ReactHandle a b = IORef (ReactState a b)

-- initialize top-level reaction handle
reactInit :: IO a -- init
             -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
             -> SF a b
             -> IO (ReactHandle a b)
reactInit init actuate (SF {sfTF = tf0}) = 
  do a0 <- init
     let (sf,b0) = tf0 a0
     -- TODO: really need to fix this interface, since right now we
     -- just ignore termination at time 0:
     r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,
				rsA = a0, rsB = b0 })
     done <- actuate r True b0
     return r

-- process a single input sample:
react :: ReactHandle a b
      -> (DTime,Maybe a)
      -> IO Bool
react rh (dt,ma') = 
  do rs@(ReactState {rsActuate = actuate,
	             rsSF = sf,
		     rsA = a,
		     rsB = b }) <- readIORef rh
     let a' = maybe a id ma'
         (sf',b') = (sfTF' sf) dt a'
     writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})
     done <- actuate rh True b'
     return done     


------------------------------------------------------------------------------
-- Embedding
------------------------------------------------------------------------------

-- New embed interface. We will probably have to revisit this. To run an
-- embedded signal function while retaining full control (e.g. start and
-- stop at will), one would probably need a continuation based interface
-- (as well as a continuation based underlying implementation).
--
-- E.g. here are interesting alternative (or maybe complementary)
-- signatures:
--
--    sample :: SF a b -> SF (Event a) (Event b)
--    sample' :: SF a b -> SF (Event (DTime, a)) (Event b)

embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
embed sf0 (a0, dtas) = b0 : loop a0 sf dtas
    where
	(sf, b0) = (sfTF sf0) a0

        loop a_prev sf [] = []
	loop a_prev sf ((dt, ma) : dtas) =
	    b : (a `seq` b `seq` (loop a sf' dtas))
	    where
		a        = maybe a_prev id ma
	        (sf', b) = (sfTF' sf) dt a


-- Synchronous embedding. The embedded signal function is run on the supplied
-- input and time stream at a given (but variable) ratio >= 0 to the outer
-- time flow. When the ratio is 0, the embedded signal function is paused.

-- !!! Should "dropped frames" be forced to avoid space leaks?
-- !!! It's kind of hard to se why, but "frame dropping" was a problem
-- !!! in the old robot simulator. Try to find an example!

embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}
    where
        tts       = scanl (\t (dt, _) -> t + dt) 0 dtas
	bbs@(b:_) = embed sf0 (a0, dtas)

	tf0 r = (esAux 0 (zip tts bbs), b)

	esAux _       []    = intErr "AFRP" "embedSynch" "Empty list!"
	esAux tp_prev tbtbs = SFTIVar {sfTF' = tf}
	    where
		tf dt r | r < 0     = usrErr "AFRP" "embedSynch"
					     "Negative ratio."
			| otherwise = let tp = tp_prev + dt * r
					  (b, tbtbs') = advance tp tbtbs
				      in
					  (esAux tp tbtbs', b)

		-- Advance the time stamped stream to the perceived time tp.
		-- Under the assumption that the perceived time never goes
		-- backwards (non-negative ratio), advance maintains the
		-- invariant that the perceived time is always >= the first
		-- time stamp.
		advance tp tbtbs@[(t, b)] = (b, tbtbs)
		advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))
		    | tp <  t' = (b, tbtbtbs)
		    | t' <= tp = advance tp tbtbs


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


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

-- | Evaluate the signal function.
evalSF :: SF a b               -- ^ Signal function to evaluate
          -> (a, [(DTime,a)])  -- ^ Initial value and sample times, with inputs
          -> [(DTime,b)]
evalSF sf0 (a0, tas) = (0, b0) : evalSF' sf' tas
    where (sf', b0) = sfTF sf0 a0
          evalSF' sf [] = []
          evalSF' sf ((dt,a):tas) = (dt,b) : evalSF' sf' tas
              where (sf', b) = sfTF' sf dt a

-- | Delay the input by the number of samples in the given list. The first samples
-- will be from the list, while the next samples will be from the input. Warning: this
-- operation only makes sense in the case when the sampling interval is constant, in which
-- case it implements a delay of @length xs * dt@ time units, where @dt@ is the sampling 
-- interval and @xs@ is the input list.
initDelay :: [a] -> SF a a 
initDelay [] = identity
initDelay (a:as) = SF sf0
    where sf0 a'       = (sfAux (as ++ [a']), a)
          sfAux (a:as) = SFTIVar (\_ a' -> (sfAux (as ++ [a']), a))