packages feed

Yampa 0.13.3 → 0.13.4

raw patch · 49 files changed

+342/−6809 lines, 49 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

CHANGELOG view
@@ -1,3 +1,11 @@+2022-04-07 Ivan Perez <ivan.perez@haskell.sexy>+        * Yampa.cabal: Version bump (0.13.4) (#203), syntax rules (#196),+          remove regression tests (#201).+        * src/: Remove unused extensions (#199), syntax rules (#200), remove+          commented code and notes (#202).+        * tests/: Rename tests (#195), remove regression tests (#201).+        * README: Add new game (#197).+ 2021-10-07 Ivan Perez <ivan.perez@haskell.sexy>         * Yampa.cabal: Version bump (0.13.3) (#193), add modules missing from           other modules (#181).
Yampa.cabal view
@@ -1,79 +1,87 @@-name: Yampa-version: 0.13.3+-- 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. cabal-version: >= 1.10-license: BSD3-license-file: LICENSE-author: Henrik Nilsson, Antony Courtney-maintainer: Ivan Perez (ivan.perez@keera.co.uk)-homepage: https://github.com/ivanperez-keera/Yampa/-category: Reactivity, FRP-synopsis: Elegant Functional Reactive Programming Language for Hybrid Systems+build-type:    Simple -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.+name:          Yampa+version:       0.13.4+author:        Henrik Nilsson, Antony Courtney+maintainer:    Ivan Perez (ivan.perez@keera.co.uk)+homepage:      https://github.com/ivanperez-keera/Yampa/+license:       BSD3+license-file:  LICENSE+category:      Reactivity, FRP+synopsis:+  Elegant Functional Reactive Programming Language for 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:-  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,+  CHANGELOG, -  examples/Elevator/Elevator.hs,-  examples/Elevator/TestElevatorMain.hs,-  examples/TailgatingDetector/TailgatingDetector.hs,-  examples/TailgatingDetector/TestTGMain.hs,-  examples/Diagrams.hs,+  examples/Diagrams.hs -  CHANGELOG+source-repository head+  type:     git+  location: git://github.com/ivanperez-keera/Yampa.git+  subdir:   yampa + -- You can disable the hlint test suite with -f-test-hlint flag test-hlint-  Description: Enable hlint test suite-  default: False-  manual: True+  description: Enable hlint test suite+  default:     False+  manual:      True  -- You can disable the haddock coverage test suite with -f-test-doc-coverage flag test-doc-coverage-  Description: Enable haddock coverage test suite-  default: False-  manual: True---- You can disable the regression test suite with -f-test-regression-flag test-regression-  Description: Enable regression test suite-  default: True-  manual: True+  description: Enable haddock coverage test suite+  default:     False+  manual:      True  flag examples-  Description: Enable examples-  default: False-  manual: True+  description: Enable examples+  default:     False+  manual:      True + library-  hs-source-dirs:  src-  ghc-options : -O3 -Wall -fno-warn-name-shadowing-  build-Depends: base < 6, random, deepseq, simple-affine-space-  if !impl(ghc>=8.0)-    build-Depends: fail == 4.9.*   exposed-modules:-    -- Main FRP modules     FRP.Yampa-    FRP.Yampa.Event-    FRP.Yampa.Task--    -- Auxiliary definitions+    FRP.Yampa.Arrow     FRP.Yampa.Basic     FRP.Yampa.Conditional     FRP.Yampa.Delays+    FRP.Yampa.Event     FRP.Yampa.EventS     FRP.Yampa.Hybrid     FRP.Yampa.Integration@@ -82,167 +90,224 @@     FRP.Yampa.Scan     FRP.Yampa.Simulation     FRP.Yampa.Switches+    FRP.Yampa.Task     FRP.Yampa.Time -    -- FRP-agnostic auxiliary definitions-    FRP.Yampa.Arrow-   other-modules:     -- Auxiliary (commonly used) types     FRP.Yampa.Diagnostics     FRP.Yampa.InternalCore +  build-depends:+      base < 6+    , deepseq+    , random+    , simple-affine-space+   default-language:     Haskell2010 -test-suite hlint-  type: exitcode-stdio-1.0-  main-is: hlint.hs-  hs-source-dirs: tests-  if !flag(test-hlint)-    buildable: False-  else+  hs-source-dirs:+    src++  ghc-options:+    -O3 -Wall -fno-warn-name-shadowing++  if !impl(ghc >= 8.0)     build-depends:-      base,-      hlint >= 1.7+      fail == 4.9.* ++test-suite hlint+  type:+    exitcode-stdio-1.0++  main-is:+    hlint.hs+   default-language:     Haskell2010 --- Verify that the code is thoroughly documented-test-suite haddock-coverage-  type: exitcode-stdio-1.0-  main-is: HaddockCoverage.hs-  ghc-options: -Wall-  hs-source-dirs: tests+  hs-source-dirs:+    tests -  if !flag(test-doc-coverage)-    buildable: False+  if !flag(test-hlint)+    buildable:+      False   else     build-depends:-      base >= 4 && < 5,-      directory,-      filepath,-      process,-      regex-posix+        base+      , hlint >= 1.7 +-- Verify that the code is thoroughly documented+test-suite haddock-coverage+  type:+    exitcode-stdio-1.0++  main-is:+    HaddockCoverage.hs+   default-language:     Haskell2010 -test-suite regression-  type: exitcode-stdio-1.0-  main-is: testAFRPMain.hs-  other-modules:-    AFRPTests-    AFRPTestsAccum-    AFRPTestsArr-    AFRPTestsBasicSF-    AFRPTestsCOC-    AFRPTestsCommon-    AFRPTestsComp-    AFRPTestsDelay-    AFRPTestsDer-    AFRPTestsEmbed-    AFRPTestsEvSrc-    AFRPTestsFirstSecond-    AFRPTestsKSwitch-    AFRPTestsLaws-    AFRPTestsLoop-    AFRPTestsLoopIntegral-    AFRPTestsLoopLaws-    AFRPTestsLoopPre-    AFRPTestsPSwitch-    AFRPTestsPre-    AFRPTestsRPSwitch-    AFRPTestsRSwitch-    AFRPTestsReact-    AFRPTestsSscan-    AFRPTestsSwitch-    AFRPTestsTask-    AFRPTestsUtils-    AFRPTestsWFG+  hs-source-dirs:+    tests -  hs-source-dirs: tests-  if !flag(test-regression)-    buildable: False+  ghc-options:+    -Wall++  if !flag(test-doc-coverage)+    buildable:+      False   else     build-depends:-      base,-      Yampa+        base >= 4 && < 5+      , directory+      , filepath+      , process+      , regex-posix -  default-language:-    Haskell2010  executable yampa-examples-sdl-bouncingbox-  main-is: MainBouncingBox.hs-  other-modules: YampaSDL-  hs-source-dirs:  examples/yampa-game/-  ghc-options : -O3 -Wall -fno-warn-name-shadowing-  if flag(examples)-    buildable: True-    build-Depends: base < 5, random, deepseq, SDL, Yampa-  else-    buildable: False+  main-is:+    MainBouncingBox.hs +  other-modules:+    YampaSDL+   default-language:     Haskell2010 -executable yampa-examples-sdl-circlingmouse-  main-is: MainCircleMouse.hs-  other-modules: YampaSDL-  hs-source-dirs:  examples/yampa-game/-  ghc-options : -O3 -Wall -fno-warn-name-shadowing+  hs-source-dirs:+    examples/yampa-game/++  ghc-options:+    -O3 -Wall -fno-warn-name-shadowing+   if flag(examples)-    buildable: True-    build-Depends: base < 5, random, deepseq, SDL, Yampa+    buildable:+      True+    build-depends:+        base < 5+      , deepseq+      , random+      , SDL+      , Yampa   else-    buildable: False+    buildable:+      False ++executable yampa-examples-sdl-circlingmouse+  main-is:+    MainCircleMouse.hs++  other-modules:+    YampaSDL+   default-language:     Haskell2010 -executable yampa-examples-sdl-wiimote-  main-is: MainWiimote.hs-  other-modules: YampaSDL-  hs-source-dirs:  examples/yampa-game/-  ghc-options : -O3 -Wall -fno-warn-name-shadowing -rtsopts+  hs-source-dirs:+    examples/yampa-game/++  ghc-options:+    -O3 -Wall -fno-warn-name-shadowing+   if flag(examples)-    buildable: True-    build-depends: base < 5, random, deepseq, SDL, hcwiid, Yampa+    buildable:+      True+    build-depends:+        base < 5+      , deepseq+      , random+      , SDL+      , Yampa   else-    buildable: False+    buildable:+      False ++executable yampa-examples-sdl-wiimote+  main-is:+    MainWiimote.hs++  other-modules:+    YampaSDL+   default-language:     Haskell2010 -executable yampa-examples-elevator-  main-is: TestElevatorMain.hs-  other-modules: Elevator-  hs-source-dirs:  examples/Elevator-  ghc-options : -O3 -Wall -fno-warn-name-shadowing+  hs-source-dirs:+    examples/yampa-game/++  ghc-options:+    -O3 -Wall -fno-warn-name-shadowing -rtsopts+   if flag(examples)-    buildable: True-    build-depends: base < 5, Yampa+    buildable:+      True+    build-depends:+        base < 5+      , deepseq+      , hcwiid+      , random+      , SDL+      , Yampa   else-    buildable: False+    buildable:+      False ++executable yampa-examples-elevator+  main-is:+    TestElevatorMain.hs++  other-modules:+    Elevator+   default-language:     Haskell2010 -executable yampa-examples-tailgatingdetector-  main-is: TestTGMain.hs-  other-modules: TailgatingDetector-  hs-source-dirs:  examples/TailgatingDetector-  ghc-options : -O3 -Wall -fno-warn-name-shadowing+  hs-source-dirs:+    examples/Elevator++  ghc-options:+    -O3 -Wall -fno-warn-name-shadowing+   if flag(examples)-    buildable: True-    build-depends: base < 5, Yampa+    buildable:+      True+    build-depends:+        base < 5+      , Yampa   else-    buildable: False+    buildable:+      False ++executable yampa-examples-tailgatingdetector+  main-is:+    TestTGMain.hs++  other-modules:+    TailgatingDetector+   default-language:     Haskell2010 -source-repository head-  type:     git-  location: git://github.com/ivanperez-keera/Yampa.git+  hs-source-dirs:+    examples/TailgatingDetector++  ghc-options:+    -O3 -Wall -fno-warn-name-shadowing++  if flag(examples)+    buildable:+      True+    build-depends:+        base < 5+      , Yampa+  else+    buildable:+      False
src/FRP/Yampa.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-} -------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa
src/FRP/Yampa/Arrow.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}---------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} -- | -- Module      :  FRP.Yampa.Arrow -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -11,9 +9,6 @@ -- Portability :  portable -- -- Arrow helper functions.------------------------------------------------------------------------------------- module FRP.Yampa.Arrow (     -- * Arrow plumbing aids     dup,        -- :: a -> (a,a)@@ -25,10 +20,11 @@     arr5,       -- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g ) where -import Control.Arrow #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif++import Control.Arrow  -- * Arrow plumbing aids
src/FRP/Yampa/Basic.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-} -- | -- Module      :  FRP.Yampa.Basic -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -33,7 +30,6 @@     initially           -- :: a -> SF a a    ) where-  import FRP.Yampa.InternalCore (SF(..), SF'(..), sfConst, sfId)
src/FRP/Yampa/Conditional.hs view
@@ -15,9 +15,10 @@   ) where  import Control.Arrow+ import FRP.Yampa.Basic-import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', Transition) import FRP.Yampa.EventS+import FRP.Yampa.InternalCore (SF (..), SF' (..), Transition, sfTF') import FRP.Yampa.Switches  -- * Guards and automata-oriented combinators@@ -79,5 +80,3 @@                    (tfP'', True) -> (pause' b_init' tf10' tfP'', b_init')                    (tfP'', False) -> let (tf10'', b0') = (sfTF' tf10') dt a                                      in (pause' b0' tf10'' tfP'', b0')--
src/FRP/Yampa/Delays.hs view
@@ -1,4 +1,3 @@--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Delays -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -10,9 +9,6 @@ -- -- SF primitives and combinators to delay signals, introducing new values in -- them.------------------------------------------------------------------------------------- module FRP.Yampa.Delays (      -- * Basic delays@@ -27,10 +23,9 @@  import Control.Arrow -import FRP.Yampa.Diagnostics-import FRP.Yampa.InternalCore (SF(..), SF'(..), Time)- import FRP.Yampa.Basic+import FRP.Yampa.Diagnostics+import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) import FRP.Yampa.Scan  infixr 0 `fby`@@ -43,9 +38,6 @@ -- -- The output has an infinitesimal delay (1 sample), and the value at time -- zero is undefined.---- !!! Redefined using SFSScan--- !!! About 20% slower than old_pre on its own. pre :: SF a a pre = sscanPrim f uninit uninit     where@@ -78,24 +70,6 @@  -- | Delay a signal by a fixed time 't', using the second parameter -- to fill in the initial 't' seconds.---- Invariants:--- t_diff measure the time since the latest output sample ideally--- should have been output. Whenever that equals or exceeds the--- time delta for the next buffered sample, it is time to output a--- new sample (although not necessarily the one first in the queue:--- it might be necessary to "catch up" by discarding samples.--- 0 <= t_diff < bdt, where bdt is the buffered time delta for the--- sample on the front of the buffer queue.------ Sum of time deltas in the queue >= q.---- !!! PROBLEM!--- Since input samples sometimes need to be duplicated, it is not a--- good idea use a delay on things like events since we then could--- end up with duplication of event occurrences.--- (Thus, we actually NEED delayEvent.)- delay :: Time -> a -> SF a a delay q a_init | q < 0     = usrErr "AFRP" "delay" "Negative delay."                | q == 0    = identity@@ -103,6 +77,16 @@     where         tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init) +        -- 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.         delayAux _ [] _ _ = undefined         delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf -- True             where@@ -118,14 +102,6 @@                         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--  -- Vim modeline -- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Diagnostics.hs view
@@ -1,4 +1,3 @@--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Diagnostics -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -9,8 +8,6 @@ -- Portability :  portable -- -- Standarized error-reporting for Yampa---------------------------------------------------------------------------------- module FRP.Yampa.Diagnostics where  -- | Reports an error due to a violation of Yampa's preconditions/requirements.
src/FRP/Yampa/Event.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}--------------------------------------------------------------------------------- -- | -- Module      : FRP.Yampa.Event -- Copyright   : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -25,75 +24,14 @@ -- -- Events are essential for many other Yampa constructs, like switches (see -- 'FRP.Yampa.Switches.switch' for details).-------------------------------------------------------------------------------------- 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' could be understood to refer to the constructor--- 'Event', not to the type name 'Event'. Thus this use of event should not be--- seen as a suffixing-with-type-name convention. But that is obviously not--- easy to see, and, more over, interpreting 'Event' as the name of the type--- might make equally good or better sense. E.g.  'fromEvent' can also be seen--- as a function taking an event signal, which is a partial function on time,--- to a normal signal. The latter is then undefined when the source event--- function is undefined.------ In other cases, it has been necessary to somehow stay out of the way of--- names used by the prelude or other commonly imported modules/modules which--- could be expected to be used heavily in Yampa code. In those cases a suffix--- 'E' have been added. Examples are 'filterE' (exists in Prelude) and 'joinE'--- (exists in Monad). Maybe the suffix isn't necessary in the last case.------ Some functions (actually only one currently, 'mapFilterE') have got an 'E'--- suffix just because they're closely related (by name or semantics) to one--- which already has an 'E' suffix. Another candidate would be 'splitE' to--- complement 'joinE'. But events carrying pairs could obviously have other--- sources than a 'joinE', so currently it is called 'split'.------ 2003-05-19: Actually, have now changed to 'splitE' to avoid a clash with the--- method 'split' in the class RandomGen.------ 2003-05-19: What about 'gate'? Stands out compared to e.g. 'filterE'.------ Currently the 'E' suffix is considered an exception. Maybe we should use--- completely different names to avoid the 'E' suffix. If the functions are not--- used that often, 'Event' might be approriate. Alternatively the suffix 'E'--- should be adopted globaly (except if the name already contains 'event' in--- some form?).------ Arguably, having both a type 'Event' and a constructor 'Event' is confusing--- since there are more than one constructor. But the name 'Event' for the--- constructor is quite apt. It's really the type name that is wrong. But no--- one has found a better name, and changing it would be a really major--- undertaking. Yes, the constructor 'Event' is not exported, but we still need--- to talk conceptually about them. On the other hand, if we consider--- Event-signals as partial functions on time, maybe it isn't so confusing:--- they just don't have a value between events, so 'NoEvent' does not really--- exist conceptually.---------------------------------------------------------------------------------- module FRP.Yampa.Event where --- 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--import Control.Applicative-import Control.DeepSeq (NFData(..))-import qualified Control.Monad.Fail as Fail+import           Control.Applicative+import           Control.DeepSeq     (NFData (..))+import qualified Control.Monad.Fail  as Fail  import FRP.Yampa.Diagnostics - infixl 8 `tag`, `attach`, `gate` infixl 7 `joinE` infixl 6 `lMerge`, `rMerge`, `merge`@@ -103,14 +41,6 @@ -- 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.- -- | A single possible event occurrence, that is, a value that may or may -- not occur. Events are used to represent values that are not produced -- continuously, such as mouse clicks (only produced when the mouse is clicked,@@ -264,14 +194,6 @@ ------------------------------------------------------------------------------ -- 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 (always prefer left event, if present). lMerge :: Event a -> Event a -> Event a
src/FRP/Yampa/EventS.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-} -- | -- Module      :  FRP.Yampa.EventS -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -19,8 +16,6 @@ -- For signals that carry events, there should be a limit in the number of -- events we can observe in a time period, no matter how much we increase the -- sampling frequency.-- module FRP.Yampa.EventS (      -- * Basic event sources@@ -58,72 +53,17 @@  import Control.Arrow -import FRP.Yampa.InternalCore (SF(..), sfConst, Time, SF'(..))- import FRP.Yampa.Arrow import FRP.Yampa.Basic import FRP.Yampa.Diagnostics import FRP.Yampa.Event import FRP.Yampa.Hybrid+import FRP.Yampa.InternalCore (SF (..), SF' (..), Time, sfConst) import FRP.Yampa.Scan import FRP.Yampa.Switches  infixr 5 `andThen` --- -- 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' =- ------------------------------------------------------------------------------ -- Basic event sources ------------------------------------------------------------------------------@@ -155,13 +95,6 @@ -- 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."@@ -169,53 +102,15 @@         qxs = (q,x):qxs  --- Event source with consecutive occurrences at the given intervals.--- Should more than one event be scheduled to occur in any sampling interval,--- only the first will in fact occur to avoid an event backlog.--- Question: Should positive periods except for the first one be required?--- Note that periods of length 0 will always be skipped except for the first.--- Right now, periods of length 0 is allowed on the grounds that no attempt--- is made to forbid simultaneous events elsewhere.-{--afterEach :: [(Time,b)] -> SF a (Event b)-afterEach [] = never-afterEach ((q,x):qxs)-    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."-    | otherwise = SF {sfTF = tf0}-    where-        tf0 _ = if q <= 0 then-                    (scheduleNextEvent 0.0 qxs, Event x)-                else-                    (awaitNextEvent (-q) x qxs, NoEvent)--        scheduleNextEvent t [] = sfNever-        scheduleNextEvent t ((q,x):qxs)-            | q < 0     = usrErr "AFRP" "afterEach" "Negative period."-            | t' >= 0   = scheduleNextEvent t' qxs-            | otherwise = awaitNextEvent t' x qxs-            where-                t' = t - q-        awaitNextEvent t x qxs = SF' {sfTF' = tf}-            where-                tf dt _ | t' >= 0   = (scheduleNextEvent t' qxs, Event x)-                        | otherwise = (awaitNextEvent t' x qxs, NoEvent)-                    where-                        t' = t + dt--}- -- | Event source with consecutive occurrences at the given intervals. -- Should more than one event be scheduled to occur in any sampling interval, -- only the first will in fact occur to avoid an event backlog.---- After all, after, repeatedly etc. are defined in terms of afterEach. afterEach :: [(Time,b)] -> SF a (Event b) afterEach qxs = afterEachCat qxs >>> arr (fmap head)  -- | Event source with consecutive occurrences at the given intervals. -- Should more than one event be scheduled to occur in any sampling interval, -- the output list will contain all events produced during that interval.---- Guaranteed not to miss any events. afterEachCat :: [(Time,b)] -> SF a (Event [b]) afterEachCat [] = never afterEachCat ((q,x):qxs)@@ -242,80 +137,12 @@                         t' = t + dt  -- | Delay for events. (Consider it a triggered after, hence /basic/.)---- Can be implemented fairly cheaply as long as the events are sparse.--- It is a question of rescheduling events for later. Not unlike "afterEach".------ It is not exactly the case that delayEvent t = delay t NoEvent--- since the rules for dropping/extrapolating samples are different.--- A single event occurrence will never be duplicated.--- If there is an event occurrence, one will be output as soon as--- possible after the given delay time, but not necessarily that--- one.  See delayEventCat.- delayEvent :: Time -> SF (Event a) (Event a) delayEvent q | q < 0     = usrErr "AFRP" "delayEvent" "Negative delay."              | q == 0    = identity              | otherwise = delayEventCat q >>> arr (fmap head)  --- There is no *guarantee* above that every event actually will be--- rescheduled since the sampling frequency (temporarily) might drop.--- The following interface would allow ALL scheduled events to occur--- as soon as possible:--- (Read "delay event and catenate events that occur so closely so as to be--- inseparable".)--- The events in the list are ordered temporally to the extent possible.---- -- This version is too strict!--- delayEventCat :: Time -> SF (Event a) (Event [a])--- delayEventCat q | q < 0     = usrErr "AFRP" "delayEventCat" "Negative delay."---                 | q == 0    = arr (fmap (:[]))---                 | otherwise = SF {sfTF = tf0}---   where---       tf0 NoEvent   = (noPendingEvent, NoEvent)---       tf0 (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent)------       noPendingEvent = SF' tf -- True---           where---               tf _ NoEvent   = (noPendingEvent, NoEvent)---               tf _ (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent)------       -- t_next is the present time w.r.t. the next scheduled event.---       -- t_last is the present time w.r.t. the last scheduled event.---       -- In the event queues, events are associated with their time---       -- w.r.t. to preceding event (positive).---       pendingEvents t_last rqxs qxs t_next x = SF' tf -- True---           where---               tf dt NoEvent    = tf1 (t_last + dt) rqxs (t_next + dt)---               tf dt (Event x') = tf1 (-q) ((q', x') : rqxs) t_next'---                   where---                       t_next' = t_next  + dt---                       t_last' = t_last  + dt---                       q'      = t_last' + q------               tf1 t_last' rqxs' t_next'---                   | t_next' >= 0 =---                       emitEventsScheduleNext t_last' rqxs' qxs t_next' [x]---                   | otherwise =---                       (pendingEvents t_last' rqxs' qxs t_next' x, NoEvent)------       -- t_next is the present time w.r.t. the *scheduled* time of the---       -- event that is about to be emitted (i.e. >= 0).---       -- The time associated with any event at the head of the event---       -- queue is also given w.r.t. the event that is about to be emitted.---       -- Thus, t_next - q' is the present time w.r.t. the event at the head---       -- of the event queue.---       emitEventsScheduleNext t_last [] [] t_next rxs =---           (noPendingEvent, Event (reverse rxs))---       emitEventsScheduleNext t_last rqxs [] t_next rxs =---           emitEventsScheduleNext t_last [] (reverse rqxs) t_next rxs---       emitEventsScheduleNext t_last rqxs ((q', x') : qxs') t_next rxs---           | q' > t_next = (pendingEvents t_last rqxs qxs' (t_next - q') x',---                            Event (reverse rxs))---           | otherwise   = emitEventsScheduleNext t_last rqxs qxs' (t_next-q')---                                                  (x' : rxs)- -- | Delay an event by a given delta and catenate events that occur so closely -- so as to be /inseparable/. delayEventCat :: Time -> SF (Event a) (Event [a])@@ -393,10 +220,6 @@ -- | A rising edge detector. Useful for things like detecting key presses. -- It is initialised as /up/, meaning that events occuring at time 0 will -- not be detected.---- Note that we initialize the loop with state set to True so that there--- will not be an occurence at t0 in the logical time frame in which--- this is started. edge :: SF Bool (Event ()) edge = iEdge True @@ -404,7 +227,6 @@ --   that events occurring at time 0 will not be detected) or down --   ('False', meaning that events ocurring at time 0 will be detected). iEdge :: Bool -> SF Bool (Event ())--- iEdge i = edgeBy (isBoolRaisingEdge ()) i iEdge b = sscanPrim f (if b then 2 else 0) NoEvent     where         f :: Int -> Bool -> Maybe (Int, Event ())@@ -418,22 +240,11 @@  -- | Like 'edge', but parameterized on the tag value. edgeTag :: a -> SF Bool (Event a)--- edgeTag a = edgeBy (isBoolRaisingEdge a) True edgeTag a = edge >>> arr (`tag` a) --- Internal utility.--- isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a--- isBoolRaisingEdge _ False False = Nothing--- isBoolRaisingEdge a False True  = Just a--- isBoolRaisingEdge _ True  True  = Nothing--- isBoolRaisingEdge _ True  False = Nothing  -- | Edge detector particularized for detecting transtitions --   on a 'Maybe' signal from 'Nothing' to 'Just'.---- !!! 2005-07-09: To be done or eliminated--- !!! Maybe could be kept as is, but could be easy to implement directly--- !!! in terms of sscan? edgeJust :: SF (Maybe a) (Event a) edgeJust = edgeBy isJustEdge (Just undefined)     where@@ -445,10 +256,6 @@ -- | 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@@ -479,35 +286,24 @@ 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)))+dropEvents n =+  -- Here dSwitch or switch does not really matter.+  dSwitch (never &&& identity)+          (const (NoEvent >-- dropEvents (n - 1)))   -- ** Hybrid continuous-to-discrete SF combinators.  -- | 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+snap =+   -- switch ensures that the entire signal function will become just+   -- "constant" once the sample has been taken.+   switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now   -- | Event source with a single occurrence at or as soon after (local) time@@ -545,14 +341,6 @@  -- | 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)) @@ -561,13 +349,6 @@ -- sometimes is more understandable switch-based code. 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--}  -- Vim modeline -- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Hybrid.hs view
@@ -1,4 +1,3 @@--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Hybrid -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -9,8 +8,6 @@ -- Portability :  non-portable (GHC extensions) -- -- Discrete to continuous-time signal functions.---------------------------------------------------------------------------------- module FRP.Yampa.Hybrid (      -- * Wave-form generation@@ -33,10 +30,9 @@  import Control.Arrow -import FRP.Yampa.InternalCore (SF, epPrim)- import FRP.Yampa.Delays import FRP.Yampa.Event+import FRP.Yampa.InternalCore (SF, epPrim)  ------------------------------------------------------------------------------ -- Wave-form generation@@ -56,22 +52,6 @@     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 a delay. --@@ -84,12 +64,6 @@ -- [1,1,1,2,2,3] 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, holding the last value when the input -- is 'Nothing'.@@ -99,11 +73,6 @@ -- -- >>> embed (trackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing]) -- [1,1,2,2,3,3]---- !!! 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 @@ -153,19 +122,7 @@ -- is always the given accumulator). dAccumHold :: a -> SF (Event (a -> a)) a dAccumHold a_init = accumHold a_init >>> iPre a_init-{---- WRONG!--- epPrim DOES and MUST patternmatch--- on the input at every time step.--- Test case to check for this added!-dAccumHold a_init = epPrim f a_init a_init-    where-        f a g = (a', a, a')-            where-                a' = g a--} - -- | Accumulator parameterized by the accumulation function. accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) accumBy g b_init = epPrim f b_init NoEvent@@ -182,71 +139,12 @@             where                 b' = g b a --- !!! This cannot be right since epPrim DOES and MUST patternmatch--- !!! on the input at every time step.--- !!! Add a test case to check for this!- -- | Zero-order hold accumulator parameterized by the accumulation function --   with delayed initialization (initial output sample is always the --   given accumulator). dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init-{---- WRONG!--- epPrim DOES and MUST patternmatch--- on the input at every time step.--- Test case to check for this added!-dAccumHoldBy g b_init = epPrim f b_init b_init-    where-        f b a = (b', b, b')-            where-                b' = g b a--} --{- Untested:--accumBy f b = switch (never &&& identity) $ \a ->-              let b' = f b a in NoEvent >-- Event b' --> accumBy f b'--But no real improvement in clarity anyway.---}---- accumBy f b = accumFilter (\b -> a -> let b' = f b a in (b', Event b')) b--{---- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))-accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)-accumBy f b_init = SF {sfTF = tf0}-    where-        tf0 NoEvent    = (abAux b_init, NoEvent)-        tf0 (Event a0) = let b' = f b_init a0-                         in (abAux b', Event b')--        abAux b = SF' {sfTF' = tf}-            where-                tf _ NoEvent   = (abAux b, NoEvent)-                tf _ (Event a) = let b' = f b a-                                 in (abAux b', Event b')--}--{--accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)-accumFilter f c_init = SF {sfTF = tf0}-    where-        tf0 NoEvent    = (afAux c_init, NoEvent)-        tf0 (Event a0) = case f c_init a0 of-                             (c', Nothing) -> (afAux c', NoEvent)-                             (c', Just b0) -> (afAux c', Event b0)--        afAux c = SF' {sfTF' = tf}-            where-                tf _ NoEvent   = (afAux c, NoEvent)-                tf _ (Event a) = case f c a of-                                     (c', Nothing) -> (afAux c', NoEvent)-                                     (c', Just b)  -> (afAux c', Event b)--}  -- | Accumulator parameterized by the accumulator function with filtering, --   possibly discarding some of the input events based on whether the second
src/FRP/Yampa/Integration.hs view
@@ -1,4 +1,3 @@--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Integration -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -25,8 +24,6 @@ -- example with other vector types like V2, V1, etc. from the library linear. -- For an example, see -- <https://gist.github.com/walseb/1e0a0ca98aaa9469ab5da04e24f482c2 this gist>.---------------------------------------------------------------------------------- module FRP.Yampa.Integration (      -- * Integration
src/FRP/Yampa/InternalCore.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-}---------------------------------------------------------------------------------+{-# LANGUAGE CPP   #-}+{-# LANGUAGE GADTs #-} -- | -- Module      :  FRP.Yampa -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -52,96 +50,6 @@ -- -- Finally, see [<#g:26>] for sources of randomness (useful in games). --- CHANGELOG:------ - Adds (most) documentation.------ - 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.InternalCore (     module Control.Arrow,     -- SF is an instance of Arrow and ArrowLoop. Method instances:@@ -202,20 +110,7 @@ -- 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. @@ -228,9 +123,6 @@ -- same representation. type DTime = Double     -- [s] --- Representation of signal function in initial state.--- (Naming: "TF" stands for Transition Function.)- -- | Signal function that transforms a signal carrying values of some type 'a' -- into a signal carrying values of some type 'b'. You can think of it as -- (Signal a -> Signal b). A signal is, conceptually, a@@ -243,41 +135,6 @@ --   It can also be seen as a Future Signal Function, meaning, --   an SF that, given a time delta or a time in the future, it will --   be an SF.---- 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@@ -292,7 +149,6 @@     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 future signal@@ -309,24 +165,6 @@ 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.- -- | Constructor for a lifted structured function. sfArr :: FunDesc a b -> SF' a b sfArr FDI         = sfId@@ -346,9 +184,6 @@     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@@ -372,9 +207,6 @@ --   The auxiliary function returns the value of the current output and --   the future held output, thus making it possible to have to distinct --   outputs for the present and the future.---- 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@@ -384,13 +216,6 @@                         in                             (sfEP f c' bne', 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.---- -- | Constructor for a zero-order hold SF' with folding. -- --   This function returns a running SF that, if there is an input, runs it@@ -413,40 +238,6 @@                   c                   bne --{---- !!! 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.- -- | Structured function definition. -- --   This type represents functions with a bit more structure, providing@@ -471,16 +262,7 @@ 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)+fdComp (FDE f1 f1ne) fd2     = FDE (f2 . f1) (f2 f1ne)     where         f2 = fdFun fd2 fdComp (FDG f1) (FDE f2 f2ne) = FDG f@@ -518,7 +300,7 @@     FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))  --- Verifies that the first argument is NoEvent. Returns the value of the+-- | 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.@@ -627,24 +409,15 @@   -- * Composition.++-- | SF 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@@ -666,32 +439,10 @@ 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)@@ -720,8 +471,7 @@                             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@@ -737,21 +487,21 @@                     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+        -- 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.         f (s1, s2, cne) a =             case f1 s1 a of                 (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)@@ -760,35 +510,17 @@                 _ -> 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@@ -796,65 +528,6 @@                 (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.@@ -878,25 +551,12 @@         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@@ -909,47 +569,26 @@ 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.+-- 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)@@ -964,29 +603,12 @@         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@@ -1001,26 +623,12 @@         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@@ -1038,24 +646,11 @@         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@@ -1085,12 +680,6 @@         -- 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@@ -1099,16 +688,6 @@                                 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@@ -1135,29 +714,17 @@         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.++-- | Widening+-- -- The definition exploits the following identities: --     first identity     = identity                            -- New --     first (constant b) = arr (\(_, c) -> (b, c))@@ -1170,29 +737,17 @@                 (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}@@ -1202,30 +757,20 @@                 (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@@ -1255,135 +800,46 @@         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@@ -1406,172 +862,63 @@         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  -- | Creates a feedback loop without delay.@@ -1591,25 +938,11 @@         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)--}  -- * Scanning
src/FRP/Yampa/Loop.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Loop -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -13,22 +9,18 @@ -- Portability :  non-portable -GHC extensions- -- -- Well-initialised loops---------------------------------------------------------------------------------- module FRP.Yampa.Loop (     -- * 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 ) where - import Control.Arrow import Data.VectorSpace -import FRP.Yampa.InternalCore (SF)--import FRP.Yampa.Integration import FRP.Yampa.Delays+import FRP.Yampa.Integration+import FRP.Yampa.InternalCore (SF)  -- * Loops with guaranteed well-defined feedback
src/FRP/Yampa/Random.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Random -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -14,8 +10,6 @@ -- Signals and signal functions with noise and randomness. -- -- The Random number generators are re-exported from "System.Random".---------------------------------------------------------------------------------- module FRP.Yampa.Random (      -- * Random number generators@@ -31,11 +25,11 @@  ) where -import System.Random (RandomGen(..), Random(..))+import System.Random (Random (..), RandomGen (..)) -import FRP.Yampa.InternalCore (SF(..), SF'(..), Time) import FRP.Yampa.Diagnostics import FRP.Yampa.Event+import FRP.Yampa.InternalCore (SF (..), SF' (..), Time)  ------------------------------------------------------------------------------ -- Noise (i.e. random signal generators) and stochastic processes@@ -52,11 +46,6 @@ 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}@@ -69,24 +58,12 @@             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"
src/FRP/Yampa/Scan.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE Rank2Types #-} -- | -- Module      :  FRP.Yampa.Scan -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -16,7 +13,6 @@ -- functions by means of an auxiliary function applied to each input and to an -- accumulator. For comparison with other FRP libraries and with stream -- processing abstractions, think of fold.- module FRP.Yampa.Scan (     sscan,              -- :: (b -> a -> b) -> b -> SF a b     sscanPrim,          -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b@@ -28,10 +24,6 @@  -- | Applies a function point-wise, using the last output as next input. This -- creates a well-formed loop based on a pure, auxiliary function.---- 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
src/FRP/Yampa/Simulation.hs view
@@ -1,9 +1,3 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE GADTs         #-}-{-# LANGUAGE MultiWayIf    #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE Rank2Types    #-}--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Simulation -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -36,8 +30,6 @@ -- -- This module also includes debugging aids needed to execute signal functions -- step by step, which are used by Yampa's testing facilities.---------------------------------------------------------------------------------- module FRP.Yampa.Simulation (    -- * Reactimation     reactimate,         -- :: IO a@@ -78,45 +70,16 @@  import Control.Monad (unless) import Data.IORef-import Data.Maybe (fromMaybe)--import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', DTime)+import Data.Maybe    (fromMaybe)  import FRP.Yampa.Diagnostics+import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..), sfTF') + ------------------------------------------------------------------------------ -- Reactimation ------------------------------------------------------------------------------ --- Reactimation of a signal function.--- init ....... IO action for initialization. Will only be invoked once,---              at (logical) time 0, before first call to "sense".---              Expected to return the value of input at time 0.--- sense ...... IO action for sensing of system input.---      arg. #1 ....... True: action may block, waiting for an OS event.---                      False: action must not block.---      res. #1 ....... Time interval since previous invocation of the sensing---                      action (or, the first time round, the init action),---                      returned. The interval must be _strictly_ greater---                      than 0. Thus even a non-blocking invocation must---                      ensure that time progresses.---      res. #2 ....... Nothing: input is unchanged w.r.t. the previously---                      returned input sample.---                      Just i: the input is currently i.---                      It is OK to always return "Just", even if input is---                      unchanged.--- actuate .... IO action for outputting the system output.---      arg. #1 ....... True: output may have changed from previous output---                      sample.---                      False: output is definitely unchanged from previous---                      output sample.---                      It is OK to ignore argument #1 and assume that the---                      the output has always changed.---      arg. #2 ....... Current output sample.---      result .......  Termination flag. Once True, reactimate will exit---                      the reactimation loop and return to its caller.--- sf ......... Signal function to reactimate.- -- | Convenience function to run a signal function indefinitely, using a IO -- actions to obtain new input and process the output. --@@ -214,30 +177,6 @@ -- Embedding ------------------------------------------------------------------------------ --- New embed interface. We will probably have to revisit this. To run an--- embedded signal function while retaining full control (e.g. start and--- stop at will), one would probably need a continuation-based interface--- (as well as a continuation based underlying implementation).------ E.g. here are interesting alternative (or maybe complementary)--- signatures:------    sample :: SF a b -> SF (Event a) (Event b)---    sample' :: SF a b -> SF (Event (DTime, a)) (Event b)------ Maybe it should be called "subSample", since that's the only thing--- that can be achieved. At least does not have the problem with missing--- events when supersampling.------ subSampleSynch :: SF a b -> SF (Event a) (Event b)--- Time progresses at the same rate in the embedded system.--- But it is only sampled on the events.--- E.g.--- repeatedly 0.1 () >>> subSampleSynch sf >>> hold------ subSample :: DTime -> SF a b -> SF (Event a) (Event b)--- Time advanced by dt for each event, not synchronized with the outer clock.- -- | Given a signal function and a pair with an initial -- input sample for the input signal, and a list of sampling -- times, possibly with new input samples at those times,@@ -260,19 +199,6 @@ -- | 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@@ -303,29 +229,6 @@                     | t' <= tp = advance tp tbtbs         advance _ _ = undefined ---- 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!  -- | Spaces a list of samples by a fixed time delta, avoiding --   unnecessary samples when the input has not changed since
src/FRP/Yampa/Switches.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-} {-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Switches -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -65,7 +62,6 @@ -- and also helps determine the expected behaviour of a combinator by looking -- at its name. For example, 'drpSwitchB' is the decoupled (/d/), recurrent -- (/r/), parallel (/p/) switch with broadcasting (/B/).- module FRP.Yampa.Switches (     -- * Basic switching     switch,  dSwitch,   -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b@@ -123,68 +119,15 @@  import Control.Arrow +import FRP.Yampa.Basic import FRP.Yampa.Diagnostics+import FRP.Yampa.Event import FRP.Yampa.InternalCore (DTime, FunDesc (..), SF (..), SF' (..), fdFun,                                sfArrG, sfConst, sfTF') -import FRP.Yampa.Basic-import FRP.Yampa.Event- ------------------------------------------------------------------------------ -- Basic switches ---------------------------------------------------------------------------------- !!! Interesting case. It seems we need scoped type variables--- !!! to be able to write down the local type signatures.--- !!! On the other hand, the scoped type variables seem to--- !!! prohibit the kind of unification that is needed for GADTs???--- !!! Maybe this could be made to wok if it actually WAS known--- !!! that scoped type variables indeed corresponds to universally--- !!! quantified variables? Or if one were to keep track of those--- !!! scoped type variables that actually do?--- !!!--- !!! Find a simpler case to experiment further. For now, elim.--- !!! the free variable.--{---- Basic switch.-switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b-switch (SF {sfTF = tf10} :: SF a (b, Event c))-       (k :: c -> SF a b) = SF {sfTF = tf0}-    where-        tf0 a0 =-            case tf10 a0 of-                (sf1, (b0, NoEvent))  -> (switchAux sf1, b0)-                (_,   (_,  Event c0)) -> sfTF (k c0) a0--        -- It would be nice to optimize further here. E.g. if it would be-        -- possible to observe the event source only.-        switchAux :: SF' a (b, Event c) -> SF' a b-        switchAux (SFId _)                 = switchAuxA1 id     -- New-        switchAux (SFConst _ (b, NoEvent)) = sfConst b-        switchAux (SFArr _ f1)             = switchAuxA1 f1-        switchAux sf1                      = SF' tf-            where-                tf dt a =-                    case (sfTF' sf1) dt a of-                        (sf1', (b, NoEvent)) -> (switchAux sf1', b)-                        (_,    (_, Event c)) -> sfTF (k c) a--        -- Could be optimized a little bit further by having a case for-        -- identity, switchAuxI1--        -- Note: While switch behaves as a stateless arrow at this point, that-        -- could change after a switch. Hence, SF' overall.-        switchAuxA1 :: (a -> (b, Event c)) -> SF' a b-        switchAuxA1 f1 = sf-            where-                sf     = SF' tf-                tf _ a =-                    case f1 a of-                        (b, NoEvent) -> (sf, b)-                        (_, Event c) -> sfTF (k c) a--}- -- | Basic switch. -- -- By default, the first signal function is applied. Whenever the second value@@ -215,34 +158,12 @@         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@@ -278,10 +199,6 @@ -- -- Remember: The continuation is evaluated strictly at the time -- of switching!---- Alternative name: "decoupled switch"?--- (The SFId optimization is highly unlikley to be of much use, but it--- does raise an interesting typing issue.) dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}     where@@ -298,12 +215,6 @@         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@@ -313,24 +224,6 @@                          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@@ -353,26 +246,10 @@ -- -- See <https://wiki.haskell.org/Yampa#Switches> for more -- information on how this switch works.---- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is--- !!! being invoked recursively on a switch. In fact, we don't even care--- !!! whether the subordinate signal function is invarying or not.--- !!! We could make use of a signal function transformer sfInv to--- !!! mark the constructor as invarying. Would that make sense?--- !!! The price would be an extra loop with case analysis.--- !!! The potential gain is fewer case analyses in superior loops. rSwitch :: SF a b -> SF (a, Event (SF a b)) b rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) -{---- Old version. New is more efficient. Which one is clearer?-rSwitch :: SF a b -> SF (a, Event (SF a b)) b-rSwitch sf = switch (first sf) rSwitch'-    where-        rSwitch' sf = switch (sf *** notYet) rSwitch'--} - -- | Recurring switch with delayed observation. -- -- Uses the given SF until an event comes in the input, in which case the SF in@@ -385,15 +262,7 @@ 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. -- -- Applies the first SF until the input signal and the output signal, when@@ -402,10 +271,6 @@ -- -- See <https://wiki.haskell.org/Yampa#Switches> for more -- information on how this switch works.---- !!! Has not been optimized properly.--- !!! Nor has opts been tested!--- !!! Don't forget Inv opts! kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}     where@@ -416,16 +281,10 @@                     (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 =@@ -435,23 +294,9 @@                             (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!+        -- !!! 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 =@@ -459,11 +304,9 @@                         (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b)                         (_,    Event c) -> sfTF (k (constant b) c) a --- !!! Untested optimization!+        -- !!! 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 =@@ -474,11 +317,8 @@                             (_,    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 =@@ -488,17 +328,7 @@                             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!+        -- !!! Untested optimization!         kSwitchAuxC1AE b fe = SF' tf -- False             where                 tf _ a =@@ -506,7 +336,7 @@                         NoEvent -> (kSwitchAuxC1AE b fe, b)                         Event c -> sfTF (k (constant b) c) a --- !!! Untested optimization!+        -- !!! Untested optimization!         kSwitchAuxA1AE f1 fe = SF' tf -- False             where                 tf _ a =@@ -527,8 +357,6 @@ -- -- See <https://wiki.haskell.org/Yampa#Switches> for more -- information on how this switch works.---- !!! Has not been optimized properly. Should be like kSwitch. dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}     where@@ -560,31 +388,6 @@ broadcast a = fmap (\sf -> (a, sf))  --- !!! Hmm. We should really optimize here.--- !!! Check for Arr in parallel!--- !!! Check for Arr FDE in parallel!!!--- !!! Check for EP in parallel!!!!!--- !!! Cf &&&.--- !!! But how??? All we know is that the collection is a functor ...--- !!! Maybe that kind of generality does not make much sense for--- !!! par and parB? (Although it is niceto be able to switch into a--- !!! par or parB from within a pSwitch[B].)--- !!! If we had a parBList, that could be defined in terms of &&&, surely?--- !!! E.g.--- !!! parBList []       = constant []--- !!! parBList (sf:sfs) = sf &&& parBList sfs >>> arr (\(x,xs) -> x:xs)--- !!!--- !!! This ought to optimize quite well. E.g.--- !!! parBList [arr1,arr2,arr3]--- !!! = arr1 &&& parBList [arr2,arr3] >>> arrX--- !!! = arr1 &&& (arr2 &&& parBList [arr3] >>> arrX) >>> arrX--- !!! = arr1 &&& (arr2 &&& (arr3 &&& parBList [] >>> arrX) >>> arrX) >>> arrX--- !!! = arr1 &&& (arr2 &&& (arr3C >>> arrX) >>> arrX) >>> arrX--- !!! = arr1 &&& (arr2 &&& (arr3CcpX) >>> arrX) >>> arrX--- !!! = arr1 &&& (arr23CcpX >>> arrX) >>> arrX--- !!! = arr1 &&& (arr23CcpXcpX) >>> arrX--- !!! = arr123CcpXcpXcpX- -- | Spatial parallel composition of a signal function collection. -- Given a collection of signal functions, it returns a signal -- function that broadcasts its input signal to every element@@ -701,9 +504,6 @@ -- the switching event occurs, all signal function are "frozen" and their -- continuations are passed to the continuation function, along with the -- event value.------- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE pSwitch :: Functor col         => (forall sf . (a -> col sf -> col (b, sf)))               -- ^ Routing function: determines the input to each signal@@ -754,9 +554,6 @@ -- Since the continuations are plain, ordinary signal functions, -- they can be resumed, discarded, stored, or combined with -- other signal functions.---- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE.--- dpSwitch :: Functor col          => (forall sf . (a -> col sf -> col (b, sf)))               -- ^ Routing function. Its purpose is to pair up each running@@ -831,12 +628,6 @@     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.@@ -863,13 +654,6 @@     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--}- ------------------------------------------------------------------------------ -- * Parallel composition/switchers with "zip" routing ------------------------------------------------------------------------------@@ -945,9 +729,6 @@ drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b] drpSwitchZ = drpSwitch (safeZip "drpSwitchZ") --- IPerez: This is actually unsafezip. Zip is actually safe. It works--- regardless of which list is smallest. This version of zip is right-biased:--- the second list determines the size of the final list. safeZip :: String -> [a] -> [b] -> [(a,b)] safeZip fn l1 l2 = safeZip' l1 l2   where
src/FRP/Yampa/Task.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP        #-} {-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Task -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -11,9 +10,6 @@ -- Portability :  non-portable (GHC extensions) -- -- Task abstraction on top of signal transformers.------------------------------------------------------------------------------------- module FRP.Yampa.Task (     Task,     mkTask,      -- :: SF a (b, Event c) -> Task a b c@@ -46,11 +42,11 @@  -- | A task is a partially SF that may terminate with a result. --- 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 =+    -- CPS-based representation allowing 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.     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))@@ -87,10 +83,6 @@  -- | Creates an SF that represents an SF and produces an event -- when the task terminates, and otherwise produces just an output.---- 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_"@@ -116,38 +108,36 @@     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).--}+-- 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
src/FRP/Yampa/Time.hs view
@@ -1,4 +1,3 @@--------------------------------------------------------------------------------- -- | -- Module      :  FRP.Yampa.Time -- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -21,8 +20,6 @@ -- produce the value one (@1@). If you really, really, really need to know the -- time delta, and need to abandon the hybrid\/FRP abstraction, see -- 'FRP.Yampa.Integration.iterFrom'.---------------------------------------------------------------------------------- module FRP.Yampa.Time (     localTime,          -- :: SF a Time     time,               -- :: SF a Time,        Other name for localTime.@@ -30,9 +27,9 @@  import Control.Arrow +import FRP.Yampa.Basic        (constant)+import FRP.Yampa.Integration  (integral) import FRP.Yampa.InternalCore (SF, Time)-import FRP.Yampa.Basic (constant)-import FRP.Yampa.Integration (integral)  -- | Outputs the time passed since the signal function instance was started. localTime :: SF a Time
− tests/AFRPTests.hs 
@@ -1,191 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 Bool-runRegTests = do-    putStrLn ""-    putStrLn "Running the AFRP regression tests ..."-    if allGood-      then putStrLn "All tests succeeded!"-      else mapM_ putStrLn failedTests-    return allGood--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 
@@ -1,361 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 
@@ -1,53 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,70 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,57 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,170 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- -******************************************************************************-*                                  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----------------------------------------------------------------------------------- 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-				           && x5 ~= y5--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..] :: [Int] ]-	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--    -- return output-    readIORef outputr----------------------------------------------------------------------------------- Some utilities used for testing laws---------------------------------------------------------------------------------fun_prod f g = \(x,y) -> (f x, g y)--assoc :: ((a,b),c) -> (a,(b,c))-assoc ((a,b),c) = (a,(b,c))--assocInv :: (a,(b,c)) -> ((a,b),c)-assocInv (a,(b,c)) = ((a,b),c)
− tests/AFRPTestsComp.hs 
@@ -1,72 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,89 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,56 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,584 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 
@@ -1,128 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 Data.Tuple (swap)--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 
@@ -1,129 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 ((*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 (id *** (+3.0))))-laws_t6_rhs :: [(Double, Double)]-laws_t6_rhs = testSF1 (arr dup >>> (arr (id *** (+3.0)) >>> first integral))--laws_t7_lhs :: [Double]-laws_t7_lhs = testSF1 (arr dup >>> (first integral >>> arr fst))-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 
@@ -1,207 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,105 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,110 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 Data.Tuple(swap)--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 = 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 assocInv >>> 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 assocInv)))----- 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 
@@ -1,63 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,325 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 
@@ -1,209 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,246 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 
@@ -1,144 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 
@@ -1,71 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 
@@ -1,473 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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]---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 
@@ -1,214 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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.EventS--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 
@@ -1,232 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 Control.Monad (when, forever)-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---- | 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 = when (p i) $ m >> for (f i) f p m-
− tests/AFRPTestsUtils.hs 
@@ -1,372 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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.Conditional-import FRP.Yampa.EventS-import FRP.Yampa.Hybrid-import FRP.Yampa.Switches--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 
@@ -1,103 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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/testAFRPMain.hs 
@@ -1,78 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 Control.Monad (when)-import System.Environment (getArgs, getProgName)-import System.Exit (exitWith, ExitCode(..))-import System.IO---- 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-    Right emsg  -> usage pname (Just emsg)-    Left tFlags ->-      if tHelp tFlags-        then usage pname Nothing-        else do-          -- Run regresion tests, check if passed-          t <- if tReg tFlags-                 then runRegTests-                 else return True-          -- Run space tests-          when (tSpace tFlags)-                  runSpaceTests-          -- Communicate if all tests have passed-          let exitCode = if t then ExitSuccess else (ExitFailure 1)-          exitWith exitCode--