packages feed

cuboid 0.12 → 0.13

raw patch · 20 files changed

+5164/−12 lines, 20 filesdep +randomdep −Yampa

Dependencies added: random

Dependencies removed: Yampa

Files

+ FRP/Yampa.hs view
@@ -0,0 +1,3314 @@+{-# LANGUAGE GADTs, Rank2Types, CPP #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- New version using GADTs.+--+-- ToDo:+--+-- * Specialize def. of repeatedly. Could have an impact on invaders.+--+-- * New defs for accs using SFAcc+--+-- * Make sure opt worked: e.g.+--+--   >     repeatedly >>> count >>> arr (fmap sqr)+--+-- * Introduce SFAccHld.+--+-- * See if possible to unify AccHld wity Acc??? They are so close.+--+-- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would+--   have been possible without GADTs???+--+-- * Look into pairs. At least pairing of SScan ought to be interesting.+--+-- * Would be nice if we could get rid of first & second with impunity+--   thanks to Id optimizations. That's a clear win, with or without+--   an explicit pair combinator.+--+-- * delayEventCat is a bit complicated ...+--+--+-- Random ideas:+--+-- * What if one used rules to optimize+--   - (arr :: SF a ()) to (constant ())+--   - (arr :: SF a a) to identity+--   But inspection of invader source code seem to indicate that+--   these are not very common cases at all.+--+-- * It would be nice if it was possible to come up with opt. rules+--   that are invariant of how signal function expressions are+--   parenthesized. Right now, we have e.g.+--       arr f >>> (constant c >>> sf)+--   being optimized to+--       cpAuxA1 f (cpAuxC1 c sf)+--   whereas it clearly should be possible to optimize to just+--       cpAuxC1 c sf+--   What if we didn't use SF' but+--      SFComp :: <tfun> -> SF' a b -> SF' b c -> SF' a c+--   ???+--+-- * The transition function would still be optimized in (pretty much)+--   the current way, but it would still be possible to look "inside"+--   composed signal functions for lost optimization opts.+--   Seems to me this could be done without too much extra effort/no dupl.+--   work.+--   E.g. new cpAux, the general case:+--+-- @+--      cpAux sf1 sf2 = SFComp tf sf1 sf2+--          where+--              tf dt a = (cpAux sf1' sf2', c)+--                  where+--                      (sf1', b) = (sfTF' sf1) dt a+--                      (sf2', c) = (sfTF' sf2) dt b+-- @+--+-- * The ONLY change was changing the constructor from SF' to SFComp and+--   adding sf1 and sf2 to the constructor app.!+--+-- * An optimized case:+--     cpAuxC1 b sf1 sf2               = SFComp tf sf1 sf2+--   So cpAuxC1 gets an extra arg, and we change the constructor.+--   But how to exploit without writing 1000s of rules???+--   Maybe define predicates on SFComp to see if the first or second+--   sf are "interesting", and if so, make "reassociate" and make a+--   recursive call? E.g. we're in the arr case, and the first sf is another+--   arr, so we'd like to combine the two.+--+-- * It would also be intersting, then, to know when to STOP playing this+--   game, due to the overhead involved.+--+-- * Why don't we have a "SWITCH" constructor that indicates that the+--   structure will change, and thus that it is worthwile to keep+--   looking for opt. opportunities, whereas a plain "SF'" would+--   indicate that things NEVER are going to change, and thus we can just+--   as well give up?+-----------------------------------------------------------------------------------------++module FRP.Yampa (+-- Re-exported module, classes, and types+    module Control.Arrow,+    module FRP.Yampa.VectorSpace,+    RandomGen(..),+    Random(..),++-- 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).++-- Temporray!+    SF(..), sfTF', SF'(..),++-- 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++-- For optimization+    arrPrim, arrEPrim,++-- Basic signal functions+    identity,		-- :: SF a a+    constant,		-- :: b -> SF a b+    localTime,		-- :: SF a Time+    time,               -- :: SF a Time,	Other name for localTime.++-- Initialization+    (-->),		-- :: b -> SF a b -> SF a b,		infixr 0+    (>--),		-- :: a -> SF a b -> SF a b,		infixr 0+    (-=>),              -- :: (b -> b) -> SF a b -> SF a b      infixr 0+    (>=-),              -- :: (a -> a) -> SF a b -> SF a b      infixr 0+    initially,		-- :: a -> SF a a++-- Simple, stateful signal processing+    sscan,		-- :: (b -> a -> b) -> b -> SF a b+    sscanPrim,		-- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b++-- Basic event sources+    never, 		-- :: SF a (Event b)+    now,		-- :: b -> SF a (Event b)+    after,		-- :: Time -> b -> SF a (Event b)+    repeatedly,		-- :: Time -> b -> SF a (Event b)+    afterEach,		-- :: [(Time,b)] -> SF a (Event b)+    afterEachCat,       -- :: [(Time,b)] -> SF a (Event [b])+    delayEvent,		-- :: Time -> SF (Event a) (Event a)+    delayEventCat,	-- :: Time -> SF (Event a) (Event [a])+    edge,		-- :: SF Bool (Event ())+    iEdge,		-- :: Bool -> SF Bool (Event ())+    edgeTag,		-- :: a -> SF Bool (Event a)+    edgeJust,		-- :: SF (Maybe a) (Event a)+    edgeBy,		-- :: (a -> a -> Maybe b) -> a -> SF a (Event b)++-- Stateful event suppression+    notYet,		-- :: SF (Event a) (Event a)+    once,		-- :: SF (Event a) (Event a)+    takeEvents,		-- :: Int -> SF (Event a) (Event a)+    dropEvents,		-- :: Int -> SF (Event a) (Event a)++-- 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+    old_hold,		-- :: a -> SF (Event a) a+    hold,		-- :: a -> SF (Event a) a+    dHold,		-- :: a -> SF (Event a) a+    trackAndHold,	-- :: a -> SF (Maybe a) a++-- Accumulators+    old_accum,		-- :: a -> SF (Event (a -> a)) (Event a)+    old_accumBy,	-- :: (b -> a -> b) -> b -> SF (Event a) (Event b)+    old_accumFilter,	-- :: (c -> a -> (c, Maybe b)) -> c+    accum,		-- :: a -> SF (Event (a -> a)) (Event a)+    accumHold,		-- :: a -> SF (Event (a -> a)) a+    dAccumHold,		-- :: a -> SF (Event (a -> a)) a+    accumBy,		-- :: (b -> a -> b) -> b -> SF (Event a) (Event b)+    accumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b+    dAccumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b+    accumFilter,	-- :: (c -> a -> (c, Maybe b)) -> c+			--    -> SF (Event a) (Event b)++-- Delays+    old_pre, old_iPre,+    pre,		-- :: SF a a+    iPre,		-- :: a -> SF a a++-- Timed delays+    delay,		-- :: Time -> a -> SF a a++-- Integration and differentiation+    integral,		-- :: VectorSpace a s => SF a a++    derivative,		-- :: VectorSpace a s => SF a a		-- Crude!+    imIntegral,		-- :: VectorSpace a s => a -> SF a a++-- Loops with guaranteed well-defined feedback+    loopPre, 		-- :: c -> SF (a,c) (b,c) -> SF a b+    loopIntegral,	-- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b++-- Pointwise functions on events+    noEvent,		-- :: Event a+    noEventFst,		-- :: (Event a, b) -> (Event c, b)+    noEventSnd,		-- :: (a, Event b) -> (a, Event c)+    event, 		-- :: a -> (b -> a) -> Event b -> a+    fromEvent,		-- :: Event a -> a+    isEvent,		-- :: Event a -> Bool+    isNoEvent,		-- :: Event a -> Bool+    tag, 		-- :: Event a -> b -> Event b,		infixl 8+    tagWith,            -- :: b -> Event a -> Event b,+    attach,		-- :: Event a -> b -> Event (a, b),	infixl 8+    lMerge, 		-- :: Event a -> Event a -> Event a,	infixl 6+    rMerge,		-- :: Event a -> Event a -> Event a,	infixl 6+    merge,		-- :: Event a -> Event a -> Event a,	infixl 6+    mergeBy,		-- :: (a -> a -> a) -> Event a -> Event a -> Event a+    mapMerge,           -- :: (a -> c) -> (b -> c) -> (a -> b -> c) +                        --    -> Event a -> Event b -> Event c+    mergeEvents,        -- :: [Event a] -> Event a+    catEvents,		-- :: [Event a] -> Event [a]+    joinE,		-- :: Event a -> Event b -> Event (a,b),infixl 7+    splitE,		-- :: Event (a,b) -> (Event a, Event b)+    filterE,	 	-- :: (a -> Bool) -> Event a -> Event a+    mapFilterE,		-- :: (a -> Maybe b) -> Event a -> Event b+    gate,		-- :: Event a -> Bool -> Event a,	infixl 8++-- 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)])++) where++import Control.Monad (unless)+import System.Random (RandomGen(..), Random(..))++#if __GLASGOW_HASKELL__ >= 610+import qualified Control.Category (Category(..))+#else+#endif++import Control.Arrow+import FRP.Yampa.Diagnostics+import FRP.Yampa.Miscellany (( # ), dup, swap)+import FRP.Yampa.Event+import FRP.Yampa.VectorSpace++import Data.IORef++infixr 0 -->, >--, -=>, >=-++------------------------------------------------------------------------------+-- Basic type definitions with associated utilities+------------------------------------------------------------------------------++-- The time type is really a bit boguous, since, as time passes, the minimal+-- interval between two consecutive floating-point-represented time points+-- increases. A better approach might be to pick a reasonable resolution+-- and represent time and time intervals by Integer (giving the number of+-- "ticks").+--+-- That might also improve the timing of time-based event sources.+-- One might actually pick the overall resolution in reactimate,+-- to be passed down, possibly in the form of a global parameter+-- record, to all signal functions on initialization. (I think only+-- switch would need to remember the record, since it is the only place+-- where signal functions get started. So it wouldn't cost all that much.++-- Time is used both for time intervals (duration), and time w.r.t. some+-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0+-- or even negative.+type Time = Double	-- [s]+++-- DTime is the time type for lengths of sample intervals. Conceptually,+-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the+-- same representation.++type DTime = Double	-- [s]+++-- Representation of signal function in initial state.+-- (Naming: "TF" stands for Transition Function.)++data SF a b = SF {sfTF :: a -> Transition a b}+++-- Representation of signal function in "running" state.+--+-- Possibly better design for Inv.+--   Problem: tension between on the one hand making use of the+--   invariant property, and on the other keeping track of how something+--   has been constructed (SFCpAXA, in particular).+--   Idea: Add a boolean field to SFCpAXA and SF' that classifies+--   a signal function as being invarying.+--   A function sfIsInv computes to True for SFArr, SFAcc (and SFSScan,+--   possibly more), extracts the field in other cases.+--+--  Motivation for using a function (Event a -> b) in SFArrE+--  rather than (a -> Event b) or (a -> b) or even (Event a -> Event b).+--    The result type should be just "b" as opposed to "Event b" for+--    increased flexibility (e.g. matching "routing functions").+--    When the result type actually IS (Event b), and this fact is+--    exploitable, we'll be in a context where is it clear that+--    this is a fact, so we don't lose anything.+--    Since the idea is that the function is only going to be applied+--    when the there is an event, one could imagine the input type+--    just "a". But that's not the type of function we're given,+--    so it would have to be "massaged" a bit (precomposing with Event)+--    to fit. This will gain nothing, and potentially we will lose if+--    we actually need to recover the original function.+--    In fact, we sometimes really need to recover the original function+--    (e.g. currently in switch), and to do it correctly (also handling+--    NoEvent), we'd have to work quite hard introducing further+--    inefficiencies.+--  Summary: Make use of what we are given and only wrap things up later+--  when it is clear whatthe need is going to be, thus avoiding costly+--  "unwrapping".++-- GADTs needed in particular for SFEP, but also e.g. SFSScan+-- exploits them since there are more type vars than in the type con.+-- But one could use existentials for those.+++data SF' a b where+    SFArr   :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b+    -- The b is intentionally unstrict as the initial output sometimes+    -- is undefined (e.g. when defining pre). In any case, it isn't+    -- necessarily used and should thus not be forced.+    SFSScan :: !(DTime -> a -> Transition a b)+               -> !(c -> a -> Maybe (c, b)) -> !c -> b +               -> SF' a b+    SFEP   :: !(DTime -> Event a -> Transition (Event a) b)+              -> !(c -> a -> (c, b, b)) -> !c -> b+              -> SF' (Event a) b+    SFCpAXA :: !(DTime -> a -> Transition a d)+               -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d)+               -> SF' a d+    --  SFPair :: ...+    SF' :: !(DTime -> a -> Transition a b) -> SF' a b++-- A transition is a pair of the next state (in the form of a signal+-- function) and the output at the present time step.++type Transition a b = (SF' a b, b)+++sfTF' :: SF' a b -> (DTime -> a -> Transition a b)+sfTF' (SFArr tf _)       = tf+sfTF' (SFSScan tf _ _ _) = tf+sfTF' (SFEP tf _ _ _)    = tf+sfTF' (SFCpAXA tf _ _ _) = tf+sfTF' (SF' tf)           = tf+++-- !!! 2005-06-30+-- Unclear why, but the isInv mechanism seems to do more+-- harm than good.+-- Disable completely and see what happens.+{-+sfIsInv :: SF' a b -> Bool+-- sfIsInv _ = False+sfIsInv (SFArr _ _)           = True+-- sfIsInv (SFAcc _ _ _ _)       = True+sfIsInv (SFEP _ _ _ _)        = True+-- sfIsInv (SFSScan ...) = True+sfIsInv (SFCpAXA _ inv _ _ _) = inv+sfIsInv (SF' _ inv)           = inv+-}++-- "Smart" constructors. The corresponding "raw" constructors should not+-- be used directly for construction.++sfArr :: FunDesc a b -> SF' a b+sfArr FDI         = sfId+sfArr (FDC b)     = sfConst b+sfArr (FDE f fne) = sfArrE f fne+sfArr (FDG f)     = sfArrG f+++sfId :: SF' a a+sfId = sf+    where+	sf = SFArr (\_ a -> (sf, a)) FDI+++sfConst :: b -> SF' a b+sfConst b = sf+    where+	sf = SFArr (\_ _ -> (sf, b)) (FDC b)+++sfNever :: SF' a (Event b)+sfNever = sfConst NoEvent+++-- Assumption: fne = f NoEvent+sfArrE :: (Event a -> b) -> b -> SF' (Event a) b+sfArrE f fne = sf+    where+        sf  = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea))+                    (FDE f fne)++sfArrG :: (a -> b) -> SF' a b+sfArrG f = sf+    where+	sf = SFArr (\_ a -> (sf, f a)) (FDG f)+++sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b+sfSScan f c b = sf +    where+        sf = SFSScan tf f c b+	tf _ a = case f c a of+		     Nothing       -> (sf, b)+		     Just (c', b') -> (sfSScan f c' b', b')++sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b+sscanPrim f c_init b_init = SF {sfTF = tf0}+    where+        tf0 a0 = case f c_init a0 of+                     Nothing       -> (sfSScan f c_init b_init, b_init)+	             Just (c', b') -> (sfSScan f c' b', b')+++-- The event-processing function *could* accept the present NoEvent+-- output as an extra state argument. That would facilitate composition+-- of event-processing functions somewhat, but would presumably incur an+-- extra cost for the more common and simple case of non-composed event+-- processors.+-- +sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b+sfEP f c bne = sf+    where+        sf = SFEP (\_ ea -> case ea of+                                 NoEvent -> (sf, bne)+                                 Event a -> let+                                                (c', b, bne') = f c a+                                            in+                                                (sfEP f c' bne', b))+                  f+                  c+                  bne+++-- epPrim is used to define hold, accum, and other event-processing+-- functions.+epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b+epPrim f c bne = SF {sfTF = tf0}+    where+        tf0 NoEvent   = (sfEP f c bne, bne)+        tf0 (Event a) = let+                            (c', b, bne') = f c a+                        in+                            (sfEP f c' bne', b)+++{-+-- !!! Maybe something like this?+-- !!! But one problem is that the invarying marking would be lost+-- !!! if the signal function is taken apart and re-constructed from+-- !!! the function description and subordinate signal function in+-- !!! cases like SFCpAXA.+sfMkInv :: SF a b -> SF a b+sfMkInv sf = SF {sfTF = ...}++    sfMkInvAux :: SF' a b -> SF' a b+    sfMkInvAux sf@(SFArr _ _) = sf+    -- sfMkInvAux sf@(SFAcc _ _ _ _) = sf+    sfMkInvAux sf@(SFEP _ _ _ _) = sf+    sfMkInvAux sf@(SFCpAXA tf inv fd1 sf2 fd3)+	| inv       = sf+	| otherwise = SFCpAXA tf' True fd1 sf2 fd3+        where+            tf' = \dt a -> let (sf', b) = tf dt a in (sfMkInvAux sf', b)+    sfMkInvAux sf@(SF' tf inv)+        | inv       = sf+        | otherwise = SF' tf' True+            tf' = ++-}++-- Motivation for event-processing function type+-- (alternative would be function of type a->b plus ensuring that it+-- only ever gets invoked on events):+-- * Now we need to be consistent with other kinds of arrows.+-- * We still want to be able to get hold of the original function.+-- 2005-02-30: OK, for FDE, invarant is that the field of type b =+-- f NoEvent.++data FunDesc a b where+    FDI :: FunDesc a a					-- Identity function+    FDC :: b -> FunDesc a b				-- Constant function+    FDE :: (Event a -> b) -> b -> FunDesc (Event a) b	-- Event-processing fun+    FDG :: (a -> b) -> FunDesc a b			-- General function++fdFun :: FunDesc a b -> (a -> b)+fdFun FDI       = id+fdFun (FDC b)   = const b+fdFun (FDE f _) = f+fdFun (FDG f)   = f++fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c+fdComp FDI           fd2     = fd2+fdComp fd1           FDI     = fd1+fdComp (FDC b)       fd2     = FDC ((fdFun fd2) b)+fdComp _             (FDC c) = FDC c+-- Hardly worth the effort?+-- 2005-03-30: No, not only not worth the effort as the only thing saved+-- would be an application of f2. Also wrong since current invariant does+-- not imply that f1ne = NoEvent. Moreover, we cannot really adopt that+-- invariant as it is not totally impossible for a user to create a function+-- that breaks it.+-- fdComp (FDE f1 f1ne) (FDE f2 f2ne) =+--    FDE (f2 . f1) (vfyNoEvent (f1 NoEvent) f2ne)+fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne)+    where+        f2 = fdFun fd2+fdComp (FDG f1) (FDE f2 f2ne) = FDG f+    where+        f a = case f1 a of+                  NoEvent -> f2ne+                  f1a     -> f2 f1a+fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1)+++fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d)+fdPar FDI     FDI     = FDI+fdPar FDI     (FDC d) = FDG (\(~(a, _)) -> (a, d))+fdPar FDI     fd2     = FDG (\(~(a, c)) -> (a, (fdFun fd2) c))+fdPar (FDC b) FDI     = FDG (\(~(_, c)) -> (b, c))+fdPar (FDC b) (FDC d) = FDC (b, d)+fdPar (FDC b) fd2     = FDG (\(~(_, c)) -> (b, (fdFun fd2) c))+fdPar fd1     fd2     = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c))+++fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c)+fdFanOut FDI     FDI     = FDG dup+fdFanOut FDI     (FDC c) = FDG (\a -> (a, c))+fdFanOut FDI     fd2     = FDG (\a -> (a, (fdFun fd2) a))+fdFanOut (FDC b) FDI     = FDG (\a -> (b, a))+fdFanOut (FDC b) (FDC c) = FDC (b, c)+fdFanOut (FDC b) fd2     = FDG (\a -> (b, (fdFun fd2) a))+fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne+    where+       f1f2 NoEvent      = f1f2ne+       f1f2 ea@(Event _) = (f1 ea, f2 ea)++       f1f2ne = (f1ne, f2ne)+fdFanOut fd1 fd2 =+    FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))+++-- Verifies that the first argument is NoEvent. Returns the value of the+-- second argument that is the case. Raises an error otherwise.+-- Used to check that functions on events do not map NoEvent to Event+-- wherever that assumption is exploited.+vfyNoEv :: Event a -> b -> b+vfyNoEv NoEvent b = b+vfyNoEv _       _  = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."+++-- Freezes a "running" signal function, i.e., turns it into a continuation in+-- the form of a plain signal function.+freeze :: SF' a b -> DTime -> SF a b+freeze sf dt = SF {sfTF = (sfTF' sf) dt}+++freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)+freezeCol sfs dt = fmap (flip freeze dt) sfs+++------------------------------------------------------------------------------+-- Arrow instance and implementation+------------------------------------------------------------------------------+#if __GLASGOW_HASKELL__ >= 610+instance Control.Category.Category SF where+     (.) = flip compPrim +     id = SF $ \x -> (sfId,x)+#else+#endif++instance Arrow SF where+    arr    = arrPrim+    first  = firstPrim+    second = secondPrim+    (***)  = parSplitPrim+    (&&&)  = parFanOutPrim+#if __GLASGOW_HASKELL__ >= 610+#else+    (>>>)  = compPrim+#endif+++-- Lifting.+{-# NOINLINE arrPrim #-}+arrPrim :: (a -> b) -> SF a b+arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}+++{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-}++arrEPrim :: (Event a -> b) -> SF (Event a) b+arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}+++-- Composition.+-- The definition exploits the following identities:+--     sf         >>> identity   = sf				-- New+--     identity   >>> sf         = sf				-- New+--     sf         >>> constant c = constant c+--     constant c >>> arr f      = constant (f c)+--     arr f      >>> arr g      = arr (g . f)+--+-- !!! Notes/Questions:+-- !!! How do we know that the optimizations terminate?+-- !!! Probably by some kind of size argument on the SF tree.+-- !!! E.g. (Hopefully) all compPrim optimizations are such that+-- !!! the number of compose nodes decrease.+-- !!! Should verify this!+--+-- !!! There is a tension between using SFInv to signal to superior+-- !!! signal functions that the subordinate signal function will not+-- !!! change form, and using SFCpAXA to allow fusion in the context+-- !!! of some suitable superior signal function.+compPrim :: SF a b -> SF b c -> SF a c+compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+    where+	tf0 a0 = (cpXX sf1 sf2, c0)+	    where+		(sf1, b0) = tf10 a0+		(sf2, c0) = tf20 b0++-- The following defs are not local to compPrim because cpAXA needs to be+-- called from parSplitPrim.+-- Naming convention: cp<X><Y> where  <X> and <Y> is one of:+-- X - arbitrary signal function+-- A - arbitrary pure arrow+-- C - constant arrow+-- E - event-processing arrow+-- G - arrow known not to be identity, constant (C) or+--     event-processing (E).++cpXX :: SF' a b -> SF' b c -> SF' a c+cpXX (SFArr _ fd1)       sf2               = cpAX fd1 sf2+cpXX sf1                 (SFArr _ fd2)     = cpXA sf1 fd2+{-+-- !!! 2005-07-07: Too strict.+-- !!! But the question is if it is worth to define pre in terms of sscan ...+-- !!! It is slower than the simplest possible pre, and the kind of coding+-- !!! required to ensure that the laziness props of the second SF are+-- !!! preserved might just slow things down further ...+cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =+    sfSScan f (s1, b, s2, c) c+    where+        f (s1, b, s2, c) a =+            case f1 s1 a of+                Nothing ->+                    case f2 s2 b of+                        Nothing        -> Nothing+                        Just (s2', c') -> Just ((s1, b, s2', c'), c')+                Just (s1', b') ->+                    case f2 s2 b' of+                        Nothing        -> Just ((s1', b', s2, c), c)+                        Just (s2', c') -> Just ((s1', b', s2', c'), c')+-}+-- !!! 2005-07-07: Indeed, this is a bit slower than the code above (14%).+-- !!! But both are better than not composing (35% faster and 26% faster)!+cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =+    sfSScan f (s1, b, s2, c) c+    where+        f (s1, b, s2, c) a =+            let+                (u, s1',  b') = case f1 s1 a of+                                    Nothing       -> (True, s1, b)+                                    Just (s1',b') -> (False,  s1', b')+            in+                case f2 s2 b' of+                    Nothing | u         -> Nothing+                            | otherwise -> Just ((s1', b', s2, c), c)+                    Just (s2', c') -> Just ((s1', b', s2', c'), c')+cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) =+    sfSScan f (s1, eb, s2, cne) cne+    where+        f (s1, eb, s2, cne) a =+            case f1 s1 a of+                Nothing ->+                    case eb of+                        NoEvent -> Nothing+                        Event b ->+                            let (s2', c, cne') = f2 s2 b+                            in+                                Just ((s1, eb, s2', cne'), c)+                Just (s1', eb') ->+                    case eb' of+                        NoEvent -> Just ((s1', eb', s2, cne), cne)+                        Event b ->+                            let (s2', c, cne') = f2 s2 b+                            in+                                Just ((s1', eb', s2', cne'), c)+-- !!! 2005-07-09: This seems to yield only a VERY marginal speedup+-- !!! without seq. With seq, substantial speedup!+cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) =+    sfSScan f (s1, bne, s2, c) c+    where+        f (s1, bne, s2, c) ea =+            let (u, s1', b', bne') = case ea of+                                         NoEvent -> (True, s1, bne, bne)+                                         Event a ->+                                             let (s1', b, bne') = f1 s1 a+                                             in+                                                  (False, s1', b, bne')+            in+                case f2 s2 b' of+                    Nothing | u         -> Nothing+                            | otherwise -> Just (seq s1' (s1', bne', s2, c), c)+                    Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c')+-- The function "f" is invoked whenever an event is to be processed. It then+-- computes the output, the new state, and the new NoEvent output.+-- However, when sequencing event processors, the ones in the latter+-- part of the chain may not get invoked since previous ones may+-- decide not to "fire". But a "new" NoEvent output still has to be+-- produced, i.e. the old one retained. Since it cannot be computed by+-- invoking the last event-processing function in the chain, it has to+-- be remembered. Since the composite event-processing function remains+-- constant/unchanged, the NoEvent output has to be part of the state.+-- An alternarive would be to make the event-processing function take an+-- extra argument. But that is likely to make the simple case more+-- expensive. See note at sfEP.+cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) =+    sfEP f (s1, s2, cne) (vfyNoEv bne cne)+    where+	f (s1, s2, cne) a =+	    case f1 s1 a of+		(s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)+		(s1', Event b, NoEvent) ->+		    let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne')+                _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event."+-- !!! 2005-06-28: Why isn't SFCpAXA (FDC ...) checked for?+-- !!! No invariant rules that out, and it would allow to drop the+-- !!! event processor ... Does that happen elsewhere?+cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =+    cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)+-- f21 will (hopefully) be invoked less frequently if merged with the+-- event processor.+cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) =+    cpXX (cpXG sf1 f21) (cpXA sf22 fd23)+-- Only functions whose domain is known to be Event can be merged+-- from the left with event processors.+cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) =+    cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) +-- !!! Other cases to look out for:+-- !!! any sf >>> SFCpAXA = SFCpAXA if first arr is const.+-- !!! But the following will presumably not work due to type restrictions.+-- !!! Need to reconstruct sf2 I think.+-- cpXX sf1 sf2@(SFCpAXA _ _ (FDC b) sf22 fd23) = sf2+cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =+    -- Termination: The first argument to cpXX is no larger than+    -- the current first argument, and the second is smaller.+    cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23+-- !!! 2005-06-27: The if below accounts for a significant slowdown.+-- !!! One would really like a cheme where opts only take place+-- !!! after a structural change ... +-- cpXX sf1 sf2 = cpXXInv sf1 sf2+-- cpXX sf1 sf2 = cpXXAux sf1 sf2+cpXX sf1 sf2 = SF' tf --  False+    -- if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False+    where+        tf dt a = (cpXX sf1' sf2', c)+	    where+	        (sf1', b) = (sfTF' sf1) dt a+		(sf2', c) = (sfTF' sf2) dt b+++{-+cpXXAux sf1@(SF' _ _) sf2@(SF' _ _) = SF' tf False+    where+        tf dt a = (cpXXAux sf1' sf2', c)+	    where+	        (sf1', b) = (sfTF' sf1) dt a+		(sf2', c) = (sfTF' sf2) dt b+cpXXAux sf1 sf2 = SF' tf False+    where+        tf dt a = (cpXXAux sf1' sf2', c)+	    where+	        (sf1', b) = (sfTF' sf1) dt a+		(sf2', c) = (sfTF' sf2) dt b+-}++{-+cpXXAux sf1 sf2 | unsimplifiable sf1 sf2 = SF' tf False+                | otherwise = cpXX sf1 sf2+    where+        tf dt a = (cpXXAux sf1' sf2', c)+	    where+	        (sf1', b) = (sfTF' sf1) dt a+		(sf2', c) = (sfTF' sf2) dt b++        unsimplifiable sf1@(SF' _ _) sf2@(SF' _ _) = True+        unsimplifiable sf1           sf2           = True+-}+                     +{-+-- wrong ...+cpXXAux sf1@(SF' _ False)           sf2                         = SF' tf False+cpXXAux sf1@(SFCpAXA _ False _ _ _) sf2                         = SF' tf False+cpXXAux sf1                         sf2@(SF' _ False)           = SF' tf False+cpXXAux sf1                         sf2@(SFCpAXA _ False _ _ _) = SF' tf False+cpXXAux sf1 sf2 =+    if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False+    where+        tf dt a = (cpXXAux sf1' sf2', c)+	    where+	        (sf1', b) = (sfTF' sf1) dt a+		(sf2', c) = (sfTF' sf2) dt b+-}++{-+cpXXInv sf1 sf2 = SF' tf True+    where+        tf dt a = sf1 `seq` sf2 `seq` (cpXXInv sf1' sf2', c)+	    where+	        (sf1', b) = (sfTF' sf1) dt a+		(sf2', c) = (sfTF' sf2) dt b+-}++-- !!! No. We need local defs. Keep fd1 and fd2. Extract f1 and f2+-- !!! once and fo all. Get rid of FDI and FDC at the top level.+-- !!! First local def. analyse sf2. SFArr, SFAcc etc. tf in+-- !!! recursive case just make use of f1 and f3.+-- !!! if sf2 is SFInv, that's delegated to a second local+-- !!! recursive def. that does not analyse sf2.++cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d+-- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2+-- is SFCpAXA, and then on the embedded sf and hence on a smaller arg.+cpAXA FDI     sf2 fd3     = cpXA sf2 fd3+cpAXA fd1     sf2 FDI     = cpAX fd1 sf2+cpAXA (FDC b) sf2 fd3     = cpCXA b sf2 fd3+cpAXA _       _   (FDC d) = sfConst d        +cpAXA fd1     sf2 fd3     = +    cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2+    where+        -- Really: cpAXAAux :: SF' b c -> SF' a d+	-- Note: Event cases are not optimized (EXA etc.)+        cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d)+                    -> SF' b c -> SF' a d+        cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) =+            sfArr (fdComp (fdComp fd1 fd2) fd3)+        cpAXAAux fd1 _ fd3 _ sf2@(SFSScan _ _ _ _) =+            cpAX fd1 (cpXA sf2 fd3)+        cpAXAAux fd1 _ fd3 _ sf2@(SFEP _ _ _ _) =+            cpAX fd1 (cpXA sf2 fd3)+        cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) =+            cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3)+        cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3+{-+            if sfIsInv sf2 then+		cpAXAInv fd1 f1 fd3 f3 sf2+	    else+		SFCpAXA tf False fd1 sf2 fd3+-}+	    where+		tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)+		    where+			(sf2', c) = (sfTF' sf2) dt (f1 a)++{-+	cpAXAInv fd1 f1 fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3+	    where+		tf dt a = sf2 `seq` (cpAXAInv fd1 f1 fd3 f3 sf2', f3 c)+		    where+			(sf2', c) = (sfTF' sf2) dt (f1 a)+-}++cpAX :: FunDesc a b -> SF' b c -> SF' a c+cpAX FDI           sf2 = sf2+cpAX (FDC b)       sf2 = cpCX b sf2+cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2+cpAX (FDG f1)      sf2 = cpGX f1 sf2++cpXA :: SF' a b -> FunDesc b c -> SF' a c+cpXA sf1 FDI           = sf1+cpXA _   (FDC c)       = sfConst c+cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne+cpXA sf1 (FDG f2)      = cpXG sf1 f2++-- Don't forget that the remaining signal function, if it is+-- SF', later could turn into something else, like SFId.+cpCX :: b -> SF' b c -> SF' a c+cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)+-- 2005-07-01:  If we were serious about the semantics of sscan being required+-- to be independent of the sampling interval, I guess one could argue for a+-- fixed-point computation here ... Or maybe not.+-- cpCX b (SFSScan _ _ _ _) = sfConst <fixed point comp>+cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c+cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne)+cpCX b (SFCpAXA _ fd21 sf22 fd23) =+    cpCXA ((fdFun fd21) b) sf22 fd23+cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI+{-+    if sfIsInv sf2 then+        cpCXInv b sf2+    else+	SFCpAXA tf False (FDC b) sf2 FDI+-}+    where+	tf dt _ = (cpCX b sf2', c)+	    where+		(sf2', c) = (sfTF' sf2) dt b+++{-+cpCXInv b sf2 = SFCpAXA tf True (FDC b) sf2 FDI+    where+	tf dt _ = sf2 `seq` (cpCXInv b sf2', c)+	    where+		(sf2', c) = (sfTF' sf2) dt b+-}+++cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d+cpCXA b sf2 FDI     = cpCX b sf2+cpCXA _ _   (FDC c) = sfConst c+cpCXA b sf2 fd3     = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2+    where+        -- fd1 = FDC b+        -- f3  = fdFun fd3++	-- Really: SF' b c -> SF' a d+        cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d)+                    -> SF' b c -> SF' a d+        cpCXAAux _ b _ f3 (SFArr _ fd2)     = sfConst (f3 ((fdFun fd2) b))+        cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c)+            where+	        f' s _ = case f s b of+                             Nothing -> Nothing+                             Just (s', c') -> Just (s', f3 c') +        cpCXAAux _ b _   f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne))+        cpCXAAux _ b fd3 _  (SFCpAXA _ fd21 sf22 fd23) =+	    cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3)+	cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3+{-+	    if sfIsInv sf2 then+		cpCXAInv fd1 b fd3 f3 sf2+            else+	        SFCpAXA tf False fd1 sf2 fd3+-}+	    where+		tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)+		    where+			(sf2', c) = (sfTF' sf2) dt b++{-+        -- For some reason, seq on sf2' in tf is faster than making+        -- cpCXAInv strict in sf2 by seq-ing on the top level (which would+	-- be similar to pattern matching on sf2).+	cpCXAInv fd1 b fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3+	    where+		tf dt _ = sf2 `seq` (cpCXAInv fd1 b fd3 f3 sf2', f3 c)+		    where+			(sf2', c) = (sfTF' sf2) dt b+-}+++cpGX :: (a -> b) -> SF' b c -> SF' a c+cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2+    where+	cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c+	cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)+        -- We actually do know that (fdComp (FDG f1) fd21) is going to+	-- result in an FDG. So we *could* call a cpGXA here. But the+	-- price is "inlining" of part of fdComp.+        cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c+        -- We really shouldn't see an EP here, as that would mean+        -- an arrow INTRODUCING events ...+	cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =+	    cpAXA (fdComp fd1 fd21) sf22 fd23+	cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI+{-+	    if sfIsInv sf2 then+	        cpGXInv fd1 f1 sf2+	    else+	        SFCpAXA tf False fd1 sf2 FDI+-}+	    where+		tf dt a = (cpGXAux fd1 f1 sf2', c)+		    where+			(sf2', c) = (sfTF' sf2) dt (f1 a)++{-+	cpGXInv fd1 f1 sf2 = SFCpAXA tf True fd1 sf2 FDI+	    where+		tf dt a = sf2 `seq` (cpGXInv fd1 f1 sf2', c)+		    where+			(sf2', c) = (sfTF' sf2) dt (f1 a)+-}+++cpXG :: SF' a b -> (b -> c) -> SF' a c+cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1+    where+	-- Really: cpXGAux :: SF' a b -> SF' a c+	cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c+	cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)+        cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b)+            where+	        f' s a = case f s a of+                             Nothing -> Nothing+                             Just (s', b') -> Just (s', f2 b') +        cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne)+            where+                f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne')+	cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) =+            cpAXA fd11 sf12 (fdComp fd22 fd2)+	cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2+{-+	    if sfIsInv sf1 then+		cpXGInv fd2 f2 sf1+	    else+		SFCpAXA tf False FDI sf1 fd2+-}+	    where+		tf dt a = (cpXGAux fd2 f2 sf1', f2 b)+		    where+			(sf1', b) = (sfTF' sf1) dt a++{-+	cpXGInv fd2 f2 sf1 = SFCpAXA tf True FDI sf1 fd2+	    where+		tf dt a = (cpXGInv fd2 f2 sf1', f2 b)+		    where+			(sf1', b) = (sfTF' sf1) dt a+-}++cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c+cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2+    where+	cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b +                   -> SF' b c -> SF' (Event a) c+	cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)+        cpEXAux _ f1 _   (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c+        -- We must not capture cne in the f closure since cne can change!+        -- See cpXX the SFEP/SFEP case for a similar situation. However,+        -- FDE represent a state-less signal function, so *its* NoEvent+        -- value never changes. Hence we only need to verify that it is+        -- NoEvent once.+	cpEXAux _ f1 f1ne (SFEP _ f2 s cne) =+	    sfEP f (s, cne) (vfyNoEv f1ne cne)+            where+                f scne@(s, cne) a =+                    case (f1 (Event a)) of+                        NoEvent -> (scne, cne, cne)+                        Event b ->+                            let (s', c, cne') = f2 s b in ((s', cne'), c, cne')+	cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) =+            cpAXA (fdComp fd1 fd21) sf22 fd23+        -- The rationale for the following is that the case analysis+	-- is typically not going to be more expensive than applying+	-- the function and possibly a bit cheaper. Thus if events+	-- are sparse, we might win, and if not, we don't loose to+	-- much.+	cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI+{-+	    if sfIsInv sf2 then+		cpEXInv fd1 f1 f1ne sf2+	    else+	    	SFCpAXA tf False fd1 sf2 FDI+-}+	    where+		tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c)+		    where+                        (sf2', c) =+			    case ea of+				NoEvent -> (sfTF' sf2) dt f1ne+				_       -> (sfTF' sf2) dt (f1 ea)++{-+	cpEXInv fd1 f1 f1ne sf2 = SFCpAXA tf True fd1 sf2 FDI+	    where+		tf dt ea = sf2 `seq` (cpEXInv fd1 f1 f1ne sf2', c)+		    where+                        (sf2', c) =+			    case ea of+				NoEvent -> (sfTF' sf2) dt f1ne+				_       -> (sfTF' sf2) dt (f1 ea)+-}++cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c+cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1+    where+	cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c+		   -> SF' a (Event b) -> SF' a c+        cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)+        cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb)+            where+	        f' s a = case f s a of+                             Nothing -> Nothing+                             Just (s', NoEvent) -> Just (s', f2ne) +                             Just (s', eb')     -> Just (s', f2 eb') +        cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) =+	    sfEP f s (vfyNoEv ebne f2ne)+            where+                f s a =+                    case f1 s a of+                        (s', NoEvent, NoEvent) -> (s', f2ne,  f2ne)+                        (s', eb,      NoEvent) -> (s', f2 eb, f2ne)+		        _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event."+        cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) =+            cpAXA fd11 sf12 (fdComp fd13 fd2)+	cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2+{-+	    if sfIsInv sf1 then+		cpXEInv fd2 f2 f2ne sf1+	    else+		SFCpAXA tf False FDI sf1 fd2+-}+	    where+		tf dt a = (cpXEAux fd2 f2 f2ne sf1',+                           case eb of NoEvent -> f2ne; _ -> f2 eb)+		    where+                        (sf1', eb) = (sfTF' sf1) dt a++{-+	cpXEInv fd2 f2 f2ne sf1 = SFCpAXA tf True FDI sf1 fd2+	    where+		tf dt a = sf1 `seq` (cpXEInv fd2 f2 f2ne sf1',+                           case eb of NoEvent -> f2ne; _ -> f2 eb)+		    where+                        (sf1', eb) = (sfTF' sf1) dt a+-}+	++-- Widening.+-- The definition exploits the following identities:+--     first identity     = identity				-- New+--     first (constant b) = arr (\(_, c) -> (b, c))+--     (first (arr f))    = arr (\(a, c) -> (f a, c))+firstPrim :: SF a b -> SF (a,c) (b,c)+firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+    where+        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))+	    where+		(sf1, b0) = tf10 a0 +++-- Also used in parSplitPrim+fpAux :: SF' a b -> SF' (a,c) (b,c)+fpAux (SFArr _ FDI)       = sfId			-- New+fpAux (SFArr _ (FDC b))   = sfArrG (\(~(_, c)) -> (b, c))+fpAux (SFArr _ fd1)       = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))+fpAux sf1 = SF' tf+    -- if sfIsInv sf1 then fpInv sf1 else SF' tf False+    where+        tf dt ~(a, c) = (fpAux sf1', (b, c))+	    where+		(sf1', b) = (sfTF' sf1) dt a +++{-+fpInv :: SF' a b -> SF' (a,c) (b,c)+fpInv sf1 = SF' tf True+    where+        tf dt ~(a, c) = sf1 `seq` (fpInv sf1', (b, c))+	    where+		(sf1', b) = (sfTF' sf1) dt a +-}+++-- Mirror image of first.+secondPrim :: SF a b -> SF (c,a) (c,b)+secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+    where+        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))+	    where+		(sf1, b0) = tf10 a0 +++-- Also used in parSplitPrim+spAux :: SF' a b -> SF' (c,a) (c,b)+spAux (SFArr _ FDI)       = sfId			-- New+spAux (SFArr _ (FDC b))   = sfArrG (\(~(c, _)) -> (c, b))+spAux (SFArr _ fd1)       = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))+spAux sf1 = SF' tf+    -- if sfIsInv sf1 then spInv sf1 else SF' tf False+    where+        tf dt ~(c, a) = (spAux sf1', (c, b))+	    where+		(sf1', b) = (sfTF' sf1) dt a +++{-+spInv :: SF' a b -> SF' (c,a) (c,b)+spInv sf1 = SF' tf True+    where+        tf dt ~(c, a) = sf1 `seq` (spInv sf1', (c, b))+	    where+		(sf1', b) = (sfTF' sf1) dt a +-}+++-- Parallel composition.+-- The definition exploits the following identities (that hold for SF):+--     identity   *** identity   = identity		-- New+--     sf         *** identity   = first sf		-- New+--     identity   *** sf         = second sf		-- New+--     constant b *** constant d = constant (b, d)+--     constant b *** arr f2     = arr (\(_, c) -> (b, f2 c)+--     arr f1     *** constant d = arr (\(a, _) -> (f1 a, d)+--     arr f1     *** arr f2     = arr (\(a, b) -> (f1 a, f2 b)+parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)+parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+    where+	tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0))+	    where+		(sf1, b0) = tf10 a0 +		(sf2, d0) = tf20 c0 ++	-- Naming convention: ps<X><Y> where  <X> and <Y> is one of:+        -- X - arbitrary signal function+        -- A - arbitrary pure arrow+        -- C - constant arrow++        psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d)+        psXX (SFArr _ fd1)       (SFArr _ fd2)       = sfArr (fdPar fd1 fd2)+        psXX (SFArr _ FDI)       sf2                 = spAux sf2	-- New+	psXX (SFArr _ (FDC b))   sf2                 = psCX b sf2+	psXX (SFArr _ fd1)       sf2                 = psAX (fdFun fd1) sf2+        psXX sf1                 (SFArr _ FDI)       = fpAux sf1	-- New+	psXX sf1                 (SFArr _ (FDC d))   = psXC sf1 d+	psXX sf1                 (SFArr _ fd2)       = psXA sf1 (fdFun fd2)+-- !!! Unclear if this really is a gain.+-- !!! potentially unnecessary tupling and untupling.+-- !!! To be investigated.+-- !!! 2005-07-01: At least for MEP 6, the corresponding opt for+-- !!! &&& was harmfull. On that basis, disable it here too.+--        psXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =+--            cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23)+	psXX sf1 sf2 = SF' tf+{-+	    if sfIsInv sf1 && sfIsInv sf2 then+		psXXInv sf1 sf2+	    else+		SF' tf False+-}+	    where+		tf dt ~(a, c) = (psXX sf1' sf2', (b, d))+		    where+		        (sf1', b) = (sfTF' sf1) dt a+			(sf2', d) = (sfTF' sf2) dt c++{-+        psXXInv :: SF' a b -> SF' c d -> SF' (a,c) (b,d)+	psXXInv sf1 sf2 = SF' tf True+	    where+		tf dt ~(a, c) = sf1 `seq` sf2 `seq` (psXXInv sf1' sf2',+                                                       (b, d))+		    where+		        (sf1', b) = (sfTF' sf1) dt a+			(sf2', d) = (sfTF' sf2) dt c+-}++        psCX :: b -> SF' c d -> SF' (a,c) (b,d)+	psCX b (SFArr _ fd2)       = sfArr (fdPar (FDC b) fd2)+	psCX b sf2                 = SF' tf+{-+	    if sfIsInv sf2 then+	        psCXInv b sf2+	    else+	        SF' tf False+-}+	    where+		tf dt ~(_, c) = (psCX b sf2', (b, d))+		    where+			(sf2', d) = (sfTF' sf2) dt c++{-+        psCXInv :: b -> SF' c d -> SF' (a,c) (b,d)+	psCXInv b sf2 = SF' tf True+	    where+		tf dt ~(_, c) = sf2 `seq` (psCXInv b sf2', (b, d))+		    where+			(sf2', d) = (sfTF' sf2) dt c+-}++        psXC :: SF' a b -> d -> SF' (a,c) (b,d)+        psXC (SFArr _ fd1)       d = sfArr (fdPar fd1 (FDC d))+	psXC sf1                 d = SF' tf+{-+	    if sfIsInv sf1 then+		psXCInv sf1 d+	    else+                SF' tf False+-}+	    where+		tf dt ~(a, _) = (psXC sf1' d, (b, d))+		    where+			(sf1', b) = (sfTF' sf1) dt a++{-+        psXCInv :: SF' a b -> d -> SF' (a,c) (b,d)+	psXCInv sf1 d = SF' tf True+	    where+		tf dt ~(a, _) = sf1 `seq` (psXCInv sf1' d, (b, d))+		    where+			(sf1', b) = (sfTF' sf1) dt a+-}++        psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)+	psAX f1 (SFArr _ fd2)       = sfArr (fdPar (FDG f1) fd2)+	psAX f1 sf2                 = SF' tf+{-+	    if sfIsInv sf2 then+	    	psAXInv f1 sf2+	    else+                SF' tf False+-}+	    where+		tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d))+		    where+			(sf2', d) = (sfTF' sf2) dt c++{-+        psAXInv :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)+	psAXInv f1 sf2 = SF' tf True+	    where+		tf dt ~(a, c) = sf2 `seq` (psAXInv f1 sf2', (f1 a, d))+		    where+			(sf2', d) = (sfTF' sf2) dt c+-}++        psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)+	psXA (SFArr _ fd1)       f2 = sfArr (fdPar fd1 (FDG f2))+	psXA sf1                 f2 = SF' tf+{-+	    if sfIsInv sf1 then+		psXAInv sf1 f2 +	    else+		SF' tf False+-}+	    where+		tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))+		    where+			(sf1', b) = (sfTF' sf1) dt a++{-+        psXAInv :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)+	psXAInv sf1 f2 = SF' tf True+	    where+		tf dt ~(a, c) = sf1 `seq` (psXAInv sf1' f2, (b, f2 c))+		    where+			(sf1', b) = (sfTF' sf1) dt a+-}+++-- !!! Hmmm. Why don't we optimize the FDE cases here???+-- !!! Seems pretty obvious that we should!+-- !!! It should also be possible to optimize an event processor in+-- !!! parallel with another event processor or an Arr FDE.++parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)+parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+    where+	tf0 a0 = (pfoXX sf1 sf2, (b0, c0))+	    where+		(sf1, b0) = tf10 a0 +		(sf2, c0) = tf20 a0 ++	-- Naming convention: pfo<X><Y> where  <X> and <Y> is one of:+        -- X - arbitrary signal function+        -- A - arbitrary pure arrow+        -- I - identity arrow+        -- C - constant arrow++        pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c)+        pfoXX (SFArr _ fd1)       (SFArr _ fd2)       = sfArr(fdFanOut fd1 fd2)+        pfoXX (SFArr _ FDI)       sf2                 = pfoIX sf2+	pfoXX (SFArr _ (FDC b))   sf2                 = pfoCX b sf2+	pfoXX (SFArr _ fd1)       sf2                 = pfoAX (fdFun fd1) sf2+        pfoXX sf1                 (SFArr _ FDI)       = pfoXI sf1+	pfoXX sf1                 (SFArr _ (FDC c))   = pfoXC sf1 c+	pfoXX sf1                 (SFArr _ fd2)       = pfoXA sf1 (fdFun fd2)+-- !!! Unclear if this really would be a gain+-- !!! 2005-07-01: NOT a win for MEP 6.+--        pfoXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =+--            cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23)+	pfoXX sf1 sf2 = SF' tf+{-+	    if sfIsInv sf1 && sfIsInv sf2 then+		pfoXXInv sf1 sf2+	    else+		SF' tf False+-}+	    where+		tf dt a = (pfoXX sf1' sf2', (b, c))+		    where+		        (sf1', b) = (sfTF' sf1) dt a+			(sf2', c) = (sfTF' sf2) dt a++{-+        pfoXXInv :: SF' a b -> SF' a c -> SF' a (b ,c)+	pfoXXInv sf1 sf2 = SF' tf True+	    where+		tf dt a = sf1 `seq` sf2 `seq` (pfoXXInv sf1' sf2', (b, c))+		    where+		        (sf1', b) = (sfTF' sf1) dt a+			(sf2', c) = (sfTF' sf2) dt a+-}++        pfoIX :: SF' a c -> SF' a (a ,c)+	pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)+	pfoIX sf2 = SF' tf+{-+	    if sfIsInv sf2 then+		pfoIXInv sf2+	    else+		SF' tf False+-}+	    where+		tf dt a = (pfoIX sf2', (a, c))+		    where+			(sf2', c) = (sfTF' sf2) dt a++{-+        pfoIXInv :: SF' a c -> SF' a (a ,c)+	pfoIXInv sf2 = SF' tf True+	    where+		tf dt a = sf2 `seq` (pfoIXInv sf2', (a, c))+		    where+			(sf2', c) = (sfTF' sf2) dt a+-}++        pfoXI :: SF' a b -> SF' a (b ,a)+	pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)+	pfoXI sf1 = SF' tf+{-+            if sfIsInv sf1 then+		pfoXIInv sf1+	    else+		SF' tf False+-}+	    where+		tf dt a = (pfoXI sf1', (b, a))+		    where+			(sf1', b) = (sfTF' sf1) dt a++{-+        pfoXIInv :: SF' a b -> SF' a (b ,a)+	pfoXIInv sf1 = SF' tf True+	    where+		tf dt a = sf1 `seq` (pfoXIInv sf1', (b, a))+		    where+			(sf1', b) = (sfTF' sf1) dt a+-}++        pfoCX :: b -> SF' a c -> SF' a (b ,c)+        pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2)+	pfoCX b sf2 = SF' tf+{-+	    if sfIsInv sf2 then+		pfoCXInv b sf2+	    else+		SF' tf False+-}+	    where+		tf dt a = (pfoCX b sf2', (b, c))+		    where+			(sf2', c) = (sfTF' sf2) dt a++{-+        pfoCXInv :: b -> SF' a c -> SF' a (b ,c)+	pfoCXInv b sf2 = SF' tf True+	    where+		tf dt a = sf2 `seq` (pfoCXInv b sf2', (b, c))+		    where+			(sf2', c) = (sfTF' sf2) dt a+-}++        pfoXC :: SF' a b -> c -> SF' a (b ,c)+	pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c))+	pfoXC sf1 c = SF' tf+{-+	    if sfIsInv sf1 then+		pfoXCInv sf1 c+	    else+	        SF' tf False+-}+	    where+		tf dt a = (pfoXC sf1' c, (b, c))+		    where+			(sf1', b) = (sfTF' sf1) dt a++{-+        pfoXCInv :: SF' a b -> c -> SF' a (b ,c)+	pfoXCInv sf1 c = SF' tf True+	    where+		tf dt a = sf1 `seq` (pfoXCInv sf1' c, (b, c))+		    where+			(sf1', b) = (sfTF' sf1) dt a+-}++        pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c)+	pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2)+	pfoAX f1 sf2 = SF' tf+{-+	    if sfIsInv sf2 then+		pfoAXInv f1 sf2+	    else+                SF' tf False+-}+	    where+		tf dt a = (pfoAX f1 sf2', (f1 a, c))+		    where+			(sf2', c) = (sfTF' sf2) dt a++{-+        pfoAXInv :: (a -> b) -> SF' a c -> SF' a (b ,c)+	pfoAXInv f1 sf2 = SF' tf True+	    where+		tf dt a = sf2 `seq` (pfoAXInv f1 sf2', (f1 a, c))+		    where+			(sf2', c) = (sfTF' sf2) dt a+-}++        pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c)+	pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2))+	pfoXA sf1 f2 = SF' tf+{-+	    if sfIsInv sf1 then+		pfoXAInv sf1 f2+	    else+		SF' tf False+-}+	    where+		tf dt a = (pfoXA sf1' f2, (b, f2 a))+		    where+			(sf1', b) = (sfTF' sf1) dt a++{-+        pfoXAInv :: SF' a b -> (a -> c) -> SF' a (b ,c)+	pfoXAInv sf1 f2 = SF' tf True+	    where+		tf dt a = sf1 `seq` (pfoXAInv sf1' f2, (b, f2 a))+		    where+			(sf1', b) = (sfTF' sf1) dt a+-}+++------------------------------------------------------------------------------+-- ArrowLoop instance and implementation+------------------------------------------------------------------------------++instance ArrowLoop SF where+    loop = loopPrim+++loopPrim :: SF (a,c) (b,c) -> SF a b+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+    where+	tf0 a0 = (loopAux sf1, b0)+	    where+	        (sf1, (b0, c0)) = tf10 (a0, c0)++        loopAux :: SF' (a,c) (b,c) -> SF' a b+	loopAux (SFArr _ FDI) = sfId+        loopAux (SFArr _ (FDC (b, _))) = sfConst b+	loopAux (SFArr _ fd1) =+            sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b)+	loopAux sf1 = SF' tf+{-+	    if sfIsInv sf1 then+		loopInv sf1+	    else+		SF' tf False+-}+	    where+		tf dt a = (loopAux sf1', b)+		    where+		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)++{-+        loopInv :: SF' (a,c) (b,c) -> SF' a b+	loopInv sf1 = SF' tf True+	    where+		tf dt a = sf1 `seq` (loopInv sf1', b)+		    where+		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)+-}+++------------------------------------------------------------------------------+-- Basic signal functions+------------------------------------------------------------------------------++-- Identity: identity = arr id+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)+++------------------------------------------------------------------------------+-- Simple, stateful signal processing+------------------------------------------------------------------------------++-- New sscan primitive. It should be possible to define lots of functions+-- in terms of this one. Eventually a new constructor will be introduced if+-- this works out.++sscan :: (b -> a -> b) -> b -> SF a b+sscan f b_init = sscanPrim f' b_init b_init+    where+        f' b a = let b' = f b a in Just (b', b')+++{-+sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b+sscanPrim f c_init b_init = SF {sfTF = tf0}+    where+        tf0 a0 = case f c_init a0 of+                     Nothing       -> (spAux f c_init b_init, b_init)+                     Just (c', b') -> (spAux f c' b', b')+ +        spAux :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b+        spAux f c b = sf+            where+                -- sf = SF' tf True+                sf = SF' tf+                tf _ a = case f c a of+                             Nothing       -> (sf, b)+                             Just (c', b') -> (spAux f c' b', b')+-}+++------------------------------------------------------------------------------+-- Basic event sources+------------------------------------------------------------------------------++-- Event source that never occurs.+never :: SF a (Event b)+never = SF {sfTF = \_ -> (sfNever, NoEvent)}+++-- Event source with a single occurrence at time 0. The value of the event+-- is given by the function argument.+now :: b -> SF a (Event b)+now b0 = (Event b0 --> never)+++-- Event source with a single occurrence at or as soon after (local) time q+-- as possible.+after :: Time -> 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.+-- !!! 2005-03-30:  This is potentially a bit inefficient since we KNOW+-- !!! (at this level) that the SF is going to be invarying. But afterEach+-- !!! does NOT know this as the argument list may well be finite.+-- !!! We could use sfMkInv, but that's not without problems.+-- !!! We're probably better off specializing afterEachCat here.++repeatedly :: Time -> b -> SF a (Event b)+repeatedly q x | q > 0 = afterEach qxs+               | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."+    where+        qxs = (q,x):qxs        +++-- Event source with consecutive occurrences at the given intervals.+-- Should more than one event be scheduled to occur in any sampling interval,+-- only the first will in fact occur to avoid an event backlog.+-- Question: Should positive periods except for the first one be required?+-- Note that periods of length 0 will always be skipped except for the first.+-- Right now, periods of length 0 is allowed on the grounds that no attempt+-- is made to forbid simultaneous events elsewhere.+{-+afterEach :: [(Time,b)] -> SF a (Event b)+afterEach [] = never+afterEach ((q,x):qxs)+    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."+    | otherwise = SF {sfTF = tf0}+    where+	tf0 _ = if q <= 0 then+                    (scheduleNextEvent 0.0 qxs, Event x)+                else+		    (awaitNextEvent (-q) x qxs, NoEvent)++	scheduleNextEvent t [] = sfNever+        scheduleNextEvent t ((q,x):qxs)+	    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."+	    | t' >= 0   = scheduleNextEvent t' qxs+	    | otherwise = awaitNextEvent t' x qxs+	    where+	        t' = t - q+	awaitNextEvent t x qxs = SF' {sfTF' = tf}+	    where+		tf dt _ | t' >= 0   = (scheduleNextEvent t' qxs, Event x)+		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)+		    where+		        t' = t + dt+-}++-- Or keep old def. for efficiency reasons?+-- After all, after, repeatedly etc. are defined in terms of afterEach.+afterEach :: [(Time,b)] -> SF a (Event b)+afterEach qxs = afterEachCat qxs >>> arr (fmap head)+++-- Guaranteed not to miss any events.+afterEachCat :: [(Time,b)] -> SF a (Event [b])+afterEachCat [] = never+afterEachCat ((q,x):qxs)+    | q < 0     = usrErr "AFRP" "afterEachCat" "Negative period."+    | otherwise = SF {sfTF = tf0}+    where+	tf0 _ = if q <= 0 then+                    emitEventsScheduleNext 0.0 [x] qxs+                else+		    (awaitNextEvent (-q) x qxs, NoEvent)++	emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs))+        emitEventsScheduleNext t xs ((q,x):qxs)+	    | q < 0     = usrErr "AFRP" "afterEachCat" "Negative period."+	    | t' >= 0   = emitEventsScheduleNext t' (x:xs) qxs+	    | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs))+	    where+	        t' = t - q+	awaitNextEvent t x qxs = SF' tf -- False+	    where+		tf dt _ | t' >= 0   = emitEventsScheduleNext t' [x] qxs+		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)+		    where+		        t' = t + dt++-- Delay for events. (Consider it a triggered after, hence "basic".)+-- Can be implemented fairly cheaply as long as the events are sparse.+-- It is a question of rescheduling events for later. Not unlike "afterEach".+--+-- It is not exactly the case that delayEvent t = delay t NoEvent+-- since the rules for dropping/extrapolating samples are different.+-- A single event occurrence will never be duplicated.+-- If there is an event occurrence, one will be output as soon as+-- possible after the given delay time, but not necessarily that+-- one.  See delayEventCat.++delayEvent :: Time -> SF (Event a) (Event a)+delayEvent q | q < 0     = usrErr "AFRP" "delayEvent" "Negative delay."+             | q == 0    = identity+             | otherwise = delayEventCat q >>> arr (fmap head)+++-- There is no *guarantee* above that every event actually will be+-- rescheduled since the sampling frequency (temporarily) might drop.+-- The following interface would allow ALL scheduled events to occur+-- as soon as possible:+-- (Read "delay event and catenate events that occur so closely so as to be+-- inseparable".)+-- The events in the list are ordered temporally to the extent possible.++{-+-- This version is too strict!+delayEventCat :: Time -> SF (Event a) (Event [a])+delayEventCat q | q < 0     = usrErr "AFRP" "delayEventCat" "Negative delay."+                | q == 0    = arr (fmap (:[]))+                | otherwise = SF {sfTF = tf0}+    where+	tf0 NoEvent   = (noPendingEvent, NoEvent)+        tf0 (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent)++        noPendingEvent = SF' tf -- True+            where+                tf _ NoEvent   = (noPendingEvent, NoEvent)+                tf _ (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent)+				 +        -- t_next is the present time w.r.t. the next scheduled event.+        -- t_last is the present time w.r.t. the last scheduled event.+        -- In the event queues, events are associated with their time+	-- w.r.t. to preceding event (positive).+        pendingEvents t_last rqxs qxs t_next x = SF' tf -- True+            where+	        tf dt NoEvent    = tf1 (t_last + dt) rqxs (t_next + dt)+                tf dt (Event x') = tf1 (-q) ((q', x') : rqxs) t_next'+		    where+		        t_next' = t_next  + dt+                        t_last' = t_last  + dt+                        q'      = t_last' + q++                tf1 t_last' rqxs' t_next'+                    | t_next' >= 0 =+                        emitEventsScheduleNext t_last' rqxs' qxs t_next' [x]+		    | otherwise =+                        (pendingEvents t_last' rqxs' qxs t_next' x, NoEvent)++        -- t_next is the present time w.r.t. the *scheduled* time of the+        -- event that is about to be emitted (i.e. >= 0).+        -- The time associated with any event at the head of the event+        -- queue is also given w.r.t. the event that is about to be emitted.+        -- Thus, t_next - q' is the present time w.r.t. the event at the head+        -- of the event queue.+        emitEventsScheduleNext t_last [] [] t_next rxs =+            (noPendingEvent, Event (reverse rxs))+        emitEventsScheduleNext t_last rqxs [] t_next rxs =+            emitEventsScheduleNext t_last [] (reverse rqxs) t_next rxs+        emitEventsScheduleNext t_last rqxs ((q', x') : qxs') t_next rxs+            | q' > t_next = (pendingEvents t_last rqxs qxs' (t_next - q') x',+                             Event (reverse rxs))+            | otherwise   = emitEventsScheduleNext t_last rqxs qxs' (t_next-q')+                                                   (x' : rxs)+-}++-- This version is not strict in the input event.+delayEventCat :: Time -> SF (Event a) (Event [a])+delayEventCat q | q < 0     = usrErr "AFRP" "delayEventCat" "Negative delay."+                | q == 0    = arr (fmap (:[]))+                | otherwise = SF {sfTF = tf0}+    where+        tf0 e = (case e of+                     NoEvent -> noPendingEvent+                     Event x -> pendingEvents (-q) [] [] (-q) x,+                 NoEvent)++        noPendingEvent = SF' tf -- True+            where+                tf _ e = (case e of+                              NoEvent -> noPendingEvent+                              Event x -> pendingEvents (-q) [] [] (-q) x,+                          NoEvent)+				 +        -- t_next is the present time w.r.t. the next scheduled event.+        -- t_last is the present time w.r.t. the last scheduled event.+        -- In the event queues, events are associated with their time+	-- w.r.t. to preceding event (positive).+        pendingEvents t_last rqxs qxs t_next x = SF' tf -- True+            where+                tf dt e+                    | t_next' >= 0 =+			emitEventsScheduleNext e t_last' rqxs qxs t_next' [x]+                    | otherwise    = +			(pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent)+                    where+		        t_next' = t_next  + dt+                        t_last' = t_last  + dt +                        (t_last'', rqxs') =+                            case e of+                                NoEvent  -> (t_last', rqxs)+                                Event x' -> (-q, (t_last'+q,x') : rqxs)++        -- t_next is the present time w.r.t. the *scheduled* time of the+        -- event that is about to be emitted (i.e. >= 0).+        -- The time associated with any event at the head of the event+        -- queue is also given w.r.t. the event that is about to be emitted.+        -- Thus, t_next - q' is the present time w.r.t. the event at the head+        -- of the event queue.+        emitEventsScheduleNext e _ [] [] _ rxs =+            (case e of+                 NoEvent -> noPendingEvent+                 Event x -> pendingEvents (-q) [] [] (-q) x, +             Event (reverse rxs))+        emitEventsScheduleNext e t_last rqxs [] t_next rxs =+            emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs+        emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs+            | q' > t_next = (case e of+                                 NoEvent -> +				     pendingEvents t_last +                                                   rqxs +                                                   qxs'+                                                   (t_next - q')+                                                   x'+                                 Event x'' ->+				     pendingEvents (-q) +                                                   ((t_last+q, x'') : rqxs)+                                                   qxs'+                                                   (t_next - q')+                                                   x',+                             Event (reverse rxs))+            | otherwise   = emitEventsScheduleNext e+                                                   t_last+                                                   rqxs +                                                   qxs' +                                                   (t_next - q')+                                                   (x' : rxs)+++-- A rising edge detector. Useful for things like detecting key presses.+-- 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+iEdge b = sscanPrim f (if b then 2 else 0) NoEvent+    where+        f :: Int -> Bool -> Maybe (Int, Event ())+        f 0 False = Nothing+        f 0 True  = Just (1, Event ())+        f 1 False = Just (0, NoEvent)+        f 1 True  = Just (2, NoEvent)+        f 2 False = Just (0, NoEvent)+        f 2 True  = Nothing+        f _ _     = undefined++-- Like edge, but parameterized on the tag value.+edgeTag :: a -> SF Bool (Event a)+-- edgeTag a = edgeBy (isBoolRaisingEdge a) True+edgeTag a = edge >>> arr (`tag` a)+++-- Internal utility.+-- isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a+-- isBoolRaisingEdge _ False False = Nothing+-- isBoolRaisingEdge a False True  = Just a+-- isBoolRaisingEdge _ True  True  = Nothing+-- isBoolRaisingEdge _ True  False = Nothing+++-- !!! 2005-07-09: To be done or eliminated+-- !!! Maybe could be kept as is, but could be easy to implement directly+-- !!! in terms of sscan?+edgeJust :: SF (Maybe a) (Event a)+edgeJust = edgeBy isJustEdge (Just undefined)+    where+        isJustEdge Nothing  Nothing     = Nothing+        isJustEdge Nothing  ma@(Just _) = ma+        isJustEdge (Just _) (Just _)    = Nothing+        isJustEdge (Just _) Nothing     = Nothing+++-- Edge detector parameterized on the edge detection function and initial+-- state, i.e., the previous input sample. The first argument to the+-- edge detection function is the previous sample, the second the current one.++-- !!! Is this broken!?! Does not disallow an edge condition that persists+-- !!! between consecutive samples. See discussion in ToDo list above.+-- !!! 2005-07-09: To be done.+edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)+edgeBy isEdge a_init = SF {sfTF = tf0}+    where+	tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))++	ebAux a_prev = SF' tf -- True+	    where+		tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))+++------------------------------------------------------------------------------+-- Stateful event suppression+------------------------------------------------------------------------------++-- Suppression of initial (at local time 0) event.+notYet :: SF (Event a) (Event a)+notYet = initially NoEvent+++-- Suppress all but 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 n | n <= 0 = never+takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1)))+++{-+-- More complicated using "switch" that "dSwitch".+takeEvents :: Int -> SF (Event a) (Event a)+takeEvents 0       = never+takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)+    where+        takeEvents' 0       a = now a+        takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)+-}+++-- Suppress first n events.+-- Here dSwitch or switch does not really matter.+dropEvents :: Int -> SF (Event a) (Event a)+dropEvents n | n <= 0  = identity+dropEvents n = dSwitch (never &&& identity)+                             (const (NoEvent >-- dropEvents (n - 1)))+++------------------------------------------------------------------------------+-- Basic switchers+------------------------------------------------------------------------------++-- !!! Interesting case. It seems we need scoped type variables+-- !!! to be able to write down the local type signatures.+-- !!! On the other hand, the scoped type variables seem to+-- !!! prohibit the kind of unification that is needed for GADTs???+-- !!! Maybe this could be made to wok if it actually WAS known+-- !!! that scoped type variables indeed corresponds to universally+-- !!! quantified variables? Or if one were to keep track of those+-- !!! scoped type variables that actually do?+-- !!!+-- !!! Find a simpler case to experiment further. For now, elim.+-- !!! the free variable.++{-+-- Basic switch.+switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+switch (SF {sfTF = tf10} :: SF a (b, Event c)) (k :: c -> SF a b) = SF {sfTF = tf0}+    where+	tf0 a0 =+	    case tf10 a0 of+	    	(sf1, (b0, NoEvent))  -> (switchAux sf1, b0)+		(_,   (_,  Event c0)) -> sfTF (k c0) a0++        -- It would be nice to optimize further here. E.g. if it would be+        -- possible to observe the event source only.+        switchAux :: SF' a (b, Event c) -> SF' a b+        switchAux (SFId _)                 = switchAuxA1 id	-- New+	switchAux (SFConst _ (b, NoEvent)) = sfConst b+	switchAux (SFArr _ f1)             = switchAuxA1 f1+	switchAux sf1                      = SF' tf+	    where+		tf dt a =+		    case (sfTF' sf1) dt a of+			(sf1', (b, NoEvent)) -> (switchAux sf1', b)+			(_,    (_, Event c)) -> sfTF (k c) a++	-- Could be optimized a little bit further by having a case for+        -- identity, switchAuxI1++	-- Note: While switch behaves as a stateless arrow at this point, that+	-- could change after a switch. Hence, SF' overall.+        switchAuxA1 :: (a -> (b, Event c)) -> SF' a b+	switchAuxA1 f1 = sf+	    where+		sf     = SF' tf+		tf _ a =+		    case f1 a of+			(b, NoEvent) -> (sf, b)+			(_, Event c) -> sfTF (k c) a+-}++-- Basic switch.+switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+    where+	tf0 a0 =+	    case tf10 a0 of+	    	(sf1, (b0, NoEvent))  -> (switchAux sf1 k, b0)+		(_,   (_,  Event c0)) -> sfTF (k c0) a0++        -- It would be nice to optimize further here. E.g. if it would be+        -- possible to observe the event source only.+        switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+	switchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b+	switchAux (SFArr _ fd1)                k = switchAuxA1 (fdFun fd1) k+	switchAux sf1                          k = SF' tf+{-+	    if sfIsInv sf1 then+		switchInv sf1 k+	    else+		SF' tf False+-}+	    where+		tf dt a =+		    case (sfTF' sf1) dt a of+			(sf1', (b, NoEvent)) -> (switchAux sf1' k, b)+			(_,    (_, Event c)) -> sfTF (k c) a++{-+        -- Note: subordinate signal function being invariant does NOT+        -- imply that the overall signal function is.+        switchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+	switchInv sf1 k = SF' tf False+	    where+		tf dt a =+		    case (sfTF' sf1) dt a of+			(sf1', (b, NoEvent)) -> (switchInv sf1' k, b)+			(_,    (_, Event c)) -> sfTF (k c) a+-}++	-- !!! Could be optimized a little bit further by having a case for+        -- !!! identity, switchAuxI1. But I'd expect identity is so unlikely+        -- !!! that there is no point.++	-- Note: While switch behaves as a stateless arrow at this point, that+	-- could change after a switch. Hence, SF' overall.+        switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b+	switchAuxA1 f1 k = sf+	    where+		sf     = SF' tf -- False+		tf _ a =+		    case f1 a of+			(b, NoEvent) -> (sf, b)+			(_, Event c) -> sfTF (k c) a+++-- Switch with delayed observation.+-- Or "decoupled switch"?+-- (The SFId optimization is highly unlikley to be of much use, but it+-- does raise an interesting typing issue.)+dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+    where+	tf0 a0 =+	    let (sf1, (b0, ec0)) = tf10 a0+            in (case ec0 of+                    NoEvent  -> dSwitchAux sf1 k+		    Event c0 -> fst (sfTF (k c0) a0),+                b0)++        -- It would be nice to optimize further here. E.g. if it would be+        -- possible to observe the event source only.+        dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+	dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b+	dSwitchAux (SFArr _ fd1)                k = dSwitchAuxA1 (fdFun fd1) k+	dSwitchAux sf1                          k = SF' tf+{-+	    if sfIsInv sf1 then+		dSwitchInv sf1 k+	    else+		SF' tf False+-}+	    where+		tf dt a =+		    let (sf1', (b, ec)) = (sfTF' sf1) dt a+                    in (case ec of+			    NoEvent -> dSwitchAux sf1' k+			    Event c -> fst (sfTF (k c) a),++			b)++{-+        -- Note: that the subordinate signal function is invariant does NOT+        -- imply that the overall signal function is.+        dSwitchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+	dSwitchInv sf1 k = SF' tf False+	    where+		tf dt a =+		    let (sf1', (b, ec)) = (sfTF' sf1) dt a+                    in (case ec of+			    NoEvent -> dSwitchInv sf1' k+			    Event c -> fst (sfTF (k c) a),++			b)+-}++	-- !!! Could be optimized a little bit further by having a case for+        -- !!! identity, switchAuxI1++	-- Note: While dSwitch behaves as a stateless arrow at this point, that+	-- could change after a switch. Hence, SF' overall.+        dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b+	dSwitchAuxA1 f1 k = sf+	    where+		sf = SF' tf -- False+		tf _ a =+		    let (b, ec) = f1 a+                    in (case ec of+			    NoEvent -> sf+			    Event c -> fst (sfTF (k c) a),++			b)+++-- Recurring switch.+-- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is+-- !!! being invoked recursively on a switch. In fact, we don't even care+-- !!! whether the subordinate signal function is invarying or not.+-- !!! We could make use of a signal function transformer sfInv to+-- !!! mark the constructor as invarying. Would that make sense?+-- !!! The price would be an extra loop with case analysis.+-- !!! The potential gain is fewer case analyses in superior loops.+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)++{-+-- Old version. New is more efficient. Which one is clearer?+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) rSwitch'+    where+        rSwitch' sf = switch (sf *** notYet) rSwitch'+-}+++-- Recurring switch with delayed observation.+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.+-- !!! Has not been optimized properly.+-- !!! Nor has opts been tested!+-- !!! Don't forget Inv opts!+kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+    where+        tf0 a0 =+	    let (sf1, b0) = tf10 a0+            in+	        case tfe0 (a0, b0) of+		    (sfe, NoEvent)  -> (kSwitchAux sf1 sfe, b0)+		    (_,   Event c0) -> sfTF (k sf10 c0) a0++-- Same problem as above: must pass k explicitly???+--        kSwitchAux (SFId _)      sfe                 = kSwitchAuxI1 sfe+        kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe+        kSwitchAux (SFArr _ fd1)     sfe = kSwitchAuxA1 (fdFun fd1) sfe+        -- kSwitchAux (SFArrE _ f1)  sfe                 = kSwitchAuxA1 f1 sfe+        -- kSwitchAux (SFArrEE _ f1) sfe                 = kSwitchAuxA1 f1 sfe+        kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+        kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) +        -- kSwitchAux sf1            (SFArrE _ fe)       = kSwitchAuxAE sf1 fe +        -- kSwitchAux sf1            (SFArrEE _ fe)      = kSwitchAuxAE sf1 fe +        kSwitchAux sf1            sfe                 = SF' tf -- False+	    where+		tf dt a =+		    let	(sf1', b) = (sfTF' sf1) dt a+		    in+		        case (sfTF' sfe) dt (a, b) of+			    (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)+			    (_,    Event c) -> sfTF (k (freeze sf1 dt) c) a++{-+-- !!! Untested optimization!+        kSwitchAuxI1 (SFConst _ NoEvent) = sfId+        kSwitchAuxI1 (SFArr _ fe)        = kSwitchAuxI1AE fe+        kSwitchAuxI1 sfe                 = SF' tf+	    where+		tf dt a =+		    case (sfTF' sfe) dt (a, a) of+			(sfe', NoEvent) -> (kSwitchAuxI1 sfe', a)+			(_,    Event c) -> sfTF (k identity c) a+-}++-- !!! Untested optimization!+        kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b+        kSwitchAuxC1 b (SFArr _ fde)        = kSwitchAuxC1AE b (fdFun fde)+        -- kSwitchAuxC1 b (SFArrE _ fe)       = kSwitchAuxC1AE b fe+        -- kSwitchAuxC1 b (SFArrEE _ fe)      = kSwitchAuxC1AE b fe+        kSwitchAuxC1 b sfe                 = SF' tf -- False+	    where+		tf dt a =+		    case (sfTF' sfe) dt (a, b) of+			(sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b)+			(_,    Event c) -> sfTF (k (constant b) c) a++-- !!! Untested optimization!+        kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1+        kSwitchAuxA1 f1 (SFArr _ fde)        = kSwitchAuxA1AE f1 (fdFun fde)+        -- kSwitchAuxA1 f1 (SFArrE _ fe)       = kSwitchAuxA1AE f1 fe+        -- kSwitchAuxA1 f1 (SFArrEE _ fe)      = kSwitchAuxA1AE f1 fe+        kSwitchAuxA1 f1 sfe                 = SF' tf -- False+	    where+		tf dt a =+		    let	b = f1 a+		    in+		        case (sfTF' sfe) dt (a, b) of+			    (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b)+			    (_,    Event c) -> sfTF (k (arr f1) c) a++-- !!! Untested optimization!+--        kSwitchAuxAE (SFId _)      fe = kSwitchAuxI1AE fe+        kSwitchAuxAE (SFArr _ (FDC b))  fe = kSwitchAuxC1AE b fe+        kSwitchAuxAE (SFArr _ fd1)   fe = kSwitchAuxA1AE (fdFun fd1) fe+        -- kSwitchAuxAE (SFArrE _ f1)  fe = kSwitchAuxA1AE f1 fe+        -- kSwitchAuxAE (SFArrEE _ f1) fe = kSwitchAuxA1AE f1 fe+        kSwitchAuxAE sf1            fe = SF' tf -- False+	    where+		tf dt a =+		    let	(sf1', b) = (sfTF' sf1) dt a+		    in+		        case fe (a, b) of+			    NoEvent -> (kSwitchAuxAE sf1' fe, b)+			    Event c -> sfTF (k (freeze sf1 dt) c) a++{-+-- !!! Untested optimization!+        kSwitchAuxI1AE fe = SF' tf -- False+	    where+		tf dt a =+		    case fe (a, a) of+			NoEvent -> (kSwitchAuxI1AE fe, a)+			Event c -> sfTF (k identity c) a+-}++-- !!! Untested optimization!+        kSwitchAuxC1AE b fe = SF' tf -- False+	    where+		tf _ a =+		    case fe (a, b) of+			NoEvent -> (kSwitchAuxC1AE b fe, b)+			Event c -> sfTF (k (constant b) c) a++-- !!! Untested optimization!+        kSwitchAuxA1AE f1 fe = SF' tf -- False+	    where+		tf _ a =+		    let	b = f1 a+		    in+		        case fe (a, b) of+			    NoEvent -> (kSwitchAuxA1AE f1 fe, b)+			    Event c -> sfTF (k (arr f1) c) a+++-- kSwitch with delayed observation.+-- !!! Has not been optimized properly. Should be like kSwitch.+dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+    where+        tf0 a0 =+	    let (sf1, b0) = tf10 a0+            in (case tfe0 (a0, b0) of+		    (sfe, NoEvent)  -> dkSwitchAux sf1 sfe+		    (_,   Event c0) -> fst (sfTF (k sf10 c0) a0),+                b0)++        dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+        dkSwitchAux sf1 sfe                     = SF' tf -- False+	    where+		tf dt a =+		    let	(sf1', b) = (sfTF' sf1) dt a+		    in (case (sfTF' sfe) dt (a, b) of+			    (sfe', NoEvent) -> dkSwitchAux sf1' sfe'+			    (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),+		        b)+++------------------------------------------------------------------------------+-- Parallel composition and switching over collections with broadcasting+------------------------------------------------------------------------------++broadcast :: Functor col => a -> col sf -> col (a, sf)+broadcast a sfs = fmap (\sf -> (a, sf)) sfs+++-- !!! Hmm. We should really optimize here.+-- !!! Check for Arr in parallel!+-- !!! Check for Arr FDE in parallel!!!+-- !!! Check for EP in parallel!!!!!+-- !!! Cf &&&.+-- !!! But how??? All we know is that the collection is a functor ...+-- !!! Maybe that kind of generality does not make much sense for+-- !!! par and parB? (Although it is niceto be able to switch into a+-- !!! par or parB from within a pSwitch[B].)+-- !!! If we had a parBList, that could be defined in terms of &&&, surely?+-- !!! E.g.+-- !!! parBList []       = constant []+-- !!! parBList (sf:sfs) = sf &&& parBList sfs >>> arr (\(x,xs) -> x:xs)+-- !!!+-- !!! This ought to optimize quite well. E.g.+-- !!! parBList [arr1,arr2,arr3]+-- !!! = arr1 &&& parBList [arr2,arr3] >>> arrX+-- !!! = arr1 &&& (arr2 &&& parBList [arr3] >>> arrX) >>> arrX+-- !!! = arr1 &&& (arr2 &&& (arr3 &&& parBList [] >>> arrX) >>> arrX) >>> arrX+-- !!! = arr1 &&& (arr2 &&& (arr3C >>> arrX) >>> arrX) >>> arrX+-- !!! = arr1 &&& (arr2 &&& (arr3CcpX) >>> arrX) >>> arrX+-- !!! = arr1 &&& (arr23CcpX >>> arrX) >>> arrX+-- !!! = arr1 &&& (arr23CcpXcpX) >>> arrX+-- !!! = arr123CcpXcpXcpX++-- Spatial parallel composition of a signal function collection.+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 = SF' tf -- True+    where+	tf dt a = +	    let bsfs  = rf a sfs+		sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+		sfs'  = fmap fst sfcs'+		cs    = fmap snd sfcs'+	    in+	        (parAux rf sfs', cs)+++-- Parallel switch parameterized on the routing function. This is the most+-- general switch from which all other (non-delayed) switches in principle+-- can be derived. The signal function collection is spatially composed in+-- parallel and run until the event signal function has an occurrence. Once+-- the switching event occurs, all signal function are "frozen" and their+-- continuations are passed to the continuation function, along with the+-- event value.+-- rf .........	Routing function: determines the input to each signal function+--		in the collection. IMPORTANT! The routing function has an+--		obligation to preserve the structure of the signal function+--		collection.+-- sfs0 .......	Signal function collection.+-- sfe0 .......	Signal function generating the switching event.+-- k .......... Continuation to be invoked once event occurs.+-- Returns the resulting signal function.+--+-- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE+--+pSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> 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 (SFArr _ (FDC NoEvent)) = parAux rf sfs+	pSwitchAux sfs sfe = SF' tf -- False+	    where+		tf dt a =+		    let bsfs  = rf a sfs+			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+			sfs'  = fmap fst sfcs'+			cs    = fmap snd sfcs'+		    in+			case (sfTF' sfe) dt (a, cs) of+			    (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)+			    (_,    Event d) -> sfTF (k (freezeCol sfs dt) d) a+++-- Parallel switch with delayed observation parameterized on the routing+-- function.+--+-- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE.+--+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 -- False+	    where+		tf dt a =+		    let bsfs  = rf a sfs+			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+			cs    = fmap snd sfcs'+		    in+			(case (sfTF' sfe) dt (a, cs) of+			     (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')+							    sfe'+			     (_,    Event d) -> fst (sfTF (k (freezeCol sfs dt)+							     d)+							  a),+                         cs)+++-- Recurring parallel switch parameterized on the routing function.+-- rf .........	Routing function: determines the input to each signal function+--		in the collection. IMPORTANT! The routing function has an+--		obligation to preserve the structure of the signal function+--		collection.+-- sfs ........	Initial signal function collection.+-- Returns the resulting signal function.++rpSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+rpSwitch rf sfs =+    pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+    noEventSnd >=- rpSwitch rf (f sfs')+++{-+rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k+    where+	k sfs f = rpSwitch' (f sfs)+	rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k+-}++-- Recurring parallel switch with delayed observation parameterized on the+-- routing function.+drpSwitch :: Functor col =>+    (forall sf . (a -> col sf -> col (b, sf)))+    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+drpSwitch rf sfs =+    dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+    noEventSnd >=- drpSwitch rf (f sfs')++{-+drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k+    where+	k sfs f = drpSwitch' (f sfs)+	drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k+-}+++------------------------------------------------------------------------------+-- Wave-form generation+------------------------------------------------------------------------------++-- Zero-order hold.+-- !!! Should be redone using SFSScan?+-- !!! Otherwise, we are missing an invarying case.+old_hold :: a -> SF (Event a) a+old_hold a_init = switch (constant a_init &&& identity)+                         ((NoEvent >--) . old_hold)++hold :: a -> SF (Event a) a+hold a_init = epPrim f () a_init+    where+        f _ a = ((), a, a)++-- !!!+-- !!! 2005-04-10: I DO NO LONGER THINK THIS IS CORRECT!+-- !!! CAN ONE POSSIBLY GET THE DESIRED STRICTNESS PROPERTIES+-- !!! ("DECOUPLING") this way???+-- !!! Also applies to the other "d" functions that were tentatively+-- !!! defined using only epPrim.+-- !!!+-- !!! 2005-06-13: Yes, indeed wrong! (But it's subtle, one has to+-- !!! make sure that the incoming event (and not just the payload+-- !!! of the event) is control dependent on  the output of "dHold"+-- !!! to observe it.+-- !!!+-- !!! 2005-06-09: But if iPre can be defined in terms of sscan,+-- !!! and ep + sscan = sscan, then things might work, and+-- !!! it might be possible to define dHold simply as hold >>> iPre+-- !!! without any performance penalty. +-- Zero-order hold with delay.+-- Identity: dHold a0 = hold a0 >>> iPre a0).+dHold :: a -> SF (Event a) a+dHold a0 = hold a0 >>> iPre a0+{-+-- THIS IS WRONG! SEE ABOVE.+dHold a_init = epPrim f a_init a_init+    where+        f a' a = (a, a', a)+-}++-- Tracks input signal when available, holds last value when disappears.+-- !!! DANGER!!! Event used inside arr! Probably OK because arr will not be+-- !!! optimized to arrE. But still. Maybe rewrite this using, say, scan?+-- !!! or switch? Switching (in hold) for every input sample does not+-- !!! seem like such a great idea anyway.+trackAndHold :: a -> SF (Maybe a) a+trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init+++------------------------------------------------------------------------------+-- Accumulators+------------------------------------------------------------------------------++old_accum :: a -> SF (Event (a -> a)) (Event a)+old_accum = accumBy (flip ($))++accum :: a -> SF (Event (a -> a)) (Event a)+accum a_init = epPrim f a_init NoEvent+    where+        f a g = (a', Event a', NoEvent)+            where+                a' = g a+++accumHold :: a -> SF (Event (a -> a)) 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+{-+-- WRONG!+-- epPrim DOES and MUST patternmatch+-- on the input at every time step.+-- Test case to check for this added!+dAccumHold a_init = epPrim f a_init a_init+    where+        f a g = (a', a, a')+            where+                a' = g a+-}+++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)++accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+accumBy g b_init = epPrim f b_init NoEvent+    where+        f b a = (b', Event b', NoEvent)+            where+                b' = g b a++accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+accumHoldBy g b_init = epPrim f b_init b_init+    where+        f b a = (b', b', b')+            where+                b' = g b a++-- !!! This cannot be right since epPrim DOES and MUST patternmatch+-- !!! on the input at every time step.+-- !!! Add a test case to check for this!++dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init+{-+-- WRONG!+-- epPrim DOES and MUST patternmatch+-- on the input at every time step.+-- Test case to check for this added!+dAccumHoldBy g b_init = epPrim f b_init b_init+    where+        f b a = (b', b, b')+            where+                b' = g b a+-}+++{- Untested:++accumBy f b = switch (never &&& identity) $ \a ->+              let b' = f b a in NoEvent >-- Event b' --> accumBy f b'++But no real improvement in clarity anyway.++-}++-- accumBy f b = accumFilter (\b -> a -> let b' = f b a in (b', Event b')) b++{-+-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+accumBy f b_init = SF {sfTF = tf0}+    where+        tf0 NoEvent    = (abAux b_init, NoEvent) +        tf0 (Event a0) = let b' = f b_init a0+		         in (abAux b', Event b')++        abAux b = SF' {sfTF' = tf}+	    where+		tf _ NoEvent   = (abAux b, NoEvent)+		tf _ (Event a) = let b' = f b a+			         in (abAux b', Event b')+-}++{-+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter f c_init = SF {sfTF = tf0}+    where+        tf0 NoEvent    = (afAux c_init, NoEvent) +        tf0 (Event a0) = case f c_init a0 of+		             (c', Nothing) -> (afAux c', NoEvent)+			     (c', Just b0) -> (afAux c', Event b0)++        afAux c = SF' {sfTF' = tf}+	    where+		tf _ NoEvent   = (afAux c, NoEvent)+		tf _ (Event a) = case f c a of+			             (c', Nothing) -> (afAux c', NoEvent)+				     (c', Just b)  -> (afAux c', Event b)+-}+++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 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter g c_init = epPrim f c_init NoEvent+    where+        f c a = case g c a of+                    (c', Nothing) -> (c', NoEvent, NoEvent)+                    (c', Just b)  -> (c', Event b, NoEvent)+++------------------------------------------------------------------------------+-- Delays+------------------------------------------------------------------------------++-- Uninitialized delay operator.+-- !!! The seq helps in the dynamic delay line example. But is it a good+-- !!! idea in general? Are there other accumulators which should be seq'ed+-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying+-- !!! design principle? What can the user assume?+--+old_pre :: SF a a+old_pre = SF {sfTF = tf0}+    where+        tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")++	preAux a_prev = SF' tf -- True+	    where+		tf _ a = {- a_prev `seq` -} (preAux a, a_prev)++-- Initialized delay operator.+old_iPre :: a -> SF a a+old_iPre = (--> old_pre)++++-- !!! Redefined using SFSScan+-- !!! About 20% slower than old_pre on its own.+pre :: SF a a+pre = sscanPrim f uninit uninit+    where+        f c a = Just (a, c)+        uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."+++-- Initialized delay operator.+iPre :: a -> SF a a+iPre = (--> pre)+++------------------------------------------------------------------------------+-- Timed delays+------------------------------------------------------------------------------+++-- Invariants:+-- t_diff measure the time since the latest output sample ideally+-- should have been output. Whenever that equals or exceeds the+-- time delta for the next buffered sample, it is time to output a+-- new sample (although not necessarily the one first in the queue:+-- it might be necessary to "catch up" by discarding samples.+-- 0 <= t_diff < bdt, where bdt is the buffered time delta for the+-- sample on the front of the buffer queue.+--+-- Sum of time deltas in the queue >= q.++-- !!! PROBLEM!+-- Since input samples sometimes need to be duplicated, it is not a+-- good idea use a delay on things like events since we then could+-- end up with duplication of event occurrences.+-- (Thus, we actually NEED delayEvent.)++delay :: Time -> a -> SF a a+delay q a_init | q < 0     = usrErr "AFRP" "delay" "Negative delay."+               | q == 0    = identity+               | otherwise = SF {sfTF = tf0}+    where+        tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init)++        delayAux _ [] _ _ = undefined+        delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf -- True+            where+                tf dt a | t_diff' < bdt =+                              (delayAux rbuf' buf t_diff' a_prev, a_prev)+                        | otherwise = nextSmpl rbuf' buf' (t_diff' - bdt) ba+                    where+        	        t_diff' = t_diff + dt+        	        rbuf'   = (dt, a) : rbuf+    +                        nextSmpl rbuf [] t_diff a =+                            nextSmpl [] (reverse rbuf) t_diff a+                        nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a+                            | t_diff < bdt = (delayAux rbuf buf t_diff a, a)+                            | otherwise    = nextSmpl rbuf buf' (t_diff-bdt) ba+                ++-- !!! Hmm. Not so easy to do efficiently, it seems ...++-- varDelay :: Time -> a -> SF (a, Time) a+-- varDelay = undefined+++------------------------------------------------------------------------------+-- Integration and differentiation+------------------------------------------------------------------------------++-- Integration using the rectangle rule.+{-# INLINE integral #-}+integral :: VectorSpace a s => SF a a+integral = SF {sfTF = tf0}+    where+        igrl0  = zeroVector++	tf0 a0 = (integralAux igrl0 a0, igrl0)++	integralAux igrl a_prev = SF' tf -- True+	    where+	        tf dt a = (integralAux igrl' a, igrl')+		    where+		       igrl' = igrl ^+^ realToFrac dt *^ a_prev+++-- "immediate" integration (using the function's value at the current time)+imIntegral :: VectorSpace a s => a -> SF a a+imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)++iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+f `iterFrom` b = SF (iterAux b) where+  -- iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a') True, b)+  iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b)+++-- 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 = SF' tf -- True+	    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!"+	-- Invarying since stsfAux [] is an error.+        stsfAux (b:bs) = SF' tf -- True+	    where+		tf _ _ = (stsfAux bs, b)++{- New def, untested:++streamToSF = sscan2 f+    where+        f []     _ = intErr "AFRP" "streamToSF" "Empty list!"+        f (b:bs) _ = (bs, b)++-}+++-- Stochastic event source with events occurring on average once every t_avg+-- seconds. However, no more than one event results from any one sampling+-- interval in the case of relatively sparse sampling, thus avoiding an+-- "event backlog" should sampling become more frequent at some later+-- point in time.+-- !!! Maybe it would better to give a frequency? But like this to make+-- !!! consitent with "repeatedly".+occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)+occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}+                       | otherwise = usrErr "AFRP" "occasionally"+				            "Non-positive average interval."+    where+	-- Generally, if events occur with an average frequency of f, the+	-- probability of at least one event occurring in an interval of t+        -- is given by (1 - exp (-f*t)). The goal in the following is to+	-- decide whether at least one event occurred in the interval of size+	-- dt preceding the current sample point. For the first point,+	-- we can think of the preceding interval as being 0, implying+	-- no probability of an event occurring.++    tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent)++    occAux [] = undefined+    occAux (r:rs) = SF' tf -- True+        where+        tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at least one event.+                  in (occAux rs, if r < p then Event x else NoEvent)+                  +++------------------------------------------------------------------------------+-- Reactimation+------------------------------------------------------------------------------++-- Reactimation of a signal function.+-- init .......	IO action for initialization. Will only be invoked once,+--		at (logical) time 0, before first call to "sense".+--		Expected to return the value of input at time 0.+-- sense ......	IO action for sensing of system input.+--	arg. #1 .......	True: action may block, waiting for an OS event.+--			False: action must not block.+--	res. #1 .......	Time interval since previous invocation of the sensing+--			action (or, the first time round, the init action),+--			returned. The interval must be _strictly_ greater+--			than 0. Thus even a non-blocking invocation must+--			ensure that time progresses.+--	res. #2 .......	Nothing: input is unchanged w.r.t. the previously+--			returned input sample.+--			Just i: the input is currently i.+--			It is OK to always return "Just", even if input is+--			unchanged.+-- actuate ....	IO action for outputting the system output.+--	arg. #1 .......	True: output may have changed from previous output+--			sample.+--			False: output is definitely unchanged from previous+--			output sample.+--			It is OK to ignore argument #1 and assume that the+--			the output has always changed.+--	arg. #2 .......	Current output sample.+--	result .......	Termination flag. Once True, reactimate will exit+--			the reactimation loop and return to its caller.+-- sf .........	Signal function to reactimate.++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)+--+-- Maybe it should be called "subSample", since that's the only thing+-- that can be achieved. At least does not have the problem with missing+-- events when supersampling.+--+-- subSampleSynch :: SF a b -> SF (Event a) (Event b)+-- Time progresses at the same rate in the embedded system.+-- But it is only sampled on the events.+-- E.g.+-- repeatedly 0.1 () >>> subSampleSynch sf >>> hold+--+-- subSample :: DTime -> SF a b -> SF (Event a) (Event b)+-- Time advanced by dt for each event, not synchronized with the outer clock.++embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]+embed sf0 (a0, dtas) = b0 : loop a0 sf dtas+    where+	(sf, b0) = (sfTF sf0) a0++        loop _ _ [] = []+	loop a_prev sf ((dt, ma) : dtas) =+	    b : (a `seq` b `seq` (loop a sf' dtas))+	    where+		a        = maybe a_prev id ma+	        (sf', b) = (sfTF' sf) dt a+++-- Synchronous embedding. The embedded signal function is run on the supplied+-- input and time stream at a given (but variable) ratio >= 0 to the outer+-- time flow. When the ratio is 0, the embedded signal function is paused.+--+-- What about running an embedded signal function at a fixed (guaranteed)+-- sampling frequency? E.g. super sampling if the outer sampling is slower,+-- subsampling otherwise. AS WELL as at a given ratio to the outer one.+--+-- Ah, but that's more or less what embedSync does.+-- So just simplify the interface. But maybe it should also be possible+-- to feed in input from the enclosing system.++-- !!! Should "dropped frames" be forced to avoid space leaks?+-- !!! It's kind of hard to se why, but "frame dropping" was a problem+-- !!! in the old robot simulator. Try to find an example!++embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b+embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}+    where+        tts       = scanl (\t (dt, _) -> t + dt) 0 dtas+	bbs@(b:_) = embed sf0 (a0, dtas)++	tf0 _ = (esAux 0 (zip tts bbs), b)++	esAux _       []    = intErr "AFRP" "embedSynch" "Empty list!"+        -- Invarying below since esAux [] is an error.+	esAux tp_prev tbtbs = SF' tf -- True+	    where+		tf dt r | r < 0     = usrErr "AFRP" "embedSynch"+					     "Negative ratio."+			| otherwise = let tp = tp_prev + dt * r+					  (b, tbtbs') = advance tp tbtbs+				      in+					  (esAux tp tbtbs', b)++		-- Advance the time stamped stream to the perceived time tp.+		-- Under the assumption that the perceived time never goes+		-- backwards (non-negative ratio), advance maintains the+		-- invariant that the perceived time is always >= the first+		-- time stamp.+        advance _  tbtbs@[(_, b)] = (b, tbtbs)+        advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))+		    | tp <  t' = (b, tbtbtbs)+		    | t' <= tp = advance tp tbtbs+        advance _ _ = undefined++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 ++-- Embedding and missing events.+-- Suppose a subsystem is super sampled. Then some of the output+-- samples will have to be dropped. If we are unlycky, the dropped+-- samples could be occurring events that we'd rather not miss.+-- This is a real problem.+-- Similarly, when feeding input into a super-sampled system,+-- we may need to extrapolate the input, assuming that it is+-- constant. But if (part of) the input is an occurring event, we'd+-- rather not duplicate that!!!+-- This suggests that:+--    * output samples should be merged through a user-supplied merge+--      function.+--    * input samples should be extrapolated if necessary through a+--      user-supplied extrapolation function.+--+-- Possible signature:+--+-- resample :: Time -> (c -> [a]) -> SF a b -> ([b] -> d) -> SF c d+--+-- But what do we do if the inner system runs more slowly than the+-- outer one? Then we need to extrapolate the output from the+-- inner system, and we have the same problem with events AGAIN!
+ FRP/Yampa/AffineSpace.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.AffineSpace+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- Affine space type relation.+--+-----------------------------------------------------------------------------------------++module FRP.Yampa.AffineSpace where++import FRP.Yampa.VectorSpace++------------------------------------------------------------------------------+-- Affine Space type relation+------------------------------------------------------------------------------++infix 6 .+^, .-^, .-.++-- Maybe origin should not be a class method, even though an origin+-- can be assocoated with any affine space.+-- Maybe distance should not be a class method, in which case the constraint+-- on the coefficient space (a) could be Fractional (i.e., a Field), which+-- seems closer to the mathematical definition of affine space, provided+-- the constraint on the coefficient space for VectorSpace is also Fractional.++-- Minimal instance: origin, .+^, .^.+class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where+    origin   :: p+    (.+^)    :: p -> v -> p+    (.-^)    :: p -> v -> p+    (.-.)    :: p -> p -> v+    distance :: p -> p -> a++    p .-^ v = p .+^ (negateVector v)++    distance p1 p2 = norm (p1 .-. p2)
+ FRP/Yampa/Diagnostics.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Diagnostics+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- Standardized error-reporting for Yampa+-----------------------------------------------------------------------------------------++module FRP.Yampa.Diagnostics where++usrErr :: String -> String -> String -> a+usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)++intErr :: String -> String -> String -> a+intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "+                          ++ msg)
+ FRP/Yampa/Event.hs view
@@ -0,0 +1,297 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Event+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- Definition of Yampa Event type.+--+-- Note on naming conventions used in this module.+--+-- Names here might have to be rethought. It's really a bit messy.+-- In general, the aim has been short and convenient names (like 'tag',+-- 'attach', 'lMerge') and thus we have tried to stay away from suffixing/+-- prefixing conventions. E.g. 'Event' as a common suffix would be very+-- verbose.+--+-- However, part of the names come from a desire to stay close to similar+-- functions for the Maybe type. e.g. 'event', 'fromEvent', 'isEvent'.+-- In many cases, this use of 'Event' can could understood to refer to the+-- constructor 'Event', not to the type name 'Event'. Thus this use of+-- event should not be seen as a suffixing-with-type-name convention. But+-- that is obviously not easy to see, and, more over, interpreting 'Event'+-- as the name of the type might make equally good or better sense. E.g.+-- 'fromEvent' can also be seen as a function taking an event signal,+-- which is a partial function on time, to a normal signal. The latter is+-- then undefined when the source event function is undefined.+--+-- In other cases, it has been necessary to somehow stay out of the way of+-- names used by the prelude or other commonly imported modules/modules+-- which could be expected to be used heavily in Yampa code. In those cases+-- a suffix 'E' have been added. Examples are 'filterE' (exists in Prelude)+-- and 'joinE' (exists in Monad). Maybe the suffix isn't necessary in the+-- last case.+--+-- Some functions (actually only one currently, 'mapFilterE') have got an 'E'+-- suffix just because they're closely related (by name or semantics) to one+-- which already has an 'E' suffix. Another candidate would be 'splitE' to+-- complement 'joinE'. But events carrying pairs could obviously have other+-- sources than a 'joinE', so currently it is called 'split'.+--+-- 2003-05-19: Actually, have now changed to 'splitE' to avoid a clash+-- with the method 'split' in the class RandomGen.+--+-- 2003-05-19: What about 'gate'? Stands out compared to e.g. 'filterE'.+--+-- Currently the 'E' suffix is considered an exception. Maybe we should use+-- completely different names to avoid the 'E' suffix. If the functions+-- are not used that often, 'Event' might be approriate. Alternatively the+-- suffix 'E' should be adopted globaly (except if the name already contains+-- 'event' in some form?).+--+-- Arguably, having both a type 'Event' and a constructor 'Event' is confusing+-- since there are more than one constructor. But the name 'Event' for the+-- constructor is quite apt. It's really the type name that is wrong. But+-- no one has found a better name, and changing it would be a really major+-- undertaking. Yes, the constructor 'Event' is not exported, but we still+-- need to talk conceptually about them. On the other hand, if we consider+-- Event-signals as partial functions on time, maybe it isn't so confusing:+-- they just don't have a value between events, so 'NoEvent' does not really+-- exist conceptually.+--+-- ToDo:+-- - Either: reveal NoEvent and Event+--   or:     introcuce 'event = Event', call what's now 'event' 'fromEvent',+--           and call what's now called 'fromEvent' something else, like+--           'unsafeFromEvent'??? Better, dump it! After all, using current+--	     names, 'fromEvent = event undefined'!+-----------------------------------------------------------------------------------------++module FRP.Yampa.Event where++import FRP.Yampa.Diagnostics+import FRP.Yampa.Forceable+++infixl 8 `tag`, `attach`, `gate`+infixl 7 `joinE`+infixl 6 `lMerge`, `rMerge`, `merge`+++------------------------------------------------------------------------------+-- The Event type+------------------------------------------------------------------------------++-- The type Event represents a single possible event occurrence.+-- It is isomorphic to Maybe, but its constructors are not exposed outside+-- the AFRP implementation.+-- There could possibly be further constructors, but note that the NeverEvent-+-- idea does not work, at least not in the current AFRP implementation.+-- Also note that it unfortunately is possible to partially break the+-- abstractions through judicious use of e.g. snap and switching.++data Event a = NoEvent+	     | Event a+--             deriving Show+++-- Make the NoEvent constructor available. Useful e.g. for initialization,+-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []).+noEvent :: Event a+noEvent = NoEvent+++-- Suppress any event in the first component of a pair.+noEventFst :: (Event a, b) -> (Event c, b)+noEventFst (_, b) = (NoEvent, b)+++-- Suppress any event in the second component of a pair.+noEventSnd :: (a, Event b) -> (a, Event c)+noEventSnd (a, _) = (a, NoEvent)+++------------------------------------------------------------------------------+-- Eq instance+------------------------------------------------------------------------------++-- Right now, we could derive this instance. But that could possibly change.++instance Eq a => Eq (Event a) where+    NoEvent   == NoEvent   = True+    (Event x) == (Event y) = x == y+    _         == _         = False+++------------------------------------------------------------------------------+-- Ord instance+------------------------------------------------------------------------------++instance Ord a => Ord (Event a) where+    compare NoEvent   NoEvent   = EQ+    compare NoEvent   (Event _) = LT+    compare (Event _) NoEvent   = GT+    compare (Event x) (Event y) = compare x y+++------------------------------------------------------------------------------+-- Functor instance+------------------------------------------------------------------------------++instance Functor Event where+    fmap _ NoEvent   = NoEvent+    fmap f (Event a) = Event (f a)+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance Forceable a => Forceable (Event a) where+    force ea@NoEvent   = ea+    force ea@(Event a) = force a `seq` ea+++------------------------------------------------------------------------------+-- Internal utilities for event construction+------------------------------------------------------------------------------++-- These utilities are to be considered strictly internal to AFRP for the+-- time being.++maybeToEvent :: Maybe a -> Event a+maybeToEvent Nothing  = NoEvent+maybeToEvent (Just a) = Event a+++------------------------------------------------------------------------------+-- Utility functions similar to those available for Maybe+------------------------------------------------------------------------------++-- An event-based version of the maybe function.+event :: a -> (b -> a) -> Event b -> a+event a _ NoEvent   = a+event _ f (Event b) = f b++fromEvent :: Event a -> a+fromEvent (Event a) = a+fromEvent NoEvent   = usrErr "AFRP" "fromEvent" "Not an event."++isEvent :: Event a -> Bool+isEvent NoEvent   = False+isEvent (Event _) = True++isNoEvent :: Event a -> Bool+isNoEvent = not . isEvent+++------------------------------------------------------------------------------+-- Event tagging+------------------------------------------------------------------------------++-- Tags an (occurring) event with a value ("replacing" the old value).+tag :: Event a -> b -> Event b+e `tag` b = fmap (const b) e++tagWith :: b -> Event a -> Event b+tagWith = flip tag++-- Attaches an extra value to the value of an occurring event.+attach :: Event a -> b -> Event (a, b)+e `attach` b = fmap (\a -> (a, b)) e+++------------------------------------------------------------------------------+-- Event merging (disjunction) and joining (conjunction)+------------------------------------------------------------------------------++-- !!! I think this is too complicated. rMerge can be obtained simply by+-- !!! swapping the arguments. So the only time it is possibly of any+-- !!! interest is for partial app. "merge" is inherently dangerous.+-- !!! But this is NOT obvious from its type: it's type is just like+-- !!! the others. This is the only example of such a def.+-- !!! Finally: mergeEvents is left-biased, but this is not reflected in+-- !!! its name.++-- Left-biased event merge.+lMerge :: Event a -> Event a -> Event a+le `lMerge` re = event re Event le+++-- Right-biased event merge.+rMerge :: Event a -> Event a -> Event a+le `rMerge` re = event le Event re+++-- Unbiased event merge: simultaneous occurrence is an error.+merge :: Event a -> Event a -> Event a+merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.")+++-- Event merge paramterezied on the conflict resolution function.+mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a+mergeBy _       NoEvent      NoEvent      = NoEvent+mergeBy _       le@(Event _) NoEvent      = le+mergeBy _       NoEvent      re@(Event _) = re+mergeBy resolve (Event l)    (Event r)    = Event (resolve l r)+++-- A generic event merge utility:+mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c) +	    -> Event a -> Event b -> Event c+mapMerge _  _  _   NoEvent   NoEvent = NoEvent+mapMerge lf _  _   (Event l) NoEvent = Event (lf l)+mapMerge _  rf _   NoEvent  (Event r) = Event (rf r)+mapMerge _  _  lrf (Event l) (Event r) = Event (lrf l r)++-- Merging of a list of events; foremost event has priority.+mergeEvents :: [Event a] -> Event a+mergeEvents = foldr lMerge NoEvent+++-- Collects simultaneous event occurrences; no event if none.+catEvents :: [Event a] -> Event [a]+catEvents eas = case [ a | Event a <- eas ] of+		    [] -> NoEvent+		    as -> Event as+++-- Join (conjucntion) of two events.+joinE :: Event a -> Event b -> Event (a,b)+joinE NoEvent   _         = NoEvent+joinE _         NoEvent   = NoEvent+joinE (Event l) (Event r) = Event (l,r)+++-- Split event carrying pairs into two events.+splitE :: Event (a,b) -> (Event a, Event b)+splitE NoEvent       = (NoEvent, NoEvent)+splitE (Event (a,b)) = (Event a, Event b)+++------------------------------------------------------------------------------+-- Event filtering+------------------------------------------------------------------------------++-- Filter out events that don't satisfy some predicate.+filterE :: (a -> Bool) -> Event a -> Event a+filterE p e@(Event a) = if (p a) then e else NoEvent+filterE _ NoEvent     = NoEvent+++-- Combined event mapping and filtering.+mapFilterE :: (a -> Maybe b) -> Event a -> Event b+mapFilterE _ NoEvent   = NoEvent+mapFilterE f (Event a) = case f a of+			    Nothing -> NoEvent+			    Just b  -> Event b+++-- Enable/disable event occurences based on an external condition.+gate :: Event a -> Bool -> Event a+_ `gate` False = NoEvent+e `gate` True  = e
+ FRP/Yampa/Forceable.hs view
@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Forceable+-- Copyright   :  (c) Zhanyong Wan, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- Hyperstrict evaluation.+-----------------------------------------------------------------------------------------++module FRP.Yampa.Forceable where+++class Forceable a where+    force :: a -> a+++instance Forceable Int where+  force = id+++instance Forceable Integer where+  force = id+++instance Forceable Double where+  force = id+++instance Forceable Float where+  force = id+++instance Forceable Bool where+  force = id+++instance Forceable () where+  force = id+++instance Forceable Char where+  force = id+++instance (Forceable a, Forceable b) => Forceable (a, b) where+  force p@(a, b) = force a `seq` force b `seq` p+++instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where+  force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p+++instance (Forceable a, Forceable b, Forceable c, Forceable d) =>+         Forceable (a, b, c, d) where+  force p@(a, b, c, d) =+      force a `seq` force b `seq` force c `seq` force d `seq` p+++instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) =>+         Forceable (a, b, c, d, e) where+  force p@(a, b, c, d, e) =+      force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p+++instance (Forceable a) => Forceable [a] where+  force nil@[] = nil+  force xs@(x:xs') = force x `seq` force xs' `seq` xs+++instance (Forceable a) => Forceable (Maybe a) where+  force mx@Nothing  = mx+  force mx@(Just x) = force x `seq` mx
+ FRP/Yampa/Geometry.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Geometry+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- Basic geometrical abstractions.+-----------------------------------------------------------------------------------------++module FRP.Yampa.Geometry (+    module FRP.Yampa.VectorSpace,+    module FRP.Yampa.AffineSpace,+    module FRP.Yampa.Vector2,+    module FRP.Yampa.Vector3,+    module FRP.Yampa.Point2,+    module FRP.Yampa.Point3+) where++import FRP.Yampa.VectorSpace+import FRP.Yampa.AffineSpace+import FRP.Yampa.Vector2+import FRP.Yampa.Vector3+import FRP.Yampa.Point2+import FRP.Yampa.Point3++
+ FRP/Yampa/Internals.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Internals+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- An interface giving access to some of the internal+-- details of the Yampa implementation.+--+-- This interface is indended to be used when the need arises to break+-- abstraction barriers, e.g. for interfacing Yampa to the real world, for+-- debugging purposes, or the like. Be aware that the internal details+-- may change. Relying on this interface means that your code is not+-- insulated against such changes.+-----------------------------------------------------------------------------------------++module FRP.Yampa.Internals (+    Event(..)		-- The event type, its constructors, and instances.+) where++import FRP.Yampa.Event+++------------------------------------------------------------------------------+-- Extra Event instances+------------------------------------------------------------------------------++instance Show a => Show (Event a) where+    showsPrec d NoEvent   = showString "NoEvent"+    showsPrec d (Event a) = showParen (d >= 10)+				      (showString "Event " . showsPrec 10 a)++
+ FRP/Yampa/MergeableRecord.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Miscellany+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- Framework for record merging.+--+-- Idea:+--+-- MergeableRecord is intended to be a super class for classes providing+-- update operations on records. The ADT induced by such a set of operations+-- can be considered a "mergeable record", which can be merged into larger+-- mergeable records essentially by function composition. Finalization turns+-- a mergeable record into a record.+--+-- Typical use:+--+-- Given+--+-- >  data Foo = Foo {l1 :: T1, l2 :: T2}+--+-- one define a mergeable record type (MR Foo) by the following instance:+--+-- @+--   instance MergeableRecord Foo where+--       mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt}+-- @+--+-- Typically, one would also provide definitions for setting the fields,+-- possibly (but not necessarily) overloaded:+--+-- @+--   instance HasL1 Foo where+--       setL1 v = mrMake (\foo -> foo {l1 = v})+-- @+--+-- Now Foo records can be created as follows:+--+-- @+--   let foo1 = setL1 v1+--   ...+--   let foo2 = setL2 v2 ~+~ foo1+--   ...+--   let foo<N> = setL1 vN ~+~ foo<N-1>+--   let fooFinal = mrFinalize foo<N>+-- @+-----------------------------------------------------------------------------------------++module FRP.Yampa.MergeableRecord (+    MergeableRecord(..),+    MR,			-- Abstract+    mrMake,+    (~+~),+    mrMerge,+    mrFinalize+) where++class MergeableRecord a where+    mrDefault :: a+++-- Type constructor for mergeable records.+newtype MergeableRecord a => MR a = MR (a -> a)+++-- Construction of a mergeable record.+mrMake :: MergeableRecord a => (a -> a) -> MR a+mrMake f = (MR f)+++-- Merge two mergeable records. Left "overrides" in case of conflict.+(~+~) :: MergeableRecord a => MR a -> MR a -> MR a+(MR f1) ~+~ (MR f2) = MR (f1 . f2)++mrMerge :: MergeableRecord a => MR a -> MR a -> MR a+mrMerge = (~+~)+++-- Finalization: turn a mergeable record into a record.+mrFinalize :: MergeableRecord a => MR a -> a+mrFinalize (MR f) = f mrDefault
+ FRP/Yampa/Miscellany.hs view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Miscellany+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- Collection of entities that really should be part+-- of the Haskell 98 prelude or simply have no better+-- home.+--+-- !!! Reverse function composition should go.+-- !!! Better to use '<<<' and '>>>' for, respectively,+-- !!! function composition and reverse function composition.+--+-----------------------------------------------------------------------------------------++module FRP.Yampa.Miscellany (+-- Reverse function composition+    ( # ),	-- :: (a -> b) -> (b -> c) -> (a -> c),	infixl 9++-- Arrow plumbing aids+    dup,	-- :: a -> (a,a)+    swap,	-- :: (a,b) -> (b,a)++-- Maps over lists of pairs+    mapFst,	-- :: (a -> b) -> [(a,c)] -> [(b,c)]+    mapSnd,	-- :: (a -> b) -> [(c,a)] -> [(c,b)]++-- Generalized tuple selectors+    sel3_1, sel3_2, sel3_3,+    sel4_1, sel4_2, sel4_3, sel4_4,+    sel5_1, sel5_2, sel5_3, sel5_4, sel5_5,++-- Floating point utilities+    fDiv,	-- :: (RealFrac a, Integral b) => a -> a -> b+    fMod,	-- :: RealFrac a => a -> a -> a+    fDivMod	-- :: (RealFrac a, Integral b) => a -> a -> (b, a)+) where++infixl 9 #+infixl 7 `fDiv`, `fMod`+++------------------------------------------------------------------------------+-- Reverse function composition+------------------------------------------------------------------------------++-- !!! Reverse function composition should go.+-- !!! Better to use <<< and >>> for, respectively,+-- !!! function composition and reverse function composition.++( # ) :: (a -> b) -> (b -> c) -> (a -> c)+f # g = g . f+++------------------------------------------------------------------------------+-- Arrow plumbing aids+------------------------------------------------------------------------------++dup :: a -> (a,a)+dup x = (x,x)++swap :: (a,b) -> (b,a)+swap ~(x,y) = (y,x)+++------------------------------------------------------------------------------+-- Maps over lists of pairs+------------------------------------------------------------------------------++mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]+mapFst _ []             = []+mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys++mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]+mapSnd _ []             = []+mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys+++------------------------------------------------------------------------------+-- Generalized tuple selectors+------------------------------------------------------------------------------++-- Triples+sel3_1 :: (a, b, c) -> a+sel3_1 (x,_,_) = x+sel3_2 :: (a, b, c) -> b+sel3_2 (_,x,_) = x+sel3_3 :: (a, b, c) -> c+sel3_3 (_,_,x) = x+++-- 4-tuples+sel4_1 :: (a, b, c, d) -> a+sel4_1 (x,_,_,_) = x+sel4_2 :: (a, b, c, d) -> b+sel4_2 (_,x,_,_) = x+sel4_3 :: (a, b, c, d) -> c+sel4_3 (_,_,x,_) = x+sel4_4 :: (a, b, c, d) -> d+sel4_4 (_,_,_,x) = x+++-- 5-tuples++sel5_1 :: (a, b, c, d, e) -> a+sel5_1 (x,_,_,_,_) = x+sel5_2 :: (a, b, c, d, e) -> b+sel5_2 (_,x,_,_,_) = x+sel5_3 :: (a, b, c, d, e) -> c+sel5_3 (_,_,x,_,_) = x+sel5_4 :: (a, b, c, d, e) -> d+sel5_4 (_,_,_,x,_) = x+sel5_5 :: (a, b, c, d, e) -> e+sel5_5 (_,_,_,_,x) = x+++------------------------------------------------------------------------------+-- Floating point utilities+------------------------------------------------------------------------------++-- Floating-point div and modulo operators.++fDiv :: (RealFrac a) => a -> a -> Integer+fDiv x y = fst (fDivMod x y)+++fMod :: (RealFrac a) => a -> a -> a+fMod x y = snd (fDivMod x y)+++fDivMod :: (RealFrac a) => a -> a -> (Integer, a)+fDivMod x y = (q, r)+    where+        q = (floor (x/y))+        r = x - fromIntegral q * y
+ FRP/Yampa/Point2.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Point2+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- 2D point abstraction (R^2).+--+-- ToDo: Deriving Show, or provide dedicated show instance?+--+-----------------------------------------------------------------------------------------++module FRP.Yampa.Point2 (+    -- module AFRPVectorSpace,+    -- module AFRPAffineSpace,+    -- module AFRPVector2,+    Point2(..),	-- Non-abstract, instance of AffineSpace+    point2X,	-- :: RealFloat a => Point2 a -> a+    point2Y	-- :: RealFloat a => Point2 a -> a+) where++import FRP.Yampa.VectorSpace ()+import FRP.Yampa.AffineSpace+import FRP.Yampa.Vector2+import FRP.Yampa.Forceable++------------------------------------------------------------------------------+-- 2D point, constructors and selectors.+------------------------------------------------------------------------------++data RealFloat a => Point2 a = Point2 !a !a deriving (Eq, Show)++point2X :: RealFloat a => Point2 a -> a+point2X (Point2 x _) = x++point2Y :: RealFloat a => Point2 a -> a+point2Y (Point2 _ y) = y+++------------------------------------------------------------------------------+-- Affine space instance+------------------------------------------------------------------------------++instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where+    origin = Point2 0 0++    (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v)++    (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v)++    (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2)+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Point2 a) where+     force = id
+ FRP/Yampa/Point3.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Point3+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- 3D point abstraction (R^3).+--+-----------------------------------------------------------------------------------------++module FRP.Yampa.Point3 (+    -- module AFRPVectorSpace,+    -- module AFRPAffineSpace,+    -- module AFRPVector3,+    Point3(..),	-- Non-abstract, instance of AffineSpace+    point3X,	-- :: RealFloat a => Point3 a -> a+    point3Y,	-- :: RealFloat a => Point3 a -> a+    point3Z	-- :: RealFloat a => Point3 a -> a+) where++import FRP.Yampa.VectorSpace ()+import FRP.Yampa.AffineSpace+import FRP.Yampa.Vector3+import FRP.Yampa.Forceable++------------------------------------------------------------------------------+-- 3D point, constructors and selectors.+------------------------------------------------------------------------------++data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq++point3X :: RealFloat a => Point3 a -> a+point3X (Point3 x _ _) = x++point3Y :: RealFloat a => Point3 a -> a+point3Y (Point3 _ y _) = y++point3Z :: RealFloat a => Point3 a -> a+point3Z (Point3 _ _ z) = z+++------------------------------------------------------------------------------+-- Affine space instance+------------------------------------------------------------------------------++instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where+    origin = Point3 0 0 0++    (Point3 x y z) .+^ v =+	Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)++    (Point3 x y z) .-^ v =+	Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)++    (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) =+	vector3 (x1 - x2) (y1 - y2) (z1 - z2)+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Point3 a) where+     force = id
+ FRP/Yampa/Task.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Task+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- Task abstraction on top of signal transformers.+--+-----------------------------------------------------------------------------------------++module FRP.Yampa.Task (+    Task,+    mkTask,	-- :: SF a (b, Event c) -> Task a b c+    runTask,	-- :: Task a b c -> SF a (Either b c)	-- Might change.+    runTask_,	-- :: Task a b c -> SF a b+    taskToSF,	-- :: Task a b c -> SF a (b, Event c)	-- Might change.+    constT,	-- :: b -> Task a b c+    sleepT, 	-- :: Time -> b -> Task a b ()+    snapT, 	-- :: Task a b a+    timeOut, 	-- :: Task a b c -> Time -> Task a b (Maybe c)+    abortWhen, 	-- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+    repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a+    for, 	-- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+    forAll, 	-- :: Monad m => [a] -> (a -> m b) -> m ()+    forEver 	-- :: Monad m => m a -> m b+) where++import FRP.Yampa+import FRP.Yampa.Utilities (snap)+import FRP.Yampa.Diagnostics++infixl 0 `timeOut`, `abortWhen`, `repeatUntil`+++------------------------------------------------------------------------------+-- The Task type+------------------------------------------------------------------------------++-- CPS-based representation allowing a termination to be detected.+-- (Note the rank 2 polymorphic type!)+-- The representation can be changed if necessary, but the Monad laws+-- follow trivially in this case.+newtype Task a b c =+    Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))+++unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))+unTask (Task f) = f+++mkTask :: SF a (b, Event c) -> Task a b c+mkTask st = Task (switch (st >>> first (arr Left)))+++-- "Runs" a task (unusually bad name?). The output from the resulting+-- signal transformer is tagged with Left while the underlying task is+-- running. Once the task has terminated, the output goes constant with+-- the value Right x, where x is the value of the terminating event.+runTask :: Task a b c -> SF a (Either b c)+runTask tk = (unTask tk) (\c -> constant (Right c))+++-- Runs a task. The output becomes undefined once the underlying task has+-- terminated. Convenient e.g. for tasks which are known not to terminate.+runTask_ :: Task a b c -> SF a b+runTask_ tk = runTask tk+              >>> arr (either id (usrErr "AFRPTask" "runTask_"+                                         "Task terminated!"))+++-- Seems as if the following is convenient after all. Suitable name???+-- Maybe that implies a representation change for Tasks?+-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)+taskToSF :: Task a b c -> SF a (b, Event c)+taskToSF tk = runTask tk+	      >>> (arr (either id ((usrErr "AFRPTask" "runTask_"+                                           "Task terminated!")))+		   &&& edgeBy isEdge (Left undefined))+    where+        isEdge (Left _)  (Left _)  = Nothing+	isEdge (Left _)  (Right c) = Just c+	isEdge (Right _) (Right _) = Nothing+	isEdge (Right _) (Left _)  = Nothing+++------------------------------------------------------------------------------+-- Monad instance+------------------------------------------------------------------------------++instance Monad (Task a b) where+    tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))+    return x = Task (\k -> k x)++{-+Let's check the monad laws:++    t >>= return+    = \k -> t (\c -> return c k)+    = \k -> t (\c -> (\x -> \k -> k x) c k)+    = \k -> t (\c -> (\x -> \k' -> k' x) c k)+    = \k -> t (\c -> k c)+    = \k -> t k+    = t+    QED++    return x >>= f+    = \k -> (return x) (\c -> f c k)+    = \k -> (\k -> k x) (\c -> f c k)+    = \k -> (\k' -> k' x) (\c -> f c k)+    = \k -> (\c -> f c k) x+    = \k -> f x k+    = f x+    QED++    (t >>= f) >>= g+    = \k -> (t >>= f) (\c -> g c k)+    = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)+    = \k -> t (\c' -> f c' (\c -> g c k))+    = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)+    = \k -> t (\c' -> (\x -> f x >>= g) c' k)+    = t >>= (\x -> f x >>= g)+    QED++No surprises (obviously, since this is essentially just the CPS monad).+-}+++------------------------------------------------------------------------------+-- Basic tasks+------------------------------------------------------------------------------++-- Non-terminating task with constant output b.+constT :: b -> Task a b c+constT b = mkTask (constant b &&& never)+++-- "Sleeps" for t seconds with constant output b.+sleepT :: Time -> b -> Task a b ()+sleepT t b = mkTask (constant b &&& after t ())+++-- Takes a "snapshot" of the input and terminates immediately with the input+-- value as the result. No time passes; law:+--+--    snapT >> snapT = snapT+--+snapT :: Task a b a+snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)+++------------------------------------------------------------------------------+-- Basic tasks combinators+------------------------------------------------------------------------------++-- Impose a time out on a task.+timeOut :: Task a b c -> Time -> Task a b (Maybe c)+tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)+    where+        aux ((b, ec), et) = (b, (lMerge (fmap Just ec)+					(fmap (const Nothing) et)))+++-- Run a "guarding" event source (SF a (Event b)) in parallel with a+-- (possibly non-terminating) task. The task will be aborted at the+-- first occurrence of the event source (if it has not terminated itself+-- before that). Useful for separating sequencing and termination concerns.+-- E.g. we can do something "useful", but in parallel watch for a (exceptional)+-- condition which should terminate that activity, whithout having to check+-- for that condition explicitly during each and every phase of the activity.+-- Example: tsk `abortWhen` lbp+abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)+tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)+    where+        aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))+++------------------------------------------------------------------------------+-- Loops+------------------------------------------------------------------------------++-- These are general monadic combinators. Maybe they don't really belong here.++-- Repeat m until result satisfies the predicate p+repeatUntil :: Monad m => m a -> (a -> Bool) -> m a+m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x+++-- C-style for-loop.+-- Example: for 0 (+1) (>=10) ...+for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()+for i f p m = if p i then m >> for (f i) f p m else return ()+++-- Perform the monadic operation for each element in the list.+forAll :: Monad m => [a] -> (a -> m b) -> m ()+forAll = flip mapM_+++-- Repeat m for ever.+forEver :: Monad m => m a -> m b+forEver m = m >> forEver m+++-- Alternatives/other potentially useful signatures:+-- until :: a -> (a -> M a) -> (a -> Bool) -> M a+-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b+-- while??? It could be:+-- while :: a -> (a -> Bool) -> (a -> M a) -> M a+++------------------------------------------------------------------------------+-- Monad transformers?+------------------------------------------------------------------------------++-- What about monad transformers if we want to compose this monad with+-- other capabilities???
+ FRP/Yampa/Utilities.hs view
@@ -0,0 +1,352 @@+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Utilities+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  portable+--+-- Derived utility definitions.+--+-- ToDo:+--+-- * Possibly add+--       impulse :: VectorSpace a k => a -> Event a+--   But to do that, we need access to Event, which we currently do not have.+--+-- * The general arrow utilities should be moved to a module+--   FRP.Yampa.Utilities.+--+-- * I'm not sure structuring the Yampa \"core\" according to what is+--   core functionality and what's not is all that useful. There are+--   many cases where we want to implement combinators that fairly+--   easily could be implemented in terms of others as primitives simply+--   because we expect that that implementation is going to be much more+--   efficient, and that the combinators are used sufficiently often to+--   warrant doing this. E.g. 'switch' should be a primitive, even though+--   it could be derived from 'pSwitch'.+--+-- * Reconsider 'recur'. If an event source has an immediate occurrence,+--   we'll get into a loop. For example: recur now. Maybe suppress+--   initial occurrences? Initial occurrences are rather pointless in this+--   case anyway.+-----------------------------------------------------------------------------------------++module FRP.Yampa.Utilities (+-- Now defined in Control.Arrow+-- General arrow utilities+    (^>>),		-- :: Arrow a => (b -> c) -> a c d -> a b d+    (>>^),		-- :: Arrow a => a b c -> (c -> d) -> a b d+    (^<<),		-- :: Arrow a => (c -> d) -> a b c -> a b d +    (<<^),		-- :: Arrow a => a c d -> (b -> c) -> a b d++-- Liftings+    arr2,		-- :: Arrow a => (b->c->d) -> a (b,c) d+    arr3,		-- :: Arrow a => (b->c->d->e) -> a (b,c,d) e+    arr4,		-- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f+    arr5,		-- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g+    lift0,		-- :: Arrow a => c -> a b c+    lift1,		-- :: Arrow a => (c->d) -> (a b c->a b d)+    lift2,		-- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)+    lift3,		-- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)+    lift4,		-- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)+    lift5,		-- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)++-- Event sources+    snap,		-- :: SF a (Event a)+    snapAfter,		-- :: Time -> SF a (Event a)+    sample,		-- :: Time -> SF a (Event a)+    recur,		-- :: SF a (Event b) -> SF a (Event b)+    andThen,            -- :: SF a (Event b)->SF a (Event b)->SF a (Event b)+    sampleWindow,	-- :: Int -> Time -> SF a (Event [a])++-- Parallel composition/switchers with "zip" routing+    parZ,		-- [SF a b] -> SF [a] [b]+    pSwitchZ,		-- [SF a b] -> SF ([a],[b]) (Event c)+			-- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]+    dpSwitchZ,		-- [SF a b] -> SF ([a],[b]) (Event c)+			-- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]+    rpSwitchZ,		-- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]+    drpSwitchZ,		-- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]++-- Guards and automata-oriented combinators+    provided,		-- :: (a -> Bool) -> SF a b -> SF a b -> SF a b++-- Wave-form generation+    old_dHold,		-- :: a -> SF (Event a) a+    dTrackAndHold,	-- :: a -> SF (Maybe a) a++-- Accumulators+    old_accumHold,	-- :: a -> SF (Event (a -> a)) a+    old_dAccumHold,	-- :: a -> SF (Event (a -> a)) a+    old_accumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b+    old_dAccumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b+    count,		-- :: Integral b => SF (Event a) (Event b)++-- Delays+    fby,		-- :: b -> SF a b -> SF a b,	infixr 0++-- Integrals+    impulseIntegral,	-- :: VectorSpace a k => SF (a, Event a) a+    old_impulseIntegral	-- :: VectorSpace a k => SF (a, Event a) a+) where++import FRP.Yampa.Diagnostics+import FRP.Yampa+++infixr 5 `andThen`+--infixr 1 ^<<, ^>>+--infixr 1 <<^, >>^+infixr 0 `fby`+++-- Now defined directly in Control.Arrow.+-- But while using an old version of Arrows ...+------------------------------------------------------------------------------+-- General arrow utilities+------------------------------------------------------------------------------+{-+(^>>) :: Arrow a => (b -> c) -> a c d -> a b d+f ^>> a = arr f >>> a++(>>^) :: Arrow a => a b c -> (c -> d) -> a b d+a >>^ f = a >>> arr f+++(^<<) :: Arrow a => (c -> d) -> a b c -> a b d +f ^<< a = arr f <<< a+++(<<^) :: Arrow a => a c d -> (b -> c) -> a b d+a <<^ f = a <<< arr f+-}++------------------------------------------------------------------------------+-- Liftings+------------------------------------------------------------------------------++arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d+arr2 = arr . uncurry+++arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e+arr3 = arr . \h (b, c, d) -> h b c d+++arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f+arr4 = arr . \h (b, c, d, e) -> h b c d e+++arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g+arr5 = arr . \h (b, c, d, e, f) -> h b c d e f+++lift0 :: Arrow a => c -> a b c+lift0 c = arr (const c)+++lift1 :: Arrow a => (c -> d) -> (a b c -> a b d)+lift1 f = \a -> a >>> arr f+++lift2 :: Arrow a => (c -> d -> e) -> (a b c -> a b d -> a b e)+lift2 f = \a1 a2 -> a1 &&& a2 >>> arr2 f+++lift3 :: Arrow a => (c -> d -> e -> f) -> (a b c -> a b d -> a b e -> a b f)+lift3 f = \a1 a2 a3 -> (lift2 f) a1 a2 &&& a3 >>> arr2 ($)+++lift4 :: Arrow a => (c->d->e->f->g) -> (a b c->a b d->a b e->a b f->a b g)+lift4 f = \a1 a2 a3 a4 -> (lift3 f) a1 a2 a3 &&& a4 >>> arr2 ($)+++lift5 :: Arrow a =>+    (c->d->e->f->g->h) -> (a b c->a b d->a b e->a b f->a b g->a b h)+lift5 f = \a1 a2 a3 a4 a5 ->(lift4 f) a1 a2 a3 a4 &&& a5 >>> arr2 ($)+++------------------------------------------------------------------------------+-- Event sources+------------------------------------------------------------------------------++-- Event source with a single occurrence at time 0. The value of the event+-- is obtained by sampling the input at that time.+-- (The outer "switch" ensures that the entire signal function will become+-- just "constant" once the sample has been taken.)+snap :: SF a (Event a)+snap = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now+++-- Event source with a single occurrence at or as soon after (local) time t_ev+-- as possible. The value of the event is obtained by sampling the input a+-- that time.+snapAfter :: Time -> SF a (Event a)+snapAfter t_ev = switch (never+			 &&& (identity+			      &&& after t_ev () >>^ \(a, e) -> e `tag` a))+			now+++-- Sample a signal at regular intervals.+sample :: Time -> SF a (Event a)+sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a+++-- Makes an event source recurring by restarting it as soon as it has an+-- occurrence.+-- !!! What about event sources that have an instantaneous occurrence?+-- !!! E.g. recur (now ()). +-- !!! Or worse, what about recur identity? (or substitute identity for+-- !!! a more sensible definition that e.g. merges any incoming event+-- !!! with an internally generated one, for example)+-- !!! Possibly we should ignore instantaneous reoccurrences.+-- New definition:+recur :: SF a (Event b) -> SF a (Event b)+recur sfe = switch (never &&& sfe) $ \b -> Event b --> (recur (NoEvent-->sfe))++andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b)+sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2)++{-+recur :: SF a (Event b) -> SF a (Event b)+recur sfe = switch (never &&& sfe) recurAux+    where+	recurAux b = switch (now b &&& sfe) recurAux+-}++-- Window sampling+-- First argument is the window length wl, second is the sampling interval t.+-- The output list should contain (min (truncate (T/t) wl)) samples, where+-- T is the time the signal function has been running. This requires some+-- care in case of sparse sampling. In case of sparse sampling, the+-- current input value is assumed to have been present at all points where+-- sampling was missed.++sampleWindow :: Int -> Time -> SF a (Event [a])+sampleWindow wl q =+    identity &&& afterEachCat (repeat (q, ()))+    >>> arr (\(a, e) -> fmap (map (const a)) e)+    >>> accumBy updateWindow []+    where+        updateWindow w as = drop (max (length w' - wl) 0) w'+            where+	        w' = w ++ as+++------------------------------------------------------------------------------+-- Parallel composition/switchers with "zip" routing+------------------------------------------------------------------------------++safeZip :: String -> [a] -> [b] -> [(a,b)]+safeZip fn as bs = safeZip' as bs+    where+	safeZip' _  []     = []+	safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs++	head' []    = err+	head' (a:_) = a++	tail' []     = err+	tail' (_:as) = as++	err = usrErr "AFRPUtilities" fn "Input list too short."+++parZ :: [SF a b] -> SF [a] [b]+parZ = par (safeZip "parZ")+++pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b])+            -> SF [a] [b]+pSwitchZ = pSwitch (safeZip "pSwitchZ")+++dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b])+             -> SF [a] [b]+dpSwitchZ = dpSwitch (safeZip "dpSwitchZ")+++rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+rpSwitchZ = rpSwitch (safeZip "rpSwitchZ")+++drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+drpSwitchZ = drpSwitch (safeZip "drpSwitchZ")+++------------------------------------------------------------------------------+-- Guards and automata-oriented combinators+------------------------------------------------------------------------------++-- Runs sft only when the predicate p is satisfied, otherwise runs sff.+provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b+provided p sft sff =+    switch (constant undefined &&& snap) $ \a0 ->+    if p a0 then stt else stf+    where+	stt = switch (sft &&& (not . p ^>> edge)) (const stf)+        stf = switch (sff &&& (p ^>> edge)) (const stt)+++------------------------------------------------------------------------------+-- Wave-form generation+------------------------------------------------------------------------------++-- Zero-order hold with delay.+-- Identity: dHold a0 = hold a0 >>> iPre a0).+old_dHold :: a -> SF (Event a) a+old_dHold a0 = dSwitch (constant a0 &&& identity) dHold'+    where+	dHold' a = dSwitch (constant a &&& notYet) dHold'+++dTrackAndHold :: a -> SF (Maybe a) a+dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init+++------------------------------------------------------------------------------+-- Accumulators+------------------------------------------------------------------------------++old_accumHold :: a -> SF (Event (a -> a)) a+old_accumHold a_init = old_accum a_init >>> old_hold a_init+++old_dAccumHold :: a -> SF (Event (a -> a)) a+old_dAccumHold a_init = old_accum a_init >>> old_dHold a_init+++old_accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+old_accumHoldBy f b_init = old_accumBy f b_init >>> old_hold b_init+++old_dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+old_dAccumHoldBy f b_init = old_accumBy f b_init >>> old_dHold b_init+++count :: Integral b => SF (Event a) (Event b)+count = accumBy (\n _ -> n + 1) 0+++------------------------------------------------------------------------------+-- Delays+------------------------------------------------------------------------------++-- Lucid-Synchrone-like initialized delay (read "followed by").+fby :: b -> SF a b -> SF a b+b0 `fby` sf = b0 --> sf >>> pre+++------------------------------------------------------------------------------+-- Integrals+------------------------------------------------------------------------------++impulseIntegral :: VectorSpace a k => SF (a, Event a) a+impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)++old_impulseIntegral :: VectorSpace a k => SF (a, Event a) a+old_impulseIntegral = (integral *** old_accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)
+ FRP/Yampa/Vector2.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Vector2+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- 2D vector abstraction (R^2).+--+-- ToDo: Deriving Show, or provide dedicated show instance?+-----------------------------------------------------------------------------------------++module FRP.Yampa.Vector2 (+    -- module AFRPVectorSpace,+    Vector2,		-- Abstract, instance of VectorSpace+    vector2,		-- :: RealFloat a => a -> a -> Vector2 a+    vector2X,		-- :: RealFloat a => Vector2 a -> a+    vector2Y,		-- :: RealFloat a => Vector2 a -> a+    vector2XY,		-- :: RealFloat a => Vector2 a -> (a, a)+    vector2Polar,	-- :: RealFloat a => a -> a -> Vector2 a+    vector2Rho,		-- :: RealFloat a => Vector2 a -> a+    vector2Theta,	-- :: RealFloat a => Vector2 a -> a+    vector2RhoTheta,	-- :: RealFloat a => Vector2 a -> (a, a)+    vector2Rotate 	-- :: RealFloat a => a -> Vector2 a -> Vector2 a+) where++import FRP.Yampa.VectorSpace+import FRP.Yampa.Forceable+++------------------------------------------------------------------------------+-- 2D vector, constructors and selectors.+------------------------------------------------------------------------------++-- Restrict coefficient space to RealFloat (rather than Floating) for now.+-- While unclear if a complex coefficient space would be useful (and if the+-- result really would be a 2d vector), the only thing causing trouble is the+-- use of atan2 in vector2Theta. Maybe atan2 can be generalized?++data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show)++vector2 :: RealFloat a => a -> a -> Vector2 a+vector2 x y = Vector2 x y++vector2X :: RealFloat a => Vector2 a -> a+vector2X (Vector2 x _) = x++vector2Y :: RealFloat a => Vector2 a -> a+vector2Y (Vector2 _ y) = y++vector2XY :: RealFloat a => Vector2 a -> (a, a)+vector2XY (Vector2 x y) = (x, y)++vector2Polar :: RealFloat a => a -> a -> Vector2 a+vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta) ++vector2Rho :: RealFloat a => Vector2 a -> a+vector2Rho (Vector2 x y) = sqrt (x * x + y * y)++vector2Theta :: RealFloat a => Vector2 a -> a+vector2Theta (Vector2 x y) = atan2 y x++vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a)+vector2RhoTheta v = (vector2Rho v, vector2Theta v)++------------------------------------------------------------------------------+-- Vector space instance+------------------------------------------------------------------------------++instance RealFloat a => VectorSpace (Vector2 a) a where+    zeroVector = Vector2 0 0++    a *^ (Vector2 x y) = Vector2 (a * x) (a * y)++    (Vector2 x y) ^/ a = Vector2 (x / a) (y / a)++    negateVector (Vector2 x y) = (Vector2 (-x) (-y))++    (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2)++    (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2)++    (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2+++------------------------------------------------------------------------------+-- Additional operations+------------------------------------------------------------------------------++vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a+vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta')+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Vector2 a) where+     force = id
+ FRP/Yampa/Vector3.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.Vector3+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- 3D vector abstraction (R^3).+--+-- ToDo: Deriving Show, or provide dedicated show instance?+-----------------------------------------------------------------------------------------++module FRP.Yampa.Vector3 (+    -- module AFRPVectorSpace,+    Vector3,		-- Abstract, instance of VectorSpace+    vector3,		-- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3X,		-- :: RealFloat a => Vector3 a -> a+    vector3Y,		-- :: RealFloat a => Vector3 a -> a+    vector3Z,		-- :: RealFloat a => Vector3 a -> a+    vector3XYZ,		-- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Spherical,	-- :: RealFloat a => a -> a -> a -> Vector3 a+    vector3Rho,		-- :: RealFloat a => Vector3 a -> a+    vector3Theta,	-- :: RealFloat a => Vector3 a -> a+    vector3Phi,		-- :: RealFloat a => Vector3 a -> a+    vector3RhoThetaPhi,	-- :: RealFloat a => Vector3 a -> (a, a, a)+    vector3Rotate 	-- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+) where++import FRP.Yampa.VectorSpace+import FRP.Yampa.Forceable++------------------------------------------------------------------------------+-- 3D vector, constructors and selectors.+------------------------------------------------------------------------------++-- Restrict coefficient space to RealFloat (rather than Floating) for now.+-- While unclear if a complex coefficient space would be useful (and if the+-- result really would be a 3d vector), the only thing causing trouble is the+-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized?++data RealFloat a => Vector3 a = Vector3 !a !a !a deriving (Eq, Show)++vector3 :: RealFloat a => a -> a -> a -> Vector3 a+vector3 x y z = Vector3 x y z++vector3X :: RealFloat a => Vector3 a -> a+vector3X (Vector3 x _ _) = x++vector3Y :: RealFloat a => Vector3 a -> a+vector3Y (Vector3 _ y _) = y++vector3Z :: RealFloat a => Vector3 a -> a+vector3Z (Vector3 _ _ z) = z++vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a)+vector3XYZ (Vector3 x y z) = (x, y, z)++vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a+vector3Spherical rho theta phi =+    Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)+    where+	rhoSinPhi = rho * sin phi++vector3Rho :: RealFloat a => Vector3 a -> a+vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)++vector3Theta :: RealFloat a => Vector3 a -> a+vector3Theta (Vector3 x y _) = atan2 y x++vector3Phi :: RealFloat a => Vector3 a -> a+vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v)++vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a)+vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi)+    where+        rho   = sqrt (x * x + y * y + z * z)+        theta = atan2 y x+	phi   = acos (z / rho)+++------------------------------------------------------------------------------+-- Vector space instance+------------------------------------------------------------------------------++instance RealFloat a => VectorSpace (Vector3 a) a where+    zeroVector = Vector3 0 0 0++    a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z)++    (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a)++    negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z))++    (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2)++    (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2)++    (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2+++------------------------------------------------------------------------------+-- Additional operations+------------------------------------------------------------------------------++vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a+vector3Rotate theta' phi' v =+    vector3Spherical (vector3Rho v)+		     (vector3Theta v + theta')+		     (vector3Phi v + phi')+++------------------------------------------------------------------------------+-- Forceable instance+------------------------------------------------------------------------------++instance RealFloat a => Forceable (Vector3 a) where+     force = id
+ FRP/Yampa/VectorSpace.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+-----------------------------------------------------------------------------------------+-- |+-- Module      :  FRP.Yampa.VectorSpace+-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  nilsson@cs.yale.edu+-- Stability   :  provisional+-- Portability :  non-portable (GHC extensions)+--+-- Vector space type relation and basic instances.+--+-----------------------------------------------------------------------------------------++module FRP.Yampa.VectorSpace where++------------------------------------------------------------------------------+-- Vector space type relation+------------------------------------------------------------------------------++infixr *^+infixl ^/+infix 7 `dot`+infixl 6 ^+^, ^-^++-- Maybe norm and normalize should not be class methods, in which case+-- the constraint on the coefficient space (a) should (or, at least, could)+-- be Fractional (roughly a Field) rather than Floating.++-- Minimal instance: zeroVector, (*^), (^+^), dot+class Floating a => VectorSpace v a | v -> a where+    zeroVector   :: v+    (*^)         :: a -> v -> v+    (^/)         :: v -> a -> v+    negateVector :: v -> v+    (^+^)        :: v -> v -> v+    (^-^)        :: v -> v -> v+    dot          :: v -> v -> a+    norm	 :: v -> a+    normalize	 :: v -> v++    v ^/ a = (1/a) *^ v++    negateVector v = (-1) *^ v++    v1 ^-^ v2 = v1 ^+^ negateVector v2++    norm v = sqrt (v `dot` v)++    normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"+        where+	    nv = norm v++------------------------------------------------------------------------------+-- Vector space instances for Float and Double+------------------------------------------------------------------------------++instance VectorSpace Float Float where+    zeroVector = 0++    a *^ x = a * x++    x ^/ a = x / a++    negateVector x = (-x)++    x1 ^+^ x2 = x1 + x2++    x1 ^-^ x2 = x1 - x2++    x1 `dot` x2 = x1 * x2+++instance VectorSpace Double Double where+    zeroVector = 0++    a *^ x = a * x++    x ^/ a = x / a++    negateVector x = (-x)++    x1 ^+^ x2 = x1 + x2++    x1 ^-^ x2 = x1 - x2++    x1 `dot` x2 = x1 * x2+++------------------------------------------------------------------------------+-- Vector space instances for small tuples of Floating+------------------------------------------------------------------------------++instance Floating a => VectorSpace (a,a) a where+    zeroVector = (0,0)++    a *^ (x,y) = (a * x, a * y)++    (x,y) ^/ a = (x / a, y / a)++    negateVector (x,y) = (-x, -y)++    (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2)++    (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2)++    (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2+++instance Floating a => VectorSpace (a,a,a) a where+    zeroVector = (0,0,0)++    a *^ (x,y,z) = (a * x, a * y, a * z)++    (x,y,z) ^/ a = (x / a, y / a, z / a)++    negateVector (x,y,z) = (-x, -y, -z)++    (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)++    (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2)++    (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2+++instance Floating a => VectorSpace (a,a,a,a) a where+    zeroVector = (0,0,0,0)++    a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u)++    (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)++    negateVector (x,y,z,u) = (-x, -y, -z, -u)++    (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2)++    (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2)++    (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2+++instance Floating a => VectorSpace (a,a,a,a,a) a where+    zeroVector = (0,0,0,0,0)++    a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v)++    (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a)++    negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v)++    (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2)++    (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2)++    (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) =+        x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2+++
Game.hs view
@@ -8,7 +8,7 @@  type R = GLdouble -data Point3D = P3D { x :: Integer, y :: Integer, z :: Integer }+data Point3D = P3D { x :: Integer, y :: Integer, z :: Integer } deriving (Show)  p3DtoV3 ::  (RealFloat a) => Point3D -> Vector3 a p3DtoV3 (P3D x y z) = vector3 (fromInteger x) (fromInteger y) (fromInteger z)@@ -39,7 +39,9 @@ -- TODO: List can't be empty! testLevel = Level (P3D 0 0 1) (P3D 4 4 5) [P3D 0 0 0, P3D 0 5 1, P3D 5 4 1] testLevel2 = Level (P3D 0 0 1) (P3D 0 4 1) [P3D 5 5 5]-testLevel3 = Level (P3D 0 1 0) (P3D 4 2 1)[P3D 0 1 1, P3D 1 2 0, P3D 1 3 3, P3D 1 1 4, P3D 2 3 0, P3D 3 1 0, P3D 3 4 0, P3D 3 0 2, P3D 3 3 3, P3D 3 1 4, P3D 4 2 0] +testLevel3 = Level (P3D 0 1 0) (P3D 4 2 1) [P3D 0 1 1, P3D 1 2 0, P3D 1 3 3,+    P3D 1 1 4, P3D 2 3 0, P3D 3 1 0, P3D 3 4 0, P3D 3 0 2, P3D 3 3 3, P3D 3 1 4,+    P3D 4 2 0]   levels = concat (repeat [testLevel, testLevel2, testLevel3])
GameLogic.hs view
@@ -13,11 +13,22 @@ -- Logic data WinLose = Win | Lose deriving (Eq) +-- Snapping integral +{-# INLINE integral' #-}+integral' = SF {sfTF = tf0}+    where igrl0  = zeroVector+          tf0 a0 = (integralAux igrl0 a0, igrl0)+          integralAux igrl a_prev = SF' tf -- True+            where tf dt a = (integralAux igrl' a, igrl')+                    where igrl' | a_prev == zeroVector = +                                    vectorApply (fromIntegral . round) igrl+                                | otherwise  = igrl ^+^ realToFrac dt *^ a_prev+ calculateState :: SF ParsedInput GameState calculateState = proc pi@(ParsedInput ws as ss ds _ _ _ _) -> do     rec speed    <- rSwitch selectSpeed -< ((pi, pos, speed, obstacles level),                                             winLose `tag` selectSpeed)-        posi     <- drSwitch (integral) -< (speed, winLose `tag` integral)+        posi     <- drSwitch (integral') -< (speed, winLose `tag` integral')         pos      <- arr calculatePPos -< (posi, level)         winLose  <- arr testWinLoseCondition -< (pos, level)         wins     <- arr (filterE (==Win)) >>> delayEvent 1 -< winLose @@ -44,7 +55,7 @@ selectSpeed = proc (pi, pos, speed, obss) -> do     let rotX = (fromInteger $ (floor $ (ws pi) - (ss pi)) `mod` 36 + 36) `mod` 36         theta = (((rotX - 6) `div` 9) + 1) `mod` 4-    -- TODO: Get rid of the undefineds? +    -- TODO: Get rid of the undefined?      speedC <- drSwitch (constant zeroVector) -<          (undefined, tagKeys (upEvs pi) speed ((-v) *^ zAxis) theta `merge`                      tagKeys (downEvs pi) speed (v *^ zAxis) theta `merge`@@ -58,9 +69,10 @@           yAxis = vector3 0 1 0           zAxis = vector3 0 0 1           v     = 0.5+          -- TODO: make nicer? too many magical numbers & not 100% reliable           collision (obss,pos,speed) = -              any (\obs -> norm (pos ^+^ (2 *^ speed) ^-^ (p3DtoV3 obs)) -                            <= 0.001) obss+              any (\obs -> norm (pos ^+^ ((1/v) *^ speed) ^-^ (p3DtoV3 obs)) +                            <= 0.4) obss           -- TODO: Confusing names, can they be generalized?           tagKeys event speed vector theta               | speed == zeroVector = event `tag` constant
Main.hs view
@@ -33,7 +33,7 @@     newTime'  <- get elapsedTime     oldTime'  <- get oldTime     let dt = let dt' = (fromIntegral $ newTime' - oldTime')/50-             in if dt' < 1 then dt' else 1 +             in if dt' < 0.8 then dt' else 0.8     react rh (dt, Just newInput')     writeIORef oldTime newTime'     return ()
cuboid.cabal view
@@ -14,9 +14,12 @@     In order to add levels check out Game.hs. If you come up with     a great level do send it to me. I plan to extract the levels     into a configuration file in the future.+    .+    A slightly modified version of Yampa was included, which exports+    the constructors that allow building new complex stateful operators  Synopsis:           3D Yampa/GLUT Puzzle Game -Version:            0.12+Version:            0.13 License:            MIT License-file:       LICENSE Copyright:          (C) 2010 Pedro Martins@@ -25,10 +28,11 @@ Bug-Reports:        http://github.com/pedromartins/cuboid/issues Stability:          experimental Build-Type:         Simple-Cabal-Version:      >= 1.4+Cabal-Version:      >= 1.6+Extra-Source-Files: FRP/*.hs, FRP/Yampa/*.hs  Executable cuboid -    Main-Is:        Main.hs-    Other-Modules:  Game, GameLogic, Graphics, Input-    Build-Depends:  base >= 3 && < 5, Yampa, GLUT+    Main-Is:            Main.hs+    Other-Modules:      Game, GameLogic, Graphics, Input+    Build-Depends:      base >= 3 && < 5, random, GLUT