packages feed

Yampa 0.9.1.2 → 0.9.2

raw patch · 71 files changed

+10254/−7208 lines, 71 filesdep +randomdep −haskell98setup-changed

Dependencies added: random

Dependencies removed: haskell98

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++- Neither name of the copyright holders nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− LICENSE.txt 
@@ -1,29 +0,0 @@-Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
-
-- Redistributions of source code must retain the above copyright notice,
-this list of conditions and the following disclaimer.
-
-- Redistributions in binary form must reproduce the above copyright
-notice, this list of conditions and the following disclaimer in the
-documentation and/or other materials provided with the distribution.
-
-- Neither name of the copyright holders nor the names of its
-contributors may be used to endorse or promote products derived from
-this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
-BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
-OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
-TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
-USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,8 +1,2 @@--module Main (main) where- import Distribution.Simple--main :: IO () main = defaultMain-
Yampa.cabal view
@@ -1,56 +1,56 @@-Name:               Yampa-Version:            0.9.1.2-License:            BSD3-License-File:       LICENSE.txt-Copyright:          Henrik Nilsson, Antony Courtney and Yale University, (c) 2003-Author:             Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson-Maintainer:         Antony Courtney	<antony@apocalypse.org>, Paul Hudak	<paul.hudak@yale.edu>, Henrik Nilsson	<nilsson@cs.yale.edu>, John Peterson	<peterson-john@cs.yale.edu>-Stability:          provisional-Homepage:           http://www.haskell.org/yampa/-Category:           Reactivity, FRP-Synopsis: Library for programming hybrid systems.-Description: -  Domain-specific language embedded in Haskell for programming hybrid (mixed discrete-time and continuous-time) systems.-  .-  Yampa is based on the concepts of Functional Reactive Programming (FRP) and is structured using arrow combinators. So, this library is known as AFRP (Arrowized FRP).-  .-  This package is just cabalizing afrp-0.4. This isn't GADTed version, and doesn't include any extensions. If you want to see and use GADTed version, you must download higher version.-Build-Type: Simple+name: Yampa+version: 0.9.2+cabal-Version: >= 1.2+license: BSD3+license-file: LICENSE+author: Henrik Nilsson, Antony Courtney+maintainer: George Giorgidze (GGG at CS dot NOTT dot AC dot UK)+homepage: http://www.haskell.org/yampa/+category: Reactivity, FRP+synopsis: Library for programming hybrid systems.+description: Domain-specific language embedded in Haskell for programming hybrid (mixed discrete-time and continuous-time) systems.+             Yampa is based on the concepts of Functional Reactive Programming (FRP) and is structured using arrow combinators.+build-type: Simple+extra-source-files: README Tested-With:        GHC Extra-Source-Files:-  tests/AFRPTests.hs,         tests/AFRPTestsFirstSecond.hs,   tests/AFRPTestsSwitch.hs,-  tests/AFRPTestsAccum.hs,    tests/AFRPTestsKSwitch.hs,       tests/AFRPTestsTask.hs,-  tests/AFRPTestsArr.hs,      tests/AFRPTestsLaws.hs,          tests/AFRPTestsUtils.hs,-  tests/AFRPTestsBasicSF.hs,  tests/AFRPTestsLoop.hs,          tests/AFRPTestsWFG.hs,-  tests/AFRPTestsCOC.hs,      tests/AFRPTestsLoopIntegral.hs,  tests/AFRPTestsCommon.hs,-  tests/AFRPTestsLoopLaws.hs, tests/AFRPTestsComp.hs,          tests/AFRPTestsLoopPre.hs,-  tests/AFRPTestsDelay.hs,    tests/AFRPTestsPSwitch.hs,       tests/AFRPTestsDer.hs,-  tests/AFRPTestsRPSwitch.hs, tests/AFRPTestsEmbed.hs,         tests/AFRPTestsRSwitch.hs,-  tests/AFRPTestsEvSrc.hs,    tests/AFRPTestsReact.hs,         tests/testAFRPMain.hs,+  tests/AFRPTests.hs,         tests/AFRPTestsCommon.hs,        tests/AFRPTestsArr.hs,+  tests/AFRPTestsComp.hs,     tests/AFRPTestsFirstSecond.hs,   tests/AFRPTestsLaws.hs,+  tests/AFRPTestsLoop.hs,     tests/AFRPTestsLoopLaws.hs,      tests/AFRPTestsBasicSF.hs,+  tests/AFRPTestsSscan.hs,    tests/AFRPTestsEvSrc.hs,         tests/AFRPTestsCOC.hs,+  tests/AFRPTestsSwitch.hs,   tests/AFRPTestsKSwitch.hs,       tests/AFRPTestsRSwitch.hs,+  tests/AFRPTestsPSwitch.hs,  tests/AFRPTestsRPSwitch.hs,      tests/AFRPTestsWFG.hs,+  tests/AFRPTestsAccum.hs,    tests/AFRPTestsPre.hs,           tests/AFRPTestsDelay.hs,+  tests/AFRPTestsDer.hs,      tests/AFRPTestsLoopPre.hs,       tests/AFRPTestsLoopIntegral.hs,+  tests/AFRPTestsReact.hs,    tests/AFRPTestsEmbed.hs,         tests/AFRPTestsUtils.hs,+  tests/AFRPTestsTask.hs,     tests/testAFRPMain.hs,   tests/Setup.lhs,            tests/testAFRP.cabal,    examples/Setup.lhs,         examples/examples.cabal,+  examples/Elevator/Elevator.hs,+  examples/Elevator/TestElevatorMain.hs,   examples/TailgatingDetector/TailgatingDetector.hs,   examples/TailgatingDetector/TestTGMain.hs -Build-Depends:  base, haskell98-GHC-Options : -O2-Hs-Source-Dirs: src-Extensions: MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, PolymorphicComponents, RankNTypes-Exposed-modules:-    AFRP, -    AFRPAffineSpace, -    AFRPDiagnostics,-    AFRPEvent,-    AFRPForceable,-    AFRPGeometry,-    AFRPInternals,-    AFRPMiscellany,-    AFRPMergeableRecord,-    AFRPPoint2,-    AFRPPoint3,-    AFRPTask,-    AFRPUtilities,-    AFRPVector2,-    AFRPVector3,-    AFRPVectorSpace+library+  hs-source-dirs:  src+  ghc-options : -O2 -Wall -fno-warn-name-shadowing+  build-Depends: base, random+  exposed-modules:+    FRP.Yampa+    FRP.Yampa.AffineSpace+    FRP.Yampa.Event+    FRP.Yampa.Geometry+    FRP.Yampa.MergeableRecord+    FRP.Yampa.Point2+    FRP.Yampa.Utilities+    FRP.Yampa.Vector3+    FRP.Yampa.Forceable+    FRP.Yampa.Point3+    FRP.Yampa.Vector2+    FRP.Yampa.VectorSpace+    FRP.Yampa.Miscellany+    FRP.Yampa.Task+    FRP.Yampa.Internals+  other-modules:+    FRP.Yampa.Diagnostics
+ examples/Elevator/Elevator.hs view
@@ -0,0 +1,105 @@+{-+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         Elevator					     *+*       Purpose:        Elevator simulation based on the Fran version	     *+*			from Simon Thompson's paper "A functional reactive   *+*			animation of a lift using Fran".		     *+*	Authors:	Henrik Nilsson					     *+*                                                                            *+*             Copyright (c) The University of Nottingham, 2004		     *+*                                                                            *+******************************************************************************+-}++module Elevator where++import FRP.Yampa+import FRP.Yampa.Utilities -- ((^<<), dHold)++------------------------------------------------------------------------------+-- Auxiliary definitions+------------------------------------------------------------------------------++type Position = Double	-- [m]+type Distance = Double	-- [m]+type Velocity = Double	-- [m/s]+++------------------------------------------------------------------------------+-- Elevator simulator+------------------------------------------------------------------------------++lower, upper :: Position+lower = 0+upper = 5++upRate, downRate :: Velocity+upRate = 1+downRate = 1.1+++elevator :: SF (Event (), Event ()) Position+elevator = proc (lbp,rbp) -> do+    rec+        -- This delayed hold can be thought of as modelling acceleration.+        -- It is not "physical" to expect a desire to travel at a certain+        -- velocity to be immediately reflected in the actual velocity.+        -- (The reason we get into trouble here is that the stop/go events+        -- depends instantaneously on "stopped" which in turn depends+        -- instantaneously on "v".)+        v <- dHold 0 -< stop    `tag` 0+                        `lMerge`+                        goUp    `tag` upRate+                        `lMerge`+                        goDown  `tag` (-downRate)+        +        y <- (lower +) ^<< integral -< v    +        +        let atBottom = y <= lower+            atTop    = y >= upper+            stopped  = v == 0		-- Somewhat dubious ...+        +            waitingBottom = atBottom && stopped+            waitingTop    = atTop    && stopped+        +        arriveBottom <- edge -< atBottom+        arriveTop    <- edge -< atTop+        +        let setUp   = lbp `tag` True+            setDown = rbp `tag` True+        +        -- This does not work. The reset events would be generated as soon+        -- as the corresponding go event was generated, but the latter+        -- depend instantaneusly on the reset signals.+--          resetUp   = goUp `tag` False+--          resetDown = goDown `tag` False++	-- One approach would be to wait for "physical confiramtion"+	-- that the elevator actually is moving in the desired direction:+--	resetUp   <- (`tag` True)  ^<< edge -< v > 0+--      resetDown <- (`tag` False) ^<< edge -< v < 0++	-- Another approach is to simply delay the reset events to avoid+        -- suppressing the very event that generates the reset event.+	resetUp   <- iPre noEvent -< goUp `tag` False+        resetDown <- iPre noEvent -< goDown `tag` False++        -- Of course, a third approach would be to just use dHold below.+        -- But that does not seem to be the right solution to me.+        upPending   <- hold False -< setUp   `lMerge` resetUp+        downPending <- hold False -< setDown `lMerge` resetDown+        +        let pending = upPending || downPending+            eitherButton = lbp `lMerge` rbp+        +            goDown  = arriveTop `gate` pending+                      `lMerge`+                      eitherButton `gate` waitingTop+            goUp    = arriveBottom `gate` pending+                      `lMerge`+                      eitherButton `gate` waitingBottom+            stop    = (arriveTop `lMerge` arriveBottom) `gate` not pending+        +    returnA -< y
+ examples/Elevator/TestElevatorMain.hs view
@@ -0,0 +1,97 @@+{-+******************************************************************************+*                                  A F R P				     *+*									     *+*       Example:        Elevator					     *+*       Purpose:        Testing of the Elevator simulator.		     *+*	Authors:	Henrik Nilsson					     *+*									     *+*             Copyright (c) The University of Nottingham, 2004		     *+*									     *+******************************************************************************+-}++module Main where++import Data.List (sortBy, intersperse)+import Data.Maybe (catMaybes)++import FRP.Yampa+import FRP.Yampa.Utilities+import FRP.Yampa.Internals	-- Just for testing purposes.++import Elevator++smplPer = 0.01++lbps :: SF a (Event ())+lbps = afterEach [(3.0, ()), (2.0, ()), (50.0, ())]++rbps :: SF a (Event ())+rbps = afterEach [(20.0, ()), (2.0, ()), (18.0, ()), (15.001, ())]+++-- Looks for interesting events by inspecting the input events+-- and the elevator position over the interval [0, t_max].++data State = Stopped | GoingUp | GoingDown deriving Eq+++testElevator :: Time -> [(Time, ((Event (), Event ()), Position))]+testElevator t_max = takeWhile ((<= t_max) . fst) tios+    where+        -- Time, Input, and Output+        tios = embed (localTime &&& ((lbps &&& rbps >>^ dup)+                                     >>> second elevator))+                     (deltaEncode smplPer (repeat ()))+++findEvents :: [(Time, ((Event (), Event ()), Position))]+              -> [(Time, Position, String)]+findEvents []                     = []+findEvents tios@((_, (_, y)) : _) = feAux Stopped y tios+    where+        feAux _    _    []                             = []+        feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') =+            if not (null message) then +                (t, y, message) : feAux s y tios'+            else+		feAux s y tios'+	    where+		s = if y == yPre then+		        Stopped+                    else if yPre < y then+                        GoingUp+                    else+			GoingDown++                ms = if s /= sPre then+		         case s of+			     Stopped ->   Just "elevator stopped"+			     GoingUp ->   Just "elevator started going up"+			     GoingDown -> Just "elevator started going down"+		     else+			 Nothing++		mu = if isEvent lbp then+                         Just "up button pressed"+                     else+                         Nothing++		md = if isEvent rbp then+                         Just "down button pressed"+                     else+                         Nothing++                message = concat (intersperse ", " (catMaybes [ms, mu, md]))++formatEvent :: (Time, Position, String) -> String+formatEvent (t, y, m) = "t = " ++ t' ++ ",\ty = " ++ y' ++ ":\t" ++ m+    where+	t' = show (fromIntegral (round (t * 100)) / 100)+	y' = show (fromIntegral (round (y * 100)) / 100)++ppEvents []       = return ()+ppEvents (e : es) = putStrLn (formatEvent e) >> ppEvents es++main = ppEvents (findEvents (testElevator 100))
examples/TailgatingDetector/TailgatingDetector.hs view
@@ -38,10 +38,10 @@  module TailgatingDetector where -import List (sortBy, (\\))+import Data.List (sortBy, (\\)) -import AFRP-import AFRPUtilities+import FRP.Yampa+import FRP.Yampa.Utilities   ------------------------------------------------------------------------------
examples/TailgatingDetector/TestTGMain.hs view
@@ -13,11 +13,11 @@  module Main where -import List (sortBy)+import Data.List (sortBy) -import AFRP-import AFRPUtilities-import AFRPInternals	-- Just for testing purposes.+import FRP.Yampa+import FRP.Yampa.Utilities+import FRP.Yampa.Internals	-- Just for testing purposes.  import TailgatingDetector
examples/examples.cabal view
@@ -5,16 +5,22 @@ License-File:       ../LICENSE.txt Copyright:          Henrik Nilsson, Antony Courtney and Yale University, (c) 2003 Author:             Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson-Maintainer:         Antony Courtney	<antony@apocalypse.org>, Paul Hudak	<paul.hudak@yale.edu>, Henrik Nilsson	<nilsson@cs.yale.edu>, John Peterson	<peterson-john@cs.yale.edu>+Maintainer:         George Giorgidze (GGG at CS dot NOTT dot AC dot UK) Stability:          provisional Homepage:           http://www.haskell.org/yampa/ Category:           Reactivity, FRP Synopsis:           Yampa examples-Build-Depends:      base, haskell98, Yampa >= 0.9.1 && < 0.9.2+Build-Depends:      base, haskell98, Yampa >= 0.9.2 +Executable:         Elevator+Main-is:            testElevatorMain.hs+ghc-options:        -O -fglasgow-exts -farrows+Hs-Source-Dirs:     Elevator+Other-modules:      Elevator+ Executable:         TailgatingDetector Main-is:            TestTGMain.hs-ghc-options:        -O-Extensions:         Arrows+ghc-options:        -O -fglasgow-exts -farrows Hs-Source-Dirs:     TailgatingDetector Other-modules:      TailgatingDetector+
− src/AFRP.hs 
@@ -1,1545 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  AFRP--- Copyright   :  (c) Yale University, 2003--- License     :  BSD-style (see the file LICENSE)--- --- Maintainer  :  antony@apocalypse.org--- Stability   :  provisional--- Portability :  non-portable (uses GHC extensions)------ The AFRP core.------ ToDo:--- * Check embedSynch for space leaks. It might be a good idea to force---   "dropped frames".--- * The internal "streamToSignal" is interesting, and a version somehow---   accepting a time stamped stream/assuming equidistant samples, possibly---   with an interpolation function, might be even more interesting. Perhaps---   consider a version that applies "cycle" to the supplied list? Note that---   there is a relation to "embedSynch" since a partial application of---   "embedSynch" to "identity" would yield something similar. Or it is---   in some sense the inverse of "embed".--- * It seems the use of VectorSpace-based integrals causes more ambiguity---   problems than before. Investigate (comments in AFRPTest.hs).--- * Maybe "now", "after", "repeatedly" should return ().---   There could be a bunch of utilities "nowTag", "afterTag", "repeatedlyTag",---   and "edgeTag". Decide based on API consistency. E.g. edge already---   returns ().--- * Reconsider the semantics of "edgeBy". Does not disallow an edge---   condition that persists between consecutive samples. OTOH, consider---   a signal that alternates between two discrete values (True, False, say).---   Surely we could then see edges on every sample. It's not really for us---   to say whether the edge detecting function does a good job or not?--- * We should probably introduce a type synonym Frequency here.---   It might be most natural to give some parameters in terms of frequency---   (like for "repeatedly" and "occasionally"). On the other hand, there---   is "after", and it would be good if "after" and "repeatedly" are---   mutually consitent, if "repeatedly" and "occsaionally" are consitent,---   and if the user knows that "Time" is the only dimension he or she needs---   to worry about.--- * Here's an argument for why "now", "after", etc. should return "()".---   The event value has to be a static entity anyway in these cases. So,---   if we need them to something DYNAMIC, then the extra argument is useless.---   Or if we don't care. If it is decided to change the interface in that---   way, I guess we could also change Time to Frequency where that makes---   sense. On the other hand, what's the point of "now" always returning---   "()"? Would one not usually want to say what to return? If yes, then---   There is something to be said for making "after" consitent with "now".---   After all, we should have "now = after 0".--- * Maybe "reactimate" should be parameterized on the monad type?--- * Revisit the "reactimate" interfaces along with embedding.--- * Revisit integration and differentiation. Valery suggests:------     integral :: VectorSpace a s => SF a a---     integral = (\ a _ dt v -> v ^+^ realToFrac dt *^ a) `iterFrom`---                zeroVector------     -- non-delayed integration (using the function's value at the current---     -- time)---     ndIntegral :: VectorSpace a s => SF a a---     ndIntegral = (\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`---                  zeroVector--- ---     derivative :: VectorSpace a s => SF a a---     derivative = (\ a a' dt _ -> (a' ^-^ a) ^/ realToFrac dt) `iterFrom`---                  zeroVector---  ---     iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b---     f `iterFrom` b = SF (iterAux b) where---         iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)---   See also the original e-mail discussion.--module AFRP (--- Re-exported module, classes, and types-    module Control.Arrow,-    module AFRPVectorSpace,-    RandomGen(..),-    Random(..),---- Reverse function composition and arrow plumbing aids-    ( # ),		-- :: (a -> b) -> (b -> c) -> (a -> c),	infixl 9-    dup,		-- :: a -> (a,a)-    swap,		-- :: (a,b) -> (b,a)---- Main types-    Time,	-- [s] Both for time w.r.t. some reference and intervals.-    SF,		-- Signal Function.-    Event(..),	-- Events; conceptually similar to Maybe (but abstract).---- Main instances-    -- SF is an instance of Arrow and ArrowLoop. Method instances:-    -- arr	:: (a -> b) -> SF a b-    -- (>>>)	:: SF a b -> SF b c -> SF a c-    -- (<<<)	:: SF b c -> SF a b -> SF a c-    -- first	:: SF a b -> SF (a,c) (b,c)-    -- second	:: SF a b -> SF (c,a) (c,b)-    -- (***)	:: SF a b -> SF a' b' -> SF (a,a') (b,b')-    -- (&&&)	:: SF a b -> SF a b' -> SF a (b,b')-    -- returnA	:: SF a a-    -- loop	:: SF (a,c) (b,c) -> SF a b--    -- Event is an instance of Functor, Eq, and Ord. Some method instances:-    -- fmap	:: (a -> b) -> Event a -> Event b-    -- (==)     :: Event a -> Event a -> Bool-    -- (<=)	:: Event a -> Event a -> Bool---- Basic signal functions-    identity,		-- :: SF a a-    constant,		-- :: b -> SF a b-    localTime,		-- :: SF a Time-    time,               -- :: SF a Time,	Other name for localTime.---- Initialization-    (-->),		-- :: b -> SF a b -> SF a b,		infixr 0-    (>--),		-- :: a -> SF a b -> SF a b,		infixr 0-    (-=>),              -- :: (b -> b) -> SF a b -> SF a b      infixr 0-    (>=-),              -- :: (a -> a) -> SF a b -> SF a b      infixr 0-    initially,		-- :: a -> SF a a---- Basic event sources-    never, 		-- :: SF a (Event b)-    now,		-- :: b -> SF a (Event b)-    after,		-- :: Time -> b -> SF a (Event b)-    repeatedly,		-- :: Time -> b -> SF a (Event b)-    afterEach,		-- :: [(Time,b)] -> SF a (Event b)-    edge,		-- :: SF Bool (Event ())-    iEdge,		-- :: Bool -> SF Bool (Event ())-    edgeTag,		-- :: a -> SF Bool (Event a)-    edgeJust,		-- :: SF (Maybe a) (Event a)-    edgeBy,		-- :: (a -> a -> Maybe b) -> a -> SF a (Event b)---- Stateful event suppression-    notYet,		-- :: SF (Event a) (Event a)-    once,		-- :: SF (Event a) (Event a)-    takeEvents,		-- :: Int -> SF (Event a) (Event a)-    dropEvents,		-- :: Int -> SF (Event a) (Event a)---- Basic switchers-    switch,  dSwitch,	-- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b-    rSwitch, drSwitch,	-- :: SF a b -> SF (a,Event (SF a b)) b-    kSwitch, dkSwitch,	-- :: SF a b-			--    -> SF (a,b) (Event c)-			--    -> (SF a b -> c -> SF a b)-			--    -> SF a b---- Parallel composition and switching over collections with broadcasting-    parB,		-- :: Functor col => col (SF a b) -> SF a (col b)-    pSwitchB,dpSwitchB, -- :: Functor col =>-			--        col (SF a b)-			--	  -> SF (a, col b) (Event c)-			--	  -> (col (SF a b) -> c -> SF a (col b))-			--	  -> SF a (col b)-    rpSwitchB,drpSwitchB,-- :: Functor col =>-			--        col (SF a b)-			--	  -> SF (a, Event (col (SF a b)->col (SF a b)))-			--	        (col b)---- Parallel composition and switching over collections with general routing-    par,		-- Functor col =>-    			--     (forall sf . (a -> col sf -> col (b, sf)))-    			--     -> col (SF b c)-    			--     -> SF a (col c)-    pSwitch, dpSwitch,  -- pSwitch :: Functor col =>-			--     (forall sf . (a -> col sf -> col (b, sf)))-			--     -> col (SF b c)-			--     -> SF (a, col c) (Event d)-			--     -> (col (SF b c) -> d -> SF a (col c))-			--     -> SF a (col c)-    rpSwitch,drpSwitch, -- Functor col =>-			--    (forall sf . (a -> col sf -> col (b, sf)))-    			--    -> col (SF b c)-			--    -> SF (a, Event (col (SF b c) -> col (SF b c)))-			--	    (col c)---- Wave-form generation-    hold,		-- :: a -> SF (Event a) a-    trackAndHold,	-- :: a -> SF (Maybe a) a---- Accumulators-    accum,		-- :: a -> SF (Event (a -> a)) (Event a)-    accumBy,		-- :: (b -> a -> b) -> b -> SF (Event a) (Event b)-    accumFilter,	-- :: (c -> a -> (c, Maybe b)) -> c-			--    -> SF (Event a) (Event b)---- Delays-    pre,		-- :: SF a a-    iPre,		-- :: a -> SF a a---- Integration and differentiation-    integral,		-- :: VectorSpace a s => SF a a-    derivative,		-- :: VectorSpace a s => SF a a		-- Crude!-    imIntegral,		-- :: VectorSpace a s => a -> SF a a---- Loops with guaranteed well-defined feedback-    loopPre, 		-- :: c -> SF (a,c) (b,c) -> SF a b-    loopIntegral,	-- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b---- Pointwise functions on events-    noEvent,		-- :: Event a-    noEventFst,		-- :: (Event a, b) -> (Event c, b)-    noEventSnd,		-- :: (a, Event b) -> (a, Event c)-    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-    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 Monad (unless)-import Random (RandomGen(..), Random(..), randoms, randomRs)--import Control.Arrow-import AFRPDiagnostics-import AFRPMiscellany (( # ), dup, swap)-import AFRPEvent-import AFRPVectorSpace--import Data.IORef--infixr 0 -->, >--, -=>, >=------------------------------------------------------------------------------------ Basic type definitions with associated utilities----------------------------------------------------------------------------------- The time type is really a bit boguous, since, as time passes, the minimal--- interval between two consecutive floating-point-represented time points--- increases. A better approach is probably to pick a reasonable resolution--- and represent time and time intervals by Integer (giving the number of--- "ticks").---- Time is used both for time intervals (duration), and time w.r.t. some--- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0--- or even negative.-type Time = Double	-- [s]----- DTime is the time type for lengths of sample intervals. Conceptually,--- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the--- same representation.--type DTime = Double	-- [s]----- Representation of signal function in initial state.--- (Naming: "TF" stands for Transition Function.)--data SF a b = SF {sfTF :: a -> Transition a b}----- Representation of signal function in running state.--- It would have been nice to have a constructor SFId representing (arr id):------     SFId {sfTF' :: DTime -> a -> Transition a b}------ But it seems as if we need dependent types as soon as we try to exploit--- that constructor (note that the type above is too general!), and a--- work-around based on keeping around an extra function as a "proof" that we--- can do the required coersions, yields codde which is no more efficient--- than using SFArr in the first place.--- (Naming: "TIVar" stands for "time-input-variable".)--data SF' a b -    = SFConst {sfTF' :: DTime -> a -> Transition a b, sfCVal :: b}-    | SFArr   {sfTF' :: DTime -> a -> Transition a b, sfAFun :: a -> b}-    | SFTIVar {sfTF' :: DTime -> a -> Transition a b}----- A transition is a pair of the next state (in the form of a signal--- function) and the output at the present time step.--type Transition a b = (SF' a b, b)----- "Smart" constructors. The corresponding "raw" constructors should not--- be used directly for construction.--sfConst :: b -> SF' a b-sfConst b = sf-    where-	sf = SFConst {sfTF' = \_ _ -> (sf, b), sfCVal = b}---sfNever :: SF' a (Event b)-sfNever = sfConst NoEvent---sfId :: SF' a a-sfId = sf-    where-	sf = SFArr {sfTF' = \_ a -> (sf, a), sfAFun = id}---sfArr :: (a -> b) -> SF' a b-sfArr f = sf-    where-	sf = SFArr {sfTF' = \_ a -> (sf, f a), sfAFun = f}----- Freezes a "running" signal function, i.e., turns it into a continuation in--- the form of a plain signal function.-freeze :: SF' a b -> DTime -> SF a b-freeze sf dt = SF {sfTF = (sfTF' sf) dt}---freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)-freezeCol sfs dt = fmap (flip freeze dt) sfs------------------------------------------------------------------------------------ Arrow instance and implementation---------------------------------------------------------------------------------instance Arrow SF where-    arr    = arrPrim-    (>>>)  = compPrim-    first  = firstPrim-    second = secondPrim-    (***)  = parSplitPrim-    (&&&)  = parFanOutPrim----- Lifting.-arrPrim :: (a -> b) -> SF a b-arrPrim f = SF {sfTF = \a -> (sfArr f, f a)}----- Composition.--- The definition exploits the following identities:---     sf         >>> constant c = constant c---     constant c >>> arr f      = constant (f c)---     arr f      >>> arr g      = arr (g . f)--- (It would have been nice to explit e.g. identity >>> sf = sf, but it would--- seem that we need dependent types for that.)-compPrim :: SF a b -> SF b c -> SF a c-compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}-    where-	tf0 a0 = (cpAux sf1 sf2, c0)-	    where-		(sf1, b0) = tf10 a0-		(sf2, c0) = tf20 b0--	cpAux _ 	       sf2@(SFConst {}) = sfConst (sfCVal sf2)-	cpAux sf1@(SFConst {}) sf2              = cpAuxC1 (sfCVal sf1) sf2-	cpAux sf1@(SFArr {})   sf2              = cpAuxA1 (sfAFun sf1) sf2-	cpAux sf1              sf2@(SFArr {})   = cpAuxA2 sf1 (sfAFun sf2)-	cpAux sf1              sf2              = SFTIVar {sfTF' = tf}-	    where-	        tf dt a = (cpAux sf1' sf2', c)-		    where-		        (sf1', b) = (sfTF' sf1) dt a-			(sf2', c) = (sfTF' sf2) dt b--	cpAuxC1 _ (SFConst {sfCVal = c})   = sfConst c-	cpAuxC1 b (SFArr   {sfAFun = f2})  = sfConst (f2 b)-	cpAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}-	    where-		tf dt _ = (cpAuxC1 b sf2', c)-		    where-			(sf2', c) = tf2 dt b--	cpAuxA1 _  (SFConst {sfCVal = c})   = sfConst c-	cpAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (f2 . f1)-	cpAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (cpAuxA1 f1 sf2', c)-		    where-			(sf2', c) = tf2 dt (f1 a)--	cpAuxA2 (SFConst {sfCVal = b})   f2 = sfConst (f2 b)-	cpAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (f2 . f1)-	cpAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (cpAuxA2 sf1' f2, f2 b)-		    where-			(sf1', b) = tf1 dt a----- Widening.--- The definition exploits the following identities:---     first (constant b) = arr (\(_, c) -> (b, c))---     (first (arr f))    = arr (\(a, c) -> (f a, c))--- (It would have been nice to exploit first identity = identity, but it would--- seem that we need dependent types for that.)-firstPrim :: SF a b -> SF (a,c) (b,c)-firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}-    where-        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))-	    where-		(sf1, b0) = tf10 a0 --	fpAux (SFConst {sfCVal = b}) = sfArr (\(~(_, c)) -> (b, c))-	fpAux (SFArr   {sfAFun = f}) = sfArr (\(~(a, c)) -> (f a, c))-	fpAux sf1                    = SFTIVar {sfTF' = tf}-	    where-	        tf dt ~(a, c) = (fpAux sf1', (b, c))-		    where-			(sf1', b) = (sfTF' sf1) dt a ----- Mirror image of first.-secondPrim :: SF a b -> SF (c,a) (c,b)-secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}-    where-        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))-	    where-		(sf1, b0) = tf10 a0 --	spAux (SFConst {sfCVal = b}) = sfArr (\(~(c, _)) -> (c, b))-	spAux (SFArr   {sfAFun = f}) = sfArr (\(~(c, a)) -> (c, f a))-	spAux sf1                    = SFTIVar {sfTF' = tf}-	    where-	        tf dt ~(c, a) = (spAux sf1', (c, b))-		    where-			(sf1', b) = (sfTF' sf1) dt a ----- Parallel composition.--- The definition exploits the following identities (which hold for SF):---     constant b *** constant d = constant (b, d)---     constant b *** arr f2     = arr (\(_, c) -> (b, f2 c)---     arr f1     *** constant d = arr (\(a, _) -> (f1 a, d)---     arr f1     *** arr f2     = arr (\(a, b) -> (f1 a, f2 b)-parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)-parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}-    where-	tf0 ~(a0, c0) = (psAux sf1 sf2, (b0, d0))-	    where-		(sf1, b0) = tf10 a0 -		(sf2, d0) = tf20 c0 --	psAux sf1@(SFConst {}) sf2              = psAuxC1 (sfCVal sf1) sf2-	psAux sf1              sf2@(SFConst {}) = psAuxC2 sf1 (sfCVal sf2)-	psAux sf1@(SFArr {})   sf2              = psAuxA1 (sfAFun sf1) sf2-	psAux sf1              sf2@(SFArr   {}) = psAuxA2 sf1 (sfAFun sf2)-	psAux sf1	       sf2		= SFTIVar {sfTF' = tf}-	    where-		tf dt ~(a, c) = (psAux sf1' sf2', (b, d))-		    where-		        (sf1', b) = (sfTF' sf1) dt a-			(sf2', d) = (sfTF' sf2) dt c--	psAuxC1 b (SFConst {sfCVal = d})   = sfConst (b, d)-	psAuxC1 b (SFArr   {sfAFun = f2})  = sfArr (\(~(_, c)) -> (b, f2 c))-	psAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}-	    where-		tf dt ~(_, c) = (psAuxC1 b sf2', (b, d))-		    where-			(sf2', d) = tf2 dt c--	psAuxC2 (SFConst {sfCVal = b})   d = sfConst (b, d)-	psAuxC2 (SFArr   {sfAFun = f1})  d = sfArr (\(~(a, _)) -> (f1 a, d))-	psAuxC2 (SFTIVar {sfTF'  = tf1}) d = SFTIVar {sfTF' = tf}-	    where-		tf dt ~(a, _) = (psAuxC2 sf1' d, (b, d))-		    where-			(sf1', b) = tf1 dt a--	psAuxA1 f1 (SFConst {sfCVal = d})   = sfArr (\(~(a,_)) -> (f1 a, d))-	psAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (\(~(a,c)) -> (f1 a, f2 c))-	psAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}-	    where-		tf dt ~(a, c) = (psAuxA1 f1 sf2', (f1 a, d))-		    where-			(sf2', d) = tf2 dt c--	psAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\(~(_,c)) -> (b, f2 c))-	psAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\(~(a,c)) -> (f1 a, f2 c))-	psAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}-	    where-		tf dt ~(a, c) = (psAuxA2 sf1' f2, (b, f2 c))-		    where-			(sf1', b) = tf1 dt a---parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)-parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}-    where-	tf0 a0 = (pfoAux sf1 sf2, (b0, c0))-	    where-		(sf1, b0) = tf10 a0 -		(sf2, c0) = tf20 a0 --	pfoAux sf1@(SFConst {}) sf2              = pfoAuxC1 (sfCVal sf1) sf2-	pfoAux sf1              sf2@(SFConst {}) = pfoAuxC2 sf1 (sfCVal sf2)-	pfoAux sf1@(SFArr {})   sf2              = pfoAuxA1 (sfAFun sf1) sf2-	pfoAux sf1              sf2@(SFArr   {}) = pfoAuxA2 sf1 (sfAFun sf2)-	pfoAux sf1	        sf2		 = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (pfoAux sf1' sf2', (b, c))-		    where-		        (sf1', b) = (sfTF' sf1) dt a-			(sf2', c) = (sfTF' sf2) dt a--	pfoAuxC1 b (SFConst {sfCVal = c})   = sfConst (b, c)-	pfoAuxC1 b (SFArr   {sfAFun = f2})  = sfArr (\a -> (b, f2 a))-	pfoAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (pfoAuxC1 b sf2', (b, c))-		    where-			(sf2', c) = tf2 dt a--	pfoAuxC2 (SFConst {sfCVal = b})   c = sfConst (b, c)-	pfoAuxC2 (SFArr   {sfAFun = f1})  c = sfArr (\a -> (f1 a, c))-	pfoAuxC2 (SFTIVar {sfTF'  = tf1}) c = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (pfoAuxC2 sf1' c, (b, c))-		    where-			(sf1', b) = tf1 dt a--	pfoAuxA1 f1 (SFConst {sfCVal = c})   = sfArr (\a -> (f1 a, c))-	pfoAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (\a -> (f1 a ,f2 a))-	pfoAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (pfoAuxA1 f1 sf2', (f1 a, c))-		    where-			(sf2', c) = tf2 dt a--	pfoAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\a -> (b, f2 a))-	pfoAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\a -> (f1 a, f2 a))-	pfoAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (pfoAuxA2 sf1' f2, (b, f2 a))-		    where-			(sf1', b) = tf1 dt a------------------------------------------------------------------------------------ ArrowLoop instance and implementation---------------------------------------------------------------------------------instance ArrowLoop SF where-    loop = loopPrim---loopPrim :: SF (a,c) (b,c) -> SF a b-loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}-    where-	tf0 a0 = (loopAux sf1, b0)-	    where-	        (sf1, (b0, c0)) = tf10 (a0, c0)--        loopAux (SFConst {sfCVal = (b, _)}) = sfConst b-	loopAux (SFArr   {sfAFun = f1})     = sfArr (\a -> let (b,c) = f1 (a,c)-                                                           in b)-	loopAux sf1                         = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (loopAux sf1', b)-		    where-		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)------------------------------------------------------------------------------------ Basic signal functions----------------------------------------------------------------------------------- Identity: identity = arr id-identity :: SF a a-identity = SF {sfTF = \a -> (sfId, a)}----- Identity: constant b = arr (const b)-constant :: b -> SF a b-constant b = SF {sfTF = \_ -> (sfConst b, b)}----- Outputs the time passed since the signal function instance was started.-localTime :: SF a Time-localTime = constant 1.0 >>> integral----- Alternative name for localTime.-time :: SF a Time-time = localTime------------------------------------------------------------------------------------ Initialization----------------------------------------------------------------------------------- Initialization operator (cf. Lustre/Lucid Synchrone).-(-->) :: b -> SF a b -> SF a b-b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}----- Input initialization operator.-(>--) :: a -> SF a b -> SF a b-a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}----- Transform initial output value.-(-=>) :: (b -> b) -> SF a b -> SF a b-f -=> (SF {sfTF = tf10}) =-    SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}----- Transform initial input value.-(>=-) :: (a -> a) -> SF a b -> SF a b-f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}----- Override initial value of input signal.-initially :: a -> SF a a-initially = (--> identity)------------------------------------------------------------------------------------ Basic event sources----------------------------------------------------------------------------------- Event source which never occurs.-never :: SF a (Event b)-never = SF {sfTF = \_ -> (sfNever, NoEvent)}----- Event source with a single occurrence at time 0. The value of the event--- is given by the function argument.-now :: b -> SF a (Event b)-now b0 = (Event b0 --> never)----- Event source with a single occurrence at or as soon after (local) time q--- as possible.-after :: Time -> b -> SF a (Event b)-after q x = afterEach [(q,x)]----- Event source with repeated occurrences with interval q.--- Note: If the interval is too short w.r.t. the sampling intervals,--- the result will be that events occur at every sample. However, no more--- than one event results from any sampling interval, thus avoiding an--- "event backlog" should sampling become more frequent at some later--- point in time.-repeatedly :: Time -> b -> SF a (Event b)-repeatedly q x | q > 0 = afterEach qxs-               | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."-    where-        qxs = (q,x):qxs        ----- Event source with consecutive occurrences at the given intervals.--- Should more than one event be scheduled to occur in any sampling interval,--- only the first will in fact occur to avoid an event backlog.--- Question: Should positive periods except for the first one be required?--- Note that periods of length 0 will always be skipped except for the first.--- Right now, periods of length 0 is allowed on the grounds that no attempt--- is made to forbid simultaneous events elsewhere.-afterEach :: [(Time,b)] -> SF a (Event b)-afterEach [] = never-afterEach ((q,x):qxs)-    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."-    | otherwise = SF {sfTF = tf0}-    where-	tf0 _ = if q <= 0 then-                    (scheduleNextEvent 0.0 qxs, Event x)-                else-		    (awaitNextEvent (-q) x qxs, NoEvent)--	scheduleNextEvent t [] = sfNever-        scheduleNextEvent t ((q,x):qxs)-	    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."-	    | t' >= 0   = scheduleNextEvent t' qxs-	    | otherwise = awaitNextEvent t' x qxs-	    where-	        t' = t - q-	awaitNextEvent t x qxs = SFTIVar {sfTF' = tf}-	    where-		tf dt _ | t' >= 0   = (scheduleNextEvent t' qxs, Event x)-		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)-		    where-		        t' = t + dt----- A rising edge detector. Useful for things like detecting key presses.--- Note that we initialize the loop with state set to True so that there--- will not be an occurence at t0 in the logical time frame in which--- this is started.-edge :: SF Bool (Event ())-edge = iEdge True---iEdge :: Bool -> SF Bool (Event ())-iEdge i = edgeBy (isBoolRaisingEdge ()) i----- Like edge, but parameterized on the tag value.-edgeTag :: a -> SF Bool (Event a)-edgeTag a = edgeBy (isBoolRaisingEdge a) True----- Internal utility.-isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a-isBoolRaisingEdge _ False False = Nothing-isBoolRaisingEdge a False True  = Just a-isBoolRaisingEdge _ True  True  = Nothing-isBoolRaisingEdge _ True  False = Nothing----- Detects an edge where a maybe signal is changing from nothing to something.-edgeJust :: SF (Maybe a) (Event a)-edgeJust = edgeBy isJustEdge (Just undefined)-    where-        isJustEdge Nothing  Nothing     = Nothing-        isJustEdge Nothing  ma@(Just _) = ma-        isJustEdge (Just _) (Just _)    = Nothing-        isJustEdge (Just _) Nothing     = Nothing----- Edge detector parameterized on the edge detection function and initial--- state, i.e., the previous input sample. The first argument to the--- edge detection function is the previous sample, the second the current one.---- !!! Is this broken!?! Does not disallow an edge condition that persists--- !!! between consecutive samples. See discussion in ToDo list above.--edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)-edgeBy isEdge a_init = SF {sfTF = tf0}-    where-	tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))--	ebAux a_prev = SFTIVar {sfTF' = tf}-	    where-		tf dt a = (ebAux a, maybeToEvent (isEdge a_prev a))------------------------------------------------------------------------------------ Stateful event suppression----------------------------------------------------------------------------------- Suppression of initial (at local time 0) event.-notYet :: SF (Event a) (Event a)-notYet = initially NoEvent----- Suppress all but first event.-once :: SF (Event a) (Event a)-once = takeEvents 1----- Suppress all but first n events.-takeEvents :: Int -> SF (Event a) (Event a)-takeEvents 0       = never-takeEvents (n + 1) = dSwitch (arr dup) (const (NoEvent >-- takeEvents n))---{---- More complicated using "switch" that "dSwitch".-takeEvents :: Int -> SF (Event a) (Event a)-takeEvents 0       = never-takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)-    where-        takeEvents' 0       a = now a-        takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)--}----- Suppress first n events.--- Here dSwitch or switch does not really matter.-dropEvents :: Int -> SF (Event a) (Event a)-dropEvents 0       = identity-dropEvents (n + 1) = dSwitch (never &&& identity)-                             (const (NoEvent >-- dropEvents n))------------------------------------------------------------------------------------ Basic switchers----------------------------------------------------------------------------------- Basic switch.-switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b-switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}-    where-	tf0 a0 =-	    case tf10 a0 of-	    	(sf1, (b0, NoEvent))  -> (switchAux sf1, b0)-		(_,   (_,  Event c0)) -> sfTF (k c0) a0--	switchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b-	switchAux (SFArr   {sfAFun = f1})           = switchAuxA1 f1-	switchAux sf1                               = SFTIVar {sfTF' = tf}-	    where-		tf dt a =-		    case (sfTF' sf1) dt a of-			(sf1', (b, NoEvent)) -> (switchAux sf1', b)-			(_,    (_, Event c)) -> sfTF (k c) a--	-- Note: While switch behaves as a stateless arrow at this point, that-	-- could change after a switch. Hence, SFTIVar overall.-	switchAuxA1 f1 = sf-	    where-		sf     = SFTIVar {sfTF' = tf}-		tf _ a =-		    case f1 a of-			(b, NoEvent) -> (sf, b)-			(_, Event c) -> sfTF (k c) a----- Switch with delayed observation.-dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b-dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}-    where-	tf0 a0 =-	    let (sf1, (b0, ec0)) = tf10 a0-            in (case ec0 of-                    NoEvent  -> dSwitchAux sf1-		    Event c0 -> fst (sfTF (k c0) a0),-                b0)--	dSwitchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b-	dSwitchAux (SFArr   {sfAFun = f1})           = dSwitchAuxA1 f1-	dSwitchAux sf1                               = SFTIVar {sfTF' = tf}-	    where-		tf dt a =-		    let (sf1', (b, ec)) = (sfTF' sf1) dt a-                    in (case ec of-			    NoEvent -> dSwitchAux sf1'-			    Event c -> fst (sfTF (k c) a),--			b)--	-- Note: While dSwitch behaves as a stateless arrow at this point, that-	-- could change after a switch. Hence, SFTIVar overall.-	dSwitchAuxA1 f1 = sf-	    where-		sf = SFTIVar {sfTF' = tf}-		tf _ a =-		    let (b, ec) = f1 a-                    in (case ec of-			    NoEvent -> sf-			    Event c -> fst (sfTF (k c) a),--			b)----- Recurring switch.-rSwitch :: SF a b -> SF (a, Event (SF a b)) b-rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)--{---- Old version. New is more efficient. Which one is clearer?-rSwitch :: SF a b -> SF (a, Event (SF a b)) b-rSwitch sf = switch (first sf) rSwitch'-    where-        rSwitch' sf = switch (sf *** notYet) rSwitch'--}----- Recurring switch with delayed observation.-drSwitch :: SF a b -> SF (a, Event (SF a b)) b-drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)--{---- Old version. New is more efficient. Which one is clearer?-drSwitch :: SF a b -> SF (a, Event (SF a b)) b-drSwitch sf = dSwitch (first sf) drSwitch'-    where-        drSwitch' sf = dSwitch (sf *** notYet) drSwitch'--}----- "Call-with-current-continuation" switch.-kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b-kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}-    where-        tf0 a0 =-	    let (sf1, b0) = tf10 a0-            in-	        case tfe0 (a0, b0) of-		    (sfe, NoEvent)  -> (kSwitchAux sf1 sfe, b0)-		    (_,   Event c0) -> sfTF (k sf10 c0) a0--        kSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1-        kSwitchAux sf1 sfe                          = SFTIVar {sfTF' = tf}-	    where-		tf dt a =-		    let	(sf1', b) = (sfTF' sf1) dt a-		    in-		        case (sfTF' sfe) dt (a, b) of-			    (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)-			    (_,    Event c) -> sfTF (k (freeze sf1 dt) c) a----- kSwitch with delayed observation.-dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b-dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}-    where-        tf0 a0 =-	    let (sf1, b0) = tf10 a0-            in (case tfe0 (a0, b0) of-		    (sfe, NoEvent)  -> dkSwitchAux sf1 sfe-		    (_,   Event c0) -> fst (sfTF (k sf10 c0) a0),-                b0)--        dkSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1-        dkSwitchAux sf1 sfe                          = SFTIVar {sfTF' = tf}-	    where-		tf dt a =-		    let	(sf1', b) = (sfTF' sf1) dt a-		    in (case (sfTF' sfe) dt (a, b) of-			    (sfe', NoEvent) -> dkSwitchAux sf1' sfe'-			    (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),-		        b)------------------------------------------------------------------------------------ Parallel composition and switching over collections with broadcasting---------------------------------------------------------------------------------broadcast :: Functor col => a -> col sf -> col (a, sf)-broadcast a sfs = fmap (\sf -> (a, sf)) sfs----- Spatial parallel composition of a signal function collection.-parB :: Functor col => col (SF a b) -> SF a (col b)-parB = par broadcast----- Parallel switch (dynamic collection of signal functions spatially composed--- in parallel).-pSwitchB :: Functor col =>-    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))-    -> SF a (col b)-pSwitchB = pSwitch broadcast---dpSwitchB :: Functor col =>-    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b))-    -> SF a (col b)-dpSwitchB = dpSwitch broadcast---rpSwitchB :: Functor col =>-    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)-rpSwitchB = rpSwitch broadcast---drpSwitchB :: Functor col =>-    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)-drpSwitchB = drpSwitch broadcast------------------------------------------------------------------------------------ Parallel composition and switching over collections with general routing----------------------------------------------------------------------------------- Spatial parallel composition of a signal function collection parameterized--- on the routing function.--- rf .........	Routing function: determines the input to each signal function---		in the collection. IMPORTANT! The routing function MUST---		preserve the structure of the signal function collection.--- sfs0 .......	Signal function collection.--- Returns the spatial parallel composition of the supplied signal functions.--par :: Functor col =>-    (forall sf . (a -> col sf -> col (b, sf)))-    -> col (SF b c)-    -> SF a (col c)-par rf sfs0 = SF {sfTF = tf0}-    where-	tf0 a0 =-	    let bsfs0 = rf a0 sfs0-		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0-		sfs   = fmap fst sfcs0-		cs0   = fmap snd sfcs0-	    in-		(parAux rf sfs, cs0)----- Internal definition. Also used in parallel swithers.-parAux :: Functor col =>-    (forall sf . (a -> col sf -> col (b, sf)))-    -> col (SF' b c)-    -> SF' a (col c)-parAux rf sfs = SFTIVar {sfTF' = tf}-    where-	tf dt a = -	    let bsfs  = rf a sfs-		sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs-		sfs'  = fmap fst sfcs'-		cs    = fmap snd sfcs'-	    in-	        (parAux rf sfs', cs)----- Parallel switch parameterized on the routing function. This is the most--- general switch from which all other (non-delayed) switches in principle--- can be derived. The signal function collection is spatially composed in--- parallel and run until the event signal function has an occurrence. Once--- the switching event occurs, all signal function are "frozen" and their--- continuations are passed to the continuation function, along with the--- event value.--- rf .........	Routing function: determines the input to each signal function---		in the collection. IMPORTANT! The routing function has an---		obligation to preserve the structure of the signal function---		collection.--- sfs0 .......	Signal function collection.--- sfe0 .......	Signal function generating the switching event.--- k .......... Continuation to be invoked once event occurs.--- Returns the resulting signal function.--pSwitch :: Functor col =>-    (forall sf . (a -> col sf -> col (b, sf)))-    -> col (SF b c)-    -> SF (a, col c) (Event d)-    -> (col (SF b c) -> d -> SF a (col c))-    -> SF a (col c)-pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}-    where-	tf0 a0 =-	    let bsfs0 = rf a0 sfs0-		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0-		sfs   = fmap fst sfcs0-		cs0   = fmap snd sfcs0-	    in-		case (sfTF sfe0) (a0, cs0) of-		    (sfe, NoEvent)  -> (pSwitchAux sfs sfe, cs0)-		    (_,   Event d0) -> sfTF (k sfs0 d0) a0--	pSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs-	pSwitchAux sfs sfe = SFTIVar {sfTF' = tf}-	    where-		tf dt a =-		    let bsfs  = rf a sfs-			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs-			sfs'  = fmap fst sfcs'-			cs    = fmap snd sfcs'-		    in-			case (sfTF' sfe) dt (a, cs) of-			    (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)-			    (_,    Event d) -> sfTF (k (freezeCol sfs dt) d) a----- Parallel switch with delayed observation parameterized on the routing--- function.-dpSwitch :: Functor col =>-    (forall sf . (a -> col sf -> col (b, sf)))-    -> col (SF b c)-    -> SF (a, col c) (Event d)-    -> (col (SF b c) -> d -> SF a (col c))-    -> SF a (col c)-dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}-    where-	tf0 a0 =-	    let bsfs0 = rf a0 sfs0-		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0-		cs0   = fmap snd sfcs0-	    in-		(case (sfTF sfe0) (a0, cs0) of-		     (sfe, NoEvent)  -> dpSwitchAux (fmap fst sfcs0) sfe-		     (_,   Event d0) -> fst (sfTF (k sfs0 d0) a0),-	         cs0)--	dpSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs-	dpSwitchAux sfs sfe = SFTIVar {sfTF' = tf}-	    where-		tf dt a =-		    let bsfs  = rf a sfs-			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs-			cs    = fmap snd sfcs'-		    in-			(case (sfTF' sfe) dt (a, cs) of-			     (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')-							    sfe'-			     (_,    Event d) -> fst (sfTF (k (freezeCol sfs dt)-							     d)-							  a),-                         cs)----- Recurring parallel switch parameterized on the routing function.--- rf .........	Routing function: determines the input to each signal function---		in the collection. IMPORTANT! The routing function has an---		obligation to preserve the structure of the signal function---		collection.--- sfs ........	Initial signal function collection.--- Returns the resulting signal function.--rpSwitch :: Functor col =>-    (forall sf . (a -> col sf -> col (b, sf)))-    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)-rpSwitch rf sfs =-    pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->-    noEventSnd >=- rpSwitch rf (f sfs')---{--rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k-    where-	k sfs f = rpSwitch' (f sfs)-	rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k--}---- Recurring parallel switch with delayed observation parameterized on the--- routing function.-drpSwitch :: Functor col =>-    (forall sf . (a -> col sf -> col (b, sf)))-    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)-drpSwitch rf sfs =-    dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->-    noEventSnd >=- drpSwitch rf (f sfs')--{--drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k-    where-	k sfs f = drpSwitch' (f sfs)-	drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k--}----------------------------------------------------------------------------------- Wave-form generation----------------------------------------------------------------------------------- Zero-order hold.-hold :: a -> SF (Event a) a-hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . hold)----- Tracks input signal when available, holds last value when disappears.-trackAndHold :: a -> SF (Maybe a) a-trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init------------------------------------------------------------------------------------ Accumulators---------------------------------------------------------------------------------accum :: a -> SF (Event (a -> a)) (Event a)-accum = accumBy (flip ($))--accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)-accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)-    where-        abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)---{---- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))-accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)-accumBy f b_init = SF {sfTF = tf0}-    where-        tf0 NoEvent    = (abAux b_init, NoEvent) -        tf0 (Event a0) = let b' = f b_init a0-		         in (abAux b', Event b')--        abAux b = SFTIVar {sfTF' = tf}-	    where-		tf _ NoEvent   = (abAux b, NoEvent)-		tf _ (Event a) = let b' = f b a-			         in (abAux b', Event b')--}--{--accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)-accumFilter f c_init = SF {sfTF = tf0}-    where-        tf0 NoEvent    = (afAux c_init, NoEvent) -        tf0 (Event a0) = case f c_init a0 of-		             (c', Nothing) -> (afAux c', NoEvent)-			     (c', Just b0) -> (afAux c', Event b0)--        afAux c = SFTIVar {sfTF' = tf}-	    where-		tf _ NoEvent   = (afAux c, NoEvent)-		tf _ (Event a) = case f c a of-			             (c', Nothing) -> (afAux c', NoEvent)-				     (c', Just b)  -> (afAux c', Event b)--}---accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)-accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)-    where-        afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)-        afAux (c, Just b)  = switch (now b &&& notYet) $ \a -> afAux (f c a)------------------------------------------------------------------------------------ Delays----------------------------------------------------------------------------------- Uninitialized delay operator.--- !!! The seq helps in the dynamic delay line example. But is it a good--- !!! idea in general? Are there other accumulators which should be seq'ed--- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying--- !!! design principle? What can the user assume?-pre = SF {sfTF = tf0}-    where-        tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")--	preAux a_prev = SFTIVar {sfTF' = tf}-	    where-		tf dt a = {- a_prev `seq` -} (preAux a, a_prev)----- Initialized delay operator.-iPre :: a -> SF a a-iPre = (--> pre)------------------------------------------------------------------------------------ Integraltion and differentiation----------------------------------------------------------------------------------- Integration using the rectangle rule.-integral :: VectorSpace a s => SF a a-integral = SF {sfTF = tf0}-    where-        igrl0  = zeroVector--	tf0 a0 = (integralAux igrl0 a0, igrl0)--	integralAux igrl a_prev = SFTIVar {sfTF' = tf}-	    where-	        tf dt a = (integralAux igrl' a, igrl')-		    where-		       igrl' = igrl ^+^ realToFrac dt *^ a_prev------ "immediate" integration (using the function's value at the current time)-imIntegral :: VectorSpace a s => a -> SF a a-imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)--iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b-f `iterFrom` b = SF (iterAux b) where-  iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)--{--integral :: Fractional a => SF a a-integral = SF {sfTF = tf0}-    where-        igrl0  = 0.0--	tf0 a0 = (integralAux igrl0 a0, igrl0)--	integralAux igrl a_prev = SFTIVar {sfTF' = tf}-	    where-	        tf dt a = (integralAux igrl' a, igrl')-		    where-		       igrl' = igrl + a_prev * realToFrac dt--}---- This is extremely crude. Use at your own risk.-derivative :: VectorSpace a s => SF a a-derivative = SF {sfTF = tf0}-    where-	tf0 a0 = (derivativeAux a0, zeroVector)--	derivativeAux a_prev = SFTIVar {sfTF' = tf}-	    where-	        tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)------------------------------------------------------------------------------------ Loops with guaranteed well-defined feedback---------------------------------------------------------------------------------loopPre :: c -> SF (a,c) (b,c) -> SF a b-loopPre c_init sf = loop (second (iPre c_init) >>> sf)----loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b-loopIntegral sf = loop (second integral >>> sf)------------------------------------------------------------------------------------ Noise (i.e. random signal generators) and stochastic processes----------------------------------------------------------------------------------- Noise (random signal) with default range for type in question;--- based on "randoms".-noise :: (RandomGen g, Random b) => g -> SF a b-noise g0 = streamToSF (randoms g0)----- Noise (random signal) with specified range; based on "randomRs".-noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b-noiseR range g0 = streamToSF (randomRs range g0)----- Internal. Not very useful for other purposes since we do not have any--- control over the intervals between each "sample". Or? A version with--- time-stamped samples would be similar to embedSynch (applied to identity).--- The list argument must be a stream (infinite list) at present.--streamToSF :: [b] -> SF a b-streamToSF []     = intErr "AFRP" "streamToSF" "Empty list!"-streamToSF (b:bs) = SF {sfTF = tf0}-    where-        tf0 _ = (stsfAux bs, b)--        stsfAux []     = intErr "AFRP" "streamToSF" "Empty list!"-        stsfAux (b:bs) = SFTIVar {sfTF' = tf}-	    where-		tf _ _ = (stsfAux bs, b)----- Stochastic event source with events occurring on average once every t_avg--- seconds. However, no more than one event results from any one sampling--- interval in the case of relatively sparse sampling, thus avoiding an--- "event backlog" should sampling become more frequent at some later--- point in time.--- !!! Maybe it would better to give a frequency? But like this to make--- !!! consitent with "repeatedly".-occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)-occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}-                       | otherwise = usrErr "AFRP" "occasionally"-				            "Non-positive average interval."-    where-	-- Generally, if events occur with an average frequency of f, the-	-- probability of at least one event occurring in an interval of t-        -- is given by (1 - exp (-f*t)). The goal in the following is to-	-- decide whether at least one event occurred in the interval of size-	-- dt preceding the current sample point. For the first point,-	-- we can think of the preceding interval as being 0, implying-	-- no probability of an event occurring.--	tf0 _ = (occAux ((randoms g) :: [Double]), NoEvent)--	occAux (r:rs) = SFTIVar {sfTF' = tf}-	    where-		tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at-			  in				-- least one event.-			      (occAux rs, if r < p then Event x else NoEvent)------------------------------------------------------------------------------------ Reactimation----------------------------------------------------------------------------------- Reactimation of a signal function.--- init .......	IO action for initialization. Will only be invoked once,---		at (logical) time 0, before first call to "sense".---		Expected to return the value of input at time 0.--- sense ......	IO action for sensing of system input.---	arg. #1 .......	True: action may block, waiting for an OS event.---			False: action must not block.---	res. #1 .......	Time interval since previous invocation of the sensing---			action (or, the first time round, the init action),---			returned. The interval must be _strictly_ greater---			than 0. Thus even a non-blocking invocation must---			ensure that time progresses.---	res. #2 .......	Nothing: input is unchanged w.r.t. the previously---			returned input sample.---			Just i: the input is currently i.---			It is OK to always return "Just", even if input is---			unchanged.--- actuate ....	IO action for outputting the system output.---	arg. #1 .......	True: output may have changed from previous output---			sample.---			False: output is definitely unchanged from previous---			output sample.---			It is OK to ignore argument #1 and assume that the---			the output has always changed.---	arg. #2 .......	Current output sample.---	result .......	Termination flag. Once True, reactimate will exit---			the reactimation loop and return to its caller.--- sf .........	Signal function to reactimate.--reactimate :: IO a-	      -> (Bool -> IO (DTime, Maybe a))-	      -> (Bool -> b -> IO Bool)-              -> SF a b-	      -> IO ()-reactimate init sense actuate (SF {sfTF = tf0}) =-    do-        a0 <- init-        let (sf, b0) = tf0 a0-        loop sf a0 b0-    where-        loop sf a b = do-	    done <- actuate True b-            unless (a `seq` b `seq` done) $ do-	        (dt, ma') <- sense False-		let a' = maybe a id ma'-                    (sf', b') = (sfTF' sf) dt a'-		loop sf' a' b'---- An API for animating a signal function when some other library--- needs to own the top-level control flow:---- reactimate's state, maintained across samples:-data ReactState a b = ReactState {-    rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,-    rsSF :: SF' a b,-    rsA :: a,-    rsB :: b-  }	      --type ReactHandle a b = IORef (ReactState a b)---- initialize top-level reaction handle-reactInit :: IO a -- init-             -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate-             -> SF a b-             -> IO (ReactHandle a b)-reactInit init actuate (SF {sfTF = tf0}) = -  do a0 <- init-     let (sf,b0) = tf0 a0-     -- TODO: really need to fix this interface, since right now we-     -- just ignore termination at time 0:-     r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,-				rsA = a0, rsB = b0 })-     done <- actuate r True b0-     return r---- process a single input sample:-react :: ReactHandle a b-      -> (DTime,Maybe a)-      -> IO Bool-react rh (dt,ma') = -  do rs@(ReactState {rsActuate = actuate,-	             rsSF = sf,-		     rsA = a,-		     rsB = b }) <- readIORef rh-     let a' = maybe a id ma'-         (sf',b') = (sfTF' sf) dt a'-     writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})-     done <- actuate rh True b'-     return done     ------------------------------------------------------------------------------------ Embedding----------------------------------------------------------------------------------- New embed interface. We will probably have to revisit this. To run an--- embedded signal function while retaining full control (e.g. start and--- stop at will), one would probably need a continuation based interface--- (as well as a continuation based underlying implementation).------ E.g. here are interesting alternative (or maybe complementary)--- signatures:------    sample :: SF a b -> SF (Event a) (Event b)---    sample' :: SF a b -> SF (Event (DTime, a)) (Event b)--embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]-embed sf0 (a0, dtas) = b0 : loop a0 sf dtas-    where-	(sf, b0) = (sfTF sf0) a0--        loop a_prev sf [] = []-	loop a_prev sf ((dt, ma) : dtas) =-	    b : (a `seq` b `seq` (loop a sf' dtas))-	    where-		a        = maybe a_prev id ma-	        (sf', b) = (sfTF' sf) dt a----- Synchronous embedding. The embedded signal function is run on the supplied--- input and time stream at a given (but variable) ratio >= 0 to the outer--- time flow. When the ratio is 0, the embedded signal function is paused.---- !!! Should "dropped frames" be forced to avoid space leaks?--- !!! It's kind of hard to se why, but "frame dropping" was a problem--- !!! in the old robot simulator. Try to find an example!--embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b-embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}-    where-        tts       = scanl (\t (dt, _) -> t + dt) 0 dtas-	bbs@(b:_) = embed sf0 (a0, dtas)--	tf0 r = (esAux 0 (zip tts bbs), b)--	esAux _       []    = intErr "AFRP" "embedSynch" "Empty list!"-	esAux tp_prev tbtbs = SFTIVar {sfTF' = tf}-	    where-		tf dt r | r < 0     = usrErr "AFRP" "embedSynch"-					     "Negative ratio."-			| otherwise = let tp = tp_prev + dt * r-					  (b, tbtbs') = advance tp tbtbs-				      in-					  (esAux tp tbtbs', b)--		-- Advance the time stamped stream to the perceived time tp.-		-- Under the assumption that the perceived time never goes-		-- backwards (non-negative ratio), advance maintains the-		-- invariant that the perceived time is always >= the first-		-- time stamp.-		advance tp tbtbs@[(t, b)] = (b, tbtbs)-		advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))-		    | tp <  t' = (b, tbtbtbs)-		    | t' <= tp = advance tp tbtbs---deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])-deltaEncode _  []        = usrErr "AFRP" "deltaEncode" "Empty input list."-deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas---deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])-deltaEncodeBy _  _  []      = usrErr "AFRP" "deltaEncodeBy" "Empty input list."-deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))-    where-	debAux a_prev []                     = []-	debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as-                             | otherwise     = Just a  : debAux a as
− src/AFRPAffineSpace.hs 
@@ -1,40 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPAffineSpace
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Affine space type relation.
---
-module AFRPAffineSpace where
-
-import AFRPVectorSpace
-
-------------------------------------------------------------------------------
--- 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)
− src/AFRPDiagnostics.hs 
@@ -1,18 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPDiagnostics
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Standardized error-reporting for AFRP 
---
-module AFRPDiagnostics where
-
-usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)
-
-intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "
-                          ++ msg)
− src/AFRPEvent.hs 
@@ -1,286 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPEvent
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Definition of AFRP 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 AFRP 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 AFRPEvent where
-
-import AFRPDiagnostics
-import AFRPForceable
-
-
-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
-
-
--- 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 f 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
-
-
--- 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)
-------------------------------------------------------------------------------
-
--- 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
− src/AFRPForceable.hs 
@@ -1,75 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPForceable
--- Copyright   :  (c) Zhanyong Wan, Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Hyperstrict evaluation.
---
-module AFRPForceable 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
− src/AFRPGeometry.hs 
@@ -1,29 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPGeometry
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Basic geometrical abstractions.
---
-module AFRPGeometry (
-    module AFRPVectorSpace,
-    module AFRPAffineSpace,
-    module AFRPVector2,
-    module AFRPVector3,
-    module AFRPPoint2,
-    module AFRPPoint3
-) where
-
-import AFRPVectorSpace
-import AFRPAffineSpace
-import AFRPVector2
-import AFRPVector3
-import AFRPPoint2
-import AFRPPoint3
-
-
− src/AFRPInternals.hs 
@@ -1,36 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPInternals
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- An interface giving access to some of the internal
--- details of the AFRP implementation.
---
--- This interface is indended to be used when the need arises to break
--- abstraction barriers, e.g. for interfacing AFRP 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 AFRPInternals (
-    Event(..)		-- The event type, its constructors, and instances.
-) where
-
-import AFRPEvent
-
-
-------------------------------------------------------------------------------
--- 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)
-
-
− src/AFRPMergeableRecord.hs 
@@ -1,77 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPMergeableRecord
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- 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 AFRPMergeableRecord (
-    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
− src/AFRPMiscellany.hs 
@@ -1,120 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPMiscellany
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Collection of entities that really should be part
--- the Haskell 98 prelude or simply have no better
--- home.
---
-module AFRPMiscellany (
--- 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
-------------------------------------------------------------------------------
-
-( # ) :: (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 f []             = []
-mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys
-
-mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]
-mapSnd f []             = []
-mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys
-
-
-------------------------------------------------------------------------------
--- Generalized tuple selectors
-------------------------------------------------------------------------------
-
--- Triples
-
-sel3_1 (x,_,_) = x
-sel3_2 (_,x,_) = x
-sel3_3 (_,_,x) = x
-
-
--- 4-tuples
-
-sel4_1 (x,_,_,_) = x
-sel4_2 (_,x,_,_) = x
-sel4_3 (_,_,x,_) = x
-sel4_4 (_,_,_,x) = x
-
-
--- 5-tuples
-
-sel5_1 (x,_,_,_,_) = x
-sel5_2 (_,x,_,_,_) = x
-sel5_3 (_,_,x,_,_) = x
-sel5_4 (_,_,_,x,_) = x
-sel5_5 (_,_,_,_,x) = x
-
-
-------------------------------------------------------------------------------
--- Floating point utilities
-------------------------------------------------------------------------------
-
--- Floating-point div and modulo operators.
-
-fDiv :: (RealFrac a, Integral b) => a -> a -> b
-fDiv x y = fst (fDivMod x y)
-
-
-fMod :: RealFrac a => a -> a -> a
-fMod x y = snd (fDivMod x y)
-
-
-fDivMod :: (RealFrac a, Integral b) => a -> a -> (b, a)
-fDivMod x y = (q, r)
-    where
-        q = (floor (x/y))
-        r = x - fromIntegral q * y
− src/AFRPPoint2.hs 
@@ -1,59 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPPoint2
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- 2D point abstraction (R^2).
---
-module AFRPPoint2 (
-    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 AFRPVectorSpace
-import AFRPAffineSpace
-import AFRPVector2
-import AFRPForceable
-
-------------------------------------------------------------------------------
--- 2D point, constructors and selectors.
-------------------------------------------------------------------------------
-
-data RealFloat a => Point2 a = Point2 !a !a deriving Eq
-
-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
− src/AFRPPoint3.hs 
@@ -1,66 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPPoint3
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- 3D point abstraction (R^3).
---
-module AFRPPoint3 (
-    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 AFRPVectorSpace
-import AFRPAffineSpace
-import AFRPVector3
-import AFRPForceable
-
-------------------------------------------------------------------------------
--- 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
− src/AFRPTask.hs 
@@ -1,218 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPTask
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Task abstraction on top of signal transformers.
---
-module AFRPTask (
-    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 AFRP
-import AFRPUtilities (snap)
-import AFRPDiagnostics
-
-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???
− src/AFRPUtilities.hs 
@@ -1,277 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  AFRPUtilities--- Copyright   :  (c) Yale University, 2003--- License     :  BSD-style (see the file LICENSE)--- --- Maintainer  :  antony@apocalypse.org--- Stability   :  provisional--- Portability :  non-portable (uses GHC extensions)------ 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---   AFRPArrowUtilities.--- * I'm not sure structuring the AFRP "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 AFRPUtilities (---- 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)---- 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-    dHold,		-- :: a -> SF (Event a) a-    dTrackAndHold,	-- :: a -> SF (Maybe a) a---- Accumulators-    accumHold,		-- :: a -> SF (Event (a -> a)) a-    dAccumHold,		-- :: a -> SF (Event (a -> a)) a-    accumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b-    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-) where--import AFRPDiagnostics-import AFRP--infixr 0 `fby`------------------------------------------------------------------------------------- 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.-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.-recur :: SF a (Event b) -> SF a (Event b)-recur sfe = switch (never &&& sfe) recurAux-    where-	recurAux b = switch (now b &&& sfe) recurAux------------------------------------------------------------------------------------ Parallel composition/switchers with "zip" routing---------------------------------------------------------------------------------safeZip :: String -> [a] -> [b] -> [(a,b)]-safeZip fn as bs = safeZip' as bs-    where-	safeZip' as []     = []-	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).-dHold :: a -> SF (Event a) a-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---------------------------------------------------------------------------------accumHold :: a -> SF (Event (a -> a)) a-accumHold a_init = accum a_init >>> hold a_init---dAccumHold :: a -> SF (Event (a -> a)) a-dAccumHold a_init = accum a_init >>> dHold a_init---accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b-accumHoldBy f b_init = accumBy f b_init >>> hold b_init---dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b-dAccumHoldBy f b_init = accumBy f b_init >>> 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 (^+^)
− src/AFRPVector2.hs 
@@ -1,99 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPVector2
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- 2D vector abstraction (R^2).
---
-module AFRPVector2 (
-    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 AFRPVectorSpace
-import AFRPForceable
-
-
-------------------------------------------------------------------------------
--- 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
− src/AFRPVector3.hs 
@@ -1,117 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPVector3
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- 3D vector abstraction (R^3).
---
-module AFRPVector3 (
-    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 AFRPVectorSpace
-import AFRPForceable
-
-------------------------------------------------------------------------------
--- 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
-
-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 x y 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
− src/AFRPVectorSpace.hs 
@@ -1,157 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  AFRPVectorSpace
--- Copyright   :  (c) Yale University, 2003
--- License     :  BSD-style (see the file LICENSE)
--- 
--- Maintainer  :  antony@apocalypse.org
--- Stability   :  provisional
--- Portability :  non-portable (uses GHC extensions)
---
--- Vector space type relation and basic instances.	
---
-module AFRPVectorSpace 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 ^+^ 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
-
-
-
+ src/FRP/Yampa.hs view
@@ -0,0 +1,3281 @@+{-# LANGUAGE GADTs, Rank2Types #-}++-- 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',++-- 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(..))++import Control.Arrow+import FRP.Yampa.Diagnostics+import FRP.Yampa.Miscellany (( # ), dup, swap)+import FRP.Yampa.Event+import FRP.Yampa.VectorSpace++-- import 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+------------------------------------------------------------------------------++instance Arrow SF where+    arr    = arrPrim+    (>>>)  = compPrim+    first  = firstPrim+    second = secondPrim+    (***)  = parSplitPrim+    (&&&)  = parFanOutPrim+++-- 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.+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!
+ src/FRP/Yampa/AffineSpace.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}++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)
+ src/FRP/Yampa/Diagnostics.hs view
@@ -0,0 +1,8 @@+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)
+ src/FRP/Yampa/Event.hs view
@@ -0,0 +1,284 @@+-- 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 AFRP 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
+ src/FRP/Yampa/Forceable.hs view
@@ -0,0 +1,63 @@+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
+ src/FRP/Yampa/Geometry.hs view
@@ -0,0 +1,17 @@+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++
+ src/FRP/Yampa/Internals.hs view
@@ -0,0 +1,37 @@+{-+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPInternals                                        *+*       Purpose:        An interface giving access to some of the internal   *+*			details of the AFRP implementation.		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- This interface is indended to be used when the need arises to break+-- abstraction barriers, e.g. for interfacing AFRP 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)++
+ src/FRP/Yampa/MergeableRecord.hs view
@@ -0,0 +1,65 @@+-- 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
+ src/FRP/Yampa/Miscellany.hs view
@@ -0,0 +1,124 @@+-- !!! 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
+ src/FRP/Yampa/Point2.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- 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
+ src/FRP/Yampa/Point3.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++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
+ src/FRP/Yampa/Task.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE Rank2Types #-}+++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???
+ src/FRP/Yampa/Utilities.hs view
@@ -0,0 +1,336 @@+-- 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+--   AFRPArrowUtilities.+--   I'm not sure structuring the AFRP "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 (^+^)
+ src/FRP/Yampa/Vector2.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+++-- 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
+ src/FRP/Yampa/Vector3.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-- 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
+ src/FRP/Yampa/VectorSpace.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}++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+++
tests/AFRPTests.hs view
@@ -1,176 +1,192 @@-{- $Id: AFRPTests.hs,v 1.27 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTests                                            *
-*       Purpose:        AFRP regression tests.				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
--- TODO:
--- * Add test cases for AFRP. There should be at least one test case for each
---   "non-trivial" entity exported from AFRP.
---
--- * Make tests cases for after and repeatedly more robust.  Must not
---   fail due to small discrepancies in floating point implementation.
---
---   01-May-2002:  evsrc_t7 currently fails in hugs.
---
--- * Restructure test cases for papallel composition and switches to reflect
---   AFRP structure better. Separate test cases for the generic definitions?
--- There are some test cases for AFRPUtils. Not intended to be exhaustive.
---
--- VectorSpace has caused some ambiguity problems. See e.g. looplaws_t2,
--- switch_t1a.
-
-module AFRPTests where
-
-import AFRP
-import AFRPTask (forAll)
-
-import AFRPTestsCommon
-import AFRPTestsArr
-import AFRPTestsComp
-import AFRPTestsFirstSecond
-import AFRPTestsLaws
-import AFRPTestsLoop
-import AFRPTestsLoopLaws
-import AFRPTestsBasicSF
-import AFRPTestsEvSrc
-import AFRPTestsCOC
-import AFRPTestsSwitch
-import AFRPTestsKSwitch
-import AFRPTestsRSwitch
-import AFRPTestsPSwitch
-import AFRPTestsRPSwitch
-import AFRPTestsWFG
-import AFRPTestsAccum
-import AFRPTestsDelay
-import AFRPTestsDer
-import AFRPTestsLoopPre
-import AFRPTestsLoopIntegral
-import AFRPTestsReact
-import AFRPTestsEmbed
-import AFRPTestsUtils
-import AFRPTestsTask
-
-
-------------------------------------------------------------------------------
--- Global test and error reporting
-------------------------------------------------------------------------------
-
-allGood = arr_tr
-          && comp_tr
-          && first_tr
-          && second_tr
-          && laws_tr
-          && loop_tr
-          && looplaws_tr
-          && basicsf_tr
-          && evsrc_tr
- 	  && coc_tr
- 	  && switch_tr
- 	  && kswitch_tr
- 	  && rswitch_tr
- 	  && pswitch_tr
- 	  && rpswitch_tr
- 	  && wfg_tr
-	  && accum_tr
- 	  && delay_tr
-	  && der_tr
-	  && loopPre_tr
-	  && loopIntegral_tr
-	  && react_tr
-	  && embed_tr
-	  && utils_tr
-	  && task_tr
-
-
-all_trs =
-    [ ("arr",          arr_trs),
-      ("comp",         comp_trs),
-      ("first",        first_trs),
-      ("second",       second_trs),
-      ("laws",         laws_trs),
-      ("loop",         loop_trs),
-      ("looplaws",     looplaws_trs),
-      ("basicsf",      basicsf_trs),
-      ("evsrc",        evsrc_trs),
-      ("coc",          coc_trs),
-      ("switch",       switch_trs),
-      ("kswitch",      kswitch_trs),
-      ("rswitch",      rswitch_trs),
-      ("pswitch",      pswitch_trs),
-      ("rpswitch",     rpswitch_trs),
-      ("wfg",	       wfg_trs),
-      ("accum",	       accum_trs),
-      ("delay",        delay_trs),
-      ("der",          der_trs),
-      ("loopPre",      loopPre_trs),
-      ("loopIntegral", loopIntegral_trs),
-      ("react",        react_trs),
-      ("embed",        embed_trs),
-      ("utils",        utils_trs),
-      ("task",         task_trs)
-    ]
-
-
-failedTests =
-    [ format n i | (n, trs) <- all_trs, (i, tr) <- zip [0..] trs, not tr ]
-    where
-	format n i = "Test " ++ n ++ "_t" ++ show i ++ " failed."
-
-
-runRegTests :: IO ()
-runRegTests = do
-    putStrLn ""
-    putStrLn "Running the AFRP regression tests ..."
-    if allGood then
-	putStrLn "All tests succeeded!"
-     else
-	forAll failedTests putStrLn
-
-
-runSpaceTests :: IO ()
-runSpaceTests = do
-    putStrLn ""
-    putStrLn "Running the AFRP space tests ..."
-    putStrLn "Testing the space behaviour. This may take a LONG time."
-    putStrLn "Observe the process size using some tool like top."
-    putStrLn "The process should not grow significantly."
-    putStrLn "Emitted success/failure indications signify termination"
-    putStrLn "and whether or not the right result was obtained. They do"
-    putStrLn "not necessarily indicate that the space behaviour is correct"
-    putStrLn "(i.e., absence of leaks)."
-    putStrLn ""
-    rst "arr" 0 arr_st0 arr_st0r
-    rst "arr" 1 arr_st1 arr_st1r
-    rst "loop" 0 loop_st0 loop_st0r
-    rst "loop" 1 loop_st1 loop_st1r
-    rst "rswitch" 0 rswitch_st0 rswitch_st0r
-    rst "pswitch" 0 pswitch_st0 pswitch_st0r
-    rst "pswitch" 1 pswitch_st1 pswitch_st1r
-    rst "rpswitch" 0 rpswitch_st0 rpswitch_st0r
-    rst "accum" 0 accum_st0 accum_st0r
-    rst "accum" 1 accum_st1 accum_st1r
-    where
-	rst n i st str = do
-	    putStrLn ("Running " ++ n ++ "_st" ++ show i ++ " ...")
-	    if st ~= str then
-		putStrLn "Success!"
-	     else
-		-- We probably won't get here in case of a (space) failure ...
-		putStrLn "Failure!"
-
--- AC: here because I had trouble running ghci:
--- fixTest :: IO ()
--- fixTest =
---   let vs = loop_t17
---   in putStrLn ("loop_t17 output: " ++ show vs)
-
-
-
+{- $Id: AFRPTests.hs,v 1.27 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTests                                            *+*       Purpose:        AFRP regression tests.				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- TODO:+-- * Add test cases for AFRP. There should be at least one test case for each+--   "non-trivial" entity exported from AFRP.+--+-- * Make tests cases for after and repeatedly more robust.  Must not+--   fail due to small discrepancies in floating point implementation.+--+--   01-May-2002:  evsrc_t7 currently fails in hugs.+--+-- * Restructure test cases for papallel composition and switches to reflect+--   AFRP structure better. Separate test cases for the generic definitions?+-- There are some test cases for AFRPUtils. Not intended to be exhaustive.+--+-- VectorSpace has caused some ambiguity problems. See e.g. looplaws_t2,+-- switch_t1a.+--+-- 2005-11-26: A simple way of making many test cases more robust would+-- be to have a version of deltaEncode that adds a little extra time+-- to the very first delta time. That way sampling would always be slightly+-- "late".+--+-- But since we often compare time stamps, we'd also either have+-- to adjust the "~=" relation to tolerate "jitter" of that magnitute,+-- or we'd have to formulate many tests more carefully to allow a+-- certain "fuzziness".++module AFRPTests where++import FRP.Yampa+import FRP.Yampa.Task (forAll)++import AFRPTestsCommon+import AFRPTestsArr+import AFRPTestsComp+import AFRPTestsFirstSecond+import AFRPTestsLaws+import AFRPTestsLoop+import AFRPTestsLoopLaws+import AFRPTestsBasicSF+import AFRPTestsSscan+import AFRPTestsEvSrc+import AFRPTestsCOC+import AFRPTestsSwitch+import AFRPTestsKSwitch+import AFRPTestsRSwitch+import AFRPTestsPSwitch+import AFRPTestsRPSwitch+import AFRPTestsWFG+import AFRPTestsAccum+import AFRPTestsPre+import AFRPTestsDelay+import AFRPTestsDer+import AFRPTestsLoopPre+import AFRPTestsLoopIntegral+import AFRPTestsReact+import AFRPTestsEmbed+import AFRPTestsUtils+import AFRPTestsTask+++------------------------------------------------------------------------------+-- Global test and error reporting+------------------------------------------------------------------------------++allGood = arr_tr+          && comp_tr+          && first_tr+          && second_tr+          && laws_tr+          && loop_tr+          && looplaws_tr+          && basicsf_tr+          && sscan_tr+          && evsrc_tr+ 	  && coc_tr+ 	  && switch_tr+ 	  && kswitch_tr+ 	  && rswitch_tr+ 	  && pswitch_tr+ 	  && rpswitch_tr+ 	  && wfg_tr+	  && accum_tr+          && pre_tr+ 	  && delay_tr+	  && der_tr+	  && loopPre_tr+	  && loopIntegral_tr+	  && react_tr+	  && embed_tr+	  && utils_tr+	  && task_tr+++all_trs =+    [ ("arr",          arr_trs),+      ("comp",         comp_trs),+      ("first",        first_trs),+      ("second",       second_trs),+      ("laws",         laws_trs),+      ("loop",         loop_trs),+      ("looplaws",     looplaws_trs),+      ("basicsf",      basicsf_trs),+      ("sscan",	       sscan_trs),+      ("evsrc",        evsrc_trs),+      ("coc",          coc_trs),+      ("switch",       switch_trs),+      ("kswitch",      kswitch_trs),+      ("rswitch",      rswitch_trs),+      ("pswitch",      pswitch_trs),+      ("rpswitch",     rpswitch_trs),+      ("wfg",	       wfg_trs),+      ("accum",	       accum_trs),+      ("pre",	       pre_trs),+      ("delay",        delay_trs),+      ("der",          der_trs),+      ("loopPre",      loopPre_trs),+      ("loopIntegral", loopIntegral_trs),+      ("react",        react_trs),+      ("embed",        embed_trs),+      ("utils",        utils_trs),+      ("task",         task_trs)+    ]+++failedTests =+    [ format n i | (n, trs) <- all_trs, (i, tr) <- zip [0..] trs, not tr ]+    where+	format n i = "Test " ++ n ++ "_t" ++ show i ++ " failed."+++runRegTests :: IO ()+runRegTests = do+    putStrLn ""+    putStrLn "Running the AFRP regression tests ..."+    if allGood then+	putStrLn "All tests succeeded!"+     else+	forAll failedTests putStrLn+++runSpaceTests :: IO ()+runSpaceTests = do+    putStrLn ""+    putStrLn "Running the AFRP space tests ..."+    putStrLn "Testing the space behaviour. This may take a LONG time."+    putStrLn "Observe the process size using some tool like top."+    putStrLn "The process should not grow significantly."+    putStrLn "Emitted success/failure indications signify termination"+    putStrLn "and whether or not the right result was obtained. They do"+    putStrLn "not necessarily indicate that the space behaviour is correct"+    putStrLn "(i.e., absence of leaks)."+    putStrLn ""+    rst "arr" 0 arr_st0 arr_st0r+    rst "arr" 1 arr_st1 arr_st1r+    rst "loop" 0 loop_st0 loop_st0r+    rst "loop" 1 loop_st1 loop_st1r+    rst "rswitch" 0 rswitch_st0 rswitch_st0r+    rst "pswitch" 0 pswitch_st0 pswitch_st0r+    rst "pswitch" 1 pswitch_st1 pswitch_st1r+    rst "rpswitch" 0 rpswitch_st0 rpswitch_st0r+    rst "accum" 0 accum_st0 accum_st0r+    rst "accum" 1 accum_st1 accum_st1r+    where+	rst n i st str = do+	    putStrLn ("Running " ++ n ++ "_st" ++ show i ++ " ...")+	    if st ~= str then+		putStrLn "Success!"+	     else+		-- We probably won't get here in case of a (space) failure ...+		putStrLn "Failure!"++-- AC: here because I had trouble running ghci:+-- fixTest :: IO ()+-- fixTest =+--   let vs = loop_t17+--   in putStrLn ("loop_t17 output: " ++ show vs)+++
tests/AFRPTestsAccum.hs view
@@ -1,205 +1,361 @@-{- $Id: AFRPTestsAccum.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsAccum					     *
-*       Purpose:        Test cases for accumulators			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsAccum (
-    accum_tr,
-    accum_trs,
-    accum_st0,
-    accum_st0r,
-    accum_st1,
-    accum_st1r
-) where
-
-import Maybe (fromJust)
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for accumulators
-------------------------------------------------------------------------------
-
-accum_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))
-    where
-	delta_inp =
-	    [Just NoEvent, Nothing, Just (Event (+1.0)), Just NoEvent,
-	     Just (Event (+2.0)), Just NoEvent, Nothing, Nothing,
-	     Just (Event (*3.0)), Just (Event (+5.0)), Nothing, Just NoEvent,
-	     Just (Event (/2.0)), Just NoEvent, Nothing, Nothing]
-            ++ repeat Nothing
-
-accum_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))
-    where
-	delta_inp =
-	    [Just (Event (+1.0)), Just NoEvent, Nothing, Nothing,
-	     Just (Event (+2.0)), Just NoEvent, Nothing, Nothing,
-	     Just (Event (*3.0)), Just (Event (+5.0)), Nothing, Just NoEvent,
-	     Just (Event (/2.0)), Just NoEvent, Nothing, Nothing]
-            ++ repeat Nothing
-
-accum_inp3 = deltaEncode 1.0 $
-    [NoEvent,   NoEvent,   Event 1.0, NoEvent,
-     Event 2.0, NoEvent,   NoEvent,   NoEvent,
-     Event 3.0, Event 5.0, Event 5.0, NoEvent,
-     Event 0.0, NoEvent,   NoEvent,   NoEvent]
-    ++ repeat NoEvent
-
-accum_inp4 = deltaEncode 1.0 $
-    [Event 1.0, NoEvent,   NoEvent,   NoEvent,
-     Event 2.0, NoEvent,   NoEvent,   NoEvent,
-     Event 3.0, Event 5.0, Event 5.0, NoEvent,
-     Event 0.0, NoEvent,   NoEvent,   NoEvent]
-    ++ repeat NoEvent
-
-
-accum_t0 :: [Event Double]
-accum_t0 = take 16 $ embed (accum 0.0) accum_inp1
-
-accum_t0r =
-    [NoEvent,   NoEvent,    Event 1.0,  NoEvent,
-     Event 3.0, NoEvent,    NoEvent,    NoEvent,
-     Event 9.0, Event 14.0, Event 19.0, NoEvent,
-     Event 9.5, NoEvent,    NoEvent,    NoEvent]
-
-
-accum_t1 :: [Event Double]
-accum_t1 = take 16 $ embed (accum 0.0) accum_inp2
-
-accum_t1r =
-    [Event 1.0, NoEvent,    NoEvent,    NoEvent,
-     Event 3.0, NoEvent,    NoEvent,    NoEvent,
-     Event 9.0, Event 14.0, Event 19.0, NoEvent,
-     Event 9.5, NoEvent,    NoEvent,    NoEvent]
-
-
-accum_t2 :: [Event Int]
-accum_t2 = take 16 $ embed (accumBy (\a d -> a + floor d) 0) accum_inp3
-
-accum_t2r :: [Event Int]
-accum_t2r =
-    [NoEvent,  NoEvent,  Event 1,  NoEvent,
-     Event 3,  NoEvent,  NoEvent,  NoEvent,
-     Event 6,  Event 11, Event 16, NoEvent,
-     Event 16, NoEvent,  NoEvent,  NoEvent]
-
-
-accum_t3 :: [Event Int]
-accum_t3 = take 16 $ embed (accumBy (\a d -> a + floor d) 0) accum_inp4
-
-accum_t3r :: [Event Int]
-accum_t3r =
-    [Event 1,  NoEvent,  NoEvent,  NoEvent,
-     Event 3,  NoEvent,  NoEvent,  NoEvent,
-     Event 6,  Event 11, Event 16, NoEvent,
-     Event 16, NoEvent,  NoEvent,  NoEvent]
-
-
-accum_accFiltFun1 a d =
-    let a' = a + floor d
-    in
-        if even a' then
-	    (a', Just (a' > 10, a'))
-        else
-	    (a', Nothing)
-
-accum_t4 :: [Event (Bool,Int)]
-accum_t4 = take 16 $ embed (accumFilter accum_accFiltFun1 0) accum_inp3
-
-accum_t4r :: [Event (Bool,Int)]
-accum_t4r =
-    [NoEvent,         NoEvent, NoEvent,         NoEvent,
-     NoEvent,         NoEvent, NoEvent,         NoEvent,
-     Event (False,6), NoEvent, Event (True,16), NoEvent,
-     Event (True,16), NoEvent, NoEvent,         NoEvent]
-
-
-accum_accFiltFun2 a d =
-    let a' = a + floor d
-    in
-        if odd a' then
-	    (a', Just (a' > 10, a'))
-        else
-	    (a', Nothing)
-
-accum_t5 :: [Event (Bool,Int)]
-accum_t5 = take 16 $ embed (accumFilter accum_accFiltFun2 0) accum_inp4
-
-accum_t5r :: [Event (Bool,Int)]
-accum_t5r =
-    [Event (False,1), NoEvent,         NoEvent, NoEvent,
-     Event (False,3), NoEvent,         NoEvent, NoEvent,
-     NoEvent,         Event (True,11), NoEvent, NoEvent,
-     NoEvent,         NoEvent,         NoEvent, NoEvent]
-
-
--- This can be seen as the definition of accumFilter
-accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
-accumFilter2 f c_init =
-    switch (never &&& attach c_init) afAux
-    where
-	afAux (c, a) =
-            case f c a of
-	        (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux
-	        (c', Just b)  -> switch (now b &&& (notYet>>>attach c')) afAux
-
-	attach :: b -> SF (Event a) (Event (b, a))
-        attach c = arr (fmap (\a -> (c, a)))
-
-accum_t6 :: [Event (Bool,Int)]
-accum_t6 = take 16 $ embed (accumFilter2 accum_accFiltFun1 0) accum_inp3
-
-accum_t6r = accum_t4	-- Should agree!
-
-accum_t7 :: [Event (Bool,Int)]
-accum_t7 = take 16 $ embed (accumFilter2 accum_accFiltFun2 0) accum_inp4
-
-accum_t7r = accum_t5	-- Should agree!
-
-
-accum_trs =
-    [ accum_t0 == accum_t0r,
-      accum_t1 == accum_t1r,
-      accum_t2 == accum_t2r,
-      accum_t3 == accum_t3r,
-      accum_t4 == accum_t4r,
-      accum_t5 == accum_t5r,
-      accum_t6 == accum_t6r,
-      accum_t7 == accum_t7r
-    ]
-
-accum_tr = and accum_trs
-
-
-accum_st0 :: Double
-accum_st0 = testSFSpaceLeak 1000000
-                            (repeatedly 1.0 1.0
-                             >>> accumBy (+) 0.0
-                             >>> hold (-99.99))
-
-accum_st0r = 249999.0
-
-
-accum_st1 :: Double
-accum_st1 = testSFSpaceLeak 1000000
-                            (arr dup
-			     >>> first (repeatedly 1.0 1.0)
-			     >>> arr (\(e,a) -> tag e a)
-                             >>> accumFilter accumFun 0.0
-                             >>> hold (-99.99))
-    where
-	accumFun c a | even (floor a) = (c+a, Just (c+a))
-		     | otherwise      = (c, Nothing)
-
-accum_st1r = 6.249975e10
+{- $Id: AFRPTestsAccum.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsAccum					     *+*       Purpose:        Test cases for accumulators			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                           University of Nottingham, 2005                   *+*                                                                            *+******************************************************************************+-}++module AFRPTestsAccum (+    accum_tr,+    accum_trs,+    accum_st0,+    accum_st0r,+    accum_st1,+    accum_st1r+) where++import Data.Maybe (fromJust)++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for accumulators+------------------------------------------------------------------------------++accum_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))+    where+	delta_inp =+	    [Just NoEvent, Nothing, Just (Event (+1.0)), Just NoEvent,+	     Just (Event (+2.0)), Just NoEvent, Nothing, Nothing,+	     Just (Event (*3.0)), Just (Event (+5.0)), Nothing, Just NoEvent,+	     Just (Event (/2.0)), Just NoEvent, Nothing, Nothing]+            ++ repeat Nothing++accum_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))+    where+	delta_inp =+	    [Just (Event (+1.0)), Just NoEvent, Nothing, Nothing,+	     Just (Event (+2.0)), Just NoEvent, Nothing, Nothing,+	     Just (Event (*3.0)), Just (Event (+5.0)), Nothing, Just NoEvent,+	     Just (Event (/2.0)), Just NoEvent, Nothing, Nothing]+            ++ repeat Nothing++accum_inp3 = deltaEncode 1.0 $+    [NoEvent,   NoEvent,   Event 1.0, NoEvent,+     Event 2.0, NoEvent,   NoEvent,   NoEvent,+     Event 3.0, Event 5.0, Event 5.0, NoEvent,+     Event 0.0, NoEvent,   NoEvent,   NoEvent]+    ++ repeat NoEvent++accum_inp4 = deltaEncode 1.0 $+    [Event 1.0, NoEvent,   NoEvent,   NoEvent,+     Event 2.0, NoEvent,   NoEvent,   NoEvent,+     Event 3.0, Event 5.0, Event 5.0, NoEvent,+     Event 0.0, NoEvent,   NoEvent,   NoEvent]+    ++ repeat NoEvent+++accum_inp5 = deltaEncode 0.25 (repeat ())+++accum_t0 :: [Event Double]+accum_t0 = take 16 $ embed (accum 0.0) accum_inp1++accum_t0r =+    [NoEvent,   NoEvent,    Event 1.0,  NoEvent,+     Event 3.0, NoEvent,    NoEvent,    NoEvent,+     Event 9.0, Event 14.0, Event 19.0, NoEvent,+     Event 9.5, NoEvent,    NoEvent,    NoEvent]+++accum_t1 :: [Event Double]+accum_t1 = take 16 $ embed (accum 0.0) accum_inp2++accum_t1r =+    [Event 1.0, NoEvent,    NoEvent,    NoEvent,+     Event 3.0, NoEvent,    NoEvent,    NoEvent,+     Event 9.0, Event 14.0, Event 19.0, NoEvent,+     Event 9.5, NoEvent,    NoEvent,    NoEvent]+++accum_t2 :: [Event Int]+accum_t2 = take 16 $ embed (accumBy (\a d -> a + floor d) 0) accum_inp3++accum_t2r :: [Event Int]+accum_t2r =+    [NoEvent,  NoEvent,  Event 1,  NoEvent,+     Event 3,  NoEvent,  NoEvent,  NoEvent,+     Event 6,  Event 11, Event 16, NoEvent,+     Event 16, NoEvent,  NoEvent,  NoEvent]+++accum_t3 :: [Event Int]+accum_t3 = take 16 $ embed (accumBy (\a d -> a + floor d) 0) accum_inp4++accum_t3r :: [Event Int]+accum_t3r =+    [Event 1,  NoEvent,  NoEvent,  NoEvent,+     Event 3,  NoEvent,  NoEvent,  NoEvent,+     Event 6,  Event 11, Event 16, NoEvent,+     Event 16, NoEvent,  NoEvent,  NoEvent]+++accum_accFiltFun1 a d =+    let a' = a + floor d+    in+        if even a' then+	    (a', Just (a' > 10, a'))+        else+	    (a', Nothing)++accum_t4 :: [Event (Bool,Int)]+accum_t4 = take 16 $ embed (accumFilter accum_accFiltFun1 0) accum_inp3++accum_t4r :: [Event (Bool,Int)]+accum_t4r =+    [NoEvent,         NoEvent, NoEvent,         NoEvent,+     NoEvent,         NoEvent, NoEvent,         NoEvent,+     Event (False,6), NoEvent, Event (True,16), NoEvent,+     Event (True,16), NoEvent, NoEvent,         NoEvent]+++accum_accFiltFun2 a d =+    let a' = a + floor d+    in+        if odd a' then+	    (a', Just (a' > 10, a'))+        else+	    (a', Nothing)++accum_t5 :: [Event (Bool,Int)]+accum_t5 = take 16 $ embed (accumFilter accum_accFiltFun2 0) accum_inp4++accum_t5r :: [Event (Bool,Int)]+accum_t5r =+    [Event (False,1), NoEvent,         NoEvent, NoEvent,+     Event (False,3), NoEvent,         NoEvent, NoEvent,+     NoEvent,         Event (True,11), NoEvent, NoEvent,+     NoEvent,         NoEvent,         NoEvent, NoEvent]+++-- This can be seen as the definition of accumFilter+accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter2 f c_init =+    switch (never &&& attach c_init) afAux+    where+	afAux (c, a) =+            case f c a of+	        (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux+	        (c', Just b)  -> switch (now b &&& (notYet>>>attach c')) afAux++	attach :: b -> SF (Event a) (Event (b, a))+        attach c = arr (fmap (\a -> (c, a)))++accum_t6 :: [Event (Bool,Int)]+accum_t6 = take 16 $ embed (accumFilter2 accum_accFiltFun1 0) accum_inp3++accum_t6r = accum_t4	-- Should agree!++accum_t7 :: [Event (Bool,Int)]+accum_t7 = take 16 $ embed (accumFilter2 accum_accFiltFun2 0) accum_inp4++accum_t7r = accum_t5	-- Should agree!+++accum_t8 :: [Event Int]+accum_t8 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumBy (+) 0+                            >>> accumBy (+) 0)+                           accum_inp5++accum_t8r :: [Event Int]+accum_t8r = [NoEvent,  NoEvent, NoEvent, NoEvent,+             Event 1,  NoEvent, NoEvent, NoEvent,+             Event 3,  NoEvent, NoEvent, NoEvent,+             Event 6,  NoEvent, NoEvent, NoEvent,+             Event 10, NoEvent, NoEvent, NoEvent,+             Event 15, NoEvent, NoEvent, NoEvent,+             Event 21, NoEvent, NoEvent, NoEvent,+             Event 28, NoEvent, NoEvent, NoEvent,+             Event 36, NoEvent, NoEvent, NoEvent,+             Event 45, NoEvent, NoEvent, NoEvent]+++accum_t9 :: [Int]+accum_t9 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumBy (+) 0+                            >>> accumBy (+) 0+                            >>> hold 0)+                           accum_inp5++accum_t9r :: [Int]+accum_t9r = [0,0,0,0,1,1,1,1,3,3,3,3,6,6,6,6,10,10,10,10,15,15,15,15,+             21,21,21,21,28,28,28,28,36,36,36,36,45,45,45,45]+++accum_t10 :: [Int]+accum_t10 = take 40 $ embed (repeatedly 1.0 1+                             >>> accumBy (+) 0+                             >>> accumHoldBy (+) 0)+                            accum_inp5++accum_t10r :: [Int]+accum_t10r = accum_t9	-- Should agree!+++accum_t11 :: [Int]+accum_t11 = take 40 $ embed (repeatedly 1.0 1+                             >>> accumBy (+) 0+                             >>> accumBy (+) 0+                             >>> dHold 0)+                            accum_inp5++accum_t11r :: [Int]+accum_t11r = [0,0,0,0,0,1,1,1,1,3,3,3,3,6,6,6,6,10,10,10,10,15,15,15,+              15,21,21,21,21,28,28,28,28,36,36,36,36,45,45,45]+++accum_t12 :: [Int]+accum_t12 = take 40 $ embed (repeatedly 1.0 1+                             >>> accumBy (+) 0+                             >>> dAccumHoldBy (+) 0)+                            accum_inp5++accum_t12r :: [Int]+accum_t12r = accum_t11	-- Should agree!+++accum_accFiltFun3 :: Int -> Int -> (Int, Maybe Int)+accum_accFiltFun3 s a =+    let s' = s + a+    in+        if odd s' then+	    (s', Just s')+        else+	    (s', Nothing)+++accum_t13 :: [Event Int]+accum_t13 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumFilter accum_accFiltFun3 0+                            >>> accumBy (+) 0+                            >>> accumBy (+) 0)+                            accum_inp5++accum_t13r :: [Event Int]+accum_t13r = [NoEvent,  NoEvent, NoEvent, NoEvent,+              Event 1,  NoEvent, NoEvent, NoEvent,+              NoEvent,  NoEvent, NoEvent, NoEvent,+              Event 5,  NoEvent, NoEvent, NoEvent,+              NoEvent,  NoEvent, NoEvent, NoEvent,+              Event 14, NoEvent, NoEvent, NoEvent,+              NoEvent,  NoEvent, NoEvent, NoEvent,+              Event 30, NoEvent, NoEvent, NoEvent,+              NoEvent,  NoEvent, NoEvent, NoEvent,+              Event 55, NoEvent, NoEvent, NoEvent]+++accum_t14 :: [Int]+accum_t14 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumFilter accum_accFiltFun3 0+                            >>> accumBy (+) 0+                            >>> accumBy (+) 0+                            >>> hold 0)+                            accum_inp5++accum_t14r :: [Int]+accum_t14r = [0,0,0,0,1,1,1,1,1,1,1,1,5,5,5,5,5,5,5,5,14,14,14,14,+              14,14,14,14,30,30,30,30,30,30,30,30,55,55,55,55]+++accum_t15 :: [Int]+accum_t15 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumFilter accum_accFiltFun3 0+                            >>> accumBy (+) 0+                            >>> accumHoldBy (+) 0)+                            accum_inp5++accum_t15r :: [Int]+accum_t15r = accum_t14	-- Should agree!+             ++accum_t16 :: [Int]+accum_t16 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumFilter accum_accFiltFun3 0+                            >>> accumBy (+) 0+                            >>> accumBy (+) 0+                            >>> dHold 0)+                            accum_inp5++accum_t16r :: [Int]+accum_t16r = [0,0,0,0,0,1,1,1,1,1,1,1,1,5,5,5,5,5,5,5,5,14,14,14,+              14,14,14,14,14,30,30,30,30,30,30,30,30,55,55,55]+++accum_t17 :: [Int]+accum_t17 = take 40 $ embed (repeatedly 1.0 1+                            >>> accumFilter accum_accFiltFun3 0+                            >>> accumBy (+) 0+                            >>> dAccumHoldBy (+) 0)+                            accum_inp5++accum_t17r :: [Int]+accum_t17r = accum_t16	-- Should agree!+             +++accum_trs =+    [ accum_t0  == accum_t0r,+      accum_t1  == accum_t1r,+      accum_t2  == accum_t2r,+      accum_t3  == accum_t3r,+      accum_t4  == accum_t4r,+      accum_t5  == accum_t5r,+      accum_t6  == accum_t6r,+      accum_t7  == accum_t7r,+      accum_t8  == accum_t8r,+      accum_t9  == accum_t9r,+      accum_t10 == accum_t10r,+      accum_t11 == accum_t11r,+      accum_t12 == accum_t12r,+      accum_t13 == accum_t13r,+      accum_t14 == accum_t14r,+      accum_t15 == accum_t15r,+      accum_t16 == accum_t16r,+      accum_t17 == accum_t17r+    ]++accum_tr = and accum_trs+++accum_st0 :: Double+accum_st0 = testSFSpaceLeak 1000000+                            (repeatedly 1.0 1.0+                             >>> accumBy (+) 0.0+                             >>> hold (-99.99))++accum_st0r = 249999.0+++accum_st1 :: Double+accum_st1 = testSFSpaceLeak 1000000+                            (arr dup+			     >>> first (repeatedly 1.0 1.0)+			     >>> arr (\(e,a) -> tag e a)+                             >>> accumFilter accumFun 0.0+                             >>> hold (-99.99))+    where+	accumFun c a | even (floor a) = (c+a, Just (c+a))+		     | otherwise      = (c, Nothing)++accum_st1r = 6.249975e10
tests/AFRPTestsArr.hs view
@@ -1,52 +1,52 @@-{- $Id: AFRPTestsArr.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsArr                                         *
-*       Purpose:        Test cases for arr				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsArr (
-    arr_trs,
-    arr_tr,
-    arr_st0,
-    arr_st0r,
-    arr_st1,
-    arr_st1r
-) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for arr
-------------------------------------------------------------------------------
-
-arr_t0 = testSF1 (arr (+1))
-arr_t0r =
-    [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,
-     17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0]
-
-arr_t1 = testSF2 (arr (+1))
-arr_t1r =
-    [1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,
-     4.0,4.0,5.0,5.0,5.0,5.0,5.0]
-
-arr_trs =
-    [ arr_t0 ~= arr_t0r,
-      arr_t1 ~= arr_t1r
-    ]
-
-arr_tr = and arr_trs
-
-arr_st0 = testSFSpaceLeak 2000000 (arr (+1))
-arr_st0r = 1000000.5
-
-arr_st1 = testSFSpaceLeak 2000000 identity
-arr_st1r = 999999.5
+{- $Id: AFRPTestsArr.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsArr                                         *+*       Purpose:        Test cases for arr				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsArr (+    arr_trs,+    arr_tr,+    arr_st0,+    arr_st0r,+    arr_st1,+    arr_st1r+) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for arr+------------------------------------------------------------------------------++arr_t0 = testSF1 (arr (+1))+arr_t0r =+    [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,+     17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0]++arr_t1 = testSF2 (arr (+1))+arr_t1r =+    [1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,+     4.0,4.0,5.0,5.0,5.0,5.0,5.0]++arr_trs =+    [ arr_t0 ~= arr_t0r,+      arr_t1 ~= arr_t1r+    ]++arr_tr = and arr_trs++arr_st0 = testSFSpaceLeak 2000000 (arr (+1))+arr_st0r = 1000000.5++arr_st1 = testSFSpaceLeak 2000000 identity+arr_st1r = 999999.5
tests/AFRPTestsBasicSF.hs view
@@ -1,69 +1,69 @@-{- $Id: AFRPTestsBasicSF.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsBasicSF				     *
-*       Purpose:        Test cases for basic signal functions		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsBasicSF (basicsf_trs, basicsf_tr) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for basic signal functions and initialization
-------------------------------------------------------------------------------
-
-basicsf_t0 :: [Double]
-basicsf_t0 = testSF1 identity
-basicsf_t0r =
-    [0.0,  1.0,  2.0,  3.0,  4.0,  5.0,  6.0,  7.0,  8.0,  9.0,
-     10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0,
-     20.0, 21.0, 22.0, 23.0, 24.0]
-
-
-basicsf_t1 :: [Double]
-basicsf_t1 = testSF1 (constant 42.0)
-basicsf_t1r =
-    [42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,
-     42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,
-     42.0, 42.0, 42.0, 42.0, 42.0]
-
-basicsf_t2 :: [Double]
-basicsf_t2 = testSF1 localTime
-basicsf_t2r =
-    [0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25,
-     2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75,
-     5.0, 5.25, 5.5, 5.75, 6.0]
-
-basicsf_t3 :: [Double]
-basicsf_t3 = testSF1 time
-basicsf_t3r =
-    [0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25,
-     2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75,
-     5.0, 5.25, 5.5, 5.75, 6.0]
-
-basicsf_t4 :: [Double]
-basicsf_t4 = testSF1 (initially 42.0)
-basicsf_t4r =
-    [42.0, 1.0,  2.0,  3.0,  4.0,  5.0,  6.0,  7.0,  8.0,  9.0,
-     10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0,
-     20.0, 21.0, 22.0, 23.0, 24.0]
-
-
-basicsf_trs =
-    [ basicsf_t0 ~= basicsf_t0r,
-      basicsf_t1 ~= basicsf_t1r,
-      basicsf_t2 ~= basicsf_t2r,
-      basicsf_t3 ~= basicsf_t3r,
-      basicsf_t4 ~= basicsf_t4r
-    ]
-
-basicsf_tr = and basicsf_trs
+{- $Id: AFRPTestsBasicSF.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsBasicSF				     *+*       Purpose:        Test cases for basic signal functions		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsBasicSF (basicsf_trs, basicsf_tr) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for basic signal functions and initialization+------------------------------------------------------------------------------++basicsf_t0 :: [Double]+basicsf_t0 = testSF1 identity+basicsf_t0r =+    [0.0,  1.0,  2.0,  3.0,  4.0,  5.0,  6.0,  7.0,  8.0,  9.0,+     10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0,+     20.0, 21.0, 22.0, 23.0, 24.0]+++basicsf_t1 :: [Double]+basicsf_t1 = testSF1 (constant 42.0)+basicsf_t1r =+    [42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,+     42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,+     42.0, 42.0, 42.0, 42.0, 42.0]++basicsf_t2 :: [Double]+basicsf_t2 = testSF1 localTime+basicsf_t2r =+    [0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25,+     2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75,+     5.0, 5.25, 5.5, 5.75, 6.0]++basicsf_t3 :: [Double]+basicsf_t3 = testSF1 time+basicsf_t3r =+    [0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25,+     2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75,+     5.0, 5.25, 5.5, 5.75, 6.0]++basicsf_t4 :: [Double]+basicsf_t4 = testSF1 (initially 42.0)+basicsf_t4r =+    [42.0, 1.0,  2.0,  3.0,  4.0,  5.0,  6.0,  7.0,  8.0,  9.0,+     10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0,+     20.0, 21.0, 22.0, 23.0, 24.0]+++basicsf_trs =+    [ basicsf_t0 ~= basicsf_t0r,+      basicsf_t1 ~= basicsf_t1r,+      basicsf_t2 ~= basicsf_t2r,+      basicsf_t3 ~= basicsf_t3r,+      basicsf_t4 ~= basicsf_t4r+    ]++basicsf_tr = and basicsf_trs
tests/AFRPTestsCOC.hs view
@@ -1,56 +1,56 @@-{- $Id: AFRPTestsCOC.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsCOC					     *
-*       Purpose:        Test cases for collection-oriented combinators	     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsCOC (coc_tr, coc_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for collection-oriented combinators
-------------------------------------------------------------------------------
-
-coc_inp1 = deltaEncode 0.1 [0.0, 0.5 ..]
-
-coc_t0 :: [[Double]]
-coc_t0 = take 20 $ embed (parB [constant 1.0, identity, integral]) coc_inp1
-
-coc_t0r =
-    [[1.0, 0.0, 0.00],
-     [1.0, 0.5, 0.00],
-     [1.0, 1.0, 0.05],
-     [1.0, 1.5, 0.15],
-     [1.0, 2.0, 0.30],
-     [1.0, 2.5, 0.50],
-     [1.0, 3.0, 0.75],
-     [1.0, 3.5, 1.05],
-     [1.0, 4.0, 1.40],
-     [1.0, 4.5, 1.80],
-     [1.0, 5.0, 2.25],
-     [1.0, 5.5, 2.75],
-     [1.0, 6.0, 3.30],
-     [1.0, 6.5, 3.90],
-     [1.0, 7.0, 4.55],
-     [1.0, 7.5, 5.25],
-     [1.0, 8.0, 6.00],
-     [1.0, 8.5, 6.80],
-     [1.0, 9.0, 7.65],
-     [1.0, 9.5, 8.55]]
-
-
-coc_trs =
-    [ coc_t0 ~= coc_t0r
-    ]
-
-coc_tr = and coc_trs
+{- $Id: AFRPTestsCOC.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsCOC					     *+*       Purpose:        Test cases for collection-oriented combinators	     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsCOC (coc_tr, coc_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for collection-oriented combinators+------------------------------------------------------------------------------++coc_inp1 = deltaEncode 0.1 [0.0, 0.5 ..]++coc_t0 :: [[Double]]+coc_t0 = take 20 $ embed (parB [constant 1.0, identity, integral]) coc_inp1++coc_t0r =+    [[1.0, 0.0, 0.00],+     [1.0, 0.5, 0.00],+     [1.0, 1.0, 0.05],+     [1.0, 1.5, 0.15],+     [1.0, 2.0, 0.30],+     [1.0, 2.5, 0.50],+     [1.0, 3.0, 0.75],+     [1.0, 3.5, 1.05],+     [1.0, 4.0, 1.40],+     [1.0, 4.5, 1.80],+     [1.0, 5.0, 2.25],+     [1.0, 5.5, 2.75],+     [1.0, 6.0, 3.30],+     [1.0, 6.5, 3.90],+     [1.0, 7.0, 4.55],+     [1.0, 7.5, 5.25],+     [1.0, 8.0, 6.00],+     [1.0, 8.5, 6.80],+     [1.0, 9.0, 7.65],+     [1.0, 9.5, 8.55]]+++coc_trs =+    [ coc_t0 ~= coc_t0r+    ]++coc_tr = and coc_trs
tests/AFRPTestsCommon.hs view
@@ -1,165 +1,165 @@-{- $Id: AFRPTestsCommon.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsCommon                                      *
-*       Purpose:        Common definitions for the regression test modules.  *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsCommon where
-
-import Data.IORef (IORef, newIORef, writeIORef, readIORef)
-import System.IO.Unsafe (unsafePerformIO)
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-------------------------------------------------------------------------------
--- Rough equality with instances
-------------------------------------------------------------------------------
-
--- Rough equality. Only intended to be good enough for test cases in this
--- module.
-
-class REq a where
-    (~=) :: a -> a -> Bool
-
-epsilon :: Fractional a => a
-epsilon = 0.0001
-
-instance REq Float where
-    x ~= y = abs (x - y) < epsilon	-- A relative measure should be used.
-
-instance REq Double where
-    x ~= y = abs (x - y) < epsilon	-- A relative measure should be used.
-
-instance REq Int where
-    (~=) = (==) 
-
-instance REq Integer where
-    (~=) = (==) 
-
-instance REq Bool where
-    (~=) = (==) 
-
-instance REq Char where
-    (~=) = (==) 
-
-instance REq () where
-    () ~= () = True
-
-instance (REq a, REq b) => REq (a,b) where
-    (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2
-
-instance (REq a, REq b, REq c) => REq (a,b,c) where
-    (x1,x2,x3) ~= (y1,y2,y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3
-
-instance (REq a, REq b, REq c, REq d) => REq (a,b,c,d) where
-    (x1,x2,x3,x4) ~= (y1,y2,y3,y4) = x1 ~= y1
-				     && x2 ~= y2
-				     && x3 ~= y3
-				     && x4 ~= y4
-
-instance (REq a, REq b, REq c, REq d, REq e) => REq (a,b,c,d,e) where
-    (x1,x2,x3,x4,x5) ~= (y1,y2,y3,y4,y5) = x1 ~= y1
-				           && x2 ~= y2
-				           && x3 ~= y3
-				           && x4 ~= y4
-
-instance REq a => REq (Maybe a) where
-    Nothing ~= Nothing   = True
-    (Just x) ~= (Just y) = x ~= y
-    _        ~= _        = False
-
-instance REq a => REq (Event a) where
-    NoEvent   ~= NoEvent   = True
-    (Event x) ~= (Event y) = x ~= y
-    _         ~= _         = False
-
-instance (REq a, REq b) => REq (Either a b) where
-    (Left x)  ~= (Left y)  = x ~= y
-    (Right x) ~= (Right y) = x ~= y
-    _         ~= _         = False
-
-instance REq a => REq [a] where
-    [] ~= []         = True
-    (x:xs) ~= (y:ys) = x ~= y && xs ~= ys
-    _      ~= _      = False
-
-
-------------------------------------------------------------------------------
--- Testing utilities
-------------------------------------------------------------------------------
-
-testSF1 :: SF Double a -> [a]
-testSF1 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 [0.0..]))
-
-
-testSF2 :: SF Double a -> [a]
-testSF2 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 input))
-    where
-	-- The initial 0.0 is just for result compatibility with an older
-	-- version.
-	input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] ]
-	freq = 5
-
-
-------------------------------------------------------------------------------
--- Test harness for space behaviour 
-------------------------------------------------------------------------------
-
-{-
--- Test for space leaks.
--- Carefully defined in an attempt to defeat fully lazy lambda lifting.
--- Seems to work, but may be unsafe if the compiler decides to optimize
--- aggressively.
-testSFSpaceLeak :: Int -> SF Double a -> a
-testSFSpaceLeak n sf = embed sf (deltaEncodeBy (~=) 0.25 [(seq n 0.0)..]) !! n
--}
-
-
--- Using embed/deltaEncode seems to be a bad idea since fully lazy
--- lambda lifting often results in lifting a big input list to the top
--- level in the form of a CAF. Using reactimate and avoiding constructing
--- input/output lists should be more robust.
-
-testSFSpaceLeak :: Int -> SF Double a -> a
-testSFSpaceLeak n sf = unsafePerformIO $ do
-    countr  <- newIORef 0
-    inputr  <- newIORef undefined
-    outputr <- newIORef undefined
-    let init = do
-	    let input0 = 0.0
-            writeIORef inputr input0
-	    count <- readIORef countr
-	    writeIORef countr (count + 1)
-	    return input0
-        sense _ = do
-	    input <- readIORef inputr
-	    let input' = input + 0.5
-	    writeIORef inputr input'
-	    count <- readIORef countr
-	    writeIORef countr (count + 1)
-	    return (0.25, Just input')
-	actuate _ output = do
-	    writeIORef outputr output
-	    input <- readIORef inputr
-	    count <- readIORef countr
-	    return (count >= n)
-    reactimate init sense actuate sf
-    output <- readIORef outputr
-    return output
-
-
-------------------------------------------------------------------------------
--- Some utilities used for testing laws
-------------------------------------------------------------------------------
-
-fun_prod f g = \(x,y) -> (f x, g y)
-assoc ((a,b),c) = (a,(b,c))
-assoc_inv (a,(b,c)) = ((a,b),c)
+{- $Id: AFRPTestsCommon.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsCommon                                      *+*       Purpose:        Common definitions for the regression test modules.  *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsCommon where++import System.IO.Unsafe (unsafePerformIO)+import Data.IORef (newIORef, writeIORef, readIORef)++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++------------------------------------------------------------------------------+-- Rough equality with instances+------------------------------------------------------------------------------++-- Rough equality. Only intended to be good enough for test cases in this+-- module.++class REq a where+    (~=) :: a -> a -> Bool++epsilon :: Fractional a => a+epsilon = 0.0001++instance REq Float where+    x ~= y = abs (x - y) < epsilon	-- A relative measure should be used.++instance REq Double where+    x ~= y = abs (x - y) < epsilon	-- A relative measure should be used.++instance REq Int where+    (~=) = (==) ++instance REq Integer where+    (~=) = (==) ++instance REq Bool where+    (~=) = (==) ++instance REq Char where+    (~=) = (==) ++instance REq () where+    () ~= () = True++instance (REq a, REq b) => REq (a,b) where+    (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2++instance (REq a, REq b, REq c) => REq (a,b,c) where+    (x1,x2,x3) ~= (y1,y2,y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3++instance (REq a, REq b, REq c, REq d) => REq (a,b,c,d) where+    (x1,x2,x3,x4) ~= (y1,y2,y3,y4) = x1 ~= y1+				     && x2 ~= y2+				     && x3 ~= y3+				     && x4 ~= y4++instance (REq a, REq b, REq c, REq d, REq e) => REq (a,b,c,d,e) where+    (x1,x2,x3,x4,x5) ~= (y1,y2,y3,y4,y5) = x1 ~= y1+				           && x2 ~= y2+				           && x3 ~= y3+				           && x4 ~= y4++instance REq a => REq (Maybe a) where+    Nothing ~= Nothing   = True+    (Just x) ~= (Just y) = x ~= y+    _        ~= _        = False++instance REq a => REq (Event a) where+    NoEvent   ~= NoEvent   = True+    (Event x) ~= (Event y) = x ~= y+    _         ~= _         = False++instance (REq a, REq b) => REq (Either a b) where+    (Left x)  ~= (Left y)  = x ~= y+    (Right x) ~= (Right y) = x ~= y+    _         ~= _         = False++instance REq a => REq [a] where+    [] ~= []         = True+    (x:xs) ~= (y:ys) = x ~= y && xs ~= ys+    _      ~= _      = False+++------------------------------------------------------------------------------+-- Testing utilities+------------------------------------------------------------------------------++testSF1 :: SF Double a -> [a]+testSF1 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 [0.0..]))+++testSF2 :: SF Double a -> [a]+testSF2 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 input))+    where+	-- The initial 0.0 is just for result compatibility with an older+	-- version.+	input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] ]+	freq = 5+++------------------------------------------------------------------------------+-- Test harness for space behaviour +------------------------------------------------------------------------------++{-+-- Test for space leaks.+-- Carefully defined in an attempt to defeat fully lazy lambda lifting.+-- Seems to work, but may be unsafe if the compiler decides to optimize+-- aggressively.+testSFSpaceLeak :: Int -> SF Double a -> a+testSFSpaceLeak n sf = embed sf (deltaEncodeBy (~=) 0.25 [(seq n 0.0)..]) !! n+-}+++-- Using embed/deltaEncode seems to be a bad idea since fully lazy+-- lambda lifting often results in lifting a big input list to the top+-- level in the form of a CAF. Using reactimate and avoiding constructing+-- input/output lists should be more robust.++testSFSpaceLeak :: Int -> SF Double a -> a+testSFSpaceLeak n sf = unsafePerformIO $ do+    countr  <- newIORef 0+    inputr  <- newIORef undefined+    outputr <- newIORef undefined+    let init = do+	    let input0 = 0.0+            writeIORef inputr input0+	    count <- readIORef countr+	    writeIORef countr (count + 1)+	    return input0+        sense _ = do+	    input <- readIORef inputr+	    let input' = input + 0.5+	    writeIORef inputr input'+	    count <- readIORef countr+	    writeIORef countr (count + 1)+	    return (0.25, Just input')+	actuate _ output = do+	    writeIORef outputr output+	    input <- readIORef inputr+	    count <- readIORef countr+	    return (count >= n)+    reactimate init sense actuate sf+    output <- readIORef outputr+    return output+++------------------------------------------------------------------------------+-- Some utilities used for testing laws+------------------------------------------------------------------------------++fun_prod f g = \(x,y) -> (f x, g y)+assoc ((a,b),c) = (a,(b,c))+assoc_inv (a,(b,c)) = ((a,b),c)
tests/AFRPTestsComp.hs view
@@ -1,71 +1,71 @@-{- $Id: AFRPTestsComp.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsComp					     *
-*       Purpose:        Test cases for (>>>)				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsComp (comp_tr, comp_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for comp
-------------------------------------------------------------------------------
-
-comp_t0 = testSF1 ((arr (+1)) >>> (arr (+2)))
-comp_t0r :: [Double]
-comp_t0r =
-    [3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,
-     18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0]
-
-comp_t1 = testSF2 ((arr (+1)) >>> (arr (+2)))
-comp_t1r :: [Double]
-comp_t1r =
-    [3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0,4.0,5.0,5.0,5.0,5.0,5.0,
-     6.0,6.0,6.0,6.0,6.0,7.0,7.0,7.0,7.0,7.0]
-
-comp_t2 = testSF1 ((constant 5.0) >>> (arr (+1)))
-comp_t2r :: [Double]
-comp_t2r =
-    [6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,
-     6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0]
-
-comp_t3 = testSF2 ((constant 5.0) >>> (arr (+1)))
-comp_t3r :: [Double]
-comp_t3r =
-    [6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,
-     6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0]
-
--- Integration by the rectangle rule or trapezoid rule makes no difference.
-comp_t4 = testSF1 ((constant 2.0) >>> integral)
-comp_t4r :: [Double]
-comp_t4r =
-    [0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5,
-     9.0,9.5,10.0,10.5,11.0,11.5,12.0]
-
--- Same result as above.
-comp_t5 = testSF2 ((constant 2.0) >>> integral)
-comp_t5r :: [Double]
-comp_t5r =
-    [0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5,
-     9.0,9.5,10.0,10.5,11.0,11.5,12.0]
-
-comp_trs =
-    [ comp_t0 ~= comp_t0r,
-      comp_t1 ~= comp_t1r,
-      comp_t2 ~= comp_t2r,
-      comp_t3 ~= comp_t3r,
-      comp_t4 ~= comp_t4r,
-      comp_t5 ~= comp_t5r
-    ]
-
-comp_tr = and comp_trs
+{- $Id: AFRPTestsComp.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsComp					     *+*       Purpose:        Test cases for (>>>)				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsComp (comp_tr, comp_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for comp+------------------------------------------------------------------------------++comp_t0 = testSF1 ((arr (+1)) >>> (arr (+2)))+comp_t0r :: [Double]+comp_t0r =+    [3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,+     18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0]++comp_t1 = testSF2 ((arr (+1)) >>> (arr (+2)))+comp_t1r :: [Double]+comp_t1r =+    [3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0,4.0,5.0,5.0,5.0,5.0,5.0,+     6.0,6.0,6.0,6.0,6.0,7.0,7.0,7.0,7.0,7.0]++comp_t2 = testSF1 ((constant 5.0) >>> (arr (+1)))+comp_t2r :: [Double]+comp_t2r =+    [6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,+     6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0]++comp_t3 = testSF2 ((constant 5.0) >>> (arr (+1)))+comp_t3r :: [Double]+comp_t3r =+    [6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,+     6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0]++-- Integration by the rectangle rule or trapezoid rule makes no difference.+comp_t4 = testSF1 ((constant 2.0) >>> integral)+comp_t4r :: [Double]+comp_t4r =+    [0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5,+     9.0,9.5,10.0,10.5,11.0,11.5,12.0]++-- Same result as above.+comp_t5 = testSF2 ((constant 2.0) >>> integral)+comp_t5r :: [Double]+comp_t5r =+    [0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5,+     9.0,9.5,10.0,10.5,11.0,11.5,12.0]++comp_trs =+    [ comp_t0 ~= comp_t0r,+      comp_t1 ~= comp_t1r,+      comp_t2 ~= comp_t2r,+      comp_t3 ~= comp_t3r,+      comp_t4 ~= comp_t4r,+      comp_t5 ~= comp_t5r+    ]++comp_tr = and comp_trs
tests/AFRPTestsDelay.hs view
@@ -1,39 +1,88 @@-{- $Id: AFRPTestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsDelay					     *
-*       Purpose:        Test cases for delays				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsDelay (delay_tr, delay_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for delays
-------------------------------------------------------------------------------
-
-delay_t0 = testSF1 (iPre 17)
-delay_t0r =
-    [17.0,0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,
-     15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0]
-
-delay_t1 = testSF2 (iPre 17)
-delay_t1r =
-    [17.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,
-     3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0]
-
-delay_trs =
-    [ delay_t0 ~= delay_t0r,
-      delay_t1 ~= delay_t1r
-    ]
-
-delay_tr = and delay_trs
+{- $Id: AFRPTestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsDelay					     *+*       Purpose:        Test cases for delays				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsDelay (delay_tr, delay_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for delays+------------------------------------------------------------------------------++delay_t0 = testSF1 (delay 0.0 undefined)+delay_t0r =+    [0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,+     15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0]++delay_t1 = testSF1 (delay 0.0001 17)+delay_t1r =+    [17.0,0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,+     15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0]++delay_t2 = testSF2 (delay 0.0001 17)+delay_t2r =+    [17.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,+     3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0]++delay_t3 = testSF1 (time +                    >>> arr (\t -> sin (0.5 * t * pi + pi))+                    >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x')) +                              >>> second (delay 0.0001 0.0)))+delay_t3r = +    take 25+         (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ]+          in tail (scanl max 0 xs))++dts_t4 = take 15 (repeat 0.1)+         ++ [0.5, 0.5]+         ++ take 15 (repeat 0.1)+         ++ [2.0]+         ++ take 20 (repeat 0.1)++input_t4 = (0, [ (dt, Just i) | (dt, i) <- zip dts_t4 [1..] ])++delay_t4, delay_t4r :: [Int]+delay_t4 = take 100 (embed (delay 1.05 (-1)) input_t4)+delay_t4r =+    [ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,	-- 0.0 s -- 0.9 s+      -1,  0,  1,  2,  3,  4,			-- 1.0 s -- 1.5 s+       9,                 14, 15, 15, 15, 15,	-- 2.0 s -- 2.9 s+      15, 16, 16, 16, 16, 16, 17, 18, 19, 20,	-- 3.0 s -- 3.9 s+      21,					-- 4.0 s+      32, 32, 32, 32, 32, 32, 32, 32, 32, 32,	-- 6.0 s -- 6.9 s+      32, 33, 34, 35, 36, 37, 38, 39, 40, 41,	-- 7.0 s -- 7.9 s+      42					-- 8.0 s+    ]+++delay_t5 = take 100 (drop 6 (embed sf (deltaEncode 0.1 (repeat ()))))+    where+        sf = time >>> arr (\t -> sin (2*pi*t)) >>> delay 0.55 (-1.0)++delay_t5r = take 100 (drop 6 (embed sf (deltaEncode 0.1 (repeat ()))))+    where+        sf = time >>> arr (\t -> sin (2*pi*(t-0.6)))+++delay_trs =+    [ delay_t0 ~= delay_t0r,+      delay_t1 ~= delay_t1r,+      delay_t2 ~= delay_t2r,+      delay_t3 ~= delay_t3r,+      delay_t4 == delay_t4r,+      delay_t5 ~= delay_t5r+    ]++delay_tr = and delay_trs
tests/AFRPTestsDer.hs view
@@ -1,55 +1,55 @@-{- $Id: AFRPTestsDer.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsDer					     *
-*       Purpose:        Test cases for derivative			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsDer (der_tr, der_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for derivative
-------------------------------------------------------------------------------
-
-der_step = 0.001
-der_N = 1000
-
-der_t0 :: [Double]
-der_t0 = take der_N $	-- First value is always 0
-         embed derivative
-               (deltaEncode der_step
-			    [sin(2 * pi * t) | t <- [0.0, der_step ..]])
-{-
--- For stepsize 0.1
-der_t0r :: [Double]
-der_t0r =
-    [ 0.0000,  5.8779,  3.6327, 0.0000, -3.6327,
-     -5.8779, -5.8779, -3.6327, 0.0000,  3.6327,
-      5.8779,  5.8779,  3.6327, 0.0000, -3.6327,
-     -5.8779, -5.8779, -3.6327, 0.0000,  3.6327]
--}
-
-der_t0r :: [Double]
-der_t0r = take der_N $ 
-          [2 * pi * cos (2 * pi * t) | t <- [0.0, der_step ..]]
-
--- We're happy if we are in the right ball park.
-der_t0_max_diff = (maximum (zipWith (\x y -> abs (x - y))
-                                    (tail der_t0)
-                                    (tail der_t0r)))
-
-der_trs =
-    [ der_t0_max_diff < 0.05
-    ]
-
-der_tr = and der_trs
+{- $Id: AFRPTestsDer.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsDer					     *+*       Purpose:        Test cases for derivative			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsDer (der_tr, der_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for derivative+------------------------------------------------------------------------------++der_step = 0.001+der_N = 1000++der_t0 :: [Double]+der_t0 = take der_N $	-- First value is always 0+         embed derivative+               (deltaEncode der_step+			    [sin(2 * pi * t) | t <- [0.0, der_step ..]])+{-+-- For stepsize 0.1+der_t0r :: [Double]+der_t0r =+    [ 0.0000,  5.8779,  3.6327, 0.0000, -3.6327,+     -5.8779, -5.8779, -3.6327, 0.0000,  3.6327,+      5.8779,  5.8779,  3.6327, 0.0000, -3.6327,+     -5.8779, -5.8779, -3.6327, 0.0000,  3.6327]+-}++der_t0r :: [Double]+der_t0r = take der_N $ +          [2 * pi * cos (2 * pi * t) | t <- [0.0, der_step ..]]++-- We're happy if we are in the right ball park.+der_t0_max_diff = (maximum (zipWith (\x y -> abs (x - y))+                                    (tail der_t0)+                                    (tail der_t0r)))++der_trs =+    [ der_t0_max_diff < 0.05+    ]++der_tr = and der_trs
tests/AFRPTestsEmbed.hs view
@@ -1,61 +1,61 @@-{- $Id: AFRPTestsEmbed.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsEmbed					     *
-*       Purpose:        Test cases for embedding			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsEmbed (embed_tr, embed_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for embedding
-------------------------------------------------------------------------------
-
-embed_ratio :: SF a Double
-embed_ratio = switch (constant 1.0 &&& after 5.0 ()) $ \_ ->
-	      switch (constant 0.0 &&& after 5.0 ()) $ \_ ->
-	      constant 3.0
-
-embed_sf :: SF a Double
-embed_sf = localTime >>> integral
-
-embed_t0 = take 20 $ embed (embed_ratio
-			    >>> embedSynch embed_sf
-					   (deltaEncode 0.01 (repeat ())))
-			   (deltaEncode 1.0 (repeat ()))
-
-embed_t0r =
-    [  0.0000,   0.4851,   1.9701,    4.4850,   7.9800,
-       7.9800,   7.9800,   7.9800,    7.9800,   7.9800,
-      24.4650,  49.9500,  84.4350,  127.9200, 180.2151,
-     241.6701, 312.1251, 391.5801, 480.03510, 577.4901]
-
-
-embed_t1 = take 20 $ embed (embed_ratio
-			    >>> embedSynch embed_sf
-					   (deltaEncode 0.5 (replicate 30 ())))
-			   (deltaEncode 1.0 (repeat ()))
-
-embed_t1r =
-    [   0.00,   0.25,   1.50,   3.75,   7.00,
-        7.00,   7.00,   7.00,   7.00,   7.00,
-       22.75,  47.50,  81.25, 101.50, 101.50,
-      101.50, 101.50, 101.50, 101.50, 101.50]
-
-embed_trs =
-    [ embed_t0 ~= embed_t0r,
-      embed_t1 ~= embed_t1r
-    ]
-
-
-embed_tr = and embed_trs
+{- $Id: AFRPTestsEmbed.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsEmbed					     *+*       Purpose:        Test cases for embedding			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsEmbed (embed_tr, embed_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for embedding+------------------------------------------------------------------------------++embed_ratio :: SF a Double+embed_ratio = switch (constant 1.0 &&& after 5.0 ()) $ \_ ->+	      switch (constant 0.0 &&& after 5.0 ()) $ \_ ->+	      constant 3.0++embed_sf :: SF a Double+embed_sf = localTime >>> integral++embed_t0 = take 20 $ embed (embed_ratio+			    >>> embedSynch embed_sf+					   (deltaEncode 0.01 (repeat ())))+			   (deltaEncode 1.0 (repeat ()))++embed_t0r =+    [  0.0000,   0.4851,   1.9701,    4.4850,   7.9800,+       7.9800,   7.9800,   7.9800,    7.9800,   7.9800,+      24.4650,  49.9500,  84.4350,  127.9200, 180.2151,+     241.6701, 312.1251, 391.5801, 480.03510, 577.4901]+++embed_t1 = take 20 $ embed (embed_ratio+			    >>> embedSynch embed_sf+					   (deltaEncode 0.5 (replicate 30 ())))+			   (deltaEncode 1.0 (repeat ()))++embed_t1r =+    [   0.00,   0.25,   1.50,   3.75,   7.00,+        7.00,   7.00,   7.00,   7.00,   7.00,+       22.75,  47.50,  81.25, 101.50, 101.50,+      101.50, 101.50, 101.50, 101.50, 101.50]++embed_trs =+    [ embed_t0 ~= embed_t0r,+      embed_t1 ~= embed_t1r+    ]+++embed_tr = and embed_trs
tests/AFRPTestsEvSrc.hs view
@@ -1,430 +1,584 @@-{- $Id: AFRPTestsEvSrc.hs,v 1.3 2003/12/19 15:32:22 henrik Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsEvSrc					     *
-*       Purpose:        Test cases for event sources			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsEvSrc (evsrc_trs, evsrc_tr) where
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for basic event sources and stateful event suppression
-------------------------------------------------------------------------------
-
-evsrc_t0 :: [Event ()]
-evsrc_t0 = testSF1 never
-
-evsrc_t0r =
-    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t1 :: [Event Int]
-evsrc_t1 = testSF1 (now 42)
-
-evsrc_t1r :: [Event Int]
-evsrc_t1r =
-    [Event 42, NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t2 :: [Event Int]
-evsrc_t2 = testSF1 (after 0.0 42)
-evsrc_t2r :: [Event Int]
-evsrc_t2r =
-    [Event 42, NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t3 :: [Event Int]
-evsrc_t3 = testSF1 (after 3.0 42)
-
-evsrc_t3r :: [Event Int]
-evsrc_t3r =
-    [NoEvent,  NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     Event 42, NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t4 :: [Event Int]
-evsrc_t4 = testSF1 (after 3.01 42)
-
-evsrc_t4r :: [Event Int]
-evsrc_t4r =
-    [NoEvent, NoEvent,  NoEvent, NoEvent,	-- 0.0 s
-     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 1.0 s
-     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 2.0 s
-     NoEvent, Event 42, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 4.0 s
-     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t5 :: [Event Int]
-evsrc_t5 = testSF1 (repeatedly 0.795 42)
-
-evsrc_t5r :: [Event Int]
-evsrc_t5r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     Event 42, NoEvent,  NoEvent,  Event 42,	-- 1.0 s
-     NoEvent,  NoEvent,  Event 42, NoEvent,	-- 2.0 s
-     NoEvent,  Event 42, NoEvent,  NoEvent,	-- 3.0 s
-     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     Event 42, NoEvent,  NoEvent,  Event 42,	-- 5.0 s
-     NoEvent]
-
-evsrc_t6 :: [Event Int]
-evsrc_t6 = testSF1 (repeatedly 0.30 42)
-
-evsrc_t6r :: [Event Int]
-evsrc_t6r =
-    [NoEvent,  NoEvent,  Event 42, Event 42,	-- 0.0 s
-     Event 42, Event 42, Event 42, NoEvent,	-- 1.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 2.0 s
-     Event 42, NoEvent,  Event 42, Event 42,	-- 3.0 s
-     Event 42, Event 42, Event 42, NoEvent,	-- 4.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 5.0 s
-     Event 42]
-
-evsrc_t7 :: [Event Int]
-evsrc_t7 = testSF1 (repeatedly 0.24 42)
-
-evsrc_t7r :: [Event Int]
-evsrc_t7r =
-    [NoEvent,  Event 42, Event 42, Event 42,	-- 0.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 1.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 2.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 3.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 4.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 5.0 s
-     Event 42]
-
-
-evsrc_t8 :: [Event Int]
-evsrc_t8 = testSF1 (afterEach [(0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4),
-                               (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8),
-			       (0.10, 9), (2.00, 10)])
-
-evsrc_t8r :: [Event Int]
-evsrc_t8r =
-    [Event 1,  Event 3,  Event 5,  NoEvent,	-- 0.0 s
-     NoEvent,  Event 6,  Event 9,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  Event 10, NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t9 :: [Event Int]
-evsrc_t9 = testSF1 (afterEach [(2.03, 0),
-			       (0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4),
-                               (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8),
-			       (0.10, 9), (2.00, 10)])
-
-evsrc_t9r :: [Event Int]
-evsrc_t9r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  Event 0,  Event 4,  NoEvent,	-- 2.0 s
-     NoEvent,  Event 6,  Event 9,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  Event 10, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t10 :: [Event ()]
-evsrc_t10 = testSF1 (localTime >>> arr (>=0) >>> edge)
-
-evsrc_t10r = 
-    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 3.0 s
-     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 4.0 s
-     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t11 :: [Event ()]
-evsrc_t11 = testSF1 (localTime >>> arr (>=4.26) >>> edge)
-
-evsrc_t11r =
-    [NoEvent, NoEvent, NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 1.0 s
-     NoEvent, NoEvent, NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 3.0 s
-     NoEvent, NoEvent, Event (), NoEvent,	-- 4.0 s
-     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 5.0 s
-     NoEvent]
-
-
--- Raising edge detector.
-evsrc_isEdge False False = Nothing
-evsrc_isEdge False True  = Just ()
-evsrc_isEdge True  True  = Nothing
-evsrc_isEdge True  False = Nothing
-
-
-evsrc_t12 :: [Event ()]
-evsrc_t12 = testSF1 (localTime >>> arr (>=0) >>> edgeBy evsrc_isEdge False)
-
-evsrc_t12r = 
-    [Event (), NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-evsrc_t13 :: [Event ()]
-evsrc_t13 = testSF1 (localTime >>> arr (>=4.26) >>> edgeBy evsrc_isEdge False)
-
-evsrc_t13r =
-    [NoEvent, NoEvent, NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 1.0 s
-     NoEvent, NoEvent, NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 3.0 s
-     NoEvent, NoEvent, Event (), NoEvent,	-- 4.0 s
-     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 5.0 s
-     NoEvent]
-
--- Raising and falling edge detector.
-evsrc_isEdge2 False False = Nothing
-evsrc_isEdge2 False True  = Just True
-evsrc_isEdge2 True  True  = Nothing
-evsrc_isEdge2 True  False = Just False
-
-evsrc_t14 :: [Event Bool]
-evsrc_t14 = testSF1 (localTime
-                    >>> arr (\t -> t >=2.01 && t <= 4.51)
-		    >>> edgeBy evsrc_isEdge2 True)
-
-evsrc_t14r =
-    [Event False, NoEvent,    NoEvent, NoEvent,		-- 0.0 s
-     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 1.0 s
-     NoEvent,     Event True, NoEvent, NoEvent,		-- 2.0 s
-     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 3.0 s
-     NoEvent,     NoEvent,    NoEvent, Event False,	-- 4.0 s
-     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 5.0 s
-     NoEvent]
-
-evsrc_t15 :: [Event Int]
-evsrc_t15 = testSF1 (now 17 &&& repeatedly 0.795 42
-		     >>> arr (uncurry merge)
-		     >>> notYet)
-
-evsrc_t15r :: [Event Int]
-evsrc_t15r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     Event 42, NoEvent,  NoEvent,  Event 42,	-- 1.0 s
-     NoEvent,  NoEvent,  Event 42, NoEvent,	-- 2.0 s
-     NoEvent,  Event 42, NoEvent,  NoEvent,	-- 3.0 s
-     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     Event 42, NoEvent,  NoEvent,  Event 42,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t16 :: [Event Int]
-evsrc_t16 = testSF1 (now 42 >>> once)
-
-evsrc_t16r :: [Event Int]
-evsrc_t16r =
-    [Event 42, NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t17 :: [Event Int]
-evsrc_t17 = testSF1 (repeatedly 0.8 42 >>> once)
-
-evsrc_t17r :: [Event Int]
-evsrc_t17r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t18 :: [Event Int]
-evsrc_t18 = testSF1 (now 42 >>> takeEvents 0)
-
-evsrc_t18r :: [Event Int]
-evsrc_t18r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t19 :: [Event Int]
-evsrc_t19 = testSF1 (now 42 >>> takeEvents 1)
-
-evsrc_t19r :: [Event Int]
-evsrc_t19r =
-    [Event 42, NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t20 :: [Event Int]
-evsrc_t20 = testSF1 (repeatedly 0.8 42 >>> takeEvents 4)
-
-evsrc_t20r :: [Event Int]
-evsrc_t20r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     Event 42, NoEvent,  NoEvent,  Event 42,	-- 1.0 s
-     NoEvent,  NoEvent,  Event 42, NoEvent,	-- 2.0 s
-     NoEvent,  Event 42, NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t21 :: [Event Int]
-evsrc_t21 = testSF1 (repeatedly 0.2 42 >>> takeEvents 4)
-
-evsrc_t21r :: [Event Int]
-evsrc_t21r =
-    [NoEvent,  Event 42, Event 42, Event 42,	-- 0.0 s
-     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t22 :: [Event Int]
-evsrc_t22 = testSF1 (now 42 >>> dropEvents 0)
-
-evsrc_t22r :: [Event Int]
-evsrc_t22r =
-    [Event 42, NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t23 :: [Event Int]
-evsrc_t23 = testSF1 (now 42 >>> dropEvents 1)
-
-evsrc_t23r :: [Event Int]
-evsrc_t23r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t24 :: [Event Int]
--- Drop 5 events to get rid of the event at 4.0 s which may or may not happen
--- exactly there. 
-evsrc_t24 = testSF1 (repeatedly 0.8 42 >>> dropEvents 5)
-
-evsrc_t24r :: [Event Int]
-evsrc_t24r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s
-     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s
-     Event 42, NoEvent,  NoEvent,  Event 42,	-- 5.0 s
-     NoEvent]
-
-
-evsrc_t25 :: [Event Int]
-evsrc_t25 = testSF1 (repeatedly 0.2 42 >>> dropEvents 4)
-
-evsrc_t25r :: [Event Int]
-evsrc_t25r =
-    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s
-     NoEvent,  Event 42, Event 42, Event 42,	-- 1.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 2.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 3.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 4.0 s
-     Event 42, Event 42, Event 42, Event 42,	-- 5.0 s
-     Event 42]
-
-
-evsrc_trs =
-    [ evsrc_t0 ~= evsrc_t0r,
-      evsrc_t1 ~= evsrc_t1r,
-      evsrc_t2 ~= evsrc_t2r,
-      evsrc_t3 ~= evsrc_t3r,
-      evsrc_t4 ~= evsrc_t4r,
-      evsrc_t5 ~= evsrc_t5r,
-      evsrc_t6 ~= evsrc_t6r,
-      evsrc_t7 ~= evsrc_t7r,
-      evsrc_t8 ~= evsrc_t8r,
-      evsrc_t9 ~= evsrc_t9r,
-      evsrc_t10 ~= evsrc_t10r,
-      evsrc_t11 ~= evsrc_t11r,
-      evsrc_t12 ~= evsrc_t12r,
-      evsrc_t13 ~= evsrc_t13r,
-      evsrc_t14 ~= evsrc_t14r,
-      evsrc_t15 ~= evsrc_t15r,
-      evsrc_t16 ~= evsrc_t16r,
-      evsrc_t17 ~= evsrc_t17r,
-      evsrc_t18 ~= evsrc_t18r,
-      evsrc_t19 ~= evsrc_t19r,
-      evsrc_t20 ~= evsrc_t20r,
-      evsrc_t21 ~= evsrc_t21r,
-      evsrc_t22 ~= evsrc_t22r,
-      evsrc_t23 ~= evsrc_t23r,
-      evsrc_t24 ~= evsrc_t24r,
-      evsrc_t25 ~= evsrc_t25r
-    ]
-
-evsrc_tr = and evsrc_trs
+{- $Id: AFRPTestsEvSrc.hs,v 1.3 2003/12/19 15:32:22 henrik Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsEvSrc					     *+*       Purpose:        Test cases for event sources			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsEvSrc (evsrc_trs, evsrc_tr) where++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for basic event sources and stateful event suppression+------------------------------------------------------------------------------++evsrc_t0 :: [Event ()]+evsrc_t0 = testSF1 never++evsrc_t0r =+    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t1 :: [Event Int]+evsrc_t1 = testSF1 (now 42)++evsrc_t1r :: [Event Int]+evsrc_t1r =+    [Event 42, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t2 :: [Event Int]+evsrc_t2 = testSF1 (after 0.0 42)+evsrc_t2r :: [Event Int]+evsrc_t2r =+    [Event 42, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t3 :: [Event Int]+evsrc_t3 = testSF1 (after 3.0 42)++evsrc_t3r :: [Event Int]+evsrc_t3r =+    [NoEvent,  NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s+     Event 42, NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t4 :: [Event Int]+evsrc_t4 = testSF1 (after 3.01 42)++evsrc_t4r :: [Event Int]+evsrc_t4r =+    [NoEvent, NoEvent,  NoEvent, NoEvent,	-- 0.0 s+     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 1.0 s+     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 2.0 s+     NoEvent, Event 42, NoEvent, NoEvent,	-- 3.0 s+     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 4.0 s+     NoEvent, NoEvent,  NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t5 :: [Event Int]+evsrc_t5 = testSF1 (repeatedly 0.795 42)++evsrc_t5r :: [Event Int]+evsrc_t5r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     Event 42, NoEvent,  NoEvent,  Event 42,	-- 1.0 s+     NoEvent,  NoEvent,  Event 42, NoEvent,	-- 2.0 s+     NoEvent,  Event 42, NoEvent,  NoEvent,	-- 3.0 s+     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     Event 42, NoEvent,  NoEvent,  Event 42,	-- 5.0 s+     NoEvent]++evsrc_t6 :: [Event Int]+evsrc_t6 = testSF1 (repeatedly 0.29999 42)++evsrc_t6r :: [Event Int]+evsrc_t6r =+    [NoEvent,  NoEvent,  Event 42, Event 42,	-- 0.0 s+     Event 42, Event 42, Event 42, NoEvent,	-- 1.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 2.0 s+     Event 42, NoEvent,  Event 42, Event 42,	-- 3.0 s+     Event 42, Event 42, Event 42, NoEvent,	-- 4.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 5.0 s+     Event 42]++evsrc_t7 :: [Event Int]+evsrc_t7 = testSF1 (repeatedly 0.24 42)++evsrc_t7r :: [Event Int]+evsrc_t7r =+    [NoEvent,  Event 42, Event 42, Event 42,	-- 0.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 1.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 2.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 3.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 4.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 5.0 s+     Event 42]+++evsrc_t8 :: [Event Int]+evsrc_t8 = testSF1 (afterEach [(0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4),+                               (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8),+			       (0.10, 9), (2.00, 10)])++evsrc_t8r :: [Event Int]+evsrc_t8r =+    [Event 1,  Event 3,  Event 5,  NoEvent,	-- 0.0 s+     NoEvent,  Event 6,  Event 9,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  Event 10, NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t9 :: [Event Int]+evsrc_t9 = testSF1 (afterEach [(2.03, 0),+			       (0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4),+                               (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8),+			       (0.10, 9), (2.00, 10), (0.00, 11), (0.00, 12)])++evsrc_t9r :: [Event Int]+evsrc_t9r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  Event 0,  Event 4,  NoEvent,	-- 2.0 s+     NoEvent,  Event 6,  Event 9,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  Event 10, NoEvent,	-- 5.0 s+     NoEvent]++++evsrc_t10 :: [Event [Int]]+evsrc_t10 = testSF1 (afterEachCat [(0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4),+                                   (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8),+			           (0.10, 9), (2.00, 10)])++evsrc_t10r :: [Event [Int]]+evsrc_t10r =+    [Event [1,2],  Event [3,4],    Event [5],  NoEvent,	-- 0.0 s+     NoEvent,      Event [6,7,8],  Event [9],  NoEvent,	-- 1.0 s+     NoEvent,      NoEvent,        NoEvent,    NoEvent,	-- 2.0 s+     NoEvent,      NoEvent,        Event [10], NoEvent,	-- 3.0 s+     NoEvent,      NoEvent,        NoEvent,    NoEvent,	-- 4.0 s+     NoEvent,      NoEvent,        NoEvent,    NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t11 :: [Event [Int]]+evsrc_t11 = testSF1 (afterEachCat [(2.03, 0),+			           (0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4),+                                   (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8),+			           (0.10, 9), (2.00, 10)])++evsrc_t11r :: [Event [Int]]+evsrc_t11r =+    [NoEvent,  NoEvent,         NoEvent,     NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,         NoEvent,     NoEvent,	-- 1.0 s+     NoEvent,  Event [0,1,2,3], Event [4,5], NoEvent,	-- 2.0 s+     NoEvent,  Event [6,7,8],   Event [9],   NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,         NoEvent,     NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,         Event [10],  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t12 :: [Event ()]+evsrc_t12 = testSF1 (localTime >>> arr (>=0) >>> edge)++evsrc_t12r = +    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 3.0 s+     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t13 :: [Event ()]+evsrc_t13 = testSF1 (localTime >>> arr (>=4.26) >>> edge)++evsrc_t13r =+    [NoEvent, NoEvent, NoEvent,  NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent,  NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 3.0 s+     NoEvent, NoEvent, Event (), NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 5.0 s+     NoEvent]+++-- Raising edge detector.+evsrc_isEdge False False = Nothing+evsrc_isEdge False True  = Just ()+evsrc_isEdge True  True  = Nothing+evsrc_isEdge True  False = Nothing+++evsrc_t14 :: [Event ()]+evsrc_t14 = testSF1 (localTime >>> arr (>=0) >>> edgeBy evsrc_isEdge False)++evsrc_t14r = +    [Event (), NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]++evsrc_t15 :: [Event ()]+evsrc_t15 = testSF1 (localTime >>> arr (>=4.26) >>> edgeBy evsrc_isEdge False)++evsrc_t15r =+    [NoEvent, NoEvent, NoEvent,  NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent,  NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 3.0 s+     NoEvent, NoEvent, Event (), NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 5.0 s+     NoEvent]++-- Raising and falling edge detector.+evsrc_isEdge2 False False = Nothing+evsrc_isEdge2 False True  = Just True+evsrc_isEdge2 True  True  = Nothing+evsrc_isEdge2 True  False = Just False++evsrc_t16 :: [Event Bool]+evsrc_t16 = testSF1 (localTime+                    >>> arr (\t -> t >=2.01 && t <= 4.51)+		    >>> edgeBy evsrc_isEdge2 True)++evsrc_t16r =+    [Event False, NoEvent,    NoEvent, NoEvent,		-- 0.0 s+     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 1.0 s+     NoEvent,     Event True, NoEvent, NoEvent,		-- 2.0 s+     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 3.0 s+     NoEvent,     NoEvent,    NoEvent, Event False,	-- 4.0 s+     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 5.0 s+     NoEvent]++evsrc_t17 :: [Event Int]+evsrc_t17 = testSF1 (now 17 &&& repeatedly 0.795 42+		     >>> arr (uncurry merge)+		     >>> notYet)++evsrc_t17r :: [Event Int]+evsrc_t17r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     Event 42, NoEvent,  NoEvent,  Event 42,	-- 1.0 s+     NoEvent,  NoEvent,  Event 42, NoEvent,	-- 2.0 s+     NoEvent,  Event 42, NoEvent,  NoEvent,	-- 3.0 s+     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     Event 42, NoEvent,  NoEvent,  Event 42,	-- 5.0 s+     NoEvent]+++evsrc_t18 :: [Event Int]+evsrc_t18 = testSF1 (now 42 >>> once)++evsrc_t18r :: [Event Int]+evsrc_t18r =+    [Event 42, NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t19 :: [Event Int]+evsrc_t19 = testSF1 (repeatedly 0.8 42 >>> once)++evsrc_t19r :: [Event Int]+evsrc_t19r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t20 :: [Event Int]+evsrc_t20 = testSF1 (now 42 >>> takeEvents 0)++evsrc_t20r :: [Event Int]+evsrc_t20r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t21 :: [Event Int]+evsrc_t21 = testSF1 (now 42 >>> takeEvents 1)++evsrc_t21r :: [Event Int]+evsrc_t21r =+    [Event 42, NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t22 :: [Event Int]+evsrc_t22 = testSF1 (repeatedly 0.8 42 >>> takeEvents 4)++evsrc_t22r :: [Event Int]+evsrc_t22r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     Event 42, NoEvent,  NoEvent,  Event 42,	-- 1.0 s+     NoEvent,  NoEvent,  Event 42, NoEvent,	-- 2.0 s+     NoEvent,  Event 42, NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t23 :: [Event Int]+evsrc_t23 = testSF1 (repeatedly 0.2 42 >>> takeEvents 4)++evsrc_t23r :: [Event Int]+evsrc_t23r =+    [NoEvent,  Event 42, Event 42, Event 42,	-- 0.0 s+     Event 42, NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t24 :: [Event Int]+evsrc_t24 = testSF1 (now 42 >>> dropEvents 0)++evsrc_t24r :: [Event Int]+evsrc_t24r =+    [Event 42, NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t25 :: [Event Int]+evsrc_t25 = testSF1 (now 42 >>> dropEvents 1)++evsrc_t25r :: [Event Int]+evsrc_t25r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 5.0 s+     NoEvent]+++evsrc_t26 :: [Event Int]+-- Drop 5 events to get rid of the event at 4.0 s which may or may not happen+-- exactly there. +evsrc_t26 = testSF1 (repeatedly 0.8 42 >>> dropEvents 5)++evsrc_t26r :: [Event Int]+evsrc_t26r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 1.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 2.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 3.0 s+     NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 4.0 s+     Event 42, NoEvent,  NoEvent,  Event 42,	-- 5.0 s+     NoEvent]+++evsrc_t27 :: [Event Int]+evsrc_t27 = testSF1 (repeatedly 0.2 42 >>> dropEvents 4)++evsrc_t27r :: [Event Int]+evsrc_t27r =+    [NoEvent,  NoEvent,  NoEvent,  NoEvent,	-- 0.0 s+     NoEvent,  Event 42, Event 42, Event 42,	-- 1.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 2.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 3.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 4.0 s+     Event 42, Event 42, Event 42, Event 42,	-- 5.0 s+     Event 42]++++evsrc_t28 :: [(Event Int, Event Int)]+evsrc_t28 = embed (repeatedly 0.5 ()+                   >>> accumBy (\n _ -> n + 1) 0+                   >>> identity &&& delayEvent 2.0)+                  (deltaEncode 0.125 (replicate 50 ()))++evsrc_t28r =+    [ (NoEvent,NoEvent),  (NoEvent,NoEvent),	-- 0.0 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 1,NoEvent),  (NoEvent,NoEvent),	-- 0.5 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 2,NoEvent),  (NoEvent,NoEvent),	-- 1.0 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 3,NoEvent),  (NoEvent,NoEvent),	-- 1.5 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 4,NoEvent),  (NoEvent,NoEvent),	-- 2.0 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 5,Event 1),  (NoEvent,NoEvent),	-- 2.5 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 6,Event 2),  (NoEvent,NoEvent),	-- 3.0 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 7,Event 3),  (NoEvent,NoEvent),	-- 3.5 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 8,Event 4),  (NoEvent,NoEvent),	-- 4.0 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 9,Event 5),  (NoEvent,NoEvent),	-- 4.5 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 10,Event 6), (NoEvent,NoEvent),	-- 5.0 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 11,Event 7), (NoEvent,NoEvent),	-- 5.5 s+      (NoEvent,NoEvent),  (NoEvent,NoEvent),+      (Event 12,Event 8), (NoEvent,NoEvent)	-- 6.0 s+    ]++evsrc_t29 :: [Event [Double]]+evsrc_t29 = embed (time &&& repeatedly 0.5001 ()+                   >>> arr (\(t,e) -> e `tag` t)+                   >>> delayEventCat 3.0)+                  input+    where+        dts   = replicate 40 0.1 ++ [2.0] ++ replicate 40 0.1+	input = ((), [(dt, Just ()) | dt <- dts]) ++{- Resulting input to the delay for reference:+[ NoEvent,   NoEvent,   NoEvent, NoEvent, NoEvent,	-- 0.0 s +  NoEvent,   Event 0.6, NoEvent, NoEvent, NoEvent,	-- 0.5 s +  NoEvent,   Event 1.1, NoEvent, NoEvent, NoEvent,	-- 1.0 s +  NoEvent,   Event 1.6, NoEvent, NoEvent, NoEvent,	-- 1.5 s +  NoEvent,   Event 2.1, NoEvent, NoEvent, NoEvent,	-- 2.0 s +  NoEvent,   Event 2.6, NoEvent, NoEvent, NoEvent,	-- 2.5 s +  NoEvent,   Event 3.1, NoEvent, NoEvent, NoEvent,	-- 3.0 s +  NoEvent,   Event 3.6, NoEvent, NoEvent, NoEvent,	-- 3.5 s +  NoEvent,						-- 4.0 s +  Event 6.0, Event 6.1, NoEvent, NoEvent, NoEvent,	-- 6.0 s +  NoEvent,   Event 6.6, NoEvent, NoEvent, NoEvent,	-- 6.5 s          +  NoEvent,   Event 7.1, NoEvent, NoEvent, NoEvent,	-- 7.0 s +  NoEvent,   Event 7.6, NoEvent, NoEvent, NoEvent,	-- 7.5 s +  NoEvent,   Event 8.1, NoEvent, NoEvent, NoEvent,	-- 8.0 s +  NoEvent,   Event 8.6, NoEvent, NoEvent, NoEvent,	-- 8.5 s +  NoEvent,   Event 9.1, NoEvent, NoEvent, NoEvent,	-- 9.0 s +  NoEvent,   Event 9.6, NoEvent, NoEvent, NoEvent,	-- 9.5 s +  NoEvent ]						-- 10.0 s+-}++evsrc_t29r =+    [ NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 0.0 s+      NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 0.5 s+      NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 1.0 s+      NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 1.5 s+      NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 2.0 s+      NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 2.5 s+      NoEvent, NoEvent,     NoEvent, NoEvent, NoEvent,		-- 3.0 s+      NoEvent, Event [0.6], NoEvent, NoEvent, NoEvent,		-- 3.5 s+      NoEvent,							-- 4.0 s+      Event [1.1, 1.6, 2.1, 2.6],				-- 6.0 s+          NoEvent, Event [3.1], NoEvent, NoEvent,+      NoEvent, NoEvent,     Event [3.6], NoEvent, NoEvent,	-- 6.5 s+      NoEvent, NoEvent,     NoEvent,     NoEvent, NoEvent,	-- 7.0 s+      NoEvent, NoEvent,     NoEvent,     NoEvent, NoEvent,	-- 7.5 s+      NoEvent, NoEvent,     NoEvent,     NoEvent, NoEvent,	-- 8.0 s+      NoEvent, NoEvent,     NoEvent,     NoEvent, NoEvent,	-- 8.5 s+      NoEvent, Event [6.0], Event [6.1], NoEvent, NoEvent,	-- 9.0 s+      NoEvent, NoEvent,     Event [6.6], NoEvent, NoEvent,	-- 9.5 s+      NoEvent							-- 10.0 s+    ]++-- "delayEvent" in a feedback loop. Should work like "repeatedly".+evsrc_t30 :: [(Event ())]+evsrc_t30 = embed (now ()+                   >>> (loop $+			    arr (uncurry lMerge)+                            >>> delayEvent 1.0+                            >>> arr dup))+                  (deltaEncode 0.125 (replicate 50 ()))+++evsrc_t30r :: [(Event ())]+evsrc_t30r =+    [ NoEvent,  NoEvent, NoEvent, NoEvent,	-- 0.0 s+      NoEvent,  NoEvent, NoEvent, NoEvent,	-- 0.5 s+      Event (), NoEvent, NoEvent, NoEvent, 	-- 1.0 s+      NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.5 s+      Event (), NoEvent, NoEvent, NoEvent,	-- 2.0 s+      NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.5 s+      Event (), NoEvent, NoEvent, NoEvent,	-- 3.0 s+      NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.5 s+      Event (), NoEvent, NoEvent, NoEvent,	-- 4.0 s+      NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.5 s+      Event (), NoEvent, NoEvent, NoEvent,	-- 5.0 s+      NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.5 s+      Event (), NoEvent				-- 6.0 s+    ]+++evsrc_trs =+    [ evsrc_t0 ~= evsrc_t0r,+      evsrc_t1 ~= evsrc_t1r,+      evsrc_t2 ~= evsrc_t2r,+      evsrc_t3 ~= evsrc_t3r,+      evsrc_t4 ~= evsrc_t4r,+      evsrc_t5 ~= evsrc_t5r,+      evsrc_t6 ~= evsrc_t6r,+      evsrc_t7 ~= evsrc_t7r,+      evsrc_t8 ~= evsrc_t8r,+      evsrc_t9 ~= evsrc_t9r,+      evsrc_t10 ~= evsrc_t10r,+      evsrc_t11 ~= evsrc_t11r,+      evsrc_t12 ~= evsrc_t12r,+      evsrc_t13 ~= evsrc_t13r,+      evsrc_t14 ~= evsrc_t14r,+      evsrc_t15 ~= evsrc_t15r,+      evsrc_t16 ~= evsrc_t16r,+      evsrc_t17 ~= evsrc_t17r,+      evsrc_t18 ~= evsrc_t18r,+      evsrc_t19 ~= evsrc_t19r,+      evsrc_t20 ~= evsrc_t20r,+      evsrc_t21 ~= evsrc_t21r,+      evsrc_t22 ~= evsrc_t22r,+      evsrc_t23 ~= evsrc_t23r,+      evsrc_t24 ~= evsrc_t24r,+      evsrc_t25 ~= evsrc_t25r,+      evsrc_t26 ~= evsrc_t26r,+      evsrc_t27 ~= evsrc_t27r,+      evsrc_t28 ~= evsrc_t28r,+      evsrc_t29 ~= evsrc_t29r,+      evsrc_t30 ~= evsrc_t30r+    ]++evsrc_tr = and evsrc_trs
tests/AFRPTestsFirstSecond.hs view
@@ -1,125 +1,125 @@-{- $Id: AFRPTestsFirstSecond.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsArr                                         *
-*       Purpose:        Test cases for first and second			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsFirstSecond (first_trs, first_tr, second_trs, second_tr) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for first
-------------------------------------------------------------------------------
-
-first_t0 :: [(Int,Double)]
-first_t0 = testSF1 (arr dup >>> first (constant 7))
-first_t0r :: [(Int,Double)]
-first_t0r =
-    [(7,0.0),  (7,1.0),  (7,2.0),  (7,3.0),  (7,4.0),
-     (7,5.0),  (7,6.0),  (7,7.0),  (7,8.0),  (7,9.0),
-     (7,10.0), (7,11.0), (7,12.0), (7,13.0), (7,14.0),
-     (7,15.0), (7,16.0), (7,17.0), (7,18.0), (7,19.0),
-     (7,20.0), (7,21.0), (7,22.0), (7,23.0), (7,24.0)]
-
-first_t1 :: [(Int,Double)]
-first_t1 = testSF2 (arr dup >>> first (constant 7))
-first_t1r :: [(Int,Double)]
-first_t1r =
-    [(7,0.0), (7,0.0), (7,0.0), (7,0.0), (7,0.0),
-     (7,1.0), (7,1.0), (7,1.0), (7,1.0), (7,1.0),
-     (7,2.0), (7,2.0), (7,2.0), (7,2.0), (7,2.0),
-     (7,3.0), (7,3.0), (7,3.0), (7,3.0), (7,3.0),
-     (7,4.0), (7,4.0), (7,4.0), (7,4.0), (7,4.0)]
-
-first_t2 :: [(Double,Double)]
-first_t2 = testSF1 (arr dup >>> first (arr (+1)))
-first_t2r =
-    [(1.0,0.0),   (2.0,1.0),   (3.0,2.0),   (4.0,3.0),   (5.0,4.0),
-     (6.0,5.0),   (7.0,6.0),   (8.0,7.0),   (9.0,8.0),   (10.0,9.0),
-     (11.0,10.0), (12.0,11.0), (13.0,12.0), (14.0,13.0), (15.0,14.0),
-     (16.0,15.0), (17.0,16.0), (18.0,17.0), (19.0,18.0), (20.0,19.0),
-     (21.0,20.0), (22.0,21.0), (23.0,22.0), (24.0,23.0), (25.0,24.0)]
-
-first_t3 :: [(Double,Double)]
-first_t3 = testSF2 (arr dup >>> first (arr (+1)))
-first_t3r =
-    [(1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0),
-     (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0),
-     (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0),
-     (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0),
-     (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0)]
-
-first_t4 :: [(Double,Double)]
-first_t4 = testSF1 (arr dup >>> first integral)
-first_t4r =
-    [(0.0,0.0),    (0.0,1.0),    (0.25,2.0),   (0.75,3.0),   (1.5,4.0),
-     (2.5,5.0),    (3.75,6.0),   (5.25,7.0),   (7.0,8.0),    (9.0,9.0),
-     (11.25,10.0), (13.75,11.0), (16.5,12.0),  (19.5,13.0),  (22.75,14.0),
-     (26.25,15.0), (30.0,16.0),  (34.0,17.0),  (38.25,18.0), (42.75,19.0),
-     (47.5,20.0),  (52.5,21.0),  (57.75,22.0), (63.25,23.0), (69.0,24.0)]
-
-first_t5 :: [(Double,Double)]
-first_t5 = testSF2 (arr dup >>> first integral)
-first_t5r =
-    [(0.0,0.0),  (0.0,0.0),  (0.0,0.0),  (0.0,0.0),  (0.0,0.0),
-     (0.0,1.0),  (0.25,1.0), (0.5,1.0),  (0.75,1.0), (1.0,1.0),
-     (1.25,2.0), (1.75,2.0), (2.25,2.0), (2.75,2.0), (3.25,2.0),
-     (3.75,3.0), (4.5,3.0),  (5.25,3.0), (6.0,3.0),  (6.75,3.0),
-     (7.5,4.0),  (8.5,4.0),  (9.5,4.0),  (10.5,4.0), (11.5,4.0)]
-
-first_trs =
-    [ first_t0 ~= first_t0r,
-      first_t1 ~= first_t1r,
-      first_t2 ~= first_t2r,
-      first_t3 ~= first_t3r,
-      first_t4 ~= first_t4r,
-      first_t5 ~= first_t5r
-    ]
-
-first_tr = and first_trs
-
-
-------------------------------------------------------------------------------
--- Test cases for second
-------------------------------------------------------------------------------
-
--- These should mirror the test cases for first.
-
-second_t0 :: [(Int,Double)]
-second_t0 = testSF1 (arr dup >>> second (constant 7) >>> arr swap)
-
-second_t1 :: [(Int,Double)]
-second_t1 = testSF2 (arr dup >>> second (constant 7) >>> arr swap)
-
-second_t2 :: [(Double,Double)]
-second_t2 = testSF1 (arr dup >>> second (arr (+1)) >>> arr swap)
-
-second_t3 :: [(Double,Double)]
-second_t3 = testSF2 (arr dup >>> second (arr (+1)) >>> arr swap)
-
-second_t4 :: [(Double,Double)]
-second_t4 = testSF1 (arr dup >>> second integral >>> arr swap)
-
-second_t5 :: [(Double,Double)]
-second_t5 = testSF2 (arr dup >>> second integral >>> arr swap)
-
-second_trs =
-    [ second_t0 ~= first_t0r,
-      second_t1 ~= first_t1r,
-      second_t2 ~= first_t2r,
-      second_t3 ~= first_t3r,
-      second_t4 ~= first_t4r,
-      second_t5 ~= first_t5r
-    ]
-
-second_tr = and second_trs
+{- $Id: AFRPTestsFirstSecond.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsArr                                         *+*       Purpose:        Test cases for first and second			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsFirstSecond (first_trs, first_tr, second_trs, second_tr) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for first+------------------------------------------------------------------------------++first_t0 :: [(Int,Double)]+first_t0 = testSF1 (arr dup >>> first (constant 7))+first_t0r :: [(Int,Double)]+first_t0r =+    [(7,0.0),  (7,1.0),  (7,2.0),  (7,3.0),  (7,4.0),+     (7,5.0),  (7,6.0),  (7,7.0),  (7,8.0),  (7,9.0),+     (7,10.0), (7,11.0), (7,12.0), (7,13.0), (7,14.0),+     (7,15.0), (7,16.0), (7,17.0), (7,18.0), (7,19.0),+     (7,20.0), (7,21.0), (7,22.0), (7,23.0), (7,24.0)]++first_t1 :: [(Int,Double)]+first_t1 = testSF2 (arr dup >>> first (constant 7))+first_t1r :: [(Int,Double)]+first_t1r =+    [(7,0.0), (7,0.0), (7,0.0), (7,0.0), (7,0.0),+     (7,1.0), (7,1.0), (7,1.0), (7,1.0), (7,1.0),+     (7,2.0), (7,2.0), (7,2.0), (7,2.0), (7,2.0),+     (7,3.0), (7,3.0), (7,3.0), (7,3.0), (7,3.0),+     (7,4.0), (7,4.0), (7,4.0), (7,4.0), (7,4.0)]++first_t2 :: [(Double,Double)]+first_t2 = testSF1 (arr dup >>> first (arr (+1)))+first_t2r =+    [(1.0,0.0),   (2.0,1.0),   (3.0,2.0),   (4.0,3.0),   (5.0,4.0),+     (6.0,5.0),   (7.0,6.0),   (8.0,7.0),   (9.0,8.0),   (10.0,9.0),+     (11.0,10.0), (12.0,11.0), (13.0,12.0), (14.0,13.0), (15.0,14.0),+     (16.0,15.0), (17.0,16.0), (18.0,17.0), (19.0,18.0), (20.0,19.0),+     (21.0,20.0), (22.0,21.0), (23.0,22.0), (24.0,23.0), (25.0,24.0)]++first_t3 :: [(Double,Double)]+first_t3 = testSF2 (arr dup >>> first (arr (+1)))+first_t3r =+    [(1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0),+     (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0),+     (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0),+     (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0),+     (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0)]++first_t4 :: [(Double,Double)]+first_t4 = testSF1 (arr dup >>> first integral)+first_t4r =+    [(0.0,0.0),    (0.0,1.0),    (0.25,2.0),   (0.75,3.0),   (1.5,4.0),+     (2.5,5.0),    (3.75,6.0),   (5.25,7.0),   (7.0,8.0),    (9.0,9.0),+     (11.25,10.0), (13.75,11.0), (16.5,12.0),  (19.5,13.0),  (22.75,14.0),+     (26.25,15.0), (30.0,16.0),  (34.0,17.0),  (38.25,18.0), (42.75,19.0),+     (47.5,20.0),  (52.5,21.0),  (57.75,22.0), (63.25,23.0), (69.0,24.0)]++first_t5 :: [(Double,Double)]+first_t5 = testSF2 (arr dup >>> first integral)+first_t5r =+    [(0.0,0.0),  (0.0,0.0),  (0.0,0.0),  (0.0,0.0),  (0.0,0.0),+     (0.0,1.0),  (0.25,1.0), (0.5,1.0),  (0.75,1.0), (1.0,1.0),+     (1.25,2.0), (1.75,2.0), (2.25,2.0), (2.75,2.0), (3.25,2.0),+     (3.75,3.0), (4.5,3.0),  (5.25,3.0), (6.0,3.0),  (6.75,3.0),+     (7.5,4.0),  (8.5,4.0),  (9.5,4.0),  (10.5,4.0), (11.5,4.0)]++first_trs =+    [ first_t0 ~= first_t0r,+      first_t1 ~= first_t1r,+      first_t2 ~= first_t2r,+      first_t3 ~= first_t3r,+      first_t4 ~= first_t4r,+      first_t5 ~= first_t5r+    ]++first_tr = and first_trs+++------------------------------------------------------------------------------+-- Test cases for second+------------------------------------------------------------------------------++-- These should mirror the test cases for first.++second_t0 :: [(Int,Double)]+second_t0 = testSF1 (arr dup >>> second (constant 7) >>> arr swap)++second_t1 :: [(Int,Double)]+second_t1 = testSF2 (arr dup >>> second (constant 7) >>> arr swap)++second_t2 :: [(Double,Double)]+second_t2 = testSF1 (arr dup >>> second (arr (+1)) >>> arr swap)++second_t3 :: [(Double,Double)]+second_t3 = testSF2 (arr dup >>> second (arr (+1)) >>> arr swap)++second_t4 :: [(Double,Double)]+second_t4 = testSF1 (arr dup >>> second integral >>> arr swap)++second_t5 :: [(Double,Double)]+second_t5 = testSF2 (arr dup >>> second integral >>> arr swap)++second_trs =+    [ second_t0 ~= first_t0r,+      second_t1 ~= first_t1r,+      second_t2 ~= first_t2r,+      second_t3 ~= first_t3r,+      second_t4 ~= first_t4r,+      second_t5 ~= first_t5r+    ]++second_tr = and second_trs
tests/AFRPTestsKSwitch.hs view
@@ -1,128 +1,128 @@-{- $Id: AFRPTestsKSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsKSwitch				     *
-*       Purpose:        Test cases for kSwitch and dkSwitch		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsKSwitch (kswitch_tr, kswitch_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for kSwitch and dkSwitch
-------------------------------------------------------------------------------
-
-kswitch_inp1 = deltaEncode 0.1 [0.0, 0.5 ..]
-
-whenSndGE :: Ord b => b -> c -> SF (a, b) (Event c)
-whenSndGE b c = arr snd >>> arr (>= b) >>> edge >>> arr (`tag` c)
-
-
-kswitch_t0 :: [Double]
-kswitch_t0 = take 20 $ embed sf kswitch_inp1
-    where
-	sf =
-	    kSwitch integral (whenSndGE 0.2 (-1.0)) $ \sf1 x ->
-	    kSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->
-            sf1
-
-kswitch_t0r =
-    [ 0.00,  0.00,  0.05, 0.15, -1.00,
-     -0.80, -0.55, -0.25, 0.10,  0.50,
-      0.95,  0.30,  0.85, 1.45,  2.10,
-      2.80,  3.55,  4.35, 5.20,  6.10]
-
-
-kswitch_t1 :: [Double]
-kswitch_t1 = take 20 $ embed sf kswitch_inp1
-    where
-	sf =
-	    dkSwitch integral (whenSndGE 0.2 (-1.0)) $ \sf1 x ->
-	    dkSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->
-            sf1
-
-kswitch_t1r =
-    [ 0.00,  0.00,  0.05, 0.15, 0.30,
-     -0.80, -0.55, -0.25, 0.10, 0.50,
-      0.95,  1.45,  0.85, 1.45, 2.10,
-      2.80,  3.55,  4.35, 5.20, 6.10]
-
-
-kswitch_t2 :: [Double]
-kswitch_t2 = take 20 $ embed sf kswitch_inp1
-    where
-	sf =
-	    kSwitch integral (now (-1.0)) $ \sf1 x ->
-	    kSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->
-            sf1
-
-kswitch_t2r =
-    [-1.00, -1.00, -0.95, -0.85, -0.70,
-     -0.50, -0.25,  0.05,  0.40,  0.80,
-      0.00,  0.50,  1.05,  1.65,  2.30,
-      3.00,  3.75,  4.55,  5.40,  6.30]
-
-
-kswitch_t3 :: [Double]
-kswitch_t3 = take 20 $ embed sf kswitch_inp1
-    where
-	sf =
-	    dkSwitch integral (now (-1.0)) $ \sf1 x ->
-	    dkSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->
-            sf1
-
-kswitch_t3r =
-    [ 0.00, -1.00, -0.95, -0.85, -0.70,
-     -0.50, -0.25,  0.05,  0.40,  0.80,
-      1.25,  0.50,  1.05,  1.65,  2.30,
-      3.00,  3.75,  4.55,  5.40,  6.30]
-
-
--- The correct strictness properties of dkSwitch are crucial here.
--- kSwitch does not work.
-kswitch_t4 = take 40 $
-    embed (loop $
-	       dkSwitch sf (sfe 0.55 (-1.0))              $ \sf1 x ->
-	       dkSwitch (sf >>> arr2 (+x)) (sfe 0.05 8.0) $ \sf2 y ->
-	       dkSwitch sf1 (sfe 2.0 (-2.0))              $ \_   z ->
-	       sf2 >>> arr2 (+(y + z))
-           )
-          (deltaEncode 0.1 (repeat ()))
-    where
-        sf :: SF (a, Double) (Double, Double)
-        sf = constant 1.0 >>> integral >>> arr dup
-
-	sfe :: Double -> Double -> SF ((a, Double), b) (Event Double)
-	sfe x e = arr fst >>> whenSndGE x e
-
-	arr2 f = arr (\(x,y) -> (f x, f y))
-
-kswitch_t4r =
-    [ 0.0,  0.1,  0.2,  0.3,  0.4,
-      0.5,  0.6, -0.9, -0.8, -0.7,
-     -0.6, -0.5, -0.4, -0.3, -0.2,
-     -0.1,  0.0,  0.1,  0.7,  0.8,
-      0.9,  1.0,  1.1,  1.2,  1.3,
-      1.4,  1.5,  1.6,  1.7,  1.8,
-      1.9,  2.0,  6.2,  6.3,  6.4,
-      6.5,  6.6,  6.7,  6.8,  6.9]
-
-
-kswitch_trs =
-    [ kswitch_t0 ~= kswitch_t0r,
-      kswitch_t1 ~= kswitch_t1r,
-      kswitch_t2 ~= kswitch_t2r,
-      kswitch_t3 ~= kswitch_t3r,
-      kswitch_t4 ~= kswitch_t4r
-    ]
-
-kswitch_tr = and kswitch_trs
+{- $Id: AFRPTestsKSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsKSwitch				     *+*       Purpose:        Test cases for kSwitch and dkSwitch		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsKSwitch (kswitch_tr, kswitch_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for kSwitch and dkSwitch+------------------------------------------------------------------------------++kswitch_inp1 = deltaEncode 0.1 [0.0, 0.5 ..]++whenSndGE :: Ord b => b -> c -> SF (a, b) (Event c)+whenSndGE b c = arr snd >>> arr (>= b) >>> edge >>> arr (`tag` c)+++kswitch_t0 :: [Double]+kswitch_t0 = take 20 $ embed sf kswitch_inp1+    where+	sf =+	    kSwitch integral (whenSndGE 0.2 (-1.0)) $ \sf1 x ->+	    kSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->+            sf1++kswitch_t0r =+    [ 0.00,  0.00,  0.05, 0.15, -1.00,+     -0.80, -0.55, -0.25, 0.10,  0.50,+      0.95,  0.30,  0.85, 1.45,  2.10,+      2.80,  3.55,  4.35, 5.20,  6.10]+++kswitch_t1 :: [Double]+kswitch_t1 = take 20 $ embed sf kswitch_inp1+    where+	sf =+	    dkSwitch integral (whenSndGE 0.2 (-1.0)) $ \sf1 x ->+	    dkSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->+            sf1++kswitch_t1r =+    [ 0.00,  0.00,  0.05, 0.15, 0.30,+     -0.80, -0.55, -0.25, 0.10, 0.50,+      0.95,  1.45,  0.85, 1.45, 2.10,+      2.80,  3.55,  4.35, 5.20, 6.10]+++kswitch_t2 :: [Double]+kswitch_t2 = take 20 $ embed sf kswitch_inp1+    where+	sf =+	    kSwitch integral (now (-1.0)) $ \sf1 x ->+	    kSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->+            sf1++kswitch_t2r =+    [-1.00, -1.00, -0.95, -0.85, -0.70,+     -0.50, -0.25,  0.05,  0.40,  0.80,+      0.00,  0.50,  1.05,  1.65,  2.30,+      3.00,  3.75,  4.55,  5.40,  6.30]+++kswitch_t3 :: [Double]+kswitch_t3 = take 20 $ embed sf kswitch_inp1+    where+	sf =+	    dkSwitch integral (now (-1.0)) $ \sf1 x ->+	    dkSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ ->+            sf1++kswitch_t3r =+    [ 0.00, -1.00, -0.95, -0.85, -0.70,+     -0.50, -0.25,  0.05,  0.40,  0.80,+      1.25,  0.50,  1.05,  1.65,  2.30,+      3.00,  3.75,  4.55,  5.40,  6.30]+++-- The correct strictness properties of dkSwitch are crucial here.+-- kSwitch does not work.+kswitch_t4 = take 40 $+    embed (loop $+	       dkSwitch sf (sfe 0.55 (-1.0))              $ \sf1 x ->+	       dkSwitch (sf >>> arr2 (+x)) (sfe 0.05 8.0) $ \sf2 y ->+	       dkSwitch sf1 (sfe 2.0 (-2.0))              $ \_   z ->+	       sf2 >>> arr2 (+(y + z))+           )+          (deltaEncode 0.1 (repeat ()))+    where+        sf :: SF (a, Double) (Double, Double)+        sf = constant 1.0 >>> integral >>> arr dup++	sfe :: Double -> Double -> SF ((a, Double), b) (Event Double)+	sfe x e = arr fst >>> whenSndGE x e++	arr2 f = arr (\(x,y) -> (f x, f y))++kswitch_t4r =+    [ 0.0,  0.1,  0.2,  0.3,  0.4,+      0.5,  0.6, -0.9, -0.8, -0.7,+     -0.6, -0.5, -0.4, -0.3, -0.2,+     -0.1,  0.0,  0.1,  0.7,  0.8,+      0.9,  1.0,  1.1,  1.2,  1.3,+      1.4,  1.5,  1.6,  1.7,  1.8,+      1.9,  2.0,  6.2,  6.3,  6.4,+      6.5,  6.6,  6.7,  6.8,  6.9]+++kswitch_trs =+    [ kswitch_t0 ~= kswitch_t0r,+      kswitch_t1 ~= kswitch_t1r,+      kswitch_t2 ~= kswitch_t2r,+      kswitch_t3 ~= kswitch_t3r,+      kswitch_t4 ~= kswitch_t4r+    ]++kswitch_tr = and kswitch_trs
tests/AFRPTestsLaws.hs view
@@ -1,89 +1,89 @@-{- $Id: AFRPTestsLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsLaws                                        *
-*       Purpose:        Test cases based on the arrow laws		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsLaws (laws_trs, laws_tr) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases based on the arrow laws
-------------------------------------------------------------------------------
-
--- For a description of the laws, see e.g. Ross Paterson: Embedding a Class of
--- Domain-Specific Languages in a Functional Language.
--- Only a very rudimentary sanity check. Obviously not intended to "prove"
--- this implementation indeed do respect the laws.
-
-laws_t0_lhs :: [Double]
-laws_t0_lhs = testSF1 (arr id >>> integral)
-laws_t0_rhs :: [Double]
-laws_t0_rhs = testSF1 (integral)
-
-laws_t1_lhs :: [Double]
-laws_t1_lhs = testSF1 (integral >>> arr id)
-laws_t1_rhs :: [Double]
-laws_t1_rhs = testSF1 (integral)
-
-laws_t2_lhs :: [Double]
-laws_t2_lhs = testSF1 ((integral >>> arr (*0.5)) >>> integral)
-laws_t2_rhs :: [Double]
-laws_t2_rhs = testSF1 (integral >>> (arr (*0.5) >>> integral))
-
-laws_t3_lhs :: [Double]
-laws_t3_lhs = testSF1 (arr ((*2.5) . (+3.0)))
-laws_t3_rhs :: [Double]
-laws_t3_rhs = testSF1 (arr (+3.0) >>> arr (*2.5))
-
-laws_t4_lhs :: [(Double, Double)]
-laws_t4_lhs = testSF1 (arr dup >>> first (arr (*2.5)))
-laws_t4_rhs :: [(Double, Double)]
-laws_t4_rhs = testSF1 (arr dup >>> arr (fun_prod (*2.5) id))
-
-laws_t5_lhs :: [(Double, Double)]
-laws_t5_lhs = testSF1 (arr dup >>> (first (integral >>> arr (+3.0))))
-laws_t5_rhs :: [(Double, Double)]
-laws_t5_rhs = testSF1 (arr dup >>> (first integral >>> first (arr (+3.0))))
-
-laws_t6_lhs :: [(Double, Double)]
-laws_t6_lhs = testSF1 (arr dup >>> (first integral>>>arr (fun_prod id (+3.0))))
-laws_t6_rhs :: [(Double, Double)]
-laws_t6_rhs = testSF1 (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral))
-
-laws_t7_lhs :: [Double]
-laws_t7_lhs = testSF1 (arr dup >>> (first integral >>> arr fst))
-laws_t7_rhs :: [Double]
-laws_t7_rhs = testSF1 (arr dup >>> (arr fst >>> integral))
-
-laws_t8_lhs :: [(Double, (Double, ()))]
-laws_t8_lhs = testSF1 (arr (\x -> ((x,x),()))
-		       >>> (first (first integral) >>> arr assoc))
-laws_t8_rhs :: [(Double, (Double, ()))]
-laws_t8_rhs = testSF1 (arr (\x -> ((x,x),()))
-		       >>> (arr assoc >>> first integral))
-
-
-laws_trs =
-    [ laws_t0_lhs ~= laws_t0_rhs,
-      laws_t1_lhs ~= laws_t1_rhs,
-      laws_t2_lhs ~= laws_t2_rhs,
-      laws_t3_lhs ~= laws_t3_rhs,
-      laws_t4_lhs ~= laws_t4_rhs,
-      laws_t5_lhs ~= laws_t5_rhs,
-      laws_t6_lhs ~= laws_t6_rhs,
-      laws_t7_lhs ~= laws_t7_rhs,
-      laws_t8_lhs ~= laws_t8_rhs
-    ]
-
-laws_tr = and laws_trs
+{- $Id: AFRPTestsLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsLaws                                        *+*       Purpose:        Test cases based on the arrow laws		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsLaws (laws_trs, laws_tr) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases based on the arrow laws+------------------------------------------------------------------------------++-- For a description of the laws, see e.g. Ross Paterson: Embedding a Class of+-- Domain-Specific Languages in a Functional Language.+-- Only a very rudimentary sanity check. Obviously not intended to "prove"+-- this implementation indeed do respect the laws.++laws_t0_lhs :: [Double]+laws_t0_lhs = testSF1 (arr id >>> integral)+laws_t0_rhs :: [Double]+laws_t0_rhs = testSF1 (integral)++laws_t1_lhs :: [Double]+laws_t1_lhs = testSF1 (integral >>> arr id)+laws_t1_rhs :: [Double]+laws_t1_rhs = testSF1 (integral)++laws_t2_lhs :: [Double]+laws_t2_lhs = testSF1 ((integral >>> arr (*0.5)) >>> integral)+laws_t2_rhs :: [Double]+laws_t2_rhs = testSF1 (integral >>> (arr (*0.5) >>> integral))++laws_t3_lhs :: [Double]+laws_t3_lhs = testSF1 (arr ((*2.5) . (+3.0)))+laws_t3_rhs :: [Double]+laws_t3_rhs = testSF1 (arr (+3.0) >>> arr (*2.5))++laws_t4_lhs :: [(Double, Double)]+laws_t4_lhs = testSF1 (arr dup >>> first (arr (*2.5)))+laws_t4_rhs :: [(Double, Double)]+laws_t4_rhs = testSF1 (arr dup >>> arr (fun_prod (*2.5) id))++laws_t5_lhs :: [(Double, Double)]+laws_t5_lhs = testSF1 (arr dup >>> (first (integral >>> arr (+3.0))))+laws_t5_rhs :: [(Double, Double)]+laws_t5_rhs = testSF1 (arr dup >>> (first integral >>> first (arr (+3.0))))++laws_t6_lhs :: [(Double, Double)]+laws_t6_lhs = testSF1 (arr dup >>> (first integral>>>arr (fun_prod id (+3.0))))+laws_t6_rhs :: [(Double, Double)]+laws_t6_rhs = testSF1 (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral))++laws_t7_lhs :: [Double]+laws_t7_lhs = testSF1 (arr dup >>> (first integral >>> arr fst))+laws_t7_rhs :: [Double]+laws_t7_rhs = testSF1 (arr dup >>> (arr fst >>> integral))++laws_t8_lhs :: [(Double, (Double, ()))]+laws_t8_lhs = testSF1 (arr (\x -> ((x,x),()))+		       >>> (first (first integral) >>> arr assoc))+laws_t8_rhs :: [(Double, (Double, ()))]+laws_t8_rhs = testSF1 (arr (\x -> ((x,x),()))+		       >>> (arr assoc >>> first integral))+++laws_trs =+    [ laws_t0_lhs ~= laws_t0_rhs,+      laws_t1_lhs ~= laws_t1_rhs,+      laws_t2_lhs ~= laws_t2_rhs,+      laws_t3_lhs ~= laws_t3_rhs,+      laws_t4_lhs ~= laws_t4_rhs,+      laws_t5_lhs ~= laws_t5_rhs,+      laws_t6_lhs ~= laws_t6_rhs,+      laws_t7_lhs ~= laws_t7_rhs,+      laws_t8_lhs ~= laws_t8_rhs+    ]++laws_tr = and laws_trs
tests/AFRPTestsLoop.hs view
@@ -1,206 +1,206 @@-{- $Id: AFRPTestsLoop.hs,v 1.6 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsLoop					     *
-*       Purpose:        Test cases for loop				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsLoop (loop_trs, loop_tr, loop_st0, loop_st0r, 
-		      loop_st1, loop_st1r) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for loop
-------------------------------------------------------------------------------
-
-loop_acc :: SF (Double, Double) (Double, Double)
-loop_acc = arr (\(x, y)->(x+y, x+y))
-
-loop_t0 :: [Double]
-loop_t0 = testSF1 (loop (constant (42.0, 43.0)))
-loop_t0r = 
-    [42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,
-     42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,
-     42.0, 42.0, 42.0, 42.0, 42.0]
-
-loop_t1 :: [Double]
-loop_t1 = testSF1 (loop identity)
-loop_t1r =
-    [0.0,  1.0,  2.0,  3.0,  4.0,  5.0,  6.0,  7.0,  8.0,  9.0,
-     10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0,
-     20.0, 21.0, 22.0, 23.0, 24.0]
-
-loop_t2 :: [Time]
-loop_t2 = testSF1 (loop (first localTime))
-loop_t2r =
-    [0.0,  0.25, 0.5,  0.75, 1.0,
-     1.25, 1.5,  1.75, 2.0,  2.25,
-     2.5,  2.75, 3.0,  3.25, 3.5,
-     3.75, 4.0,  4.25, 4.5,  4.75,
-     5.0,  5.25, 5.5,  5.75, 6.0]
-
--- AC, 10-March-2002: I think this is the simplest test that will
--- fail with AltST.
-loop_t3 :: [Time]
-loop_t3 = testSF1 (loop (second (iPre 0)))
-loop_t3r =
-    [0.0,  1.0,  2.0,  3.0,  4.0,
-     5.0,  6.0,  7.0,  8.0,  9.0,
-     10.0, 11.0, 12.0, 13.0, 14.0,
-     15.0, 16.0, 17.0, 18.0, 19.0,
-     20.0, 21.0, 22.0, 23.0, 24.0]
-
-loop_t4 :: [Double]
-loop_t4 = testSF1 (loop (second (iPre 0) >>> loop_acc))
-loop_t4r =
-    [0.0,   1.0,   3.0,   6.0,   10.0, 
-     15.0,  21.0,  28.0,  36.0,  45.0,
-     55.0,  66.0,  78.0,  91.0,  105.0,
-     120.0, 136.0, 153.0, 171.0, 190.0,
-     210.0, 231.0, 253.0, 276.0, 300.0]
-
-loop_t5 :: [Double]
-loop_t5 = testSF2 (loop (second (iPre 0) >>> loop_acc))
-loop_t5r =
-    [0.0,  0.0,  0.0,  0.0,  0.0, 
-     1.0,  2.0,  3.0,  4.0,  5.0,
-     7.0,  9.0,  11.0, 13.0, 15.0,
-     18.0, 21.0, 24.0, 27.0, 30.0,
-     34.0, 38.0, 42.0, 46.0, 50.0]
-
-loop_t6 :: [Double]
-loop_t6 = testSF1 (loop (iPre (0,0) >>> first localTime >>> loop_acc))
-loop_t6r =
-    [0.0,   0.25,  0.75,  1.5,   2.5,
-     3.75,  5.25,  7.0,   9.0,   11.25,
-     13.75, 16.5,  19.5,  22.75, 26.25,
-     30.0,  34.0,  38.25, 42.75, 47.5,
-     52.5,  57.75, 63.25, 69.0,  75.0]
-
-loop_t7 :: [Double]
-loop_t7 = testSF1 (loop (loop_acc >>> second (iPre 0)))
-loop_t7r = loop_t4r
-
-loop_t8 :: [Double]
-loop_t8 = testSF2 (loop (loop_acc >>> second (iPre 0)))
-loop_t8r = loop_t5r
-
-loop_t9 :: [Double]
-loop_t9 = testSF1 (loop (first localTime >>> loop_acc >>> iPre (0,0)))
-loop_t9r =
-    [0.0,   0.0,   0.25,  0.75,  1.5,
-     2.5,   3.75,  5.25,  7.0,   9.0,
-     11.25, 13.75, 16.5,  19.5,  22.75,
-     26.25, 30.0,  34.0,  38.25, 42.75,
-     47.5,  52.5,  57.75, 63.25, 69.0]
-
-loop_t10 :: [Double]
-loop_t10 = testSF1 (loop (loop_acc >>> second (iPre 0) >>> identity))
-loop_t10r = loop_t4r
-
-loop_t11 :: [Double]
-loop_t11 = testSF2 (loop (loop_acc >>> second (iPre 0) >>> identity))
-loop_t11r = loop_t5r
-
-loop_t12 :: [Double]
-loop_t12 = testSF1 (loop (first localTime
-                          >>> loop_acc
-                          >>> iPre (0,0)
-                          >>> identity))
-loop_t12r = loop_t9r
-
--- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration.
--- Values as given by using exp directly:
--- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413
-loop_t13 :: [Double]
-loop_t13 =
-    let
-	es = embed (loop (second integral >>> arr (\(_, x) -> (x + 1, x + 1))))
-                   (deltaEncode 0.001 (repeat ()))
-    in
-	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
-loop_t13r = [1.0,2.71692, 7.38167, 20.05544, 54.48911, 148.04276]
-
-loop_t14 :: [Double]
-loop_t14 =
-    let
-	es = embed (loop (arr (\(_, x) -> (x + 1, x + 1)) >>> second integral))
-                   (deltaEncode 0.001 (repeat ()))
-    in
-	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
-loop_t14r = loop_t13r
-
-loop_t15 :: [Double]
-loop_t15 =
-    let
-	es = embed (loop (arr (\(_, x) -> (x + 1, x + 1))
-                          >>> second integral
-			  >>> identity))
-                   (deltaEncode 0.001 (repeat ()))
-    in
-	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
-loop_t15r = loop_t13r
-
--- A generator for factorial:  The least-fixed point of this function is
--- the factorial function.
-
-factGen f n = if (n==0) then 1 else n*f(n-1)
-
--- Can we use loop to construct a fixed point?
-loop_t16 :: [Int]
-loop_t16 = testSF1 (loop $ arr (\ (_,f) -> (f 4,factGen f)))
-loop_t16r =
-  [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24]
-
--- A simple loop test taken from MiniYampa:
--- This results in pulling on the fed-back output during evaluation, because
--- switch is strict in its input sample:
-loop_t17 :: [Double]
-loop_t17 = testSF1 (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x,noEvent)) >>> (iPre (25, noEvent)))
-loop_t17r =
-  [0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,
-   16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0]
-
-loop_trs =
-    [ loop_t0  ~= loop_t0r,
-      loop_t1  ~= loop_t1r,
-      loop_t2  ~= loop_t2r,
-      loop_t3  ~= loop_t3r,
-      loop_t4  ~= loop_t4r,
-      loop_t5  ~= loop_t5r,
-      loop_t6  ~= loop_t6r,
-      loop_t7  ~= loop_t7r,
-      loop_t8  ~= loop_t8r,
-      loop_t9  ~= loop_t9r,
-      loop_t10 ~= loop_t10r,
-      loop_t11 ~= loop_t11r,
-      loop_t12 ~= loop_t12r,
-      loop_t13 ~= loop_t13r,
-      loop_t14 ~= loop_t14r,
-      loop_t15 ~= loop_t15r,
-      loop_t16 ~= loop_t16r,
-      loop_t17 ~= loop_t17r
-    ]
-
-loop_tr = and loop_trs
-
-loop_st0 = testSFSpaceLeak 2000000
-			   (loop (second (iPre 0) >>> loop_acc))
-loop_st0r = 9.999995e11
-
--- A simple loop test taken from MiniYampa:
--- This results in pulling on the fed-back output during evaluation, because
--- switch is strict in its input sample:
-loop_st1 :: Double
-loop_st1 = testSFSpaceLeak 2000000
-             (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x + x + x + x + x + x + x,noEvent)) >>> (iPre (25, noEvent)))
+{- $Id: AFRPTestsLoop.hs,v 1.6 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsLoop					     *+*       Purpose:        Test cases for loop				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsLoop (loop_trs, loop_tr, loop_st0, loop_st0r, +		      loop_st1, loop_st1r) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for loop+------------------------------------------------------------------------------++loop_acc :: SF (Double, Double) (Double, Double)+loop_acc = arr (\(x, y)->(x+y, x+y))++loop_t0 :: [Double]+loop_t0 = testSF1 (loop (constant (42.0, 43.0)))+loop_t0r = +    [42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,+     42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0,+     42.0, 42.0, 42.0, 42.0, 42.0]++loop_t1 :: [Double]+loop_t1 = testSF1 (loop identity)+loop_t1r =+    [0.0,  1.0,  2.0,  3.0,  4.0,  5.0,  6.0,  7.0,  8.0,  9.0,+     10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0,+     20.0, 21.0, 22.0, 23.0, 24.0]++loop_t2 :: [Time]+loop_t2 = testSF1 (loop (first localTime))+loop_t2r =+    [0.0,  0.25, 0.5,  0.75, 1.0,+     1.25, 1.5,  1.75, 2.0,  2.25,+     2.5,  2.75, 3.0,  3.25, 3.5,+     3.75, 4.0,  4.25, 4.5,  4.75,+     5.0,  5.25, 5.5,  5.75, 6.0]++-- AC, 10-March-2002: I think this is the simplest test that will+-- fail with AltST.+loop_t3 :: [Time]+loop_t3 = testSF1 (loop (second (iPre 0)))+loop_t3r =+    [0.0,  1.0,  2.0,  3.0,  4.0,+     5.0,  6.0,  7.0,  8.0,  9.0,+     10.0, 11.0, 12.0, 13.0, 14.0,+     15.0, 16.0, 17.0, 18.0, 19.0,+     20.0, 21.0, 22.0, 23.0, 24.0]++loop_t4 :: [Double]+loop_t4 = testSF1 (loop (second (iPre 0) >>> loop_acc))+loop_t4r =+    [0.0,   1.0,   3.0,   6.0,   10.0, +     15.0,  21.0,  28.0,  36.0,  45.0,+     55.0,  66.0,  78.0,  91.0,  105.0,+     120.0, 136.0, 153.0, 171.0, 190.0,+     210.0, 231.0, 253.0, 276.0, 300.0]++loop_t5 :: [Double]+loop_t5 = testSF2 (loop (second (iPre 0) >>> loop_acc))+loop_t5r =+    [0.0,  0.0,  0.0,  0.0,  0.0, +     1.0,  2.0,  3.0,  4.0,  5.0,+     7.0,  9.0,  11.0, 13.0, 15.0,+     18.0, 21.0, 24.0, 27.0, 30.0,+     34.0, 38.0, 42.0, 46.0, 50.0]++loop_t6 :: [Double]+loop_t6 = testSF1 (loop (iPre (0,0) >>> first localTime >>> loop_acc))+loop_t6r =+    [0.0,   0.25,  0.75,  1.5,   2.5,+     3.75,  5.25,  7.0,   9.0,   11.25,+     13.75, 16.5,  19.5,  22.75, 26.25,+     30.0,  34.0,  38.25, 42.75, 47.5,+     52.5,  57.75, 63.25, 69.0,  75.0]++loop_t7 :: [Double]+loop_t7 = testSF1 (loop (loop_acc >>> second (iPre 0)))+loop_t7r = loop_t4r++loop_t8 :: [Double]+loop_t8 = testSF2 (loop (loop_acc >>> second (iPre 0)))+loop_t8r = loop_t5r++loop_t9 :: [Double]+loop_t9 = testSF1 (loop (first localTime >>> loop_acc >>> iPre (0,0)))+loop_t9r =+    [0.0,   0.0,   0.25,  0.75,  1.5,+     2.5,   3.75,  5.25,  7.0,   9.0,+     11.25, 13.75, 16.5,  19.5,  22.75,+     26.25, 30.0,  34.0,  38.25, 42.75,+     47.5,  52.5,  57.75, 63.25, 69.0]++loop_t10 :: [Double]+loop_t10 = testSF1 (loop (loop_acc >>> second (iPre 0) >>> identity))+loop_t10r = loop_t4r++loop_t11 :: [Double]+loop_t11 = testSF2 (loop (loop_acc >>> second (iPre 0) >>> identity))+loop_t11r = loop_t5r++loop_t12 :: [Double]+loop_t12 = testSF1 (loop (first localTime+                          >>> loop_acc+                          >>> iPre (0,0)+                          >>> identity))+loop_t12r = loop_t9r++-- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration.+-- Values as given by using exp directly:+-- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413+loop_t13 :: [Double]+loop_t13 =+    let+	es = embed (loop (second integral >>> arr (\(_, x) -> (x + 1, x + 1))))+                   (deltaEncode 0.001 (repeat ()))+    in+	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]+loop_t13r = [1.0,2.71692, 7.38167, 20.05544, 54.48911, 148.04276]++loop_t14 :: [Double]+loop_t14 =+    let+	es = embed (loop (arr (\(_, x) -> (x + 1, x + 1)) >>> second integral))+                   (deltaEncode 0.001 (repeat ()))+    in+	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]+loop_t14r = loop_t13r++loop_t15 :: [Double]+loop_t15 =+    let+	es = embed (loop (arr (\(_, x) -> (x + 1, x + 1))+                          >>> second integral+			  >>> identity))+                   (deltaEncode 0.001 (repeat ()))+    in+	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]+loop_t15r = loop_t13r++-- A generator for factorial:  The least-fixed point of this function is+-- the factorial function.++factGen f n = if (n==0) then 1 else n*f(n-1)++-- Can we use loop to construct a fixed point?+loop_t16 :: [Int]+loop_t16 = testSF1 (loop $ arr (\ (_,f) -> (f 4,factGen f)))+loop_t16r =+  [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24]++-- A simple loop test taken from MiniYampa:+-- This results in pulling on the fed-back output during evaluation, because+-- switch is strict in its input sample:+loop_t17 :: [Double]+loop_t17 = testSF1 (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x,noEvent)) >>> (iPre (25, noEvent)))+loop_t17r =+  [0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,+   16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0]++loop_trs =+    [ loop_t0  ~= loop_t0r,+      loop_t1  ~= loop_t1r,+      loop_t2  ~= loop_t2r,+      loop_t3  ~= loop_t3r,+      loop_t4  ~= loop_t4r,+      loop_t5  ~= loop_t5r,+      loop_t6  ~= loop_t6r,+      loop_t7  ~= loop_t7r,+      loop_t8  ~= loop_t8r,+      loop_t9  ~= loop_t9r,+      loop_t10 ~= loop_t10r,+      loop_t11 ~= loop_t11r,+      loop_t12 ~= loop_t12r,+      loop_t13 ~= loop_t13r,+      loop_t14 ~= loop_t14r,+      loop_t15 ~= loop_t15r,+      loop_t16 ~= loop_t16r,+      loop_t17 ~= loop_t17r+    ]++loop_tr = and loop_trs++loop_st0 = testSFSpaceLeak 2000000+			   (loop (second (iPre 0) >>> loop_acc))+loop_st0r = 9.999995e11++-- A simple loop test taken from MiniYampa:+-- This results in pulling on the fed-back output during evaluation, because+-- switch is strict in its input sample:+loop_st1 :: Double+loop_st1 = testSFSpaceLeak 2000000+             (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x + x + x + x + x + x + x,noEvent)) >>> (iPre (25, noEvent))) loop_st1r = 999999.5
tests/AFRPTestsLoopIntegral.hs view
@@ -1,104 +1,104 @@-{- $Id: AFRPTestsLoopIntegral.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsLoopIntegral				     *
-*       Purpose:        Test cases for loopIntegral			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsLoopIntegral (loopIntegral_tr, loopIntegral_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for loopIntegral
-------------------------------------------------------------------------------
-
--- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration.
--- Values as given by using exp directly:
--- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413
-loopIntegral_t0 =
-    let
-	es = embed (loopIntegral (arr (\(_, x) -> (x + 1, x + 1))))
-                   (deltaEncode 0.001 (repeat ()))
-    in
-	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
-loopIntegral_t0r :: [Double]
-loopIntegral_t0r = [1.0,2.71692,7.38167,20.05544,54.48911,148.04276]
-
-
--- Test case with a time varying signal transformer inside the loop.
--- Starting at position 0 [m], accelerate by 1.0 [m/s^2] until position
--- exceeds 2.0 [m]. Then accelerate by -1.0 [m/s^2] until position gets
--- below 0.0 [m]. Then accelerate at 1.0 [m/s^2] again. And so on.
-
-type Position = Double
-type Velocity = Double
-type Acceleration = Double
-
-posCntrl :: SF b Position
-posCntrl = loopIntegral posCntrlNR
-    where
-	posCntrlNR :: SF (b, Velocity) (Position, Acceleration)
-	posCntrlNR =
-	    arr snd			-- Get the velocity.
-	    >>> integral		-- This integral gives us the position.
-	    >>> arr (\x -> (x,x))
-	    >>>
-		(second $
-		    arr (\x -> (x,x))
-		    >>>
-			(first $
-			    arr (>=2.0)
-			    >>> edge
-			    >>> (arr (fmap (const (constant (-1.0))))))
-		    >>>
-			(second $
-			    arr (< 0.0)
-			    >>> edge
-			    >>> (arr (fmap (const (constant 1.0)))))
-		    >>> arr (\(e1,e2) -> e1 `lMerge` e2)
-		    >>> arr (\e -> ((), e))
-		    >>> rSwitch (constant 1.0))
-
-
-loopIntegral_t1 = take 250 (embed posCntrl (deltaEncode 0.1 (repeat ())))
-
--- Result only partially verified. But the sign of the acceleration changes
--- at roughly the right points.
-loopIntegral_t1r :: [Double]
-loopIntegral_t1r =
-    [0.0,0.0,0.01,0.03,0.06,0.1,0.15,0.21,0.28,0.36,0.45,0.55,0.66,0.78,0.91,
-     1.05,1.2,1.36,1.53,1.71,1.9,2.1,2.31,2.51,2.7,2.88,3.05,3.21,3.36,3.5,
-     3.63,3.75,3.86,3.96,4.05,4.13,4.2,4.26,4.31,4.35,4.38,4.4,4.41,4.41,4.4,
-     4.38,4.35,4.31,4.26,4.2,4.13,4.05,3.96,3.86,3.75,3.63,3.5,3.36,3.21,3.05,
-     2.88,2.7,2.51,2.31,2.1,1.88,1.65,1.41,1.16,0.9,0.63,0.35,0.06,-0.24,
-     -0.55,-0.85,-1.14,-1.42,-1.69,-1.95,-2.2,-2.44,-2.67,-2.89,-3.1,-3.3,
-     -3.49,-3.67,-3.84,-4.0,-4.15,-4.29,-4.42,-4.54,-4.65,-4.75,-4.84,-4.92,
-     -4.99,-5.05,-5.1,-5.14,-5.17,-5.19,-5.2,-5.2,-5.19,-5.17,-5.14,-5.1,
-     -5.05,-4.99,-4.92,-4.84,-4.75,-4.65,-4.54,-4.42,-4.29,-4.15,-4.0,-3.84,
-     -3.67,-3.49,-3.3,-3.1,-2.89,-2.67,-2.44,-2.2,-1.95,-1.69,-1.42,-1.14,
-     -0.85,-0.55,-0.24,0.08,0.41,0.75,1.1,1.46,1.83,2.21,2.6,2.98,3.35,3.71,
-     4.06,4.4,4.73,5.05,5.36,5.66,5.95,6.23,6.5,6.76,7.01,7.25,7.48,7.7,7.91,
-     8.11,8.3,8.48,8.65,8.81,8.96,9.1,9.23,9.35,9.46,9.56,9.65,9.73,9.8,9.86,
-     9.91,9.95,9.98,10.0,10.01,10.01,10.0,9.98,9.95,9.91,9.86,9.8,9.73,9.65,
-     9.56,9.46,9.35,9.23,9.1,8.96,8.81,8.65,8.48,8.3,8.11,7.91,7.7,7.48,7.25,
-     7.01,6.76,6.5,6.23,5.95,5.66,5.36,5.05,4.73,4.4,4.06,3.71,3.35,2.98,2.6,
-     2.21,1.81,1.4,0.98,0.55,0.11,-0.34,-0.80,-1.25,-1.69,-2.12,-2.54,-2.95,
-     -3.35,-3.74,-4.12,-4.49,-4.85,-5.2,-5.54,-5.87,-6.19,-6.5,-6.8,-7.09,
-     -7.37,-7.64,-7.9]
-
-
-loopIntegral_trs =
-    [ loopIntegral_t0 ~= loopIntegral_t0r,
-      loopIntegral_t1 ~= loopIntegral_t1r
-    ]
-
-loopIntegral_tr = and loopIntegral_trs
+{- $Id: AFRPTestsLoopIntegral.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsLoopIntegral				     *+*       Purpose:        Test cases for loopIntegral			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsLoopIntegral (loopIntegral_tr, loopIntegral_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for loopIntegral+------------------------------------------------------------------------------++-- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration.+-- Values as given by using exp directly:+-- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413+loopIntegral_t0 =+    let+	es = embed (loopIntegral (arr (\(_, x) -> (x + 1, x + 1))))+                   (deltaEncode 0.001 (repeat ()))+    in+	[es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]+loopIntegral_t0r :: [Double]+loopIntegral_t0r = [1.0,2.71692,7.38167,20.05544,54.48911,148.04276]+++-- Test case with a time varying signal transformer inside the loop.+-- Starting at position 0 [m], accelerate by 1.0 [m/s^2] until position+-- exceeds 2.0 [m]. Then accelerate by -1.0 [m/s^2] until position gets+-- below 0.0 [m]. Then accelerate at 1.0 [m/s^2] again. And so on.++type Position = Double+type Velocity = Double+type Acceleration = Double++posCntrl :: SF b Position+posCntrl = loopIntegral posCntrlNR+    where+	posCntrlNR :: SF (b, Velocity) (Position, Acceleration)+	posCntrlNR =+	    arr snd			-- Get the velocity.+	    >>> integral		-- This integral gives us the position.+	    >>> arr (\x -> (x,x))+	    >>>+		(second $+		    arr (\x -> (x,x))+		    >>>+			(first $+			    arr (>=2.0)+			    >>> edge+			    >>> (arr (fmap (const (constant (-1.0))))))+		    >>>+			(second $+			    arr (< 0.0)+			    >>> edge+			    >>> (arr (fmap (const (constant 1.0)))))+		    >>> arr (\(e1,e2) -> e1 `lMerge` e2)+		    >>> arr (\e -> ((), e))+		    >>> rSwitch (constant 1.0))+++loopIntegral_t1 = take 250 (embed posCntrl (deltaEncode 0.1 (repeat ())))++-- Result only partially verified. But the sign of the acceleration changes+-- at roughly the right points.+loopIntegral_t1r :: [Double]+loopIntegral_t1r =+    [0.0,0.0,0.01,0.03,0.06,0.1,0.15,0.21,0.28,0.36,0.45,0.55,0.66,0.78,0.91,+     1.05,1.2,1.36,1.53,1.71,1.9,2.1,2.31,2.51,2.7,2.88,3.05,3.21,3.36,3.5,+     3.63,3.75,3.86,3.96,4.05,4.13,4.2,4.26,4.31,4.35,4.38,4.4,4.41,4.41,4.4,+     4.38,4.35,4.31,4.26,4.2,4.13,4.05,3.96,3.86,3.75,3.63,3.5,3.36,3.21,3.05,+     2.88,2.7,2.51,2.31,2.1,1.88,1.65,1.41,1.16,0.9,0.63,0.35,0.06,-0.24,+     -0.55,-0.85,-1.14,-1.42,-1.69,-1.95,-2.2,-2.44,-2.67,-2.89,-3.1,-3.3,+     -3.49,-3.67,-3.84,-4.0,-4.15,-4.29,-4.42,-4.54,-4.65,-4.75,-4.84,-4.92,+     -4.99,-5.05,-5.1,-5.14,-5.17,-5.19,-5.2,-5.2,-5.19,-5.17,-5.14,-5.1,+     -5.05,-4.99,-4.92,-4.84,-4.75,-4.65,-4.54,-4.42,-4.29,-4.15,-4.0,-3.84,+     -3.67,-3.49,-3.3,-3.1,-2.89,-2.67,-2.44,-2.2,-1.95,-1.69,-1.42,-1.14,+     -0.85,-0.55,-0.24,0.08,0.41,0.75,1.1,1.46,1.83,2.21,2.6,2.98,3.35,3.71,+     4.06,4.4,4.73,5.05,5.36,5.66,5.95,6.23,6.5,6.76,7.01,7.25,7.48,7.7,7.91,+     8.11,8.3,8.48,8.65,8.81,8.96,9.1,9.23,9.35,9.46,9.56,9.65,9.73,9.8,9.86,+     9.91,9.95,9.98,10.0,10.01,10.01,10.0,9.98,9.95,9.91,9.86,9.8,9.73,9.65,+     9.56,9.46,9.35,9.23,9.1,8.96,8.81,8.65,8.48,8.3,8.11,7.91,7.7,7.48,7.25,+     7.01,6.76,6.5,6.23,5.95,5.66,5.36,5.05,4.73,4.4,4.06,3.71,3.35,2.98,2.6,+     2.21,1.81,1.4,0.98,0.55,0.11,-0.34,-0.80,-1.25,-1.69,-2.12,-2.54,-2.95,+     -3.35,-3.74,-4.12,-4.49,-4.85,-5.2,-5.54,-5.87,-6.19,-6.5,-6.8,-7.09,+     -7.37,-7.64,-7.9]+++loopIntegral_trs =+    [ loopIntegral_t0 ~= loopIntegral_t0r,+      loopIntegral_t1 ~= loopIntegral_t1r+    ]++loopIntegral_tr = and loopIntegral_trs
tests/AFRPTestsLoopLaws.hs view
@@ -1,107 +1,107 @@-{- $Id: AFRPTestsLoopLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsLoopLaws                                    *
-*       Purpose:        Test cases based on the arrow laws for loop	     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsLoopLaws (looplaws_trs, looplaws_tr) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases based on the arrow laws for loop
-------------------------------------------------------------------------------
-
--- For a description of the laws, see Ross Paterson: Embedding a Class of
--- Domain-Specific Languages in a Functional Language.
--- Only a very rudimentary sanity check. Obviously not intended to "prove"
--- this implementation indeed do respect the laws.
-
-simple_loop :: ((a,c) -> (b,c)) -> (a -> b)
-simple_loop f a = b
-    where
-	(b, c) = f (a, c)
-
-
--- Left tightening
-looplaws_t0_f = second integral >>> arr swap
-looplaws_t0_h :: Fractional a => SF a a
-looplaws_t0_h = arr (+10.0)
-looplaws_t0_lhs :: [Double]
-looplaws_t0_lhs = testSF1 (loop (first looplaws_t0_h >>> looplaws_t0_f))
-looplaws_t0_rhs :: [Double]
-looplaws_t0_rhs = testSF1 (looplaws_t0_h >>> loop looplaws_t0_f)
-
-
--- Right tightening
-looplaws_t1_f = second integral >>> arr swap
-looplaws_t1_h :: Fractional a => SF a a
-looplaws_t1_h = arr (+10.0)
-looplaws_t1_lhs :: [Double]
-looplaws_t1_lhs = testSF1 (loop (looplaws_t1_f >>> first looplaws_t1_h))
-looplaws_t1_rhs :: [Double]
-looplaws_t1_rhs = testSF1 (loop looplaws_t1_f >>> looplaws_t1_h)
-
-
--- Sliding
--- Used to work with only signature t2_f :: Fractional a -> SF a a
-looplaws_t2_f :: SF (Double, Double) (Double, Double)
-looplaws_t2_f = integral
-looplaws_t2_k = fun_prod id (+42.0)
-looplaws_t2_lhs :: [Double]
-looplaws_t2_lhs = testSF1 (loop (looplaws_t2_f >>> arr looplaws_t2_k))
-looplaws_t2_rhs :: [Double]
-looplaws_t2_rhs = testSF1 (loop (arr looplaws_t2_k >>> looplaws_t2_f))
-
-
--- Vanishing
--- The lazy pattern matching (~) is necessary to avoid a black hole in the
--- RHS due to premature forcing of tuples. As far as I can tell, loop is
--- as lazy as it can be, and this problem could not have been solved by
--- "fixing" the loop definition.
-looplaws_t3_f = second integral
-		>>> first (arr swap)
-		>>> arr (\ ~((a,b),c) -> ((a,c),b))
-looplaws_t3_lhs :: [Double]
-looplaws_t3_lhs = testSF1 (loop (loop looplaws_t3_f))
-looplaws_t3_rhs :: [Double]
-looplaws_t3_rhs = testSF1 (loop (arr assoc_inv >>> looplaws_t3_f >>>arr assoc))
-
-
--- Superposing
-looplaws_t4_f = second integral >>> arr swap
-looplaws_t4_lhs :: [(Double,Double)]
-looplaws_t4_lhs = testSF1 (arr dup >>> (second (loop looplaws_t4_f)))
-looplaws_t4_rhs :: [(Double, Double)]
-looplaws_t4_rhs = testSF1 (arr dup >>> (loop (arr assoc
-				        >>> second looplaws_t4_f
-				        >>> arr assoc_inv)))
-
-
--- Extension
-looplaws_t5_f = \(a,c) -> (take 5 c, a : c)
-looplaws_t5_lhs :: [[Double]]
-looplaws_t5_lhs = testSF1 (loop (arr looplaws_t5_f))
-looplaws_t5_rhs :: [[Double]]
-looplaws_t5_rhs = testSF1 (arr (simple_loop looplaws_t5_f))
-
-
-looplaws_trs =
-    [ looplaws_t0_lhs  ~= looplaws_t0_rhs,
-      looplaws_t1_lhs  ~= looplaws_t1_rhs,
-      looplaws_t2_lhs  ~= looplaws_t2_rhs,
-      looplaws_t3_lhs  ~= looplaws_t3_rhs,
-      looplaws_t4_lhs  ~= looplaws_t4_rhs,
-      looplaws_t5_lhs  ~= looplaws_t5_rhs
-    ]
-
-looplaws_tr = and looplaws_trs
+{- $Id: AFRPTestsLoopLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsLoopLaws                                    *+*       Purpose:        Test cases based on the arrow laws for loop	     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsLoopLaws (looplaws_trs, looplaws_tr) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases based on the arrow laws for loop+------------------------------------------------------------------------------++-- For a description of the laws, see Ross Paterson: Embedding a Class of+-- Domain-Specific Languages in a Functional Language.+-- Only a very rudimentary sanity check. Obviously not intended to "prove"+-- this implementation indeed do respect the laws.++simple_loop :: ((a,c) -> (b,c)) -> (a -> b)+simple_loop f a = b+    where+	(b, c) = f (a, c)+++-- Left tightening+looplaws_t0_f = second integral >>> arr swap+looplaws_t0_h :: Fractional a => SF a a+looplaws_t0_h = arr (+10.0)+looplaws_t0_lhs :: [Double]+looplaws_t0_lhs = testSF1 (loop (first looplaws_t0_h >>> looplaws_t0_f))+looplaws_t0_rhs :: [Double]+looplaws_t0_rhs = testSF1 (looplaws_t0_h >>> loop looplaws_t0_f)+++-- Right tightening+looplaws_t1_f = second integral >>> arr swap+looplaws_t1_h :: Fractional a => SF a a+looplaws_t1_h = arr (+10.0)+looplaws_t1_lhs :: [Double]+looplaws_t1_lhs = testSF1 (loop (looplaws_t1_f >>> first looplaws_t1_h))+looplaws_t1_rhs :: [Double]+looplaws_t1_rhs = testSF1 (loop looplaws_t1_f >>> looplaws_t1_h)+++-- Sliding+-- Used to work with only signature t2_f :: Fractional a -> SF a a+looplaws_t2_f :: SF (Double, Double) (Double, Double)+looplaws_t2_f = integral+looplaws_t2_k = fun_prod id (+42.0)+looplaws_t2_lhs :: [Double]+looplaws_t2_lhs = testSF1 (loop (looplaws_t2_f >>> arr looplaws_t2_k))+looplaws_t2_rhs :: [Double]+looplaws_t2_rhs = testSF1 (loop (arr looplaws_t2_k >>> looplaws_t2_f))+++-- Vanishing+-- The lazy pattern matching (~) is necessary to avoid a black hole in the+-- RHS due to premature forcing of tuples. As far as I can tell, loop is+-- as lazy as it can be, and this problem could not have been solved by+-- "fixing" the loop definition.+looplaws_t3_f = second integral+		>>> first (arr swap)+		>>> arr (\ ~((a,b),c) -> ((a,c),b))+looplaws_t3_lhs :: [Double]+looplaws_t3_lhs = testSF1 (loop (loop looplaws_t3_f))+looplaws_t3_rhs :: [Double]+looplaws_t3_rhs = testSF1 (loop (arr assoc_inv >>> looplaws_t3_f >>>arr assoc))+++-- Superposing+looplaws_t4_f = second integral >>> arr swap+looplaws_t4_lhs :: [(Double,Double)]+looplaws_t4_lhs = testSF1 (arr dup >>> (second (loop looplaws_t4_f)))+looplaws_t4_rhs :: [(Double, Double)]+looplaws_t4_rhs = testSF1 (arr dup >>> (loop (arr assoc+				        >>> second looplaws_t4_f+				        >>> arr assoc_inv)))+++-- Extension+looplaws_t5_f = \(a,c) -> (take 5 c, a : c)+looplaws_t5_lhs :: [[Double]]+looplaws_t5_lhs = testSF1 (loop (arr looplaws_t5_f))+looplaws_t5_rhs :: [[Double]]+looplaws_t5_rhs = testSF1 (arr (simple_loop looplaws_t5_f))+++looplaws_trs =+    [ looplaws_t0_lhs  ~= looplaws_t0_rhs,+      looplaws_t1_lhs  ~= looplaws_t1_rhs,+      looplaws_t2_lhs  ~= looplaws_t2_rhs,+      looplaws_t3_lhs  ~= looplaws_t3_rhs,+      looplaws_t4_lhs  ~= looplaws_t4_rhs,+      looplaws_t5_lhs  ~= looplaws_t5_rhs+    ]++looplaws_tr = and looplaws_trs
tests/AFRPTestsLoopPre.hs view
@@ -1,62 +1,62 @@-{- $Id: AFRPTestsLoopPre.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsLoopPre				     *
-*       Purpose:        Test cases for loopPre				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsLoopPre (loopPre_tr, loopPre_trs) where
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for loopPre
-------------------------------------------------------------------------------
-
-loop_acc :: SF (Double, Double) (Double, Double)
-loop_acc = arr (\(x, y)->(x+y, x+y))
-
--- This kind of test will fail for infinitesimal delay!
-loopPre_t0 = testSF1 (loopPre 0 loop_acc)
-loopPre_t0r =
-    [0.0,1.0,3.0,6.0,10.0,15.0,21.0,28.0,36.0,45.0,55.0,66.0,78.0,91.0,
-     105.0,120.0,136.0,153.0,171.0,190.0,210.0,231.0,253.0,276.0,300.0]
-
-loopPre_t1 = testSF2 (loopPre 0 loop_acc)
-loopPre_t1r =
-    [0.0,0.0,0.0,0.0,0.0,1.0,2.0,3.0,4.0,5.0,7.0,9.0,11.0,13.0,15.0,18.0,
-     21.0,24.0,27.0,30.0,34.0,38.0,42.0,46.0,50.0]
-
--- This kind of test will fail for infinitesimal delay!
-loopPre_t2 = testSF1 (loopPre False (arr (dup . not . snd)))
-loopPre_t2r =
-    [True,False,True,False,True,False,True,False,True,False,True,False,
-     True,False,True,False,True,False,True,False,True,False,True,False,True]
-
-loopPre_t3 = testSF1 (loopPre 0 (first localTime))
-loopPre_t3r =
-    [0.0,0.25,0.5,0.75,1.0,1.25,1.5,1.75,2.0,2.25,2.5,2.75,3.0,3.25,3.5,3.75,
-     4.0,4.25,4.5,4.75,5.0,5.25,5.5,5.75,6.0]
-
-loopPre_t4 = testSF1 (loopPre 0 (first localTime >>> loop_acc))
-loopPre_t4r =
-    [0.0,0.25,0.75,1.5,2.5,3.75,5.25,7.0,9.0,11.25,13.75,16.5,19.5,22.75,
-     26.25,30.0,34.0,38.25,42.75,47.5,52.5,57.75,63.25,69.0,75.0]
-
-loopPre_trs =
-    [ loopPre_t0 ~= loopPre_t0r,
-      loopPre_t1 ~= loopPre_t1r,
-      loopPre_t2 ~= loopPre_t2r,
-      loopPre_t3 ~= loopPre_t3r,
-      loopPre_t4 ~= loopPre_t4r
-    ]
-
-loopPre_tr = and loopPre_trs
+{- $Id: AFRPTestsLoopPre.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsLoopPre				     *+*       Purpose:        Test cases for loopPre				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsLoopPre (loopPre_tr, loopPre_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for loopPre+------------------------------------------------------------------------------++loop_acc :: SF (Double, Double) (Double, Double)+loop_acc = arr (\(x, y)->(x+y, x+y))++-- This kind of test will fail for infinitesimal delay!+loopPre_t0 = testSF1 (loopPre 0 loop_acc)+loopPre_t0r =+    [0.0,1.0,3.0,6.0,10.0,15.0,21.0,28.0,36.0,45.0,55.0,66.0,78.0,91.0,+     105.0,120.0,136.0,153.0,171.0,190.0,210.0,231.0,253.0,276.0,300.0]++loopPre_t1 = testSF2 (loopPre 0 loop_acc)+loopPre_t1r =+    [0.0,0.0,0.0,0.0,0.0,1.0,2.0,3.0,4.0,5.0,7.0,9.0,11.0,13.0,15.0,18.0,+     21.0,24.0,27.0,30.0,34.0,38.0,42.0,46.0,50.0]++-- This kind of test will fail for infinitesimal delay!+loopPre_t2 = testSF1 (loopPre False (arr (dup . not . snd)))+loopPre_t2r =+    [True,False,True,False,True,False,True,False,True,False,True,False,+     True,False,True,False,True,False,True,False,True,False,True,False,True]++loopPre_t3 = testSF1 (loopPre 0 (first localTime))+loopPre_t3r =+    [0.0,0.25,0.5,0.75,1.0,1.25,1.5,1.75,2.0,2.25,2.5,2.75,3.0,3.25,3.5,3.75,+     4.0,4.25,4.5,4.75,5.0,5.25,5.5,5.75,6.0]++loopPre_t4 = testSF1 (loopPre 0 (first localTime >>> loop_acc))+loopPre_t4r =+    [0.0,0.25,0.75,1.5,2.5,3.75,5.25,7.0,9.0,11.25,13.75,16.5,19.5,22.75,+     26.25,30.0,34.0,38.25,42.75,47.5,52.5,57.75,63.25,69.0,75.0]++loopPre_trs =+    [ loopPre_t0 ~= loopPre_t0r,+      loopPre_t1 ~= loopPre_t1r,+      loopPre_t2 ~= loopPre_t2r,+      loopPre_t3 ~= loopPre_t3r,+      loopPre_t4 ~= loopPre_t4r+    ]++loopPre_tr = and loopPre_trs
tests/AFRPTestsPSwitch.hs view
@@ -1,325 +1,325 @@-{- $Id: AFRPTestsPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsPSwitch				     *
-*       Purpose:        Test cases for pSwitchB and dpSwitchB		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsPSwitch (
-    pswitch_tr,
-    pswitch_trs,
-    pswitch_st0,
-    pswitch_st0r,
-    pswitch_st1,
-    pswitch_st1r
-) where
-
-import List (findIndex)
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for pSwitchB and dpSwitchB
-------------------------------------------------------------------------------
-
-pswitch_inp1 = deltaEncode 0.1 [0.0, 0.5 ..]
-
-whenFstGE :: Ord a => a -> c -> SF (a, b) (Event c)
-whenFstGE a c = arr fst >>> arr (>= a) >>> edge >>> arr (`tag` c)
-
-pswitch_t0 :: [[Double]]
-pswitch_t0 = take 20 $ embed sf pswitch_inp1
-    where
-	sf =
-	    pSwitchB [] (whenFstGE 1.25 10.0) $ \sfs x ->
-	    pSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->
-	    pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0) $ \sfs x->
-	    pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 7.25 20.0) $ \sfs _->
-	    parB (take 2 sfs)
-
-pswitch_t0r =
-    [[],			-- 0.0
-     [],			-- 0.5
-     [],			-- 1.0
-     [0.0],			-- 1.5
-     [0.15],			-- 2.0
-     [0.35],			-- 2.5
-     [0.60],			-- 3.0
-     [0.90],			-- 3.5
-     [10.00, 1.25],		-- 4.0
-     [10.40, 1.65],		-- 4.5
-     [10.85, 2.10],		-- 5.0
-     [20.00, 11.35, 2.60],	-- 5.5
-     [20.55, 11.90, 3.15],	-- 6.0
-     [21.15, 12.50, 3.75],	-- 6.5
-     [21.80, 13.15, 4.40],	-- 7.0
-     [22.50, 13.85],		-- 7.5
-     [23.25, 14.60],		-- 8.0
-     [24.05, 15.40],		-- 8.5
-     [24.90, 16.25],		-- 9.0
-     [25.80, 17.15]]		-- 9.5
-
-
-pswitch_t1 :: [[Double]]
-pswitch_t1 = take 20 $ embed sf pswitch_inp1
-    where
-	sf =
-	    dpSwitchB [] (whenFstGE 1.25 10.0) $ \sfs x ->
-	    dpSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->
-	    dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0)$ \sfs x->
-	    dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 7.25 20.0)$ \sfs _->
-	    parB (take 2 sfs)
-
-
-pswitch_t1r =
-    [[],			-- 0.0
-     [],			-- 0.5
-     [],			-- 1.0
-     [],			-- 1.5
-     [0.15],			-- 2.0
-     [0.35],			-- 2.5
-     [0.60],			-- 3.0
-     [0.90],			-- 3.5
-     [1.25],			-- 4.0
-     [10.40, 1.65],		-- 4.5
-     [10.85, 2.10],		-- 5.0
-     [11.35, 2.60],		-- 5.5
-     [20.55, 11.90, 3.15],	-- 6.0
-     [21.15, 12.50, 3.75],	-- 6.5
-     [21.80, 13.15, 4.40],	-- 7.0
-     [22.50, 13.85, 5.10],	-- 7.5
-     [23.25, 14.60],		-- 8.0
-     [24.05, 15.40],		-- 8.5
-     [24.90, 16.25],		-- 9.0
-     [25.80, 17.15]]		-- 9.5
-
-
-pswitch_t2 :: [[Double]]
-pswitch_t2 = take 20 $ embed sf pswitch_inp1
-    where
-	sf =
-	    pSwitchB [] (now 10.0) $ \sfs x ->
-	    pSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->
-	    pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0) $ \sfs x->
-	    pSwitchB ((integral>>>arr(+x)):sfs)(now 20.0) $ \sfs _->
-	    parB (take 2 sfs)
-
-pswitch_t2r =
-    [[0.00],		-- 0.0
-     [0.00],		-- 0.5
-     [0.05],		-- 1.0
-     [0.15],		-- 1.5
-     [0.30],		-- 2.0
-     [0.50],		-- 2.5
-     [0.75],		-- 3.0
-     [1.05],		-- 3.5
-     [10.00,  1.40],	-- 4.0
-     [10.40,  1.80],	-- 4.5
-     [10.85,  2.25],	-- 5.0
-     [20.00, 11.35],	-- 5.5
-     [20.55, 11.90],	-- 6.0
-     [21.15, 12.50],	-- 6.5
-     [21.80, 13.15],	-- 7.0
-     [22.50, 13.85],	-- 7.5
-     [23.25, 14.60],	-- 8.0
-     [24.05, 15.40],	-- 8.5
-     [24.90, 16.25],	-- 9.0
-     [25.80, 17.15]]	-- 9.5
-
-
-pswitch_t3 :: [[Double]]
-pswitch_t3 = take 20 $ embed sf pswitch_inp1
-    where
-	sf =
-	    dpSwitchB [] (now 10.0) $ \sfs x ->
-	    dpSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->
-	    dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0)$ \sfs x->
-	    dpSwitchB ((integral>>>arr(+x)):sfs) (now 20.0) $ \sfs _->
-	    parB (take 2 sfs)
-
-pswitch_t3r =
-    [[],		-- 0.0
-     [0.00],		-- 0.5
-     [0.05],		-- 1.0
-     [0.15],		-- 1.5
-     [0.30],		-- 2.0
-     [0.50],		-- 2.5
-     [0.75],		-- 3.0
-     [1.05],		-- 3.5
-     [1.40],		-- 4.0
-     [10.40,  1.80],	-- 4.5
-     [10.85,  2.25],	-- 5.0
-     [11.35,  2.75],	-- 5.5
-     [20.55, 11.90],	-- 6.0
-     [21.15, 12.50],	-- 6.5
-     [21.80, 13.15],	-- 7.0
-     [22.50, 13.85],	-- 7.5
-     [23.25, 14.60],	-- 8.0
-     [24.05, 15.40],	-- 8.5
-     [24.90, 16.25],	-- 9.0
-     [25.80, 17.15]]	-- 9.5
-
-
--- Starts three "ramps" with different phase. As soon as one exceeds a
--- threshold, it's restarted, while the others are left alone. The
--- observaton of the output is done via the loop (rather than the directly
--- from the outputs of the signal functions in the collection), thus the
--- use of a delayed switch is essential.
-
-pswitch_ramp :: Double -> SF a Double
-pswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase)
-
--- We assume that only one signal function will reach the limit at a time.
-pswitch_limit :: Double -> SF ((a, [Double]), b) (Event Int)
-pswitch_limit x = arr (snd . fst) >>> arr (findIndex (>=x)) >>> edgeJust
-
-pswitch_t4 :: [[Double]]
-pswitch_t4 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ()))
-    where
-        sf :: SF (a, [Double]) ([Double],[Double])
-	sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]
-        	       (pswitch_limit 2.99)
-		       pswitch_t4rec
-	     >>> arr dup
-        
-pswitch_t4rec :: [SF (a, [Double]) Double]
-                 -> Int
-                 -> SF (a, [Double]) [Double]
-pswitch_t4rec sfs n =
-    dpSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs)
-	      (pswitch_limit 2.99)
-	      pswitch_t4rec
-
-pswitch_t4r =
-    [[0.0, 1.0, 2.0],
-     [0.2, 1.2, 2.2],
-     [0.4, 1.4, 2.4],
-     [0.6, 1.6, 2.6],
-     [0.8, 1.8, 2.8],
-     [1.0, 2.0, 3.0],
-     [1.2, 2.2, 0.2],
-     [1.4, 2.4, 0.4],
-     [1.6, 2.6, 0.6],
-     [1.8, 2.8, 0.8],
-     [2.0, 3.0, 1.0],
-     [2.2, 0.2, 1.2],
-     [2.4, 0.4, 1.4],
-     [2.6, 0.6, 1.6],
-     [2.8, 0.8, 1.8],
-     [3.0, 1.0, 2.0],
-     [0.2, 1.2, 2.2],
-     [0.4, 1.4, 2.4],
-     [0.6, 1.6, 2.6],
-     [0.8, 1.8, 2.8],
-     [1.0, 2.0, 3.0],
-     [1.2, 2.2, 0.2],
-     [1.4, 2.4, 0.4],
-     [1.6, 2.6, 0.6],
-     [1.8, 2.8, 0.8],
-     [2.0, 3.0, 1.0],
-     [2.2, 0.2, 1.2],
-     [2.4, 0.4, 1.4],
-     [2.6, 0.6, 1.6],
-     [2.8, 0.8, 1.8]]
-
-
--- Variation of the test above, with direct observation (not via loop) and
--- immediate switch.
-
--- We assume that only one signal function will reach the limit at a time.
-pswitch_limit2 :: Double -> SF (a, [Double]) (Event Int)
-pswitch_limit2 x = arr snd >>> arr (findIndex (>=x)) >>> edgeJust
-
-pswitch_t5 :: [([Double], Double)]
-pswitch_t5 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ()))
-    where
-        sf :: SF (a, [Double]) (([Double], Double), [Double])
-	sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]
-        	        (pswitch_limit2 2.99)
-		        pswitch_t5rec)
-	      &&& (arr snd >>> arr sum))
-	     >>> arr (\(xs, y) -> ((xs, y), xs))
-        
-pswitch_t5rec :: [SF (a, [Double]) Double]
-                 -> Int
-                 -> SF (a, [Double]) [Double]
-pswitch_t5rec sfs n =
-    pSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs)
-	     (pswitch_limit2 2.99)
-	     pswitch_t5rec
-
-pswitch_t5r =
-    [([0.0, 1.0, 2.0], 3.0),
-     ([0.2, 1.2, 2.2], 3.6),
-     ([0.4, 1.4, 2.4], 4.2),
-     ([0.6, 1.6, 2.6], 4.8),
-     ([0.8, 1.8, 2.8], 5.4),
-     ([1.0, 2.0, 0.0], 3.0),
-     ([1.2, 2.2, 0.2], 3.6),
-     ([1.4, 2.4, 0.4], 4.2),
-     ([1.6, 2.6, 0.6], 4.8),
-     ([1.8, 2.8, 0.8], 5.4),
-     ([2.0, 0.0, 1.0], 3.0),
-     ([2.2, 0.2, 1.2], 3.6),
-     ([2.4, 0.4, 1.4], 4.2),
-     ([2.6, 0.6, 1.6], 4.8),
-     ([2.8, 0.8, 1.8], 5.4),
-     ([0.0, 1.0, 2.0], 3.0),
-     ([0.2, 1.2, 2.2], 3.6),
-     ([0.4, 1.4, 2.4], 4.2),
-     ([0.6, 1.6, 2.6], 4.8),
-     ([0.8, 1.8, 2.8], 5.4),
-     ([1.0, 2.0, 0.0], 3.0),
-     ([1.2, 2.2, 0.2], 3.6),
-     ([1.4, 2.4, 0.4], 4.2),
-     ([1.6, 2.6, 0.6], 4.8),
-     ([1.8, 2.8, 0.8], 5.4),
-     ([2.0, 0.0, 1.0], 3.0),
-     ([2.2, 0.2, 1.2], 3.6),
-     ([2.4, 0.4, 1.4], 4.2),
-     ([2.6, 0.6, 1.6], 4.8),
-     ([2.8, 0.8, 1.8], 5.4)]
-
-
-pswitch_trs =
-    [ pswitch_t0 ~= pswitch_t0r,
-      pswitch_t1 ~= pswitch_t1r,
-      pswitch_t2 ~= pswitch_t2r,
-      pswitch_t3 ~= pswitch_t3r,
-      pswitch_t4 ~= pswitch_t4r,
-      pswitch_t5 ~= pswitch_t5r
-    ]
-
-pswitch_tr = and pswitch_trs
-
-
-pswitch_st0 = testSFSpaceLeak 1000000 (loop sf)
-    where
-        sf :: SF (a, [Double]) ([Double],[Double])
-	sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]
-        	       (pswitch_limit 2.99)
-		       pswitch_t4rec
-	     >>> arr dup
-
-pswitch_st0r = [1.5,2.5,0.5]
-
-
-pswitch_st1 = testSFSpaceLeak 1000000 (loop sf)
-    where
-        sf :: SF (a, [Double]) (([Double], Double), [Double])
-	sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]
-        	        (pswitch_limit2 2.99)
-		        pswitch_t5rec)
-	      &&& (arr snd >>> arr sum))
-	     >>> arr (\(xs, y) -> ((xs, y), xs))
-
-pswitch_st1r = ([1.5,2.5,0.5],4.5)
+{- $Id: AFRPTestsPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsPSwitch				     *+*       Purpose:        Test cases for pSwitchB and dpSwitchB		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsPSwitch (+    pswitch_tr,+    pswitch_trs,+    pswitch_st0,+    pswitch_st0r,+    pswitch_st1,+    pswitch_st1r+) where++import Data.List (findIndex)++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for pSwitchB and dpSwitchB+------------------------------------------------------------------------------++pswitch_inp1 = deltaEncode 0.1 [0.0, 0.5 ..]++whenFstGE :: Ord a => a -> c -> SF (a, b) (Event c)+whenFstGE a c = arr fst >>> arr (>= a) >>> edge >>> arr (`tag` c)++pswitch_t0 :: [[Double]]+pswitch_t0 = take 20 $ embed sf pswitch_inp1+    where+	sf =+	    pSwitchB [] (whenFstGE 1.25 10.0) $ \sfs x ->+	    pSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->+	    pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0) $ \sfs x->+	    pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 7.25 20.0) $ \sfs _->+	    parB (take 2 sfs)++pswitch_t0r =+    [[],			-- 0.0+     [],			-- 0.5+     [],			-- 1.0+     [0.0],			-- 1.5+     [0.15],			-- 2.0+     [0.35],			-- 2.5+     [0.60],			-- 3.0+     [0.90],			-- 3.5+     [10.00, 1.25],		-- 4.0+     [10.40, 1.65],		-- 4.5+     [10.85, 2.10],		-- 5.0+     [20.00, 11.35, 2.60],	-- 5.5+     [20.55, 11.90, 3.15],	-- 6.0+     [21.15, 12.50, 3.75],	-- 6.5+     [21.80, 13.15, 4.40],	-- 7.0+     [22.50, 13.85],		-- 7.5+     [23.25, 14.60],		-- 8.0+     [24.05, 15.40],		-- 8.5+     [24.90, 16.25],		-- 9.0+     [25.80, 17.15]]		-- 9.5+++pswitch_t1 :: [[Double]]+pswitch_t1 = take 20 $ embed sf pswitch_inp1+    where+	sf =+	    dpSwitchB [] (whenFstGE 1.25 10.0) $ \sfs x ->+	    dpSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->+	    dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0)$ \sfs x->+	    dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 7.25 20.0)$ \sfs _->+	    parB (take 2 sfs)+++pswitch_t1r =+    [[],			-- 0.0+     [],			-- 0.5+     [],			-- 1.0+     [],			-- 1.5+     [0.15],			-- 2.0+     [0.35],			-- 2.5+     [0.60],			-- 3.0+     [0.90],			-- 3.5+     [1.25],			-- 4.0+     [10.40, 1.65],		-- 4.5+     [10.85, 2.10],		-- 5.0+     [11.35, 2.60],		-- 5.5+     [20.55, 11.90, 3.15],	-- 6.0+     [21.15, 12.50, 3.75],	-- 6.5+     [21.80, 13.15, 4.40],	-- 7.0+     [22.50, 13.85, 5.10],	-- 7.5+     [23.25, 14.60],		-- 8.0+     [24.05, 15.40],		-- 8.5+     [24.90, 16.25],		-- 9.0+     [25.80, 17.15]]		-- 9.5+++pswitch_t2 :: [[Double]]+pswitch_t2 = take 20 $ embed sf pswitch_inp1+    where+	sf =+	    pSwitchB [] (now 10.0) $ \sfs x ->+	    pSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->+	    pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0) $ \sfs x->+	    pSwitchB ((integral>>>arr(+x)):sfs)(now 20.0) $ \sfs _->+	    parB (take 2 sfs)++pswitch_t2r =+    [[0.00],		-- 0.0+     [0.00],		-- 0.5+     [0.05],		-- 1.0+     [0.15],		-- 1.5+     [0.30],		-- 2.0+     [0.50],		-- 2.5+     [0.75],		-- 3.0+     [1.05],		-- 3.5+     [10.00,  1.40],	-- 4.0+     [10.40,  1.80],	-- 4.5+     [10.85,  2.25],	-- 5.0+     [20.00, 11.35],	-- 5.5+     [20.55, 11.90],	-- 6.0+     [21.15, 12.50],	-- 6.5+     [21.80, 13.15],	-- 7.0+     [22.50, 13.85],	-- 7.5+     [23.25, 14.60],	-- 8.0+     [24.05, 15.40],	-- 8.5+     [24.90, 16.25],	-- 9.0+     [25.80, 17.15]]	-- 9.5+++pswitch_t3 :: [[Double]]+pswitch_t3 = take 20 $ embed sf pswitch_inp1+    where+	sf =+	    dpSwitchB [] (now 10.0) $ \sfs x ->+	    dpSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x ->+	    dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0)$ \sfs x->+	    dpSwitchB ((integral>>>arr(+x)):sfs) (now 20.0) $ \sfs _->+	    parB (take 2 sfs)++pswitch_t3r =+    [[],		-- 0.0+     [0.00],		-- 0.5+     [0.05],		-- 1.0+     [0.15],		-- 1.5+     [0.30],		-- 2.0+     [0.50],		-- 2.5+     [0.75],		-- 3.0+     [1.05],		-- 3.5+     [1.40],		-- 4.0+     [10.40,  1.80],	-- 4.5+     [10.85,  2.25],	-- 5.0+     [11.35,  2.75],	-- 5.5+     [20.55, 11.90],	-- 6.0+     [21.15, 12.50],	-- 6.5+     [21.80, 13.15],	-- 7.0+     [22.50, 13.85],	-- 7.5+     [23.25, 14.60],	-- 8.0+     [24.05, 15.40],	-- 8.5+     [24.90, 16.25],	-- 9.0+     [25.80, 17.15]]	-- 9.5+++-- Starts three "ramps" with different phase. As soon as one exceeds a+-- threshold, it's restarted, while the others are left alone. The+-- observaton of the output is done via the loop (rather than the directly+-- from the outputs of the signal functions in the collection), thus the+-- use of a delayed switch is essential.++pswitch_ramp :: Double -> SF a Double+pswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase)++-- We assume that only one signal function will reach the limit at a time.+pswitch_limit :: Double -> SF ((a, [Double]), b) (Event Int)+pswitch_limit x = arr (snd . fst) >>> arr (findIndex (>=x)) >>> edgeJust++pswitch_t4 :: [[Double]]+pswitch_t4 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ()))+    where+        sf :: SF (a, [Double]) ([Double],[Double])+	sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]+        	       (pswitch_limit 2.99)+		       pswitch_t4rec+	     >>> arr dup+        +pswitch_t4rec :: [SF (a, [Double]) Double]+                 -> Int+                 -> SF (a, [Double]) [Double]+pswitch_t4rec sfs n =+    dpSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs)+	      (pswitch_limit 2.99)+	      pswitch_t4rec++pswitch_t4r =+    [[0.0, 1.0, 2.0],+     [0.2, 1.2, 2.2],+     [0.4, 1.4, 2.4],+     [0.6, 1.6, 2.6],+     [0.8, 1.8, 2.8],+     [1.0, 2.0, 3.0],+     [1.2, 2.2, 0.2],+     [1.4, 2.4, 0.4],+     [1.6, 2.6, 0.6],+     [1.8, 2.8, 0.8],+     [2.0, 3.0, 1.0],+     [2.2, 0.2, 1.2],+     [2.4, 0.4, 1.4],+     [2.6, 0.6, 1.6],+     [2.8, 0.8, 1.8],+     [3.0, 1.0, 2.0],+     [0.2, 1.2, 2.2],+     [0.4, 1.4, 2.4],+     [0.6, 1.6, 2.6],+     [0.8, 1.8, 2.8],+     [1.0, 2.0, 3.0],+     [1.2, 2.2, 0.2],+     [1.4, 2.4, 0.4],+     [1.6, 2.6, 0.6],+     [1.8, 2.8, 0.8],+     [2.0, 3.0, 1.0],+     [2.2, 0.2, 1.2],+     [2.4, 0.4, 1.4],+     [2.6, 0.6, 1.6],+     [2.8, 0.8, 1.8]]+++-- Variation of the test above, with direct observation (not via loop) and+-- immediate switch.++-- We assume that only one signal function will reach the limit at a time.+pswitch_limit2 :: Double -> SF (a, [Double]) (Event Int)+pswitch_limit2 x = arr snd >>> arr (findIndex (>=x)) >>> edgeJust++pswitch_t5 :: [([Double], Double)]+pswitch_t5 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ()))+    where+        sf :: SF (a, [Double]) (([Double], Double), [Double])+	sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]+        	        (pswitch_limit2 2.99)+		        pswitch_t5rec)+	      &&& (arr snd >>> arr sum))+	     >>> arr (\(xs, y) -> ((xs, y), xs))+        +pswitch_t5rec :: [SF (a, [Double]) Double]+                 -> Int+                 -> SF (a, [Double]) [Double]+pswitch_t5rec sfs n =+    pSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs)+	     (pswitch_limit2 2.99)+	     pswitch_t5rec++pswitch_t5r =+    [([0.0, 1.0, 2.0], 3.0),+     ([0.2, 1.2, 2.2], 3.6),+     ([0.4, 1.4, 2.4], 4.2),+     ([0.6, 1.6, 2.6], 4.8),+     ([0.8, 1.8, 2.8], 5.4),+     ([1.0, 2.0, 0.0], 3.0),+     ([1.2, 2.2, 0.2], 3.6),+     ([1.4, 2.4, 0.4], 4.2),+     ([1.6, 2.6, 0.6], 4.8),+     ([1.8, 2.8, 0.8], 5.4),+     ([2.0, 0.0, 1.0], 3.0),+     ([2.2, 0.2, 1.2], 3.6),+     ([2.4, 0.4, 1.4], 4.2),+     ([2.6, 0.6, 1.6], 4.8),+     ([2.8, 0.8, 1.8], 5.4),+     ([0.0, 1.0, 2.0], 3.0),+     ([0.2, 1.2, 2.2], 3.6),+     ([0.4, 1.4, 2.4], 4.2),+     ([0.6, 1.6, 2.6], 4.8),+     ([0.8, 1.8, 2.8], 5.4),+     ([1.0, 2.0, 0.0], 3.0),+     ([1.2, 2.2, 0.2], 3.6),+     ([1.4, 2.4, 0.4], 4.2),+     ([1.6, 2.6, 0.6], 4.8),+     ([1.8, 2.8, 0.8], 5.4),+     ([2.0, 0.0, 1.0], 3.0),+     ([2.2, 0.2, 1.2], 3.6),+     ([2.4, 0.4, 1.4], 4.2),+     ([2.6, 0.6, 1.6], 4.8),+     ([2.8, 0.8, 1.8], 5.4)]+++pswitch_trs =+    [ pswitch_t0 ~= pswitch_t0r,+      pswitch_t1 ~= pswitch_t1r,+      pswitch_t2 ~= pswitch_t2r,+      pswitch_t3 ~= pswitch_t3r,+      pswitch_t4 ~= pswitch_t4r,+      pswitch_t5 ~= pswitch_t5r+    ]++pswitch_tr = and pswitch_trs+++pswitch_st0 = testSFSpaceLeak 1000000 (loop sf)+    where+        sf :: SF (a, [Double]) ([Double],[Double])+	sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]+        	       (pswitch_limit 2.99)+		       pswitch_t4rec+	     >>> arr dup++pswitch_st0r = [1.5,2.5,0.5]+++pswitch_st1 = testSFSpaceLeak 1000000 (loop sf)+    where+        sf :: SF (a, [Double]) (([Double], Double), [Double])+	sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]+        	        (pswitch_limit2 2.99)+		        pswitch_t5rec)+	      &&& (arr snd >>> arr sum))+	     >>> arr (\(xs, y) -> ((xs, y), xs))++pswitch_st1r = ([1.5,2.5,0.5],4.5)
+ tests/AFRPTestsPre.hs view
@@ -0,0 +1,208 @@+{- $Id: AFRPTestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsPre					     *+*       Purpose:        Test cases for pre and (derived) combinators	     *+*			that (semantically) involves a pre.		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*             Copyright (c) University of Nottingham, 2005                   *+*                                                                            *+******************************************************************************+-}++module AFRPTestsPre (pre_tr, pre_trs) where++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for pre and related combinators+------------------------------------------------------------------------------++pre_t0 = testSF1 (iPre 17)+pre_t0r =+    [17.0,0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,+     15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0]++pre_t1 = testSF2 (iPre 17)+pre_t1r =+    [17.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,+     3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0]++pre_t2 = testSF1 (time +                  >>> arr (\t -> sin (0.5 * t * pi + pi))+                  >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x')) +                            >>> second (iPre 0.0)))++pre_t2r = +    take 25+         (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ]+          in tail (scanl max 0 xs))+++-- This is a (somewhat strange) way of doing a counter that+-- stops after reaching a threshold. Note that the ingoing event+-- is *control dependent* on the output of the counter, so+-- "dHold" really has to have the capability of delivering an+-- output without looking at the current input at all.+pre_t3, pre_t3r :: [Int]+pre_t3 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = repeatedly 1.0 ()+             >>> (loop $+                      arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10))+                      >>> dHold 0+                      >>> arr dup)+pre_t3r = [0,0,0,0,	-- 0s+           0,1,1,1,	-- 1s+           1,2,2,2,	-- 2s+           2,3,3,3,	-- 3s+           3,4,4,4,	-- 4s+           4,5,5,5,	-- 5s+           5,6,6,6,	-- 6s+           6,7,7,7,	-- 7s+           7,8,8,8,	-- 8s+           8,9,9,9,	-- 9s+           9,10,10,10,	-- 10s+           10,10,10,10,	-- 11s+           10,10]	-- 12s++-- Version of the above that tests that thigs still work OK also if+-- there is an initial event.+pre_t4, pre_t4r :: [Int]+pre_t4 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge)+             >>> (loop $+                      arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10))+                      >>> dHold 0+                      >>> arr dup)+pre_t4r = [0,1,1,1,	-- 0s +           1,2,2,2,	-- 1s +           2,3,3,3,	-- 2s +           3,4,4,4,	-- 3s +           4,5,5,5,	-- 4s +           5,6,6,6,	-- 5s +           6,7,7,7,	-- 6s +           7,8,8,8,	-- 7s +           8,9,9,9,	-- 8s +           9,10,10,10,	-- 9s +           10,10,10,10,	-- 10s+           10,10,10,10,	-- 11s+           10,10]	-- 12s+++-- Similar test to "pre_t3" above but for dAccumHold.+pre_t5, pre_t5r :: [Int]+pre_t5 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = repeatedly 1.0 ()+             >>> (loop $+                      arr (\(e,c) -> (e `tag` (+1)) `gate` (c < 10))+                      >>> dAccumHold 0+                      >>> arr dup)+pre_t5r = [0,0,0,0,	-- 0s+           0,1,1,1,	-- 1s+           1,2,2,2,	-- 2s+           2,3,3,3,	-- 3s+           3,4,4,4,	-- 4s+           4,5,5,5,	-- 5s+           5,6,6,6,	-- 6s+           6,7,7,7,	-- 7s+           7,8,8,8,	-- 8s+           8,9,9,9,	-- 9s+           9,10,10,10,	-- 10s+           10,10,10,10,	-- 11s+           10,10]	-- 12s+++-- Similar test to "pre_t4" above but for dAccumHold.+pre_t6, pre_t6r :: [Int]+pre_t6 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge)+             >>> (loop $+                      arr (\(e,c) -> (e `tag` (+1)) `gate` (c < 10))+                      >>> dAccumHold 0+                      >>> arr dup)+pre_t6r = [0,1,1,1,	-- 0s +           1,2,2,2,	-- 1s +           2,3,3,3,	-- 2s +           3,4,4,4,	-- 3s +           4,5,5,5,	-- 4s +           5,6,6,6,	-- 5s +           6,7,7,7,	-- 6s +           7,8,8,8,	-- 7s +           8,9,9,9,	-- 8s +           9,10,10,10,	-- 9s +           10,10,10,10,	-- 10s+           10,10,10,10,	-- 11s+           10,10]	-- 12s+++-- Similar test to "pre_t3" above but for dAccumHoldBy.+pre_t7, pre_t7r :: [Int]+pre_t7 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = repeatedly 1.0 ()+             >>> (loop $+                      arr (\(e,c) -> e `gate` (c < 10))+                      >>> dAccumHoldBy (\c _ -> c + 1) 0+                      >>> arr dup)+pre_t7r = [0,0,0,0,	-- 0s+           0,1,1,1,	-- 1s+           1,2,2,2,	-- 2s+           2,3,3,3,	-- 3s+           3,4,4,4,	-- 4s+           4,5,5,5,	-- 5s+           5,6,6,6,	-- 6s+           6,7,7,7,	-- 7s+           7,8,8,8,	-- 8s+           8,9,9,9,	-- 9s+           9,10,10,10,	-- 10s+           10,10,10,10,	-- 11s+           10,10]	-- 12s+++-- Similar test to "pre_t4" above but for dAccumHoldBy.+pre_t8, pre_t8r :: [Int]+pre_t8 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge)+             >>> (loop $+                      arr (\(e,c) -> e `gate` (c < 10))+                      >>> dAccumHoldBy (\c _ -> c + 1) 0+                      >>> arr dup)+pre_t8r = [0,1,1,1,	-- 0s +           1,2,2,2,	-- 1s +           2,3,3,3,	-- 2s +           3,4,4,4,	-- 3s +           4,5,5,5,	-- 4s +           5,6,6,6,	-- 5s +           6,7,7,7,	-- 6s +           7,8,8,8,	-- 7s +           8,9,9,9,	-- 8s +           9,10,10,10,	-- 9s +           10,10,10,10,	-- 10s+           10,10,10,10,	-- 11s+           10,10]	-- 12s++++pre_trs =+    [ pre_t0 ~= pre_t0r,+      pre_t1 ~= pre_t1r,+      pre_t2 ~= pre_t2r,+      pre_t3 == pre_t3r,+      pre_t4 == pre_t4r,+      pre_t5 == pre_t5r,+      pre_t6 == pre_t6r,+      pre_t7 == pre_t7r,+      pre_t8 == pre_t8r+    ]++pre_tr = and pre_trs
tests/AFRPTestsRPSwitch.hs view
@@ -1,246 +1,246 @@-{- $Id: AFRPTestsRPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsRPSwitch				     *
-*       Purpose:        Test cases for rpSwitchB and drpSwitchB		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsRPSwitch (
-    rpswitch_tr,
-    rpswitch_trs,
-    rpswitch_st0,
-    rpswitch_st0r
-) where
-
-import Maybe (fromJust)
-import List (findIndex)
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for rpSwitchB and drpSwitchB
-------------------------------------------------------------------------------
-
-rpswitch_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))
-    where
-	delta_inp =
-            [Just (1.0, NoEvent), Nothing, Nothing,
-             Just (2.0, Event (integral:)), Just (3.0, NoEvent), Nothing,
-             Just (4.0, NoEvent), Nothing, Nothing,
-             Just (5.0, Event ((integral >>> arr (+100.0)):)),
-             Just (6.0, NoEvent), Nothing,
-             Just (7.0, NoEvent), Nothing, Nothing,
-             Just (8.0, Event tail), Just (9.0, NoEvent), Nothing]
-            ++ repeat Nothing
-
-
--- This input contains exaples of "continuos switching", i.e. the same
--- switching event ocurring during a a few contiguous time steps.
--- It also starts with an immediate switch.
-rpswitch_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))
-    where
-        delta_inp =
-            [Just (1.0, Event (integral:)),
-             Just (1.0, NoEvent), Nothing,
-             Just (2.0, Event ((integral >>> arr(+100.0)):)), Nothing, Nothing,
-             Just (3.0, Event ((integral >>> arr(+200.0)):)), Nothing, Nothing,
-             Just (4.0, NoEvent), Nothing, Nothing,
-             Just (5.0, Event ((arr (*3)):)),
-             Just (5.0, NoEvent), Nothing,
-             Just (6.0, Event tail), Just (7.0, Event ((arr (*7)):)),
-             Just (8.0, Event (take 2)),
-             Just (9.0, NoEvent), Nothing]
-            ++ repeat Nothing
-
-
-rpswitch_t0 :: [[Double]]
-rpswitch_t0 = take 20 $ embed (rpSwitchB []) rpswitch_inp1
-
-rpswitch_t0r =
-    [[],		-- 0 s
-     [],		-- 1 s
-     [],		-- 2 s
-     [0.0],		-- 3 s
-     [2.0],		-- 4 s
-     [5.0],		-- 5 s
-     [8.0],		-- 6 s
-     [12.0],		-- 7 s
-     [16.0],		-- 8 s
-     [100.0, 20.0],	-- 9 s
-     [105.0, 25.0],	-- 10 s
-     [111.0, 31.0],	-- 11 s
-     [117.0, 37.0],	-- 12 s
-     [124.0, 44.0],	-- 13 s
-     [131.0, 51.0],	-- 14 s
-     [58.0],		-- 15 s
-     [66.0],		-- 16 s
-     [75.0],		-- 17 s
-     [84.0],		-- 18 s
-     [93.0]]		-- 19 s
-
-
-rpswitch_t1 :: [[Double]]
-rpswitch_t1 = take 20 $ embed (drpSwitchB []) rpswitch_inp1
-
-rpswitch_t1r =
-    [[],		-- 0 s 
-     [],		-- 1 s 
-     [],		-- 2 s 
-     [],		-- 3 s 
-     [2.0],		-- 4 s 
-     [5.0],		-- 5 s 
-     [8.0],		-- 6 s 
-     [12.0],		-- 7 s 
-     [16.0],		-- 8 s 
-     [20.0]	,	-- 9 s 
-     [105.0, 25.0],	-- 10 s
-     [111.0, 31.0],	-- 11 s
-     [117.0, 37.0],	-- 12 s
-     [124.0, 44.0],	-- 13 s
-     [131.0, 51.0],	-- 14 s
-     [138.0, 58.0],	-- 15 s
-     [66.0],		-- 16 s
-     [75.0],		-- 17 s
-     [84.0],		-- 18 s
-     [93.0]]		-- 19 s
-
-
-rpswitch_t2 :: [[Double]]
-rpswitch_t2 = take 20 $ embed (rpSwitchB []) rpswitch_inp2
-
-rpswitch_t2r =
-    [[0.0],							-- 0 s 
-     [1.0],							-- 1 s 
-     [2.0],							-- 2 s 
-     [100.0, 3.0],						-- 3 s 
-     [100.0, 102.0, 5.0],					-- 4 s 
-     [100.0, 102.0, 104.0, 7.0],				-- 5 s 
-     [200.0, 102.0, 104.0, 106.0, 9.0],				-- 6 s 
-     [200.0, 203.0, 105.0, 107.0, 109.0, 12.0],			-- 7 s 
-     [200.0, 203.0, 206.0, 108.0, 110.0, 112.0, 15.0],		-- 8 s 
-     [203.0, 206.0, 209.0, 111.0, 113.0, 115.0, 18.0],		-- 9 s 
-     [207.0, 210.0, 213.0, 115.0, 117.0, 119.0, 22.0],		-- 10 s
-     [211.0, 214.0, 217.0, 119.0, 121.0, 123.0, 26.0],		-- 11 s
-     [15.0, 215.0, 218.0, 221.0, 123.0, 125.0, 127.0, 30.0],	-- 12 s
-     [15.0, 220.0, 223.0, 226.0, 128.0, 130.0, 132.0, 35.0],	-- 13 s
-     [15.0, 225.0, 228.0, 231.0, 133.0, 135.0, 137.0, 40.0],	-- 14 s
-     [230.0, 233.0, 236.0, 138.0, 140.0, 142.0, 45.0],		-- 15 s
-     [49.0, 236.0, 239.0, 242.0, 144.0, 146.0, 148.0, 51.0],	-- 16 s
-     [56.0, 243.0],						-- 17 s
-     [63.0, 251.0],						-- 18 s
-     [63.0, 260.0]]						-- 19 s
-
-
-rpswitch_t3 :: [[Double]]
-rpswitch_t3 = take 20 $ embed (drpSwitchB []) rpswitch_inp2
-
-rpswitch_t3r =
-    [[],							-- 0 s 
-     [1.0],							-- 1 s 
-     [2.0],							-- 2 s 
-     [3.0],							-- 3 s 
-     [102.0, 5.0],						-- 4 s 
-     [102.0, 104.0, 7.0],					-- 5 s 
-     [102.0, 104.0, 106.0, 9.0],				-- 6 s 
-     [203.0, 105.0, 107.0, 109.0, 12.0],			-- 7 s 
-     [203.0, 206.0, 108.0, 110.0, 112.0, 15.0],			-- 8 s 
-     [203.0, 206.0, 209.0, 111.0, 113.0, 115.0, 18.0],		-- 9 s 
-     [207.0, 210.0, 213.0, 115.0, 117.0, 119.0, 22.0],		-- 10 s
-     [211.0, 214.0, 217.0, 119.0, 121.0, 123.0, 26.0],		-- 11 s
-     [215.0, 218.0, 221.0, 123.0, 125.0, 127.0, 30.0],		-- 12 s
-     [15.0, 220.0, 223.0, 226.0, 128.0, 130.0, 132.0, 35.0],	-- 13 s
-     [15.0, 225.0, 228.0, 231.0, 133.0, 135.0, 137.0, 40.0],	-- 14 s
-     [18.0, 230.0, 233.0, 236.0, 138.0, 140.0, 142.0, 45.0],	-- 15 s
-     [236.0, 239.0, 242.0, 144.0, 146.0, 148.0, 51.0],		-- 16 s
-     [56.0, 243.0, 246.0, 249.0, 151.0, 153.0, 155.0, 58.0],	-- 17 s
-     [63.0, 251.0],						-- 18 s
-     [63.0, 260.0]]						-- 19 s
-
-
--- Starts three "ramps" with different phase. As soon as one exceeds a
--- threshold, it's restarted, while the others are left alone. The observaton
--- of the output is done via a loop, thus the  use of a delayed switch is
--- essential.
-
-rpswitch_ramp :: Double -> SF a Double
-rpswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase)
-
--- We assume that only one signal function will reach the limit at a time.
-rpswitch_limit :: Double -> SF [Double] (Event ([SF a Double]->[SF a Double]))
-rpswitch_limit x = arr (findIndex (>=x)) >>> edgeJust >>> arr (fmap restart)
-    where
-	restart n = \sfs -> take n sfs ++ [rpswitch_ramp 0.0] ++ drop (n+1) sfs
-
-rpswitch_t4 :: [[Double]]
-rpswitch_t4 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ()))
-    where
-        sf :: SF (a, [Double]) ([Double],[Double])
-	sf = (second (rpswitch_limit 2.99)
-	      >>> drpSwitchB [rpswitch_ramp 0.0,
-			      rpswitch_ramp 1.0,
-			      rpswitch_ramp 2.0])
-	     >>> arr dup
-
-rpswitch_t4r =
-    [[0.0, 1.0, 2.0],
-     [0.2, 1.2, 2.2],
-     [0.4, 1.4, 2.4],
-     [0.6, 1.6, 2.6],
-     [0.8, 1.8, 2.8],
-     [1.0, 2.0, 3.0],
-     [1.2, 2.2, 0.2],
-     [1.4, 2.4, 0.4],
-     [1.6, 2.6, 0.6],
-     [1.8, 2.8, 0.8],
-     [2.0, 3.0, 1.0],
-     [2.2, 0.2, 1.2],
-     [2.4, 0.4, 1.4],
-     [2.6, 0.6, 1.6],
-     [2.8, 0.8, 1.8],
-     [3.0, 1.0, 2.0],
-     [0.2, 1.2, 2.2],
-     [0.4, 1.4, 2.4],
-     [0.6, 1.6, 2.6],
-     [0.8, 1.8, 2.8],
-     [1.0, 2.0, 3.0],
-     [1.2, 2.2, 0.2],
-     [1.4, 2.4, 0.4],
-     [1.6, 2.6, 0.6],
-     [1.8, 2.8, 0.8],
-     [2.0, 3.0, 1.0],
-     [2.2, 0.2, 1.2],
-     [2.4, 0.4, 1.4],
-     [2.6, 0.6, 1.6],
-     [2.8, 0.8, 1.8]]
-
-
-rpswitch_trs =
-    [ rpswitch_t0 ~= rpswitch_t0r,
-      rpswitch_t1 ~= rpswitch_t1r,
-      rpswitch_t2 ~= rpswitch_t2r,
-      rpswitch_t3 ~= rpswitch_t3r,
-      rpswitch_t4 ~= rpswitch_t4r
-    ]
-
-rpswitch_tr = and rpswitch_trs
-
-
-rpswitch_st0 = testSFSpaceLeak 1000000 (loop sf)
-    where
-        sf :: SF (a, [Double]) ([Double],[Double])
-	sf = (second (rpswitch_limit 2.99)
-	      >>> drpSwitchB [rpswitch_ramp 0.0,
-			      rpswitch_ramp 1.0,
-			      rpswitch_ramp 2.0])
-	     >>> arr dup
-
-rpswitch_st0r = [1.5,2.5,0.5]
+{- $Id: AFRPTestsRPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsRPSwitch				     *+*       Purpose:        Test cases for rpSwitchB and drpSwitchB		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsRPSwitch (+    rpswitch_tr,+    rpswitch_trs,+    rpswitch_st0,+    rpswitch_st0r+) where++import Data.Maybe (fromJust)+import Data.List (findIndex)++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for rpSwitchB and drpSwitchB+------------------------------------------------------------------------------++rpswitch_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))+    where+	delta_inp =+            [Just (1.0, NoEvent), Nothing, Nothing,+             Just (2.0, Event (integral:)), Just (3.0, NoEvent), Nothing,+             Just (4.0, NoEvent), Nothing, Nothing,+             Just (5.0, Event ((integral >>> arr (+100.0)):)),+             Just (6.0, NoEvent), Nothing,+             Just (7.0, NoEvent), Nothing, Nothing,+             Just (8.0, Event tail), Just (9.0, NoEvent), Nothing]+            ++ repeat Nothing+++-- This input contains exaples of "continuos switching", i.e. the same+-- switching event ocurring during a a few contiguous time steps.+-- It also starts with an immediate switch.+rpswitch_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))+    where+        delta_inp =+            [Just (1.0, Event (integral:)),+             Just (1.0, NoEvent), Nothing,+             Just (2.0, Event ((integral >>> arr(+100.0)):)), Nothing, Nothing,+             Just (3.0, Event ((integral >>> arr(+200.0)):)), Nothing, Nothing,+             Just (4.0, NoEvent), Nothing, Nothing,+             Just (5.0, Event ((arr (*3)):)),+             Just (5.0, NoEvent), Nothing,+             Just (6.0, Event tail), Just (7.0, Event ((arr (*7)):)),+             Just (8.0, Event (take 2)),+             Just (9.0, NoEvent), Nothing]+            ++ repeat Nothing+++rpswitch_t0 :: [[Double]]+rpswitch_t0 = take 20 $ embed (rpSwitchB []) rpswitch_inp1++rpswitch_t0r =+    [[],		-- 0 s+     [],		-- 1 s+     [],		-- 2 s+     [0.0],		-- 3 s+     [2.0],		-- 4 s+     [5.0],		-- 5 s+     [8.0],		-- 6 s+     [12.0],		-- 7 s+     [16.0],		-- 8 s+     [100.0, 20.0],	-- 9 s+     [105.0, 25.0],	-- 10 s+     [111.0, 31.0],	-- 11 s+     [117.0, 37.0],	-- 12 s+     [124.0, 44.0],	-- 13 s+     [131.0, 51.0],	-- 14 s+     [58.0],		-- 15 s+     [66.0],		-- 16 s+     [75.0],		-- 17 s+     [84.0],		-- 18 s+     [93.0]]		-- 19 s+++rpswitch_t1 :: [[Double]]+rpswitch_t1 = take 20 $ embed (drpSwitchB []) rpswitch_inp1++rpswitch_t1r =+    [[],		-- 0 s +     [],		-- 1 s +     [],		-- 2 s +     [],		-- 3 s +     [2.0],		-- 4 s +     [5.0],		-- 5 s +     [8.0],		-- 6 s +     [12.0],		-- 7 s +     [16.0],		-- 8 s +     [20.0]	,	-- 9 s +     [105.0, 25.0],	-- 10 s+     [111.0, 31.0],	-- 11 s+     [117.0, 37.0],	-- 12 s+     [124.0, 44.0],	-- 13 s+     [131.0, 51.0],	-- 14 s+     [138.0, 58.0],	-- 15 s+     [66.0],		-- 16 s+     [75.0],		-- 17 s+     [84.0],		-- 18 s+     [93.0]]		-- 19 s+++rpswitch_t2 :: [[Double]]+rpswitch_t2 = take 20 $ embed (rpSwitchB []) rpswitch_inp2++rpswitch_t2r =+    [[0.0],							-- 0 s +     [1.0],							-- 1 s +     [2.0],							-- 2 s +     [100.0, 3.0],						-- 3 s +     [100.0, 102.0, 5.0],					-- 4 s +     [100.0, 102.0, 104.0, 7.0],				-- 5 s +     [200.0, 102.0, 104.0, 106.0, 9.0],				-- 6 s +     [200.0, 203.0, 105.0, 107.0, 109.0, 12.0],			-- 7 s +     [200.0, 203.0, 206.0, 108.0, 110.0, 112.0, 15.0],		-- 8 s +     [203.0, 206.0, 209.0, 111.0, 113.0, 115.0, 18.0],		-- 9 s +     [207.0, 210.0, 213.0, 115.0, 117.0, 119.0, 22.0],		-- 10 s+     [211.0, 214.0, 217.0, 119.0, 121.0, 123.0, 26.0],		-- 11 s+     [15.0, 215.0, 218.0, 221.0, 123.0, 125.0, 127.0, 30.0],	-- 12 s+     [15.0, 220.0, 223.0, 226.0, 128.0, 130.0, 132.0, 35.0],	-- 13 s+     [15.0, 225.0, 228.0, 231.0, 133.0, 135.0, 137.0, 40.0],	-- 14 s+     [230.0, 233.0, 236.0, 138.0, 140.0, 142.0, 45.0],		-- 15 s+     [49.0, 236.0, 239.0, 242.0, 144.0, 146.0, 148.0, 51.0],	-- 16 s+     [56.0, 243.0],						-- 17 s+     [63.0, 251.0],						-- 18 s+     [63.0, 260.0]]						-- 19 s+++rpswitch_t3 :: [[Double]]+rpswitch_t3 = take 20 $ embed (drpSwitchB []) rpswitch_inp2++rpswitch_t3r =+    [[],							-- 0 s +     [1.0],							-- 1 s +     [2.0],							-- 2 s +     [3.0],							-- 3 s +     [102.0, 5.0],						-- 4 s +     [102.0, 104.0, 7.0],					-- 5 s +     [102.0, 104.0, 106.0, 9.0],				-- 6 s +     [203.0, 105.0, 107.0, 109.0, 12.0],			-- 7 s +     [203.0, 206.0, 108.0, 110.0, 112.0, 15.0],			-- 8 s +     [203.0, 206.0, 209.0, 111.0, 113.0, 115.0, 18.0],		-- 9 s +     [207.0, 210.0, 213.0, 115.0, 117.0, 119.0, 22.0],		-- 10 s+     [211.0, 214.0, 217.0, 119.0, 121.0, 123.0, 26.0],		-- 11 s+     [215.0, 218.0, 221.0, 123.0, 125.0, 127.0, 30.0],		-- 12 s+     [15.0, 220.0, 223.0, 226.0, 128.0, 130.0, 132.0, 35.0],	-- 13 s+     [15.0, 225.0, 228.0, 231.0, 133.0, 135.0, 137.0, 40.0],	-- 14 s+     [18.0, 230.0, 233.0, 236.0, 138.0, 140.0, 142.0, 45.0],	-- 15 s+     [236.0, 239.0, 242.0, 144.0, 146.0, 148.0, 51.0],		-- 16 s+     [56.0, 243.0, 246.0, 249.0, 151.0, 153.0, 155.0, 58.0],	-- 17 s+     [63.0, 251.0],						-- 18 s+     [63.0, 260.0]]						-- 19 s+++-- Starts three "ramps" with different phase. As soon as one exceeds a+-- threshold, it's restarted, while the others are left alone. The observaton+-- of the output is done via a loop, thus the  use of a delayed switch is+-- essential.++rpswitch_ramp :: Double -> SF a Double+rpswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase)++-- We assume that only one signal function will reach the limit at a time.+rpswitch_limit :: Double -> SF [Double] (Event ([SF a Double]->[SF a Double]))+rpswitch_limit x = arr (findIndex (>=x)) >>> edgeJust >>> arr (fmap restart)+    where+	restart n = \sfs -> take n sfs ++ [rpswitch_ramp 0.0] ++ drop (n+1) sfs++rpswitch_t4 :: [[Double]]+rpswitch_t4 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ()))+    where+        sf :: SF (a, [Double]) ([Double],[Double])+	sf = (second (rpswitch_limit 2.99)+	      >>> drpSwitchB [rpswitch_ramp 0.0,+			      rpswitch_ramp 1.0,+			      rpswitch_ramp 2.0])+	     >>> arr dup++rpswitch_t4r =+    [[0.0, 1.0, 2.0],+     [0.2, 1.2, 2.2],+     [0.4, 1.4, 2.4],+     [0.6, 1.6, 2.6],+     [0.8, 1.8, 2.8],+     [1.0, 2.0, 3.0],+     [1.2, 2.2, 0.2],+     [1.4, 2.4, 0.4],+     [1.6, 2.6, 0.6],+     [1.8, 2.8, 0.8],+     [2.0, 3.0, 1.0],+     [2.2, 0.2, 1.2],+     [2.4, 0.4, 1.4],+     [2.6, 0.6, 1.6],+     [2.8, 0.8, 1.8],+     [3.0, 1.0, 2.0],+     [0.2, 1.2, 2.2],+     [0.4, 1.4, 2.4],+     [0.6, 1.6, 2.6],+     [0.8, 1.8, 2.8],+     [1.0, 2.0, 3.0],+     [1.2, 2.2, 0.2],+     [1.4, 2.4, 0.4],+     [1.6, 2.6, 0.6],+     [1.8, 2.8, 0.8],+     [2.0, 3.0, 1.0],+     [2.2, 0.2, 1.2],+     [2.4, 0.4, 1.4],+     [2.6, 0.6, 1.6],+     [2.8, 0.8, 1.8]]+++rpswitch_trs =+    [ rpswitch_t0 ~= rpswitch_t0r,+      rpswitch_t1 ~= rpswitch_t1r,+      rpswitch_t2 ~= rpswitch_t2r,+      rpswitch_t3 ~= rpswitch_t3r,+      rpswitch_t4 ~= rpswitch_t4r+    ]++rpswitch_tr = and rpswitch_trs+++rpswitch_st0 = testSFSpaceLeak 1000000 (loop sf)+    where+        sf :: SF (a, [Double]) ([Double],[Double])+	sf = (second (rpswitch_limit 2.99)+	      >>> drpSwitchB [rpswitch_ramp 0.0,+			      rpswitch_ramp 1.0,+			      rpswitch_ramp 2.0])+	     >>> arr dup++rpswitch_st0r = [1.5,2.5,0.5]
tests/AFRPTestsRSwitch.hs view
@@ -1,144 +1,144 @@-{- $Id: AFRPTestsRSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsRSwitch				     *
-*       Purpose:        Test cases for rSwitch and drSwitch		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsRSwitch (
-    rswitch_tr,
-    rswitch_trs,
-    rswitch_st0,
-    rswitch_st0r
-) where
-
-import Maybe (fromJust)
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for rSwitch and drSwitch
-------------------------------------------------------------------------------
-
-rswitch_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))
-    where
-	delta_inp =
-            [Just (1.0, NoEvent), Nothing, Nothing,
-             Just (2.0, Event (arr (*3))), Just (3.0, NoEvent), Nothing,
-             Just (4.0, NoEvent), Nothing, Nothing,
-             Just (5.0, Event integral),
-             Just (6.0, NoEvent), Nothing,
-             Just (7.0, NoEvent), Nothing, Nothing,
-             Just (8.0, Event (arr (*7))), Just (9.0, NoEvent), Nothing]
-            ++ repeat Nothing
-
-
--- This input contains exaples of "continuos switching", i.e. the same
--- switching event ocurring during a a few contiguous time steps.
--- It also starts with an immediate switch.
-rswitch_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))
-    where
-        delta_inp =
-            [Just (1.0, Event integral),
-             Just (1.0, NoEvent), Nothing,
-             Just (2.0, Event (arr (*2))), Nothing, Nothing,
-             Just (3.0, Event integral), Nothing, Nothing,
-             Just (4.0, NoEvent), Nothing, Nothing,
-             Just (5.0, Event integral),
-             Just (5.0, NoEvent), Nothing,
-             Just (6.0, Event (arr (*3))), Just (7.0, Event (arr (*4))),
-             Just (8.0, Event integral),
-             Just (9.0, NoEvent), Nothing]
-            ++ repeat Nothing
-
-
-rswitch_t0 = take 20 $ embed (rSwitch (arr (+3))) rswitch_inp1
-
--- Integration using rectangle rule assumed.
-rswitch_t0r :: [Double]
-rswitch_t0r =
-    [4.0,  4.0,  4.0,  6.0,  9.0,
-     9.0,  12.0, 12.0, 12.0, 0.0,
-     5.0,  11.0, 17.0, 24.0, 31.0,
-     56.0, 63.0, 63.0, 63.0, 63.0]
-
-
-rswitch_t1 = take 20 $ embed (rSwitch integral) rswitch_inp1
-
--- Integration using rectangle rule assumed.
-rswitch_t1r :: [Double]
-rswitch_t1r =
-    [0.0,  1.0,  2.0,  6.0,  9.0,
-     9.0,  12.0, 12.0, 12.0, 0.0,
-     5.0,  11.0, 17.0, 24.0, 31.0,
-     56.0, 63.0, 63.0, 63.0, 63.0]
-
-rswitch_t2 = take 20 $ embed (rSwitch (arr (+100))) rswitch_inp2
-
--- Integration using rectangle rule assumed.
-rswitch_t2r :: [Double]
-rswitch_t2r =
-    [0.0,  1.0,  2.0, 4.0, 4.0,
-     4.0,  0.0,  0.0, 0.0, 3.0,
-     7.0,  11.0, 0.0, 5.0, 10.0,
-     18.0, 28.0, 0.0, 8.0, 17.0]
-
-
-rswitch_t3 = take 20 $ embed (drSwitch (arr (+100))) rswitch_inp2
-
--- Integration using rectangle rule assumed.
-rswitch_t3r :: [Double]
-rswitch_t3r =
-    [101.0, 1.0,  2.0,  3.0, 4.0,
-     4.0,   6.0,  3.0,  3.0, 3.0,
-     7.0,   11.0, 15.0, 5.0, 10.0,
-     15.0,  21.0, 32.0, 8.0, 17.0]
-
-
-rswitch_sawTooth :: SF a Double
-rswitch_sawTooth =
-    loop (second (arr (>=5.0)
-                  >>> edge
-                  >>> arr (`tag` ramp))
-          >>> drSwitch ramp
-          >>> arr dup)
-    where
-        ramp :: SF a Double
-        ramp = constant 1.0 >>> integral
-
-rswitch_inp3 = deltaEncode 0.5 (repeat 0.0)
-
-rswitch_t4 = take 40 $ embed rswitch_sawTooth rswitch_inp3
-
-rswitch_t4r =
-    [0.0, 0.5, 1.0, 1.5, 2.0,
-     2.5, 3.0, 3.5, 4.0, 4.5,
-     5.0, 0.5, 1.0, 1.5, 2.0,
-     2.5, 3.0, 3.5, 4.0, 4.5,
-     5.0, 0.5, 1.0, 1.5, 2.0,
-     2.5, 3.0, 3.5, 4.0, 4.5,
-     5.0, 0.5, 1.0, 1.5, 2.0,
-     2.5, 3.0, 3.5, 4.0, 4.5]
-
-rswitch_trs =
-    [ rswitch_t0 ~= rswitch_t0r,
-      rswitch_t1 ~= rswitch_t1r,
-      rswitch_t2 ~= rswitch_t2r,
-      rswitch_t3 ~= rswitch_t3r,
-      rswitch_t4 ~= rswitch_t4r
-    ]
-
-rswitch_tr = and rswitch_trs
-
-
-rswitch_st0 = testSFSpaceLeak 2000000 rswitch_sawTooth
-rswitch_st0r = 4.75
+{- $Id: AFRPTestsRSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsRSwitch				     *+*       Purpose:        Test cases for rSwitch and drSwitch		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsRSwitch (+    rswitch_tr,+    rswitch_trs,+    rswitch_st0,+    rswitch_st0r+) where++import Data.Maybe (fromJust)++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for rSwitch and drSwitch+------------------------------------------------------------------------------++rswitch_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))+    where+	delta_inp =+            [Just (1.0, NoEvent), Nothing, Nothing,+             Just (2.0, Event (arr (*3))), Just (3.0, NoEvent), Nothing,+             Just (4.0, NoEvent), Nothing, Nothing,+             Just (5.0, Event integral),+             Just (6.0, NoEvent), Nothing,+             Just (7.0, NoEvent), Nothing, Nothing,+             Just (8.0, Event (arr (*7))), Just (9.0, NoEvent), Nothing]+            ++ repeat Nothing+++-- This input contains exaples of "continuos switching", i.e. the same+-- switching event ocurring during a a few contiguous time steps.+-- It also starts with an immediate switch.+rswitch_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp))+    where+        delta_inp =+            [Just (1.0, Event integral),+             Just (1.0, NoEvent), Nothing,+             Just (2.0, Event (arr (*2))), Nothing, Nothing,+             Just (3.0, Event integral), Nothing, Nothing,+             Just (4.0, NoEvent), Nothing, Nothing,+             Just (5.0, Event integral),+             Just (5.0, NoEvent), Nothing,+             Just (6.0, Event (arr (*3))), Just (7.0, Event (arr (*4))),+             Just (8.0, Event integral),+             Just (9.0, NoEvent), Nothing]+            ++ repeat Nothing+++rswitch_t0 = take 20 $ embed (rSwitch (arr (+3))) rswitch_inp1++-- Integration using rectangle rule assumed.+rswitch_t0r :: [Double]+rswitch_t0r =+    [4.0,  4.0,  4.0,  6.0,  9.0,+     9.0,  12.0, 12.0, 12.0, 0.0,+     5.0,  11.0, 17.0, 24.0, 31.0,+     56.0, 63.0, 63.0, 63.0, 63.0]+++rswitch_t1 = take 20 $ embed (rSwitch integral) rswitch_inp1++-- Integration using rectangle rule assumed.+rswitch_t1r :: [Double]+rswitch_t1r =+    [0.0,  1.0,  2.0,  6.0,  9.0,+     9.0,  12.0, 12.0, 12.0, 0.0,+     5.0,  11.0, 17.0, 24.0, 31.0,+     56.0, 63.0, 63.0, 63.0, 63.0]++rswitch_t2 = take 20 $ embed (rSwitch (arr (+100))) rswitch_inp2++-- Integration using rectangle rule assumed.+rswitch_t2r :: [Double]+rswitch_t2r =+    [0.0,  1.0,  2.0, 4.0, 4.0,+     4.0,  0.0,  0.0, 0.0, 3.0,+     7.0,  11.0, 0.0, 5.0, 10.0,+     18.0, 28.0, 0.0, 8.0, 17.0]+++rswitch_t3 = take 20 $ embed (drSwitch (arr (+100))) rswitch_inp2++-- Integration using rectangle rule assumed.+rswitch_t3r :: [Double]+rswitch_t3r =+    [101.0, 1.0,  2.0,  3.0, 4.0,+     4.0,   6.0,  3.0,  3.0, 3.0,+     7.0,   11.0, 15.0, 5.0, 10.0,+     15.0,  21.0, 32.0, 8.0, 17.0]+++rswitch_sawTooth :: SF a Double+rswitch_sawTooth =+    loop (second (arr (>=5.0)+                  >>> edge+                  >>> arr (`tag` ramp))+          >>> drSwitch ramp+          >>> arr dup)+    where+        ramp :: SF a Double+        ramp = constant 1.0 >>> integral++rswitch_inp3 = deltaEncode 0.5 (repeat 0.0)++rswitch_t4 = take 40 $ embed rswitch_sawTooth rswitch_inp3++rswitch_t4r =+    [0.0, 0.5, 1.0, 1.5, 2.0,+     2.5, 3.0, 3.5, 4.0, 4.5,+     5.0, 0.5, 1.0, 1.5, 2.0,+     2.5, 3.0, 3.5, 4.0, 4.5,+     5.0, 0.5, 1.0, 1.5, 2.0,+     2.5, 3.0, 3.5, 4.0, 4.5,+     5.0, 0.5, 1.0, 1.5, 2.0,+     2.5, 3.0, 3.5, 4.0, 4.5]++rswitch_trs =+    [ rswitch_t0 ~= rswitch_t0r,+      rswitch_t1 ~= rswitch_t1r,+      rswitch_t2 ~= rswitch_t2r,+      rswitch_t3 ~= rswitch_t3r,+      rswitch_t4 ~= rswitch_t4r+    ]++rswitch_tr = and rswitch_trs+++rswitch_st0 = testSFSpaceLeak 2000000 rswitch_sawTooth+rswitch_st0r = 4.75
tests/AFRPTestsReact.hs view
@@ -1,70 +1,70 @@-{- $Id: AFRPTestsReact.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsReact					     *
-*       Purpose:        Test cases for reactimation			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsReact (react_tr, react_trs) where
-
-import Data.IORef (IORef, newIORef, writeIORef, readIORef)
-import System.IO.Unsafe (unsafePerformIO)
-
-import AFRP
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for reactimation
-------------------------------------------------------------------------------
-
-react_t0 :: [(Double, Double)]
-react_t0 = unsafePerformIO $ do
-    countr   <- newIORef undefined
-    inputr   <- newIORef undefined
-    outputsr <- newIORef []
-    let init = do
-	    writeIORef countr 1
-	    let input0 = 0.0
-            writeIORef inputr input0
-	    return input0
-        sense _ = do
-	    count <- readIORef countr
-	    if count >= 5 then do
-		writeIORef countr 1
-		input <- readIORef inputr
-		let input' = input + 0.5
-		writeIORef inputr input'
-		return (0.1, Just input')
-	     else do
-		writeIORef countr (count + 1)
-		return (0.1, Nothing)
-	actuate _ output = do
-	    outputs <- readIORef outputsr
-	    writeIORef outputsr (output : outputs)
-	    input <- readIORef inputr
-	    return (input > 5.0)
-    reactimate init sense actuate (arr dup >>> second integral)
-    outputs <- readIORef outputsr
-    return (take 25 (reverse outputs))
-    
-
-react_t0r :: [(Double, Double)]
-react_t0r = [
-    (0.0,0.00), (0.0,0.00), (0.0,0.00), (0.0,0.00), (0.0,0.00),
-    (0.5,0.00), (0.5,0.05), (0.5,0.10), (0.5,0.15), (0.5,0.20),
-    (1.0,0.25), (1.0,0.35), (1.0,0.45), (1.0,0.55), (1.0,0.65),
-    (1.5,0.75), (1.5,0.90), (1.5,1.05), (1.5,1.20), (1.5,1.35),
-    (2.0,1.50), (2.0,1.70), (2.0,1.90), (2.0,2.10), (2.0,2.30)]
-
-
-react_trs = [ react_t0 ~= react_t0r ]
-
-
-react_tr = and react_trs
+{- $Id: AFRPTestsReact.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsReact					     *+*       Purpose:        Test cases for reactimation			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsReact (react_tr, react_trs) where++import System.IO.Unsafe (unsafePerformIO)+import Data.IORef (newIORef, writeIORef, readIORef)++import FRP.Yampa++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for reactimation+------------------------------------------------------------------------------++react_t0 :: [(Double, Double)]+react_t0 = unsafePerformIO $ do+    countr   <- newIORef undefined+    inputr   <- newIORef undefined+    outputsr <- newIORef []+    let init = do+	    writeIORef countr 1+	    let input0 = 0.0+            writeIORef inputr input0+	    return input0+        sense _ = do+	    count <- readIORef countr+	    if count >= 5 then do+		writeIORef countr 1+		input <- readIORef inputr+		let input' = input + 0.5+		writeIORef inputr input'+		return (0.1, Just input')+	     else do+		writeIORef countr (count + 1)+		return (0.1, Nothing)+	actuate _ output = do+	    outputs <- readIORef outputsr+	    writeIORef outputsr (output : outputs)+	    input <- readIORef inputr+	    return (input > 5.0)+    reactimate init sense actuate (arr dup >>> second integral)+    outputs <- readIORef outputsr+    return (take 25 (reverse outputs))+    ++react_t0r :: [(Double, Double)]+react_t0r = [+    (0.0,0.00), (0.0,0.00), (0.0,0.00), (0.0,0.00), (0.0,0.00),+    (0.5,0.00), (0.5,0.05), (0.5,0.10), (0.5,0.15), (0.5,0.20),+    (1.0,0.25), (1.0,0.35), (1.0,0.45), (1.0,0.55), (1.0,0.65),+    (1.5,0.75), (1.5,0.90), (1.5,1.05), (1.5,1.20), (1.5,1.35),+    (2.0,1.50), (2.0,1.70), (2.0,1.90), (2.0,2.10), (2.0,2.30)]+++react_trs = [ react_t0 ~= react_t0r ]+++react_tr = and react_trs
+ tests/AFRPTestsSscan.hs view
@@ -0,0 +1,478 @@+{- $Id$+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsSscan					     *+*       Purpose:        Test cases for pre sscan	     		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*             Copyright (c) University of Nottingham, 2005                   *+*                                                                            *+******************************************************************************+-}++module AFRPTestsSscan (sscan_tr, sscan_trs) where++import FRP.Yampa+import FRP.Yampa.Internals++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases sscan+------------------------------------------------------------------------------++-- pre and iPre in terms of sscan+pre_sscan :: SF a a+pre_sscan = sscanPrim f uninit uninit+    where+        f c a = Just (a, c)+        uninit = error "pre_sscan: Uninitialized pre operator."++iPre_sscan :: a -> SF a a+iPre_sscan = (--> pre_sscan)+++sscan_t0, sscan_t0r :: [Double]+sscan_t0 = testSF1 (iPre_sscan 17)+sscan_t0r =+    [17.0,0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,+     15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0]+++sscan_t1, sscan_t1r :: [Double]+sscan_t1 = testSF2 (iPre_sscan 17)+sscan_t1r =+    [17.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,+     3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0]+++sscan_t2, sscan_t2r :: [Double]+sscan_t2 = testSF1 (time +                    >>> arr (\t -> sin (0.5 * t * pi + pi))+                    >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x')) +                              >>> second (iPre_sscan 0.0)))+sscan_t2r = +    take 25+         (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ]+          in tail (scanl max 0 xs))++++sscan_t3, sscan_t3r :: [Double]+sscan_t3 = testSF1 (time +                    >>> arr (\t -> sin (0.5 * t * pi + pi))+                    >>> sscan max 0.0)++sscan_t3r = +    take 25+         (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ]+          in tail (scanl max 0 xs))+++hold_sscan :: a -> SF (Event a) a+hold_sscan a = sscanPrim f () a+    where+        f _ NoEvent   = Nothing +        f _ (Event a) = Just ((), a)+++dHold_sscan :: a -> SF (Event a) a+dHold_sscan a = hold_sscan a >>> iPre_sscan a+++-- This is a (somewhat strange) way of doing a counter that+-- stops after reaching a threshold. Note that the ingoing event+-- is *control dependent* on the output of the counter, so+-- "dHold" really has to have the capability of delivering an+-- output without looking at the current input at all.+sscan_t4, sscan_t4r :: [Int]+sscan_t4 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = repeatedly 1.0 ()+             >>> (loop $+                      arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10))+                      >>> dHold_sscan 0+                      >>> arr dup)+sscan_t4r = [0,0,0,0,		-- 0s+             0,1,1,1,		-- 1s+             1,2,2,2,		-- 2s+             2,3,3,3,		-- 3s+             3,4,4,4,		-- 4s+             4,5,5,5,		-- 5s+             5,6,6,6,		-- 6s+             6,7,7,7,		-- 7s+             7,8,8,8,		-- 8s+             8,9,9,9,		-- 9s+             9,10,10,10,	-- 10s+             10,10,10,10,	-- 11s+             10,10]		-- 12s++-- Version of the above that tests that thigs still work OK also if+-- there is an initial event.+sscan_t5, sscan_t5r :: [Int]+sscan_t5 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge)+             >>> (loop $+                      arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10))+                      >>> dHold_sscan 0+                      >>> arr dup)+sscan_t5r = [0,1,1,1,		-- 0s +             1,2,2,2,		-- 1s +             2,3,3,3,		-- 2s +             3,4,4,4,		-- 3s +             4,5,5,5,		-- 4s +             5,6,6,6,		-- 5s +             6,7,7,7,		-- 6s +             7,8,8,8,		-- 7s +             8,9,9,9,		-- 8s +             9,10,10,10,	-- 9s +             10,10,10,10,	-- 10s+             10,10,10,10,	-- 11s+             10,10]		-- 12s+++-- Version of the sscan_t4 in terms of sscan+sscan_t6, sscan_t6r :: [Int]+sscan_t6 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = repeatedly 1.0 () >>> (sscanPrim f 0 0)++        f c NoEvent               = Nothing+        f c (Event _) | c < 10    = Just (c', c')+                      | otherwise = Nothing+            where+	        c' = c + 1+++sscan_t6r = [0,0,0,0,		-- 0s+             1,1,1,1,		-- 1s+             2,2,2,2,		-- 2s+             3,3,3,3,		-- 3s+             4,4,4,4,		-- 4s+             5,5,5,5,		-- 5s+             6,6,6,6,		-- 6s+             7,7,7,7,		-- 7s+             8,8,8,8,		-- 8s+             9,9,9,9,		-- 9s+             10,10,10,10,	-- 10s+             10,10,10,10,	-- 11s+             10,10]		-- 12s++-- Version of sscan_t5 directly in terms of sscan.+sscan_t7, sscan_t7r :: [Int]+sscan_t7 = take 50 (embed sf (deltaEncode 0.25 (repeat ())))+    where+        sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge)+             >>> (sscanPrim f 0 0)++        f c NoEvent               = Nothing+        f c (Event _) | c < 10    = Just (c', c')+                      | otherwise = Nothing+            where+	        c' = c + 1+        ++sscan_t7r = [1,1,1,1,		-- 0s +             2,2,2,2,		-- 1s +             3,3,3,3,		-- 2s +             4,4,4,4,		-- 3s +             5,5,5,5,		-- 4s +             6,6,6,6,		-- 5s +             7,7,7,7,		-- 6s +             8,8,8,8,		-- 7s +             9,9,9,9,		-- 8s +             10,10,10,10,	-- 9s +             10,10,10,10,	-- 10s+             10,10,10,10,	-- 11s+             10,10]		-- 12s+++edge_sscan :: SF Bool (Event ())+edge_sscan = sscanPrim f 2 NoEvent+    where+        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+++sscan_t8 :: [Event ()]+sscan_t8 = testSF1 (localTime >>> arr (>=0) >>> edge_sscan)++sscan_t8r = +    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 3.0 s+     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent,	NoEvent,	-- 5.0 s+     NoEvent]+++sscan_t9 :: [Event ()]+sscan_t9 = testSF1 (localTime >>> arr (>=4.26) >>> edge_sscan)++sscan_t9r =+    [NoEvent, NoEvent, NoEvent,  NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent,  NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 3.0 s+     NoEvent, NoEvent, Event (), NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 5.0 s+     NoEvent]+++maybeToEvent :: Maybe a -> Event a+maybeToEvent Nothing  = NoEvent+maybeToEvent (Just a) = Event a+++edgeBy_sscan :: (a -> a -> Maybe b) -> a -> SF a (Event b)+edgeBy_sscan f a = sscanPrim g a NoEvent+    where+        g a_prev a = Just (a, maybeToEvent (f a_prev a))+++-- Raising edge detector.+sscan_isEdge False False = Nothing+sscan_isEdge False True  = Just ()+sscan_isEdge True  True  = Nothing+sscan_isEdge True  False = Nothing+++sscan_t10 :: [Event ()]+sscan_t10 = testSF1 (localTime+                     >>> arr (>=0)+                     >>> edgeBy_sscan sscan_isEdge False)++sscan_t10r = +    [Event (), NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent,  NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]++sscan_t11 :: [Event ()]+sscan_t11 = testSF1 (localTime +                     >>> arr (>=4.26)+                     >>> edgeBy_sscan sscan_isEdge False)++sscan_t11r =+    [NoEvent, NoEvent, NoEvent,  NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent,  NoEvent,	-- 2.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 3.0 s+     NoEvent, NoEvent, Event (), NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent,	 NoEvent,	-- 5.0 s+     NoEvent]++-- Raising and falling edge detector.+sscan_isEdge2 False False = Nothing+sscan_isEdge2 False True  = Just True+sscan_isEdge2 True  True  = Nothing+sscan_isEdge2 True  False = Just False++sscan_t12 :: [Event Bool]+sscan_t12 = testSF1 (localTime+                    >>> arr (\t -> t >=2.01 && t <= 4.51)+		    >>> edgeBy_sscan sscan_isEdge2 True)++sscan_t12r =+    [Event False, NoEvent,    NoEvent, NoEvent,		-- 0.0 s+     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 1.0 s+     NoEvent,     Event True, NoEvent, NoEvent,		-- 2.0 s+     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 3.0 s+     NoEvent,     NoEvent,    NoEvent, Event False,	-- 4.0 s+     NoEvent,     NoEvent,    NoEvent, NoEvent,		-- 5.0 s+     NoEvent]++++smaximum_sscan :: Ord a => SF a a+smaximum_sscan =+    switch (identity &&& now () >>> arr (\(a,e) -> (a, e `tag` a)))+           (\a0 -> sscanPrim (\c a -> if a > c+                                      then (Just (a,a))+                                      else Nothing)+                             a0 a0)+++sscan_t13, sscan_t13r :: [Double]+sscan_t13 = take 100 (embed sf (deltaEncode 0.1 (repeat ())))+    where+        sf = time+             >>> arr (\t -> (t + 1) * cos (pi * t + pi))+             >>> smaximum_sscan++sscan_t13r =+    take 100+         (let xs = [ (t + 1) * cos (pi * t + pi) | t <- [0.0, 0.1 ..] ]+          in tail (scanl max (-100) xs))+++-- Some tests of signal functions that may be implemented using sscan+-- internally and their combinations with other sscan-based signal+-- functions and event processors.++sscan_t14, sscan_t14r :: [Event Int]+sscan_t14 = take 100 (embed sf (deltaEncode 0.1 (repeat ())))+    where+        sf :: SF () (Event Int)+        sf = time >>> arr (\t -> sin (2 * t))+             >>> arr (>0)+             >>> edge+             >>> arr (`tag` (+1))+             >>> accum 0++sscan_t14r =+    [NoEvent,Event 1,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,Event 2,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,Event 3,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     Event 4,NoEvent,NoEvent,NoEvent,NoEvent]++sscan_t15, sscan_t15r :: [Int]+sscan_t15 = take 100 (embed sf (deltaEncode 0.1 (repeat ())))+    where+        sf :: SF () Int+        sf = time >>> arr (\t -> sin (2 * t))+             >>> arr (>0)+             >>> edge+             >>> arr (`tag` (+1))+             >>> accumHold 0++sscan_t15r =+    [0,1,1,1,1,1,1,1,1,1,+     1,1,1,1,1,1,1,1,1,1,+     1,1,1,1,1,1,1,1,1,1,+     1,1,2,2,2,2,2,2,2,2,+     2,2,2,2,2,2,2,2,2,2,+     2,2,2,2,2,2,2,2,2,2,+     2,2,2,3,3,3,3,3,3,3,+     3,3,3,3,3,3,3,3,3,3,+     3,3,3,3,3,3,3,3,3,3,+     3,3,3,3,3,4,4,4,4,4]++sscan_t16, sscan_t16r :: [Int]+sscan_t16 = take 100 (embed sf (deltaEncode 0.1 (repeat ())))+    where+        sf :: SF () Int+        sf = time >>> arr (\t -> sin (2 * t))+             >>> arr (>0)+             >>> edge+             >>> arr (`tag` (+1))+             >>> dAccumHold 0++sscan_t16r =+    [0,0,1,1,1,1,1,1,1,1,+     1,1,1,1,1,1,1,1,1,1,+     1,1,1,1,1,1,1,1,1,1,+     1,1,1,2,2,2,2,2,2,2,+     2,2,2,2,2,2,2,2,2,2,+     2,2,2,2,2,2,2,2,2,2,+     2,2,2,2,3,3,3,3,3,3,+     3,3,3,3,3,3,3,3,3,3,+     3,3,3,3,3,3,3,3,3,3,+     3,3,3,3,3,3,4,4,4,4]++sscan_t17, sscan_t17r :: [Event Int]+sscan_t17 = take 100 (embed sf (deltaEncode 0.1 (repeat ())))+    where+        sf :: SF () (Event Int)+        sf = time >>> arr (\t -> sin (2 * t))+             >>> arr (>0)+             >>> iPre False+             >>> edge+             >>> arr (`tag` (+1))+             >>> accum 0++sscan_t17r =+    [NoEvent,NoEvent,Event 1,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,Event 2,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,Event 3,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,NoEvent,NoEvent,NoEvent,NoEvent,+     NoEvent,Event 4,NoEvent,NoEvent,NoEvent]++sscan_t18, sscan_t18r :: [Int]+sscan_t18 = take 100 (embed sf (deltaEncode 0.1 (repeat ())))+    where+        sf :: SF () Int+        sf = time >>> arr (\t -> sin (2 * t))+             >>> arr (>0)+             >>> iPre False+             >>> edge+             >>> arr (`tag` (+1))+             >>> accumHold 0++sscan_t18r = +    [0,0,1,1,1,1,1,1,1,1,+     1,1,1,1,1,1,1,1,1,1,+     1,1,1,1,1,1,1,1,1,1,+     1,1,1,2,2,2,2,2,2,2,+     2,2,2,2,2,2,2,2,2,2,+     2,2,2,2,2,2,2,2,2,2,+     2,2,2,2,3,3,3,3,3,3,+     3,3,3,3,3,3,3,3,3,3,+     3,3,3,3,3,3,3,3,3,3,+     3,3,3,3,3,3,4,4,4,4]++sscan_trs =+    [ sscan_t0 ~= sscan_t0r,+      sscan_t1 ~= sscan_t1r,+      sscan_t2 ~= sscan_t2r,+      sscan_t3 ~= sscan_t3r,+      sscan_t4 == sscan_t4r,+      sscan_t5 == sscan_t5r,+      sscan_t6 == sscan_t6r,+      sscan_t7 == sscan_t7r,+      sscan_t8 == sscan_t8r,+      sscan_t9 == sscan_t9r,+      sscan_t10 == sscan_t10r,+      sscan_t11 == sscan_t11r,+      sscan_t12 == sscan_t12r,+      sscan_t13 ~= sscan_t13r,+      sscan_t14 ~= sscan_t14r,+      sscan_t15 ~= sscan_t15r,+      sscan_t16 ~= sscan_t16r,+      sscan_t17 ~= sscan_t17r,+      sscan_t18 ~= sscan_t18r+    ]++sscan_tr = and sscan_trs
tests/AFRPTestsSwitch.hs view
@@ -1,214 +1,214 @@-{- $Id: AFRPTestsSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsSwitch					     *
-*       Purpose:        Test cases for switch				     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsSwitch (switch_tr, switch_trs) where
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-import AFRPUtilities (snap)
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for switch and dSwitch
-------------------------------------------------------------------------------
-
-switch_inp1 = deltaEncode 1.0 $
-    [1.0, 1.0, 1.0,
-     2.0,
-     3.0, 3.0,
-     4.0, 4.0, 4.0,
-     5.0,
-     6.0, 6.0,
-     7.0, 7.0, 7.0, 
-     8.0]
-     ++ repeat 9.0
-
-switch_t0 = take 18 $
-    embed (switch switch_t0a $ \x ->
-           switch (switch_t0b x) $ \x ->
-	   switch (switch_t0c x) $ \x ->
-	   switch (switch_t0c x) $ \x ->
-	   switch (switch_t0d x) $ \x ->
-	   switch (switch_t0e x) $ \x ->
-	   switch (switch_t0e x) $
-           switch_t0final)
-	  switch_inp1
-
-switch_t0a :: SF Double (Double, Event Int)
-switch_t0a = localTime
-             >>> arr dup
-             >>> second (arr (>= 3.0) >>> edge >>> arr (`tag` 17))
-
-switch_t0b :: Int -> SF Double (Double, Event Int)
-switch_t0b x = localTime
-               >>> arr dup
-               >>> second (arr (>= 3.0) >>> edge >>> arr (`tag` (23 + x)))
-
--- This should raise an event IMMEDIATELY: no time should pass.
-switch_t0c :: Num b => b -> SF a (a, Event b)
-switch_t0c x = arr dup >>> second (now (x + 1))
-
-switch_t0d x = (arr (+ (fromIntegral x))) &&& (arr (>= 7.0) >>> edge)
-
--- This should raise an event IMMEDIATELY: no time should pass.
-switch_t0e :: b -> SF a (a, Event a)
-switch_t0e _ = arr dup >>> second snap
-
-switch_t0final :: Double -> SF Double Double
-switch_t0final x = arr (+x)
-
-switch_t0r =
-    [0.0,  1.0,  2.0, 				-- switch_t0a
-     0.0,  1.0,  2.0,   			-- switch_t0b
-     46.0, 46.0, 46.0, 47.0, 48.0, 48.0,	-- switch_t0d
-     14.0, 14.0, 14.0, 15.0, 16.0, 16.0		-- switch_t0final
-    ]
-
-
-switch_t1 = take 32 $ embed (switch_t1rec 42.0) switch_inp1
-
--- Outputs current input, local time, and the value of the initializing
--- argument until some time has passed (determined by integrating a constant),
--- at which point an event occurs.
-switch_t1a :: Double -> SF Double ((Double,Double,Double), Event ())
-switch_t1a x = (arr dup >>> second localTime >>> arr (\(a,t) -> (a,t,x)))
-	       &&& (constant 0.5
-                    >>> integral
-                    >>> (arr (>= (2.0 :: Double)) -- Used to work with no sig.
-                    >>> edge))
-
--- This should raise an event IMMEDIATELY: no time should pass.
-switch_t1b :: b -> SF a ((Double,Double,Double), Event a)
-switch_t1b _ = constant (-999.0,-999.0,-999.0) &&& snap
-
-switch_t1rec :: Double -> SF Double (Double,Double,Double)
-switch_t1rec x =
-    switch (switch_t1a x) $ \x ->
-    switch (switch_t1b x) $ \x ->
-    switch (switch_t1b x) $
-    switch_t1rec
-
-switch_t1r =
-    [(1.0,0.0,42.0), (1.0,1.0,42.0), (1.0,2.0,42.0), (2.0,3.0,42.0),
-     (3.0,0.0,3.0),  (3.0,1.0,3.0),  (4.0,2.0,3.0),  (4.0,3.0,3.0),
-     (4.0,0.0,4.0),  (5.0,1.0,4.0),  (6.0,2.0,4.0),  (6.0,3.0,4.0),
-     (7.0,0.0,7.0),  (7.0,1.0,7.0),  (7.0,2.0,7.0),  (8.0,3.0,7.0),
-     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),
-     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),
-     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),
-     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0)]
-
-switch_t2 = take 18 $
-    embed (dSwitch switch_t0a $ \x ->
-           dSwitch (switch_t0b x) $ \x ->
-           dSwitch (switch_t0c x) $ \x ->
-           dSwitch (switch_t0c x) $ \x ->
-	   dSwitch (switch_t0d x) $ \x ->
-	   dSwitch (switch_t0e x) $ \x ->
-	   dSwitch (switch_t0e x) $
-           switch_t0final)
-	  switch_inp1
-
-switch_t2r =
-    [0.0,  1.0,  2.0,				-- switch_t0a
-     3.0,  1.0,  2.0,				-- switch_t0b
-     3.0,  46.0, 46.0, 47.0, 48.0, 48.0,	-- switch_t0d
-     49.0, 14.0, 14.0, 15.0, 16.0, 16.0		-- switch_t0final
-    ]
-
-
-switch_t3 = take 32 $ embed (switch_t3rec 42.0) switch_inp1
-
-switch_t3rec :: Double -> SF Double (Double,Double,Double)
-switch_t3rec x =
-    dSwitch (switch_t1a x) $ \x ->
-    dSwitch (switch_t1b x) $ \x ->
-    dSwitch (switch_t1b x) $
-    switch_t3rec
-
-switch_t3r =
-    [(1.0,0.0,42.0), (1.0,1.0,42.0), (1.0,2.0,42.0), (2.0,3.0,42.0),
-     (3.0,4.0,42.0), (3.0,1.0,3.0),  (4.0,2.0,3.0),  (4.0,3.0,3.0),
-     (4.0,4.0,3.0),  (5.0,1.0,4.0),  (6.0,2.0,4.0),  (6.0,3.0,4.0),
-     (7.0,4.0,4.0),  (7.0,1.0,7.0),  (7.0,2.0,7.0),  (8.0,3.0,7.0),
-     (9.0,4.0,7.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),
-     (9.0,4.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),
-     (9.0,4.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),
-     (9.0,4.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0)]
-
-
--- The correct strictness properties of dSwitch are crucial here.
--- switch does not work.
-switch_t4 = take 25 $
-    embed (loop $
-	       dSwitch switch_t4a $ \_ ->
-	       dSwitch switch_t4a $ \_ ->
-	       dSwitch switch_t4a $ \_ ->
-	       switch_t4final
-           )
-          (deltaEncode 1.0 (repeat ()))
-
-
-switch_t4a :: SF (a, Double) ((Double, Double), Event ())
-switch_t4a = (constant 1.0 >>> integral >>> arr dup)
-             &&& (arr (\ (_, x) -> x >= 5.0) >>> edge)
-
-switch_t4final :: SF (a, Double) (Double, Double)
-switch_t4final = constant 0.1 >>> integral >>> arr dup
-
-switch_t4r =
-    [0.0, 1.0, 2.0, 3.0, 4.0,				-- switch_t4a
-     5.0, 1.0, 2.0, 3.0, 4.0,				-- switch_t4a
-     5.0, 1.0, 2.0, 3.0, 4.0,				-- switch_t4a
-     5.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9	-- switch_t4final
-    ]
-
-
-impulseIntegral2 :: VectorSpace a s => SF (a, Event a) a
-impulseIntegral2 =
-    switch (first integral >>> arr (\(a, ea) -> (a, fmap (^+^a) ea)))
-	   impulseIntegral2'
-    where
-	impulseIntegral2' :: VectorSpace a s => a -> SF (a, Event a) a
-	impulseIntegral2' a =
-	    switch ((integral >>> arr (^+^a)) *** notYet
-		    >>> arr (\(a, ea) -> (a, fmap (^+^a) ea)))
-		   impulseIntegral2'
-
-switch_t5 :: [Double]
-switch_t5 = take 50 $ embed impulseIntegral2
-			    (deltaEncode 0.1 (zip (repeat 1.0) evSeq))
-    where
-	evSeq = replicate 9 NoEvent ++ [Event 10.0]
-		++ replicate 9 NoEvent ++ [Event (-10.0)]
-		++ evSeq
-
-switch_t5r =
-    [ 0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8, 10.9,
-     11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8,  1.9,
-      2.0,  2.1,  2.2,  2.3,  2.4,  2.5,  2.6,  2.7,  2.8, 12.9,
-     13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8,  3.9,
-      4.0,  4.1,  4.2,  4.3,  4.4,  4.5,  4.6,  4.7,  4.8, 14.9]
-
-
-switch_trs =
-    [ switch_t0 ~= switch_t0r,
-      switch_t1 ~= switch_t1r,
-      switch_t2 ~= switch_t2r,
-      switch_t3 ~= switch_t3r,
-      switch_t4 ~= switch_t4r,
-      switch_t5 ~= switch_t5r
-    ]
-
-switch_tr = and switch_trs
+{- $Id: AFRPTestsSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsSwitch					     *+*       Purpose:        Test cases for switch				     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsSwitch (switch_tr, switch_trs) where++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))+import FRP.Yampa.Utilities (snap)++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for switch and dSwitch+------------------------------------------------------------------------------++switch_inp1 = deltaEncode 1.0 $+    [1.0, 1.0, 1.0,+     2.0,+     3.0, 3.0,+     4.0, 4.0, 4.0,+     5.0,+     6.0, 6.0,+     7.0, 7.0, 7.0, +     8.0]+     ++ repeat 9.0++switch_t0 = take 18 $+    embed (switch switch_t0a $ \x ->+           switch (switch_t0b x) $ \x ->+	   switch (switch_t0c x) $ \x ->+	   switch (switch_t0c x) $ \x ->+	   switch (switch_t0d x) $ \x ->+	   switch (switch_t0e x) $ \x ->+	   switch (switch_t0e x) $+           switch_t0final)+	  switch_inp1++switch_t0a :: SF Double (Double, Event Int)+switch_t0a = localTime+             >>> arr dup+             >>> second (arr (>= 3.0) >>> edge >>> arr (`tag` 17))++switch_t0b :: Int -> SF Double (Double, Event Int)+switch_t0b x = localTime+               >>> arr dup+               >>> second (arr (>= 3.0) >>> edge >>> arr (`tag` (23 + x)))++-- This should raise an event IMMEDIATELY: no time should pass.+switch_t0c :: Num b => b -> SF a (a, Event b)+switch_t0c x = arr dup >>> second (now (x + 1))++switch_t0d x = (arr (+ (fromIntegral x))) &&& (arr (>= 7.0) >>> edge)++-- This should raise an event IMMEDIATELY: no time should pass.+switch_t0e :: b -> SF a (a, Event a)+switch_t0e _ = arr dup >>> second snap++switch_t0final :: Double -> SF Double Double+switch_t0final x = arr (+x)++switch_t0r =+    [0.0,  1.0,  2.0, 				-- switch_t0a+     0.0,  1.0,  2.0,   			-- switch_t0b+     46.0, 46.0, 46.0, 47.0, 48.0, 48.0,	-- switch_t0d+     14.0, 14.0, 14.0, 15.0, 16.0, 16.0		-- switch_t0final+    ]+++switch_t1 = take 32 $ embed (switch_t1rec 42.0) switch_inp1++-- Outputs current input, local time, and the value of the initializing+-- argument until some time has passed (determined by integrating a constant),+-- at which point an event occurs.+switch_t1a :: Double -> SF Double ((Double,Double,Double), Event ())+switch_t1a x = (arr dup >>> second localTime >>> arr (\(a,t) -> (a,t,x)))+	       &&& (constant 0.5+                    >>> integral+                    >>> (arr (>= (2.0 :: Double)) -- Used to work with no sig.+                    >>> edge))++-- This should raise an event IMMEDIATELY: no time should pass.+switch_t1b :: b -> SF a ((Double,Double,Double), Event a)+switch_t1b _ = constant (-999.0,-999.0,-999.0) &&& snap++switch_t1rec :: Double -> SF Double (Double,Double,Double)+switch_t1rec x =+    switch (switch_t1a x) $ \x ->+    switch (switch_t1b x) $ \x ->+    switch (switch_t1b x) $+    switch_t1rec++switch_t1r =+    [(1.0,0.0,42.0), (1.0,1.0,42.0), (1.0,2.0,42.0), (2.0,3.0,42.0),+     (3.0,0.0,3.0),  (3.0,1.0,3.0),  (4.0,2.0,3.0),  (4.0,3.0,3.0),+     (4.0,0.0,4.0),  (5.0,1.0,4.0),  (6.0,2.0,4.0),  (6.0,3.0,4.0),+     (7.0,0.0,7.0),  (7.0,1.0,7.0),  (7.0,2.0,7.0),  (8.0,3.0,7.0),+     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),+     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),+     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),+     (9.0,0.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0)]++switch_t2 = take 18 $+    embed (dSwitch switch_t0a $ \x ->+           dSwitch (switch_t0b x) $ \x ->+           dSwitch (switch_t0c x) $ \x ->+           dSwitch (switch_t0c x) $ \x ->+	   dSwitch (switch_t0d x) $ \x ->+	   dSwitch (switch_t0e x) $ \x ->+	   dSwitch (switch_t0e x) $+           switch_t0final)+	  switch_inp1++switch_t2r =+    [0.0,  1.0,  2.0,				-- switch_t0a+     3.0,  1.0,  2.0,				-- switch_t0b+     3.0,  46.0, 46.0, 47.0, 48.0, 48.0,	-- switch_t0d+     49.0, 14.0, 14.0, 15.0, 16.0, 16.0		-- switch_t0final+    ]+++switch_t3 = take 32 $ embed (switch_t3rec 42.0) switch_inp1++switch_t3rec :: Double -> SF Double (Double,Double,Double)+switch_t3rec x =+    dSwitch (switch_t1a x) $ \x ->+    dSwitch (switch_t1b x) $ \x ->+    dSwitch (switch_t1b x) $+    switch_t3rec++switch_t3r =+    [(1.0,0.0,42.0), (1.0,1.0,42.0), (1.0,2.0,42.0), (2.0,3.0,42.0),+     (3.0,4.0,42.0), (3.0,1.0,3.0),  (4.0,2.0,3.0),  (4.0,3.0,3.0),+     (4.0,4.0,3.0),  (5.0,1.0,4.0),  (6.0,2.0,4.0),  (6.0,3.0,4.0),+     (7.0,4.0,4.0),  (7.0,1.0,7.0),  (7.0,2.0,7.0),  (8.0,3.0,7.0),+     (9.0,4.0,7.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),+     (9.0,4.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),+     (9.0,4.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0),+     (9.0,4.0,9.0),  (9.0,1.0,9.0),  (9.0,2.0,9.0),  (9.0,3.0,9.0)]+++-- The correct strictness properties of dSwitch are crucial here.+-- switch does not work.+switch_t4 = take 25 $+    embed (loop $+	       dSwitch switch_t4a $ \_ ->+	       dSwitch switch_t4a $ \_ ->+	       dSwitch switch_t4a $ \_ ->+	       switch_t4final+           )+          (deltaEncode 1.0 (repeat ()))+++switch_t4a :: SF (a, Double) ((Double, Double), Event ())+switch_t4a = (constant 1.0 >>> integral >>> arr dup)+             &&& (arr (\ (_, x) -> x >= 5.0) >>> edge)++switch_t4final :: SF (a, Double) (Double, Double)+switch_t4final = constant 0.1 >>> integral >>> arr dup++switch_t4r =+    [0.0, 1.0, 2.0, 3.0, 4.0,				-- switch_t4a+     5.0, 1.0, 2.0, 3.0, 4.0,				-- switch_t4a+     5.0, 1.0, 2.0, 3.0, 4.0,				-- switch_t4a+     5.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9	-- switch_t4final+    ]+++impulseIntegral2 :: VectorSpace a s => SF (a, Event a) a+impulseIntegral2 =+    switch (first integral >>> arr (\(a, ea) -> (a, fmap (^+^a) ea)))+	   impulseIntegral2'+    where+	impulseIntegral2' :: VectorSpace a s => a -> SF (a, Event a) a+	impulseIntegral2' a =+	    switch ((integral >>> arr (^+^a)) *** notYet+		    >>> arr (\(a, ea) -> (a, fmap (^+^a) ea)))+		   impulseIntegral2'++switch_t5 :: [Double]+switch_t5 = take 50 $ embed impulseIntegral2+			    (deltaEncode 0.1 (zip (repeat 1.0) evSeq))+    where+	evSeq = replicate 9 NoEvent ++ [Event 10.0]+		++ replicate 9 NoEvent ++ [Event (-10.0)]+		++ evSeq++switch_t5r =+    [ 0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8, 10.9,+     11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8,  1.9,+      2.0,  2.1,  2.2,  2.3,  2.4,  2.5,  2.6,  2.7,  2.8, 12.9,+     13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8,  3.9,+      4.0,  4.1,  4.2,  4.3,  4.4,  4.5,  4.6,  4.7,  4.8, 14.9]+++switch_trs =+    [ switch_t0 ~= switch_t0r,+      switch_t1 ~= switch_t1r,+      switch_t2 ~= switch_t2r,+      switch_t3 ~= switch_t3r,+      switch_t4 ~= switch_t4r,+      switch_t5 ~= switch_t5r+    ]++switch_tr = and switch_trs
tests/AFRPTestsTask.hs view
@@ -1,217 +1,217 @@-{- $Id: AFRPTestsTask.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsTask					     *
-*       Purpose:        Test cases for tasks (AFRPTask)			     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
--- Very rudimentary testing of AFRPTask.
-
-module AFRPTestsTask (task_tr, task_trs) where
-
-import AFRP
-import AFRPTask
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for tasks (AFRPTask)
-------------------------------------------------------------------------------
-
-task_t0 = testSF1 (runTask (do
-			       mkTask (localTime
-			               &&&(localTime >>> arr (>=5.0) >>> edge))
-			       x <- snapT
-			       return (x * 2.0))
-                 )
-
-task_t0r =
-    [Left 0.0,   Left 0.25,  Left 0.5,   Left 0.75,  Left 1.0,
-     Left 1.25,  Left 1.5,   Left 1.75,  Left 2.0,   Left 2.25,
-     Left 2.5,   Left 2.75,  Left 3.0,   Left 3.25,  Left 3.5,
-     Left 3.75,  Left 4.0,   Left 4.25,  Left 4.5,   Left 4.75,
-     Right 40.0, Right 40.0, Right 40.0, Right 40.0, Right 40.0]
-
-
-task_t1 = testSF1 (runTask (do
-			       mkTask (localTime
-			               &&& (localTime>>>arr (>=5.0) >>> edge))
-			       return ()   -- No time should pass!
-			       return ()   -- No Time should pass!
-			       snapT	   -- No time should pass!
-                               snapT	   -- No time should pass!
-			       x <- snapT
-			       return (x * 2.0))
-                 )
-
-
-task_t2 = testSF1 (runTask (do
-			       sleepT 1.51 42.0
-			       x <- snapT
-			       y <- snapT
-			       sleepT 1.51 x
-			       if x == y then
-			           sleepT 1.51 (x * 2)
-				else
-				   sleepT 0.51 (x * 3)
-			  )
-		 )
-
-task_t2r =
-    [Left 42.0, Left 42.0, Left 42.0, Left 42.0,	-- 0.0 s
-     Left 42.0, Left 42.0, Left 42.0, Left 7.0,		-- 1.0 s
-     Left 7.0,	Left 7.0,  Left 7.0,  Left 7.0,		-- 2.0 s
-     Left 7.0,	Left 7.0,  Left 14.0, Left 14.0,	-- 3.0 s
-     Left 14.0,	Left 14.0, Left 14.0, Left 14.0,	-- 4.0 s
-     Left 14.0,	Right (),  Right (),  Right (),		-- 5.0 s
-     Right ()]
-
-
-task_t3 = testSF1 (runTask (do
-			      c <- sawtooth `timeOut` 3.49
-			      case c of
-			          Nothing -> sleepT 1.51 (-10.0)
-				  Just x  -> sleepT 1.51 x
-			  )
-		 )
-    where
-        sawtooth =
-	    forEver ((mkTask (constant 2.0 >>> integral &&& never))
-	             `timeOut` 1.5)
-
-task_t3r :: [Either Double ()]	    
-task_t3r =
-    [Left 0.0,     Left 0.5,     Left 1.0,     Left 1.5,	-- 0.0 s
-     Left 2.0,     Left 2.5,     Left 0.0,     Left 0.5,	-- 1.0 s
-     Left 1.0,     Left 1.5,     Left 2.0,     Left 2.5,	-- 2.0 s
-     Left 0.0,     Left 0.5,     Left (-10.0), Left (-10.0),	-- 3.0 s
-     Left (-10.0), Left (-10.0), Left (-10.0), Left (-10.0),	-- 4.0 s
-     Left (-10.0), Right (),	 Right (),     Right (),	-- 5.0 s
-     Right ()]
-
-
-task_t4 = testSF1 (runTask (do
-			      c <- sawtooth `timeOut` 3.49
-			      case c of
-			          Nothing -> sleepT 1.51 (-10.0)
-				  Just x  -> sleepT 1.51 x
-			  )
-		 )
-    where
-        sawtooth = do
-	    for 1 (+1) (<=2)
-                ((mkTask (constant 2.0 >>> integral &&& never))
-		 `timeOut` 1.5)
-	    return (-42.0)
-
-task_t4r :: [Either Double ()]
-task_t4r =
-    [Left 0.0,     Left 0.5,     Left 1.0,     Left 1.5,	-- 0.0 s
-     Left 2.0,     Left 2.5,     Left 0.0,     Left 0.5,	-- 1.0 s
-     Left 1.0,     Left 1.5,     Left 2.0,     Left 2.5,	-- 2.0 s
-     Left (-42.0), Left (-42.0), Left (-42.0), Left (-42.0),	-- 3.0 s
-     Left (-42.0), Left (-42.0), Left (-42.0), Right (),	-- 4.0 s
-     Right (),	   Right (),	 Right (),     Right (),	-- 5.0 s
-     Right ()]
-
-
-task_t5 = testSF1 (runTask (do
-			      x<-(sawtoothCycle>>snapT) `repeatUntil` (>=20.0)
-			      y<-snapT
-			      return (x == y)
-			  )
-		 )
-    where
-	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
-
-task_t5r :: [Either Double Bool]
-task_t5r =
-    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 0.0 s, 0 - 3
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 1.0 s, 4 - 7
-     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 2.0 s, 8 - 11
-     Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 3.0 s, 12 - 15
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 4.0 s, 16 - 19,
-     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 5.0 s, 20 - 23
-     Right True]
-
-
-task_t6 = testSF1 $ runTask $
-    do
-        x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))
-	     `abortWhen` (localTime >>> arr (>=3.51) >>> edge)
-        y <- snapT
-	return (x,y)
-    where
-	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
-
-task_t6r :: [Either Double (Either Double (), Double)]
-task_t6r =
-    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,		-- 0.0 s, 0 - 3
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,		-- 1.0 s, 4 - 7
-     Left 1.0, Left 1.5, Left 2.0, Left 2.5,		-- 2.0 s, 8 - 11
-     Left 0.0, Left 0.5, Left 1.0, Right (Right (),15.0), -- 3.0 s, 12 - 15
-     Right (Right (),15.0), Right (Right (),15.0),	-- 4.0 s, 16, 17
-     Right (Right (),15.0), Right (Right (),15.0),	-- 4.5 s, 18, 19
-     Right (Right (),15.0), Right (Right (),15.0),	-- 5.0 s, 20, 21
-     Right (Right (),15.0), Right (Right (),15.0),	-- 5.5 s, 22, 23
-     Right (Right (),15.0)]
-
-task_t7 = testSF1 $ runTask $
-    do
-        x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))
-	     `abortWhen` (localTime >>> arr (>=5.75) >>> edge)
-        y <- snapT
-	return (x,y)
-    where
-	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
-
-task_t7r :: [Either Double (Either Double (), Double)]
-task_t7r =
-    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 0.0 s, 0 - 3
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 1.0 s, 4 - 7
-     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 2.0 s, 8 - 11
-     Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 3.0 s, 12 - 15
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 4.0 s, 16 - 19
-     Left 1.0, Left 1.5, Left 2.0, Right (Right (),23.0), -- 5.0 s, 20 - 23
-     Right (Right (),23.0)]
-
-task_t8 = testSF1 $ runTask $
-    do
-        x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))
-	     `abortWhen` (localTime >>> arr (>=5.76) >>> edge)
-        y <- snapT
-	return (x,y)
-    where
-	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
-
--- Since abortWhen uses lMergeEvent, the terminating event of the task
--- gets priority over the aborting event.
-task_t8r :: [Either Double (Either Double (), Double)]
-task_t8r =
-    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 0.0 s, 0 - 3
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 1.0 s, 4 - 7
-     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 2.0 s, 8 - 11
-     Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 3.0 s, 12 - 15
-     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 4.0 s, 16 - 19
-     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 5.0 s, 20 - 23
-     Right (Left 24.0,24.0)]
-
-task_trs =
-    [ task_t0 ~= task_t0r,
-      task_t1 ~= task_t0r,	-- Intentionally! task_t0 = task_t1!
-      task_t2 ~= task_t2r,
-      task_t3 ~= task_t3r,
-      task_t4 ~= task_t4r,
-      task_t5 ~= task_t5r,
-      task_t6 ~= task_t6r,
-      task_t7 ~= task_t7r,
-      task_t8 ~= task_t8r
-    ]
-
-task_tr = and task_trs
+{- $Id: AFRPTestsTask.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsTask					     *+*       Purpose:        Test cases for tasks (AFRPTask)			     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- Very rudimentary testing of AFRPTask.++module AFRPTestsTask (task_tr, task_trs) where++import FRP.Yampa+import FRP.Yampa.Task++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for tasks (AFRPTask)+------------------------------------------------------------------------------++task_t0 = testSF1 (runTask (do+			       mkTask (localTime+			               &&&(localTime >>> arr (>=5.0) >>> edge))+			       x <- snapT+			       return (x * 2.0))+                 )++task_t0r =+    [Left 0.0,   Left 0.25,  Left 0.5,   Left 0.75,  Left 1.0,+     Left 1.25,  Left 1.5,   Left 1.75,  Left 2.0,   Left 2.25,+     Left 2.5,   Left 2.75,  Left 3.0,   Left 3.25,  Left 3.5,+     Left 3.75,  Left 4.0,   Left 4.25,  Left 4.5,   Left 4.75,+     Right 40.0, Right 40.0, Right 40.0, Right 40.0, Right 40.0]+++task_t1 = testSF1 (runTask (do+			       mkTask (localTime+			               &&& (localTime>>>arr (>=5.0) >>> edge))+			       return ()   -- No time should pass!+			       return ()   -- No Time should pass!+			       snapT	   -- No time should pass!+                               snapT	   -- No time should pass!+			       x <- snapT+			       return (x * 2.0))+                 )+++task_t2 = testSF1 (runTask (do+			       sleepT 1.51 42.0+			       x <- snapT+			       y <- snapT+			       sleepT 1.51 x+			       if x == y then+			           sleepT 1.51 (x * 2)+				else+				   sleepT 0.51 (x * 3)+			  )+		 )++task_t2r =+    [Left 42.0, Left 42.0, Left 42.0, Left 42.0,	-- 0.0 s+     Left 42.0, Left 42.0, Left 42.0, Left 7.0,		-- 1.0 s+     Left 7.0,	Left 7.0,  Left 7.0,  Left 7.0,		-- 2.0 s+     Left 7.0,	Left 7.0,  Left 14.0, Left 14.0,	-- 3.0 s+     Left 14.0,	Left 14.0, Left 14.0, Left 14.0,	-- 4.0 s+     Left 14.0,	Right (),  Right (),  Right (),		-- 5.0 s+     Right ()]+++task_t3 = testSF1 (runTask (do+			      c <- sawtooth `timeOut` 3.49+			      case c of+			          Nothing -> sleepT 1.51 (-10.0)+				  Just x  -> sleepT 1.51 x+			  )+		 )+    where+        sawtooth =+	    forEver ((mkTask (constant 2.0 >>> integral &&& never))+	             `timeOut` 1.5)++task_t3r :: [Either Double ()]	    +task_t3r =+    [Left 0.0,     Left 0.5,     Left 1.0,     Left 1.5,	-- 0.0 s+     Left 2.0,     Left 2.5,     Left 0.0,     Left 0.5,	-- 1.0 s+     Left 1.0,     Left 1.5,     Left 2.0,     Left 2.5,	-- 2.0 s+     Left 0.0,     Left 0.5,     Left (-10.0), Left (-10.0),	-- 3.0 s+     Left (-10.0), Left (-10.0), Left (-10.0), Left (-10.0),	-- 4.0 s+     Left (-10.0), Right (),	 Right (),     Right (),	-- 5.0 s+     Right ()]+++task_t4 = testSF1 (runTask (do+			      c <- sawtooth `timeOut` 3.49+			      case c of+			          Nothing -> sleepT 1.51 (-10.0)+				  Just x  -> sleepT 1.51 x+			  )+		 )+    where+        sawtooth = do+	    for 1 (+1) (<=2)+                ((mkTask (constant 2.0 >>> integral &&& never))+		 `timeOut` 1.5)+	    return (-42.0)++task_t4r :: [Either Double ()]+task_t4r =+    [Left 0.0,     Left 0.5,     Left 1.0,     Left 1.5,	-- 0.0 s+     Left 2.0,     Left 2.5,     Left 0.0,     Left 0.5,	-- 1.0 s+     Left 1.0,     Left 1.5,     Left 2.0,     Left 2.5,	-- 2.0 s+     Left (-42.0), Left (-42.0), Left (-42.0), Left (-42.0),	-- 3.0 s+     Left (-42.0), Left (-42.0), Left (-42.0), Right (),	-- 4.0 s+     Right (),	   Right (),	 Right (),     Right (),	-- 5.0 s+     Right ()]+++task_t5 = testSF1 (runTask (do+			      x<-(sawtoothCycle>>snapT) `repeatUntil` (>=20.0)+			      y<-snapT+			      return (x == y)+			  )+		 )+    where+	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())++task_t5r :: [Either Double Bool]+task_t5r =+    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 0.0 s, 0 - 3+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 1.0 s, 4 - 7+     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 2.0 s, 8 - 11+     Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 3.0 s, 12 - 15+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 4.0 s, 16 - 19,+     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 5.0 s, 20 - 23+     Right True]+++task_t6 = testSF1 $ runTask $+    do+        x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))+	     `abortWhen` (localTime >>> arr (>=3.51) >>> edge)+        y <- snapT+	return (x,y)+    where+	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())++task_t6r :: [Either Double (Either Double (), Double)]+task_t6r =+    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,		-- 0.0 s, 0 - 3+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,		-- 1.0 s, 4 - 7+     Left 1.0, Left 1.5, Left 2.0, Left 2.5,		-- 2.0 s, 8 - 11+     Left 0.0, Left 0.5, Left 1.0, Right (Right (),15.0), -- 3.0 s, 12 - 15+     Right (Right (),15.0), Right (Right (),15.0),	-- 4.0 s, 16, 17+     Right (Right (),15.0), Right (Right (),15.0),	-- 4.5 s, 18, 19+     Right (Right (),15.0), Right (Right (),15.0),	-- 5.0 s, 20, 21+     Right (Right (),15.0), Right (Right (),15.0),	-- 5.5 s, 22, 23+     Right (Right (),15.0)]++task_t7 = testSF1 $ runTask $+    do+        x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))+	     `abortWhen` (localTime >>> arr (>=5.75) >>> edge)+        y <- snapT+	return (x,y)+    where+	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())++task_t7r :: [Either Double (Either Double (), Double)]+task_t7r =+    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 0.0 s, 0 - 3+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 1.0 s, 4 - 7+     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 2.0 s, 8 - 11+     Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 3.0 s, 12 - 15+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 4.0 s, 16 - 19+     Left 1.0, Left 1.5, Left 2.0, Right (Right (),23.0), -- 5.0 s, 20 - 23+     Right (Right (),23.0)]++task_t8 = testSF1 $ runTask $+    do+        x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))+	     `abortWhen` (localTime >>> arr (>=5.76) >>> edge)+        y <- snapT+	return (x,y)+    where+	sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())++-- Since abortWhen uses lMergeEvent, the terminating event of the task+-- gets priority over the aborting event.+task_t8r :: [Either Double (Either Double (), Double)]+task_t8r =+    [Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 0.0 s, 0 - 3+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 1.0 s, 4 - 7+     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 2.0 s, 8 - 11+     Left 0.0, Left 0.5, Left 1.0, Left 1.5,	-- 3.0 s, 12 - 15+     Left 2.0, Left 2.5, Left 0.0, Left 0.5,	-- 4.0 s, 16 - 19+     Left 1.0, Left 1.5, Left 2.0, Left 2.5,	-- 5.0 s, 20 - 23+     Right (Left 24.0,24.0)]++task_trs =+    [ task_t0 ~= task_t0r,+      task_t1 ~= task_t0r,	-- Intentionally! task_t0 = task_t1!+      task_t2 ~= task_t2r,+      task_t3 ~= task_t3r,+      task_t4 ~= task_t4r,+      task_t5 ~= task_t5r,+      task_t6 ~= task_t6r,+      task_t7 ~= task_t7r,+      task_t8 ~= task_t8r+    ]++task_tr = and task_trs
tests/AFRPTestsUtils.hs view
@@ -1,276 +1,369 @@-{- $Id: AFRPTestsUtils.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsUtils					     *
-*       Purpose:        Test cases for utilities (AFRPUtilities)	     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
--- Not really intended to test all definitions in the utilities module.
-
-module AFRPTestsUtils (utils_tr, utils_trs) where
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-import AFRPUtilities
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for utilities (AFRPUtils)
-------------------------------------------------------------------------------
-
--- Should re-order these test cases to reflect the order in AFRPUtils
--- at some point.
-
-utils_inp1 = deltaEncode 1.0 $
-    [NoEvent,   NoEvent,   Event 1.0, NoEvent,
-     Event 2.0, NoEvent,   NoEvent,   NoEvent,
-     Event 3.0, Event 4.0, Event 4.0, NoEvent,
-     Event 0.0, NoEvent,   NoEvent,   NoEvent]
-    ++ repeat NoEvent
-
-
-utils_inp2 = deltaEncode 1.0 $
-    [Event 1.0, NoEvent,   NoEvent,   NoEvent,
-     Event 2.0, NoEvent,   NoEvent,   NoEvent,
-     Event 3.0, Event 4.0, Event 4.0, NoEvent,
-     Event 0.0, NoEvent,   NoEvent,   NoEvent]
-    ++ repeat NoEvent
-
-
-utils_t0 :: [Double]
-utils_t0 = take 16 $ embed (dHold 99.99) utils_inp1
-
-utils_t0r =
-    [99.99, 99.99, 99.99, 1.0,
-     1.0,   2.0,   2.0,   2.0,
-     2.0,   3.0,   4.0,   4.0,
-     4.0,   0.0,   0.0,   0.0]
-
-utils_t1 :: [Double]
-utils_t1 = take 16 $ embed (dHold 99.99) utils_inp2
-
-utils_t1r =
-    [99.99, 1.0, 1.0, 1.0,
-     1.0,   2.0, 2.0, 2.0,
-     2.0,   3.0, 4.0, 4.0,
-     4.0,   0.0, 0.0, 0.0]
-
-
-utils_inp3 = deltaEncode 1.0 $
-    [Nothing,  Nothing,  Just 1.0, Just 2.0, Just 3.0,
-     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,
-     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,
-     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]
-    ++ repeat Nothing
-
-utils_inp4 = deltaEncode 1.0 $
-    [Just 0.0, Nothing,  Just 1.0, Just 2.0, Just 3.0,
-     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,
-     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,
-     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]
-    ++ repeat Nothing
-
-
-utils_t2 :: [Double]
-utils_t2 = take 25 $ embed (dTrackAndHold 99.99) utils_inp3
-
-utils_t2r =
-    [99.99, 99.99, 99.99, 1.0, 2.0,
-     3.0,   4.0,   4.0,   4.0, 4.0,
-     3.0,   2.0,   2.0,   1.0, 0.0,
-     1.0,   2.0,   3.0,   3.0, 3.0,
-     4.0,   4.0,   4.0,   4.0, 4.0]
-
-utils_t3 :: [Double]
-utils_t3 = take 25 $ embed (dTrackAndHold 99.99) utils_inp4
-
-utils_t3r =
-    [99.99, 0.0, 0.0, 1.0, 2.0,
-     3.0,   4.0, 4.0, 4.0, 4.0,
-     3.0,   2.0, 2.0, 1.0, 0.0,
-     1.0,   2.0, 3.0, 3.0, 3.0,
-     4.0,   4.0, 4.0, 4.0, 4.0]
-
-
-utils_t4 :: [Event Int]
-utils_t4 = take 16 $ embed count utils_inp1
-
-utils_t4r :: [Event Int]
-utils_t4r = 
-    [NoEvent, NoEvent, Event 1, NoEvent,
-     Event 2, NoEvent, NoEvent, NoEvent,
-     Event 3, Event 4, Event 5, NoEvent,
-     Event 6, NoEvent, NoEvent, NoEvent]
-
-
-utils_t5 :: [Event Int]
-utils_t5 = take 16 $ embed count utils_inp2
-
-utils_t5r :: [Event Int]
-utils_t5r = 
-    [Event 1, NoEvent, NoEvent, NoEvent,
-     Event 2, NoEvent, NoEvent, NoEvent,
-     Event 3, Event 4, Event 5, NoEvent,
-     Event 6, NoEvent, NoEvent, NoEvent]
-
-
-dynDelayLine :: a -> SF (a, Event Bool) a
-dynDelayLine a0 =
-    second (arr (fmap (\p -> if p then addDelay else delDelay)))
-    >>> loop (arr (\((a, e), as) -> (a:as, e))
-              >>> rpSwitchZ [iPre a0]
-              >>> arr (\as -> (last as, init as)))
-    where
-	addDelay ds = ds ++ [last ds]
-
-        delDelay [d] = [d]
-        delDelay ds  = init ds
-
-utils_t6 :: [Int]
-utils_t6 = take 200 $ embed (dynDelayLine 0)
-			    (deltaEncode 0.1 (zip [1..] evSeq))
-    where
-	evSeq = NoEvent : Event True : NoEvent : NoEvent : Event True :
-		NoEvent : NoEvent : Event False : evSeq
-
-utils_t6r =
-    [0,1,1,2,3,3,4,6,7,8,8,9,10,10,11,13,14,15,15,16,17,17,18,20,21,22,22,23,
-     24,24,25,27,28,29,29,30,31,31,32,34,35,36,36,37,38,38,39,41,42,43,43,44,
-     45,45,46,48,49,50,50,51,52,52,53,55,56,57,57,58,59,59,60,62,63,64,64,65,
-     66,66,67,69,70,71,71,72,73,73,74,76,77,78,78,79,80,80,81,83,84,85,85,86,
-     87,87,88,90,91,92,92,93,94,94,95,97,98,99,99,100,101,101,102,104,105,106,
-     106,107,108,108,109,111,112,113,113,114,115,115,116,118,119,120,120,121,
-     122,122,123,125,126,127,127,128,129,129,130,132,133,134,134,135,136,136,
-     137,139,140,141,141,142,143,143,144,146,147,148,148,149,150,150,151,153,
-     154,155,155,156,157,157,158,160,161,162,162,163,164,164,165,167,168,169,
-     169,170,171,171,172,174]
-
-utils_t7 :: [Double]
-utils_t7 = take 50 $ embed impulseIntegral
-                           (deltaEncode 0.1 (zip (repeat 1.0) evSeq))
-    where
-	evSeq = replicate 9 NoEvent ++ [Event 10.0]
-		++ replicate 9 NoEvent ++ [Event (-10.0)]
-		++ evSeq
-
-utils_t7r =
-    [ 0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8, 10.9,
-     11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8,  1.9,
-      2.0,  2.1,  2.2,  2.3,  2.4,  2.5,  2.6,  2.7,  2.8, 12.9,
-     13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8,  3.9,
-      4.0,  4.1,  4.2,  4.3,  4.4,  4.5,  4.6,  4.7,  4.8, 14.9]
-
-
-utils_t8 :: [Double]
-utils_t8 = take 50 $ embed (provided (even . floor) integral (constant (-1)))
-                           (deltaEncode 0.1 input)
-    where
-	input = replicate 10 1
-		++ replicate 10 2
-		++ replicate 10 3
-		++ replicate 10 4
-		++ input
-
-utils_t8r =
-    [-1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,
-      0.0,  0.2,  0.4,  0.6,  0.8,  1.0,  1.2,  1.4,  1.6,  1.8,
-     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,
-      0.0,  0.4,  0.8,  1.2,  1.6,  2.0,  2.4,  2.8,  3.2,  3.6,
-     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0]
-
-
-utils_t9 :: [Double]
-utils_t9 = take 50 $ embed (provided (odd . floor) integral (constant (-1)))
-                           (deltaEncode 0.1 input)
-    where
-	input = replicate 10 1
-		++ replicate 10 2
-		++ replicate 10 3
-		++ replicate 10 4
-		++ input
-
-utils_t9r =
-    [ 0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8,  0.9,
-     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,
-      0.0,  0.3,  0.6,  0.9,  1.2,  1.5,  1.8,  2.1,  2.4,  2.7,
-     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,
-      0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8,  0.9]
-
-
-utils_t10 :: [Event Double]
-utils_t10 = testSF1 snap
-
-utils_t10r =
-    [Event 0.0, NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-utils_t11 :: [Event Double]
-utils_t11 = testSF1 (snapAfter 2.6)
-
-utils_t11r =
-    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     NoEvent, NoEvent, NoEvent, Event 11.0,	-- 2.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     NoEvent, NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     NoEvent]
-
-
-utils_t12 :: [Event Double]
-utils_t12 = testSF1 (sample 0.99)
-
-utils_t12r =
-    [NoEvent,    NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     Event 4.0,  NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     Event 8.0,  NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     Event 12.0, NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     Event 16.0, NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     Event 20.0, NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     Event 24.0]
-
-
-utils_t13 :: [Event ()]
-utils_t13 = testSF1 (recur (after 0.99 ()))
-
-utils_t13r =
-    [NoEvent,  NoEvent, NoEvent, NoEvent,	-- 0.0 s
-     Event (), NoEvent, NoEvent, NoEvent,	-- 1.0 s
-     Event (), NoEvent, NoEvent, NoEvent,	-- 2.0 s
-     Event (), NoEvent, NoEvent, NoEvent,	-- 3.0 s
-     Event (), NoEvent, NoEvent, NoEvent,	-- 4.0 s
-     Event (), NoEvent, NoEvent, NoEvent,	-- 5.0 s
-     Event ()]
-
-
-utils_trs =
-    [ utils_t0 ~= utils_t0r,
-      utils_t1 ~= utils_t1r,
-      utils_t2 ~= utils_t2r,
-      utils_t3 ~= utils_t3r,
-      utils_t4 ~= utils_t4r,
-      utils_t5 ~= utils_t5r,
-      utils_t6 ~= utils_t6r,
-      utils_t7 ~= utils_t7r,
-      utils_t8 ~= utils_t8r,
-      utils_t9 ~= utils_t9r,
-      utils_t10 ~= utils_t10r,
-      utils_t11 ~= utils_t11r,
-      utils_t12 ~= utils_t12r,
-      utils_t13 ~= utils_t13r
-    ]
-
-utils_tr = and utils_trs
+{- $Id: AFRPTestsUtils.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsUtils					     *+*       Purpose:        Test cases for utilities (AFRPUtilities)	     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++-- Not really intended to test all definitions in the utilities module.++module AFRPTestsUtils (utils_tr, utils_trs) where++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))+import FRP.Yampa.Utilities++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for utilities (AFRPUtils)+------------------------------------------------------------------------------++-- Should re-order these test cases to reflect the order in AFRPUtils+-- at some point.++utils_inp1 = deltaEncode 1.0 $+    [NoEvent,   NoEvent,   Event 1.0, NoEvent,+     Event 2.0, NoEvent,   NoEvent,   NoEvent,+     Event 3.0, Event 4.0, Event 4.0, NoEvent,+     Event 0.0, NoEvent,   NoEvent,   NoEvent]+    ++ repeat NoEvent+++utils_inp2 = deltaEncode 1.0 $+    [Event 1.0, NoEvent,   NoEvent,   NoEvent,+     Event 2.0, NoEvent,   NoEvent,   NoEvent,+     Event 3.0, Event 4.0, Event 4.0, NoEvent,+     Event 0.0, NoEvent,   NoEvent,   NoEvent]+    ++ repeat NoEvent+++utils_t0 :: [Double]+utils_t0 = take 16 $ embed (dHold 99.99) utils_inp1++utils_t0r =+    [99.99, 99.99, 99.99, 1.0,+     1.0,   2.0,   2.0,   2.0,+     2.0,   3.0,   4.0,   4.0,+     4.0,   0.0,   0.0,   0.0]++utils_t1 :: [Double]+utils_t1 = take 16 $ embed (dHold 99.99) utils_inp2++utils_t1r =+    [99.99, 1.0, 1.0, 1.0,+     1.0,   2.0, 2.0, 2.0,+     2.0,   3.0, 4.0, 4.0,+     4.0,   0.0, 0.0, 0.0]+++utils_inp3 = deltaEncode 1.0 $+    [Nothing,  Nothing,  Just 1.0, Just 2.0, Just 3.0,+     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,+     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,+     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]+    ++ repeat Nothing++utils_inp4 = deltaEncode 1.0 $+    [Just 0.0, Nothing,  Just 1.0, Just 2.0, Just 3.0,+     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,+     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,+     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]+    ++ repeat Nothing+++utils_t2 :: [Double]+utils_t2 = take 25 $ embed (dTrackAndHold 99.99) utils_inp3++utils_t2r =+    [99.99, 99.99, 99.99, 1.0, 2.0,+     3.0,   4.0,   4.0,   4.0, 4.0,+     3.0,   2.0,   2.0,   1.0, 0.0,+     1.0,   2.0,   3.0,   3.0, 3.0,+     4.0,   4.0,   4.0,   4.0, 4.0]++utils_t3 :: [Double]+utils_t3 = take 25 $ embed (dTrackAndHold 99.99) utils_inp4++utils_t3r =+    [99.99, 0.0, 0.0, 1.0, 2.0,+     3.0,   4.0, 4.0, 4.0, 4.0,+     3.0,   2.0, 2.0, 1.0, 0.0,+     1.0,   2.0, 3.0, 3.0, 3.0,+     4.0,   4.0, 4.0, 4.0, 4.0]+++utils_t4 :: [Event Int]+utils_t4 = take 16 $ embed count utils_inp1++utils_t4r :: [Event Int]+utils_t4r = +    [NoEvent, NoEvent, Event 1, NoEvent,+     Event 2, NoEvent, NoEvent, NoEvent,+     Event 3, Event 4, Event 5, NoEvent,+     Event 6, NoEvent, NoEvent, NoEvent]+++utils_t5 :: [Event Int]+utils_t5 = take 16 $ embed count utils_inp2++utils_t5r :: [Event Int]+utils_t5r = +    [Event 1, NoEvent, NoEvent, NoEvent,+     Event 2, NoEvent, NoEvent, NoEvent,+     Event 3, Event 4, Event 5, NoEvent,+     Event 6, NoEvent, NoEvent, NoEvent]+++dynDelayLine :: a -> SF (a, Event Bool) a+dynDelayLine a0 =+    second (arr (fmap (\p -> if p then addDelay else delDelay)))+    >>> loop (arr (\((a, e), as) -> (a:as, e))+              >>> rpSwitchZ [iPre a0]+              >>> arr (\as -> (last as, init as)))+    where+	addDelay ds = ds ++ [last ds]++        delDelay [d] = [d]+        delDelay ds  = init ds++utils_t6 :: [Int]+utils_t6 = take 200 $ embed (dynDelayLine 0)+			    (deltaEncode 0.1 (zip [1..] evSeq))+    where+	evSeq = NoEvent : Event True : NoEvent : NoEvent : Event True :+		NoEvent : NoEvent : Event False : evSeq++utils_t6r =+    [0,1,1,2,3,3,4,6,7,8,8,9,10,10,11,13,14,15,15,16,17,17,18,20,21,22,22,23,+     24,24,25,27,28,29,29,30,31,31,32,34,35,36,36,37,38,38,39,41,42,43,43,44,+     45,45,46,48,49,50,50,51,52,52,53,55,56,57,57,58,59,59,60,62,63,64,64,65,+     66,66,67,69,70,71,71,72,73,73,74,76,77,78,78,79,80,80,81,83,84,85,85,86,+     87,87,88,90,91,92,92,93,94,94,95,97,98,99,99,100,101,101,102,104,105,106,+     106,107,108,108,109,111,112,113,113,114,115,115,116,118,119,120,120,121,+     122,122,123,125,126,127,127,128,129,129,130,132,133,134,134,135,136,136,+     137,139,140,141,141,142,143,143,144,146,147,148,148,149,150,150,151,153,+     154,155,155,156,157,157,158,160,161,162,162,163,164,164,165,167,168,169,+     169,170,171,171,172,174]++utils_t7 :: [Double]+utils_t7 = take 50 $ embed impulseIntegral+                           (deltaEncode 0.1 (zip (repeat 1.0) evSeq))+    where+	evSeq = replicate 9 NoEvent ++ [Event 10.0]+		++ replicate 9 NoEvent ++ [Event (-10.0)]+		++ evSeq++utils_t7r =+    [ 0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8, 10.9,+     11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8,  1.9,+      2.0,  2.1,  2.2,  2.3,  2.4,  2.5,  2.6,  2.7,  2.8, 12.9,+     13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8,  3.9,+      4.0,  4.1,  4.2,  4.3,  4.4,  4.5,  4.6,  4.7,  4.8, 14.9]+++utils_t8 :: [Double]+utils_t8 = take 50 $ embed (provided (even . floor) integral (constant (-1)))+                           (deltaEncode 0.1 input)+    where+	input = replicate 10 1+		++ replicate 10 2+		++ replicate 10 3+		++ replicate 10 4+		++ input++utils_t8r =+    [-1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,+      0.0,  0.2,  0.4,  0.6,  0.8,  1.0,  1.2,  1.4,  1.6,  1.8,+     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,+      0.0,  0.4,  0.8,  1.2,  1.6,  2.0,  2.4,  2.8,  3.2,  3.6,+     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0]+++utils_t9 :: [Double]+utils_t9 = take 50 $ embed (provided (odd . floor) integral (constant (-1)))+                           (deltaEncode 0.1 input)+    where+	input = replicate 10 1+		++ replicate 10 2+		++ replicate 10 3+		++ replicate 10 4+		++ input++utils_t9r =+    [ 0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8,  0.9,+     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,+      0.0,  0.3,  0.6,  0.9,  1.2,  1.5,  1.8,  2.1,  2.4,  2.7,+     -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0,+      0.0,  0.1,  0.2,  0.3,  0.4,  0.5,  0.6,  0.7,  0.8,  0.9]+++utils_t10 :: [Event Double]+utils_t10 = testSF1 snap++utils_t10r =+    [Event 0.0, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 2.0 s+     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent,   NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++utils_t11 :: [Event Double]+utils_t11 = testSF1 (snapAfter 2.6)++utils_t11r =+    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent, Event 11.0,	-- 2.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]+++utils_t12 :: [Event Double]+utils_t12 = testSF1 (sample 0.99)++utils_t12r =+    [NoEvent,    NoEvent, NoEvent, NoEvent,	-- 0.0 s+     Event 4.0,  NoEvent, NoEvent, NoEvent,	-- 1.0 s+     Event 8.0,  NoEvent, NoEvent, NoEvent,	-- 2.0 s+     Event 12.0, NoEvent, NoEvent, NoEvent,	-- 3.0 s+     Event 16.0, NoEvent, NoEvent, NoEvent,	-- 4.0 s+     Event 20.0, NoEvent, NoEvent, NoEvent,	-- 5.0 s+     Event 24.0]+++utils_t13 :: [Event ()]+utils_t13 = testSF1 (recur (after 0.99 ()))++utils_t13r =+    [NoEvent,  NoEvent, NoEvent, NoEvent,	-- 0.0 s+     Event (), NoEvent, NoEvent, NoEvent,	-- 1.0 s+     Event (), NoEvent, NoEvent, NoEvent,	-- 2.0 s+     Event (), NoEvent, NoEvent, NoEvent,	-- 3.0 s+     Event (), NoEvent, NoEvent, NoEvent,	-- 4.0 s+     Event (), NoEvent, NoEvent, NoEvent,	-- 5.0 s+     Event ()]+++utils_t14 :: [Event Int]+utils_t14 = testSF1 (after 1.0 1 `andThen` now 2 `andThen` after 2.0 3)++utils_t14r =+    [NoEvent, NoEvent, NoEvent, NoEvent,	-- 0.0 s+     Event 1, NoEvent, NoEvent, NoEvent,	-- 1.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 2.0 s+     Event 3, NoEvent, NoEvent, NoEvent,	-- 3.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 4.0 s+     NoEvent, NoEvent, NoEvent, NoEvent,	-- 5.0 s+     NoEvent]++utils_t15 = take 50 (embed (time >>> sampleWindow 5 0.5)+                           (deltaEncode 0.125 (repeat ())))++utils_t15r =+    [ NoEvent,                     NoEvent, NoEvent, NoEvent,	-- 0.0 s+      Event [0.5],                 NoEvent, NoEvent, NoEvent,	-- 0.5 s+      Event [0.5,1.0],             NoEvent, NoEvent, NoEvent,	-- 1.0 s+      Event [0.5,1.0,1.5],         NoEvent, NoEvent, NoEvent,	-- 1.5 s+      Event [0.5,1.0,1.5,2.0],     NoEvent, NoEvent, NoEvent, 	-- 2.0 s+      Event [0.5,1.0,1.5,2.0,2.5], NoEvent, NoEvent, NoEvent,	-- 2.5 s+      Event [1.0,1.5,2.0,2.5,3.0], NoEvent, NoEvent, NoEvent,	-- 3.0 s+      Event [1.5,2.0,2.5,3.0,3.5], NoEvent, NoEvent, NoEvent,	-- 3.5 s+      Event [2.0,2.5,3.0,3.5,4.0], NoEvent, NoEvent, NoEvent,	-- 4.0 s+      Event [2.5,3.0,3.5,4.0,4.5], NoEvent, NoEvent, NoEvent,	-- 4.5 s+      Event [3.0,3.5,4.0,4.5,5.0], NoEvent, NoEvent, NoEvent,	-- 5.0 s+      Event [3.5,4.0,4.5,5.0,5.5], NoEvent, NoEvent, NoEvent,	-- 5.5 s+      Event [4.0,4.5,5.0,5.5,6.0], NoEvent			-- 6.0 s+    ]+++{-+-- Not robust+utils_t16 = take 50 (embed (time >>> sampleWindow 5 0.5) input)+    where+        input = ((), [(dt, Just ()) | dt <- dts])++        dts = replicate 15 0.1+              ++ [1.0, 1.0]+              ++ replicate 15 0.1+              ++ [2.0]+              ++ replicate 10 0.1++utils_t16r =+    [ NoEvent, NoEvent,          NoEvent, NoEvent, NoEvent,		-- 0.0+      NoEvent, Event [0.6],      NoEvent, NoEvent, NoEvent,		-- 0.5+      NoEvent, Event [0.6, 1.1], NoEvent, NoEvent, NoEvent,		-- 1.0+      NoEvent,								-- 1.5+      Event [0.6,1.1,2.5,2.5,2.5],               			-- 2.5+      Event [2.5,2.5,2.5,3.5,3.5], NoEvent, NoEvent, NoEvent, NoEvent,	-- 3.5+      NoEvent, Event [2.5,2.5,3.5,3.5,4.1], NoEvent, NoEvent, NoEvent,  -- 4.0+      NoEvent, Event [2.5,3.5,3.5,4.1,4.6], NoEvent, NoEvent, NoEvent,	-- 4.5+      NoEvent,								-- 5.0+      Event [7.0,7.0,7.0,7.0,7.0], NoEvent, NoEvent, NoEvent, NoEvent,	-- 7.0+      NoEvent, Event [7.0,7.0,7.0,7.0,7.6], NoEvent, NoEvent, NoEvent,	-- 7.5+      NoEvent								-- 8.0+    ]+-}++utils_t16 = take 50 (embed (time >>> sampleWindow 5 0.4999) input)+    where+        input = ((), [(dt, Just ()) | dt <- dts])++        dts = replicate 15 0.1+              ++ [1.0, 1.0]+              ++ replicate 15 0.1+              ++ [2.0]+              ++ replicate 10 0.1++utils_t16r =+    [ NoEvent,          NoEvent, NoEvent, NoEvent, NoEvent,		-- 0.0+      Event [0.5],      NoEvent, NoEvent, NoEvent, NoEvent,		-- 0.5+      Event [0.5, 1.0], NoEvent, NoEvent, NoEvent, NoEvent,		-- 1.0+      Event [0.5, 1.0, 1.5],						-- 1.5+      Event [0.5, 1.0, 1.5, 2.5, 2.5],         				-- 2.5+      Event [1.5, 2.5, 2.5, 3.5, 3.5], NoEvent, NoEvent, NoEvent,	-- 3.5+                                                         NoEvent,+      Event [2.5, 2.5, 3.5, 3.5, 4.0], NoEvent, NoEvent, NoEvent,  	-- 4.0+      							 NoEvent,+      Event [2.5, 3.5, 3.5, 4.0, 4.5], NoEvent, NoEvent, NoEvent,	-- 4.5+							 NoEvent,+      Event [3.5, 3.5, 4.0, 4.5, 5.0],					-- 5.0+      Event [5.0, 7.0, 7.0, 7.0, 7.0], NoEvent, NoEvent, NoEvent,	-- 7.0+							 NoEvent,+      Event [7.0, 7.0, 7.0, 7.0, 7.5], NoEvent, NoEvent, NoEvent,	-- 7.5+							 NoEvent,+      Event [7.0, 7.0, 7.0, 7.5, 8.0]					-- 8.0+    ]++utils_trs =+    [ utils_t0 ~= utils_t0r,+      utils_t1 ~= utils_t1r,+      utils_t2 ~= utils_t2r,+      utils_t3 ~= utils_t3r,+      utils_t4 ~= utils_t4r,+      utils_t5 ~= utils_t5r,+      utils_t6 ~= utils_t6r,+      utils_t7 ~= utils_t7r,+      utils_t8 ~= utils_t8r,+      utils_t9 ~= utils_t9r,+      utils_t10 ~= utils_t10r,+      utils_t11 ~= utils_t11r,+      utils_t12 ~= utils_t12r,+      utils_t13 ~= utils_t13r,+      utils_t14 ~= utils_t14r,+      utils_t15 ~= utils_t15r,+      utils_t16 ~= utils_t16r+    ]++utils_tr = and utils_trs
tests/AFRPTestsWFG.hs view
@@ -1,103 +1,103 @@-{- $Id: AFRPTestsWFG.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         AFRPTestsWFG					     *
-*       Purpose:        Test cases for wave-form generation		     *
-*	Authors:	Antony Courtney and Henrik Nilsson		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-
-module AFRPTestsWFG (wfg_tr, wfg_trs) where
-
-import AFRP
-import AFRPInternals (Event(NoEvent, Event))
-
-import AFRPTestsCommon
-
-------------------------------------------------------------------------------
--- Test cases for wave-form generation
-------------------------------------------------------------------------------
-
-wfg_inp1 = deltaEncode 1.0 $
-    [NoEvent,   NoEvent,   Event 1.0, NoEvent,
-     Event 2.0, NoEvent,   NoEvent,   NoEvent,
-     Event 3.0, Event 4.0, Event 4.0, NoEvent,
-     Event 0.0, NoEvent,   NoEvent,   NoEvent]
-    ++ repeat NoEvent
-
-
-wfg_inp2 = deltaEncode 1.0 $
-    [Event 1.0, NoEvent,   NoEvent,   NoEvent,
-     Event 2.0, NoEvent,   NoEvent,   NoEvent,
-     Event 3.0, Event 4.0, Event 4.0, NoEvent,
-     Event 0.0, NoEvent,   NoEvent,   NoEvent]
-    ++ repeat NoEvent
-
-
-wfg_t0 :: [Double]
-wfg_t0 = take 16 $ embed (hold 99.99) wfg_inp1
-
-wfg_t0r =
-    [99.99, 99.99, 1.0, 1.0,
-     2.0,   2.0,   2.0, 2.0,
-     3.0,   4.0,   4.0, 4.0,
-     0.0,   0.0,   0.0, 0.0]
-
-wfg_t1 :: [Double]
-wfg_t1 = take 16 $ embed (hold 99.99) wfg_inp2
-
-wfg_t1r =
-    [1.0, 1.0, 1.0, 1.0,
-     2.0, 2.0, 2.0, 2.0,
-     3.0, 4.0, 4.0, 4.0,
-     0.0, 0.0, 0.0, 0.0]
-
-wfg_inp3 = deltaEncode 1.0 $
-    [Nothing,  Nothing,  Just 1.0, Just 2.0, Just 3.0,
-     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,
-     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,
-     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]
-    ++ repeat Nothing
-
-wfg_inp4 = deltaEncode 1.0 $
-    [Just 0.0, Nothing,  Just 1.0, Just 2.0, Just 3.0,
-     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,
-     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,
-     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]
-    ++ repeat Nothing
-
-
-wfg_t2 :: [Double]
-wfg_t2 = take 25 $ embed (trackAndHold 99.99) wfg_inp3
-
-wfg_t2r =
-    [99.99, 99.99, 1.0, 2.0, 3.0,
-     4.0,   4.0,   4.0, 4.0, 3.0,
-     2.0,   2.0,   1.0, 0.0, 1.0,
-     2.0,   3.0,   3.0, 3.0, 4.0,
-     4.0,   4.0,   4.0, 4.0, 4.0]
-
-
-wfg_t3 :: [Double]
-wfg_t3 = take 25 $ embed (trackAndHold 99.99) wfg_inp4
-
-wfg_t3r =
-    [0.0, 0.0, 1.0, 2.0, 3.0,
-     4.0, 4.0, 4.0, 4.0, 3.0,
-     2.0, 2.0, 1.0, 0.0, 1.0,
-     2.0, 3.0, 3.0, 3.0, 4.0,
-     4.0, 4.0, 4.0, 4.0, 4.0]
-
-
-wfg_trs =
-    [ wfg_t0 ~= wfg_t0r,
-      wfg_t1 ~= wfg_t1r,
-      wfg_t2 ~= wfg_t2r,
-      wfg_t3 ~= wfg_t3r
-    ]
-
-wfg_tr = and wfg_trs
+{- $Id: AFRPTestsWFG.hs,v 1.2 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         AFRPTestsWFG					     *+*       Purpose:        Test cases for wave-form generation		     *+*	Authors:	Antony Courtney and Henrik Nilsson		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module AFRPTestsWFG (wfg_tr, wfg_trs) where++import FRP.Yampa+import FRP.Yampa.Internals (Event(NoEvent, Event))++import AFRPTestsCommon++------------------------------------------------------------------------------+-- Test cases for wave-form generation+------------------------------------------------------------------------------++wfg_inp1 = deltaEncode 1.0 $+    [NoEvent,   NoEvent,   Event 1.0, NoEvent,+     Event 2.0, NoEvent,   NoEvent,   NoEvent,+     Event 3.0, Event 4.0, Event 4.0, NoEvent,+     Event 0.0, NoEvent,   NoEvent,   NoEvent]+    ++ repeat NoEvent+++wfg_inp2 = deltaEncode 1.0 $+    [Event 1.0, NoEvent,   NoEvent,   NoEvent,+     Event 2.0, NoEvent,   NoEvent,   NoEvent,+     Event 3.0, Event 4.0, Event 4.0, NoEvent,+     Event 0.0, NoEvent,   NoEvent,   NoEvent]+    ++ repeat NoEvent+++wfg_t0 :: [Double]+wfg_t0 = take 16 $ embed (hold 99.99) wfg_inp1++wfg_t0r =+    [99.99, 99.99, 1.0, 1.0,+     2.0,   2.0,   2.0, 2.0,+     3.0,   4.0,   4.0, 4.0,+     0.0,   0.0,   0.0, 0.0]++wfg_t1 :: [Double]+wfg_t1 = take 16 $ embed (hold 99.99) wfg_inp2++wfg_t1r =+    [1.0, 1.0, 1.0, 1.0,+     2.0, 2.0, 2.0, 2.0,+     3.0, 4.0, 4.0, 4.0,+     0.0, 0.0, 0.0, 0.0]++wfg_inp3 = deltaEncode 1.0 $+    [Nothing,  Nothing,  Just 1.0, Just 2.0, Just 3.0,+     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,+     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,+     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]+    ++ repeat Nothing++wfg_inp4 = deltaEncode 1.0 $+    [Just 0.0, Nothing,  Just 1.0, Just 2.0, Just 3.0,+     Just 4.0, Nothing,  Nothing,  Nothing,  Just 3.0,+     Just 2.0, Nothing,  Just 1.0, Just 0.0, Just 1.0,+     Just 2.0, Just 3.0, Nothing,  Nothing,  Just 4.0]+    ++ repeat Nothing+++wfg_t2 :: [Double]+wfg_t2 = take 25 $ embed (trackAndHold 99.99) wfg_inp3++wfg_t2r =+    [99.99, 99.99, 1.0, 2.0, 3.0,+     4.0,   4.0,   4.0, 4.0, 3.0,+     2.0,   2.0,   1.0, 0.0, 1.0,+     2.0,   3.0,   3.0, 3.0, 4.0,+     4.0,   4.0,   4.0, 4.0, 4.0]+++wfg_t3 :: [Double]+wfg_t3 = take 25 $ embed (trackAndHold 99.99) wfg_inp4++wfg_t3r =+    [0.0, 0.0, 1.0, 2.0, 3.0,+     4.0, 4.0, 4.0, 4.0, 3.0,+     2.0, 2.0, 1.0, 0.0, 1.0,+     2.0, 3.0, 3.0, 3.0, 4.0,+     4.0, 4.0, 4.0, 4.0, 4.0]+++wfg_trs =+    [ wfg_t0 ~= wfg_t0r,+      wfg_t1 ~= wfg_t1r,+      wfg_t2 ~= wfg_t2r,+      wfg_t3 ~= wfg_t3r+    ]++wfg_tr = and wfg_trs
tests/testAFRP.cabal view
@@ -2,7 +2,7 @@ Version:            0.0 Description:        Tests for Yampa functions. License:            BSD3-License-File:       ../LICENSE.txt+License-File:       ../LICENSE Copyright:          Henrik Nilsson, Antony Courtney and Yale University, (c) 2003 Author:             Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson Maintainer:         Antony Courtney	<antony@apocalypse.org>, Paul Hudak	<paul.hudak@yale.edu>, Henrik Nilsson	<nilsson@cs.yale.edu>, John Peterson	<peterson-john@cs.yale.edu>@@ -10,36 +10,36 @@ Homepage:           http://www.haskell.org/yampa/ Category:           Reactivity, FRP Synopsis:           Tests for Yampa functions.--Build-Depends:       base, haskell98, Yampa >= 0.9.1 && < 0.9.2+Build-Depends:       base, Yampa >= 0.9.2  Executable:          testAFRP Main-is:             testAFRPMain.hs ghc-options:         -O -fglasgow-exts -Other-modules:-    AFRPTests,-    AFRPTestsCommon,-    AFRPTestsArr,-    AFRPTestsComp,-    AFRPTestsFirstSecond,-    AFRPTestsLaws,-    AFRPTestsLoop,-    AFRPTestsLoopLaws,-    AFRPTestsBasicSF,-    AFRPTestsEvSrc,-    AFRPTestsCOC,-    AFRPTestsSwitch,-    AFRPTestsKSwitch,-    AFRPTestsRSwitch,-    AFRPTestsPSwitch,-    AFRPTestsRPSwitch,-    AFRPTestsWFG,-    AFRPTestsAccum,-    AFRPTestsDelay,-    AFRPTestsDer,-    AFRPTestsLoopPre,-    AFRPTestsLoopIntegral,-    AFRPTestsReact,-    AFRPTestsEmbed,-    AFRPTestsUtils,-    AFRPTestsTask+Other-modules:      AFRPTests,+                    AFRPTestsCommon,+                    AFRPTestsArr,+                    AFRPTestsComp,+                    AFRPTestsFirstSecond,+                    AFRPTestsLaws,+                    AFRPTestsLoop,+                    AFRPTestsLoopLaws,+                    AFRPTestsBasicSF,+                    AFRPTestsSscan,+                    AFRPTestsEvSrc,+                    AFRPTestsCOC,+                    AFRPTestsSwitch,+                    AFRPTestsKSwitch,+                    AFRPTestsRSwitch,+                    AFRPTestsPSwitch,+                    AFRPTestsRPSwitch,+                    AFRPTestsWFG,+                    AFRPTestsAccum,+                    AFRPTestsPre,+                    AFRPTestsDelay,+                    AFRPTestsDer,+                    AFRPTestsLoopPre,+                    AFRPTestsLoopIntegral,+                    AFRPTestsReact,+                    AFRPTestsEmbed,+                    AFRPTestsUtils,+                    AFRPTestsTask
tests/testAFRPMain.hs view
@@ -1,71 +1,71 @@-{- $Id: testAFRPMain.hs,v 1.9 2003/11/10 21:28:58 antony Exp $
-******************************************************************************
-*                                  A F R P                                   *
-*                                                                            *
-*       Module:         testAFRPMain                                         *
-*       Purpose:        Main driver routine for running tests.               *
-*	Authors:	Henrik Nilsson and Antony Courtney		     *
-*                                                                            *
-*             Copyright (c) Yale University, 2003                            *
-*                                                                            *
-******************************************************************************
--}
-module Main where
-
-import AFRPTests
-
-import IO
-import System -- getArgs
-
--- main = runTests
--- main = runSpaceTests
-
-data TestFlags = TestFlags { tReg :: Bool -- run regression tests
-			   , tSpace :: Bool -- run space tests
-			   , tHelp :: Bool -- print usage and exit
-			     }
-
-defFlags = TestFlags { tReg = False, tSpace = False, tHelp = False}
-allFlags = TestFlags { tReg = True, tSpace = True, tHelp = False}
-
-parseArgs :: TestFlags -> [String] -> Either TestFlags String
-parseArgs flags [] = Left flags
-parseArgs flags (arg:args) =
-  case arg of
-    "-r" -> parseArgs (flags {tReg = True}) args
-    "-s" -> parseArgs (flags {tSpace = True}) args
-    "-h" -> parseArgs (flags {tHelp = True}) args
-    _ -> Right ("invalid argument: " ++ arg)
-
-usage :: String -> Maybe String -> IO ()
-usage pname mbEmsg = do
-  case mbEmsg of
-    (Just emsg) -> hPutStrLn stderr (pname ++ ": " ++ emsg)
-    _ -> return ()
-  hPutStrLn stderr ("usage: " ++ pname ++ " [-r] [-s] [-h]")
-  hPutStrLn stderr "\t-s run space tests"
-  hPutStrLn stderr "\t-r run regression tests"
-  hPutStrLn stderr "\t-h print this help message"
-  hPutStrLn stderr "(no arguments runs all tests.)"
-
-main :: IO ()
-main = do
-  pname <- getProgName
-  args <- getArgs
-  let eFlags = if (length args) < 1 
-                 then (Left allFlags)
-                 else parseArgs defFlags args
-  case eFlags of
-    (Left tFlags) ->  
-      if (tHelp tFlags)
-        then usage pname Nothing
-        else do
-          if (tReg tFlags)
-            then runRegTests
-            else return ()
-          if (tSpace tFlags)
-            then runSpaceTests
-            else return ()
-    (Right emsg) -> usage pname (Just emsg)
-
-
+{- $Id: testAFRPMain.hs,v 1.9 2003/11/10 21:28:58 antony Exp $+******************************************************************************+*                                  A F R P                                   *+*                                                                            *+*       Module:         testAFRPMain                                         *+*       Purpose:        Main driver routine for running tests.               *+*	Authors:	Henrik Nilsson and Antony Courtney		     *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}+module Main where++import AFRPTests++import System.IO+import System.Environment (getArgs, getProgName)++-- main = runTests+-- main = runSpaceTests++data TestFlags = TestFlags { tReg :: Bool -- run regression tests+			   , tSpace :: Bool -- run space tests+			   , tHelp :: Bool -- print usage and exit+			     }++defFlags = TestFlags { tReg = False, tSpace = False, tHelp = False}+allFlags = TestFlags { tReg = True, tSpace = True, tHelp = False}++parseArgs :: TestFlags -> [String] -> Either TestFlags String+parseArgs flags [] = Left flags+parseArgs flags (arg:args) =+  case arg of+    "-r" -> parseArgs (flags {tReg = True}) args+    "-s" -> parseArgs (flags {tSpace = True}) args+    "-h" -> parseArgs (flags {tHelp = True}) args+    _ -> Right ("invalid argument: " ++ arg)++usage :: String -> Maybe String -> IO ()+usage pname mbEmsg = do+  case mbEmsg of+    (Just emsg) -> hPutStrLn stderr (pname ++ ": " ++ emsg)+    _ -> return ()+  hPutStrLn stderr ("usage: " ++ pname ++ " [-r] [-s] [-h]")+  hPutStrLn stderr "\t-s run space tests"+  hPutStrLn stderr "\t-r run regression tests"+  hPutStrLn stderr "\t-h print this help message"+  hPutStrLn stderr "(no arguments runs all tests.)"++main :: IO ()+main = do+  pname <- getProgName+  args <- getArgs+  let eFlags = if (length args) < 1 +                 then (Left allFlags)+                 else parseArgs defFlags args+  case eFlags of+    (Left tFlags) ->  +      if (tHelp tFlags)+        then usage pname Nothing+        else do+          if (tReg tFlags)+            then runRegTests+            else return ()+          if (tSpace tFlags)+            then runSpaceTests+            else return ()+    (Right emsg) -> usage pname (Just emsg)++