packages feed

yampa-test 0.13.4 → 0.13.5

raw patch · 50 files changed

+5051/−5657 lines, 50 filesdep ~YampaPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Yampa

API changes (from Hackage documentation)

Files

CHANGELOG view
@@ -1,3 +1,24 @@+2022-06-07 Ivan Perez <ivan.perez@haskell.sexy>+        * yampa-test.cabal: Version bump (0.13.5) (#220), fix broken link in+          description (#204), enable all warnings (#206), rename flag (#208),+          rename test (#208), adjust modules to run regression tests with+          QuickCheck testing module (#208), reorganize tests to match Yampa's+          module hierarchy (#216).+        * src/: Style consistency of separators (#211), adjust format of export+          lists (#212), compress multiple empty lines (#214), adjust+          indentation to two spaces (#215).+        * tests/: Replace tabs with spaces (#205), remove local option disable+          warning on tabs (#206), format module header to conform to style+          guide (#207), adjust modules to run regression tests with QuickCheck+          testing module (#208), rename space usage test to reflect module's+          new purpose (#208), style consistency of separators (#211), adjust+          format of export lists (#212), align lists, tuples, records by+          leading comma (#213), compress multiple empty lines (#214), adjust+          indentation to two spaces (#215), reorganize tests to match Yampa's+          module hierarchy (#216), reorganize declarations and tests within+          modules to match Yampa (#217), move ArrowLoop tests into InternalCore+          test module (#218).+ 2022-04-07 Ivan Perez <ivan.perez@haskell.sexy>         * yampa-test.cabal: Version bump (0.13.4) (#203), syntax rules (#196),           add regression tests (#201).
src/FRP/Yampa/LTLFuture.hs view
@@ -14,9 +14,9 @@ -- see what is going on there... :(  module FRP.Yampa.LTLFuture-  ( TPred(..)-  , evalT-  )+    ( TPred(..)+    , evalT+    )   where  import FRP.Yampa@@ -51,11 +51,11 @@ evalT (Until t1 t2)   = \stream -> (evalT t1 stream && evalT (Next (Until t1 t2)) stream)                                    || evalT t2 stream evalT (Next t1)       = \stream -> case stream of-                                    (a,[]) -> True   -- This is important. It determines how-                                                     -- always and next behave at the-                                                     -- end of the stream, which affects that is and isn't-                                                     -- a tautology. It should be reviewed very carefully.-                                    (a1,(dt, a2):as) -> evalT (tauApp t1 a1 dt) (a2, as)+                                     (a,[]) -> True   -- This is important. It determines how+                                                      -- always and next behave at the+                                                      -- end of the stream, which affects that is and isn't+                                                      -- a tautology. It should be reviewed very carefully.+                                     (a1,(dt, a2):as) -> evalT (tauApp t1 a1 dt) (a2, as)  -- | Tau-application (transportation to the future) tauApp :: TPred a -> a -> DTime -> TPred a
src/FRP/Yampa/LTLPast.hs view
@@ -10,7 +10,6 @@  module FRP.Yampa.LTLPast where ------------------------------------------------------------------------------- import FRP.Yampa  -- | True if both inputs are True.
src/FRP/Yampa/QuickCheck.hs view
@@ -17,22 +17,22 @@ -- paper was: uniDistStream. This has been fixed.  module FRP.Yampa.QuickCheck-  (-    -- * Random stream generation-    generateStream-  , generateStreamWith+    (+      -- * Random stream generation+      generateStream+    , generateStreamWith -    -- ** Parameters used to generate random input streams-  , Distribution(..)-  , Range-  , Length+      -- ** Parameters used to generate random input streams+    , Distribution(..)+    , Range+    , Length -    -- ** Helpers for common cases-  , uniDistStream-  , uniDistStreamMaxDT-  , fixedDelayStream-  , fixedDelayStreamWith-  )+      -- ** Helpers for common cases+    , uniDistStream+    , uniDistStreamMaxDT+    , fixedDelayStream+    , fixedDelayStreamWith+    )   where  import Control.Applicative ((<$>), pure)@@ -56,7 +56,6 @@ -- samples. type Length = Maybe (Either Int DTime) - -- | Generate a random delta according to some required specifications. generateDeltas :: Distribution -> Range -> Length -> Gen DTime generateDeltas DistConstant            (mn, mx) len = generateDelta mn mx@@ -179,7 +178,6 @@ -- generateStreamLenDT (Nothing, Nothing) (Just (Right ds)) = f2  <$> arbitrary --   where --     f2 l = (ds / fromIntegral l, l)-  -- | Generate a stream of values with uniformly distributed time deltas. uniDistStream :: Arbitrary a => Gen (SignalSampleStream a)
+ tests/Main.hs view
@@ -0,0 +1,49 @@+-- 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 Main where++import Test.Tasty (TestTree, defaultMain, testGroup)++import qualified Test.FRP.Yampa.Basic        as Basic+import qualified Test.FRP.Yampa.Conditional  as Conditional+import qualified Test.FRP.Yampa.Delays       as Delays+import qualified Test.FRP.Yampa.EventS       as EventS+import qualified Test.FRP.Yampa.Hybrid       as Hybrid+import qualified Test.FRP.Yampa.Integration  as Integration+import qualified Test.FRP.Yampa.InternalCore as InternalCore+import qualified Test.FRP.Yampa.Loop         as Loop+import qualified Test.FRP.Yampa.Scan         as Scan+import qualified Test.FRP.Yampa.Simulation   as Simulation+import qualified Test.FRP.Yampa.Switches     as Switches+import qualified Test.FRP.Yampa.Task         as Task+import qualified Test.FRP.Yampa.Time         as Time++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Yampa QC properties"+  [ Basic.tests+  , Conditional.tests+  , Delays.tests+  , EventS.tests+  , Hybrid.tests+  , Integration.tests+  , InternalCore.tests+  , Loop.tests+  , Scan.tests+  , Simulation.tests+  , Switches.tests+  , Task.tests+  , Time.tests+  ]
+ tests/Space.hs view
@@ -0,0 +1,249 @@+-- |+-- Module      : Space+-- Description : Space tests.+-- Copyright   : Yale University, 2003+-- Authors     : Henrik Nilsson and Antony Courtney+module Main where++import FRP.Yampa+import Data.List (findIndex)+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef (newIORef, writeIORef, readIORef)++import TestsCommon (REq(..))++main :: IO ()+main = do+    putStrLn ""+    putStrLn "Running the Yampa 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)++-- * Test cases for arr++arr_st0 = testSFSpaceLeak 2000000 (arr (+1))+arr_st0r = 1000000.5++arr_st1 = testSFSpaceLeak 2000000 identity+arr_st1r = 999999.5++-- * Test cases for loop++loop_acc :: SF (Double, Double) (Double, Double)+loop_acc = arr (\(x, y)->(x+y, x+y))++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++-- * Test cases for rSwitch and drSwitch++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_st0 = testSFSpaceLeak 2000000 rswitch_sawTooth+rswitch_st0r = 4.75++-- * Test cases for pSwitchB and dpSwitchB++-- 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_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++-- 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_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_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)++-- * Test cases for rpSwitchB and drpSwitchB++-- 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_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]++-- * Test cases for accumulators++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++------------------------------------------------------------------------------+-- 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
+ tests/Test/FRP/Yampa/Basic.hs view
@@ -0,0 +1,116 @@+-- |+-- Description : Test cases for basic signal functions+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Basic+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Basic"+  [ testProperty "identity (fixed)"  (property $ basicsf_t0 ~= basicsf_t0r)+  , testProperty "identity (qc)"     prop_basic_identity_1+  , testProperty "identity (qc)"     prop_basic_identity_2+  , testProperty "constant (fixed)"  (property $ basicsf_t1 ~= basicsf_t1r)+  , testProperty "constant (qc)"     prop_basic_constant+  , testProperty "initially (fixed)" (property $ basicsf_t4 ~= basicsf_t4r)+  , testProperty "initially (qc)"    prop_basic_initially+  ]++-- * Basic signal functions++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+  ]++-- Yampa's Basic SF builders+prop_basic_identity_1 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream+        sf   = identity+        pred = (==)++prop_basic_identity_2 =+    forAll myStream (evalT $ prop_always_equal identity (arr id))+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++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+  ]++prop_basic_constant =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sf   = constant 42.0+        pred = const (== 42.0)++-- * Initialization++prop_insert =+    forAll initialValueG $ \initialValue ->+    forAll finalValueG $ \finalValue ->+    forAll myStream $ evalT $+      let sfStep = initialValue --> constant finalValue++      in And (prop (sfStep, const (== initialValue)))+             (Next $ Always $+                       (prop (sfStep, const (== finalValue))))++  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        initialValueG :: Gen Float+        initialValueG = arbitrary++        finalValueG  :: Gen Float+        finalValueG = arbitrary++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+  ]++prop_basic_initially =+    forAll myStream $ evalT $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sf   = initially 42.0+        pred = const (== 42.0)++-- * Auxiliary++-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)++-- | Compares two SFs, resulting in true if they are always equal+prop_always_equal sf1 sf2 =+    Always $ SP ((sf1 &&& sf2) >>> arr sameResult)+  where sameResult = uncurry (==)
+ tests/Test/FRP/Yampa/Conditional.hs view
@@ -0,0 +1,61 @@+-- |+-- Description : Test cases for FRP.Yampa.Conditional+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Conditional+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Conditional (provided)++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Conditional"+  [ testProperty "provided (1, fixed)" (property $ utils_t8 ~= utils_t8r)+  , testProperty "provided (2, fixed)" (property $ utils_t9 ~= utils_t9r)+  ]++-- * Guards and automata-oriented combinators++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+  ]
+ tests/Test/FRP/Yampa/Delays.hs view
@@ -0,0 +1,303 @@+-- |+-- Description : Test cases for FRP.Yampa.Delays+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Delays+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Delays"+  [ testProperty "iPre (0, fixed)"         (property $ pre_t0 ~= pre_t0r)+  , testProperty "iPre (1, fixed)"         (property $ pre_t1 ~= pre_t1r)+  , testProperty "iPre (2, fixed)"         (property $ pre_t2 ~= pre_t2r)+  , testProperty "iPre (3, fixed)"         (property $ pre_t3 == pre_t3r)+  , testProperty "iPre (4, fixed)"         (property $ pre_t4 == pre_t4r)+  , testProperty "iPre (5, fixed)"         (property $ pre_t5 == pre_t5r)+  , testProperty "iPre (6, fixed)"         (property $ pre_t6 == pre_t6r)+  , testProperty "iPre (7, fixed)"         (property $ pre_t7 == pre_t7r)+  , testProperty "iPre (8, fixed)"         (property $ pre_t8 == pre_t8r)+  , testProperty "delay (0, fixed)"        (property $ delay_t0 ~= delay_t0r)+  , testProperty "delay (1, fixed)"        (property $ delay_t1 ~= delay_t1r)+  , testProperty "delay (2, fixed)"        (property $ delay_t2 ~= delay_t2r)+  , testProperty "delay (3, fixed)"        (property $ delay_t3 ~= delay_t3r)+  , testProperty "delay (4, fixed)"        (property $ delay_t4 == delay_t4r)+  , testProperty "delay (5, fixed)"        (property $ delay_t5 ~= delay_t5r)+  , testProperty "delay (zero delay, qc)"  prop_delay_1+  , testProperty "delay (small delay, qc)" prop_delay_2+  ]++-- * Delays++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+          ]++-- * Timed 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)))++-- | Delaying by 0.0 has no effect+prop_delay_1 =+    forAll myStream $ evalT $ prop_always_equal sfDelayed sf+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sfDelayed = delay 0.0 undefined >>> sf+        sf = arr (+1)++-- | Delaying input signal by a small amount will fill in the "blank" signal+--   with the given value, which will become also the sample at the initial+--   time.+prop_delay_2 =+    forAll myStream $ evalT $+      (prop (sfDelayed, (\x y -> y == initialValue)))+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sfDelayed = delay 0.0001 initialValue++        initialValue = 17++-- * Auxiliary++-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)++-- | Compares two SFs, resulting in true if they are always equal+prop_always_equal sf1 sf2 =+    Always $ SP ((sf1 &&& sf2) >>> arr sameResult)+  where sameResult = uncurry (==)
+ tests/Test/FRP/Yampa/EventS.hs view
@@ -0,0 +1,799 @@+-- |+-- Description : Test cases for signal functions working with events+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson++-- Notes pertaining to regression tests:+-- - Add test cases for Yampa. There should be at least one test case for each+--   "non-trivial" entity exported from Yampa.+--+-- - 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.+module Test.FRP.Yampa.EventS+    ( tests+    )+  where++import Test.QuickCheck hiding (once, sample)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.EventS (snap, sampleWindow, recur, andThen, snapAfter, sample)+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.EventS"+  [ testProperty "never (0, fixed)"        (property $ evsrc_t0 ~= evsrc_t0r)+  , testProperty "Events > No event"       prop_event_noevent+  , testProperty "eventS (1, fixed)"       (property $ evsrc_t1 ~= evsrc_t1r)+  , testProperty "Events > Now"            prop_event_now+  , testProperty "eventS (2, fixed)"       (property $ evsrc_t2 ~= evsrc_t2r)+  , testProperty "Events > After 0.0"      prop_event_after_0+  , testProperty "eventS (3, fixed)"       (property $ evsrc_t3 ~= evsrc_t3r)+  , testProperty "eventS (4, fixed)"       (property $ evsrc_t4 ~= evsrc_t4r)+  , testProperty "eventS (5, fixed)"       (property $ evsrc_t5 ~= evsrc_t5r)+  , testProperty "eventS (6, fixed)"       (property $ evsrc_t6 ~= evsrc_t6r)+  , testProperty "eventS (7, fixed)"       (property $ evsrc_t7 ~= evsrc_t7r)+  , testProperty "eventS (8, fixed)"       (property $ evsrc_t8 ~= evsrc_t8r)+  , testProperty "eventS (9, fixed)"       (property $ evsrc_t9 ~= evsrc_t9r)+  , testProperty "eventS (10, fixed)"      (property $ evsrc_t10 ~= evsrc_t10r)+  , testProperty "eventS (11, fixed)"      (property $ evsrc_t11 ~= evsrc_t11r)+  , testProperty "eventS (28, fixed)"      (property $ evsrc_t28 ~= evsrc_t28r)+  , testProperty "eventS (30, fixed)"      (property $ evsrc_t30 ~= evsrc_t30r)+  , testProperty "eventS (29, fixed)"      (property $ evsrc_t29 ~= evsrc_t29r)+  , testProperty "eventS (12, fixed)"      (property $ evsrc_t12 ~= evsrc_t12r)+  , testProperty "eventS (13, fixed)"      (property $ evsrc_t13 ~= evsrc_t13r)+  , testProperty "eventS (14, fixed)"      (property $ evsrc_t14 ~= evsrc_t14r)+  , testProperty "eventS (15, fixed)"      (property $ evsrc_t15 ~= evsrc_t15r)+  , testProperty "eventS (16, fixed)"      (property $ evsrc_t16 ~= evsrc_t16r)+  , testProperty "eventS (17, fixed)"      (property $ evsrc_t17 ~= evsrc_t17r)+  , testProperty "eventS (18, fixed)"      (property $ evsrc_t18 ~= evsrc_t18r)+  , testProperty "eventS (19, fixed)"      (property $ evsrc_t19 ~= evsrc_t19r)+  , testProperty "eventS (20, fixed)"      (property $ evsrc_t20 ~= evsrc_t20r)+  , testProperty "eventS (21, fixed)"      (property $ evsrc_t21 ~= evsrc_t21r)+  , testProperty "eventS (22, fixed)"      (property $ evsrc_t22 ~= evsrc_t22r)+  , testProperty "eventS (23, fixed)"      (property $ evsrc_t23 ~= evsrc_t23r)+  , testProperty "eventS (24, fixed)"      (property $ evsrc_t24 ~= evsrc_t24r)+  , testProperty "eventS (25, fixed)"      (property $ evsrc_t25 ~= evsrc_t25r)+  , testProperty "eventS (26, fixed)"      (property $ evsrc_t26 ~= evsrc_t26r)+  , testProperty "eventS (27, fixed)"      (property $ evsrc_t27 ~= evsrc_t27r)+  , testProperty "snap (fixed)"            (property $ utils_t10 ~= utils_t10r)+  , testProperty "snapAfter (fixed)"       (property $ utils_t11 ~= utils_t11r)+  , testProperty "sample (fixed)"          (property $ utils_t12 ~= utils_t12r)+  , testProperty "sampleWindow (0, fixed)" (property $ utils_t15 ~= utils_t15r)+  , testProperty "sampleWindow (1, fixed)" (property $ utils_t16 ~= utils_t16r)+  , testProperty "after (0, fixed)"        (property $ utils_t13 ~= utils_t13r)+  , testProperty "after (1, fixed)"        (property $ utils_t14 ~= utils_t14r)+  ]++-- * Basic event sources++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+  ]++prop_event_noevent =+    forAll myStream $ evalT $ Always $ prop (sfNever, const (== noEvent))++  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream+        sfNever :: SF Float (Event Float)+        sfNever = never++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+  ]++prop_event_now =+    forAll myStream $ evalT $+      -- (sf, p0) /\ O [] (sf, pn)+      And (prop (sf, p0))                 -- Initially+          (Next $ Always $ prop (sf, pn)) -- After first sample++  where sf = Yampa.now 42.0++        p0 x y = y == Event 42.0+        pn x y = y == noEvent++        myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++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+  ]++prop_event_after_0 =+    forAll myStream $ evalT $+      -- (sf, p0) /\ O [] (sf, pn)+      And (prop (sf, p0))                 -- Initially+          (Next $ Always $ prop (sf, pn)) -- After first sample++  where sf = after 0.0 42.0++        p0 x y = y == Event 42.0+        pn x y = y == noEvent++        myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++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_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+  ]++-- "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_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+  ]++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+  ]++-- * Stateful event suppression++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+  ]++-- ** Hybrid continuous-to-discrete SF combinators.++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_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+  ]++-- * Repetition and switching++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+  ]++-- * Auxiliary++-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)
+ tests/Test/FRP/Yampa/Hybrid.hs view
@@ -0,0 +1,472 @@+-- |+-- Description : Test cases for hybrid signal functions+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Hybrid+    ( tests+    )+  where++import Data.Maybe (fromJust)++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Hybrid as Yampa++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Hybrid"+  [ testProperty "hold (0, fixed)"          (property $ wfg_t0 ~= wfg_t0r)+  , testProperty "hold (1, fixed)"          (property $ wfg_t1 ~= wfg_t1r)+  , testProperty "dHold (0, fixed)"         (property $ utils_t0 ~= utils_t0r)+  , testProperty "dHold (1, fixed)"         (property $ utils_t1 ~= utils_t1r)+  , testProperty "trackAndHold (0, fixed)"  (property $ wfg_t2 ~= wfg_t2r)+  , testProperty "trackAndHold (1, fixed)"  (property $ wfg_t3 ~= wfg_t3r)+  , testProperty "dTrackAndHold (0, fixed)" (property $ utils_t2 ~= utils_t2r)+  , testProperty "dTrackAndHold (1, fixed)" (property $ utils_t3 ~= utils_t3r)+  , testProperty "accum (0, fixed)"         (property $ accum_t0  == accum_t0r)+  , testProperty "accum (1, fixed)"         (property $ accum_t1  == accum_t1r)+  , testProperty "accum (2, fixed)"         (property $ accum_t2  == accum_t2r)+  , testProperty "accum (3, fixed)"         (property $ accum_t3  == accum_t3r)+  , testProperty "accum (8, fixed)"         (property $ accum_t8  == accum_t8r)+  , testProperty "accum (9, fixed)"         (property $ accum_t9  == accum_t9r)+  , testProperty "accum (11, fixed)"        (property $ accum_t11 == accum_t11r)+  , testProperty "accum (10, fixed)"        (property $ accum_t10 == accum_t10r)+  , testProperty "accum (12, fixed)"        (property $ accum_t12 == accum_t12r)+  , testProperty "accum (4, fixed)"         (property $ accum_t4  == accum_t4r)+  , testProperty "accum (5, fixed)"         (property $ accum_t5  == accum_t5r)+  , testProperty "accum (6, fixed)"         (property $ accum_t6  == accum_t6r)+  , testProperty "accum (7, fixed)"         (property $ accum_t7  == accum_t7r)+  , testProperty "accum (13, fixed)"        (property $ accum_t13 == accum_t13r)+  , testProperty "accum (14, fixed)"        (property $ accum_t14 == accum_t14r)+  , testProperty "accum (15, fixed)"        (property $ accum_t15 == accum_t15r)+  , testProperty "accum (16, fixed)"        (property $ accum_t16 == accum_t16r)+  , testProperty "accum (17, fixed)"        (property $ accum_t17 == accum_t17r)+  ]++-- * Wave-form generation++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_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_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+  ]++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+  ]++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_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_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_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_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_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_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_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++-- * Accumulators++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_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_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_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_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_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_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_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_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_inp5 = deltaEncode 0.25 (repeat ())++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_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_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_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_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_accFiltFun1 a d =+  let a' = a + floor d+  in if even 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+  ]++accum_accFiltFun2 a d =+  let a' = a + floor d+  in if odd a'+       then (a', Just (a' > 10, a'))+       else (a', Nothing)++-- 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_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!
+ tests/Test/FRP/Yampa/Integration.hs view
@@ -0,0 +1,152 @@+-- |+-- Description : Test cases for FRP.Yampa.Integration+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Integration+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Integration"+  [ testProperty "impulseIntegral (0, fixed)" (property $ utils_t7 ~= utils_t7r)+  , testProperty "count (0, fixed)"           (property $ utils_t4 ~= utils_t4r)+  , testProperty "count (1, fixed)"           (property $ utils_t5 ~= utils_t5r)+  , testProperty "derivative (fixed)"         (property $ der_t0_max_diff < 0.05)+  , testProperty "derivative (1, qc)"         prop_derivative_1+  , testProperty "derivative (2, qc)"         prop_derivative_2+  ]++-- * Integration+--+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_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_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_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+  ]++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++-- * Differentiation++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)))++prop_derivative_1 =+    forAll myStream $ evalT $+      Next $ Always $ prop ((sfDer &&& sfDerByHand), const close)++  where myStream :: Gen (SignalSampleStream Double)+        myStream = fixedDelayStreamWith (\t -> sin(2 * pi * t)) der_step++        sfDer :: SF Time Time+        sfDer = derivative++        sfDerByHand = localTime >>> arr (\t -> (2 * pi * cos (2 * pi * t)))++        close (x,y) = abs (x-y) < 0.05++prop_derivative_2 =+    forAll myStream $ evalT $+      Next $ Always $ prop ( sfDer &&& sfDerByHand+                           , const close)++  where+    myStream :: Gen (SignalSampleStream Double)+    myStream = fixedDelayStream der_step++    sfDer :: SF Time Time+    sfDer = localTime+              >>> arr (\t -> sin(2*pi*t))+                >>> derivative++    sfDerByHand = localTime+                    >>> arr (\t -> 2*pi*cos (2*pi*t))++    close (x,y) = abs (x-y) < 0.05++-- * Auxiliary+-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)
+ tests/Test/FRP/Yampa/InternalCore.hs view
@@ -0,0 +1,694 @@+-- |+-- Description : Test cases for FRP.Yampa.InternalCore+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.InternalCore+    ( tests+    )+  where++import Test.QuickCheck+import Test.QuickCheck.Function+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Data.Tuple (swap)++import FRP.Yampa as Yampa+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.InternalCore"+  [ testProperty "arr (0, fixed)"                         (property $ arr_t0 ~= arr_t0r)+  , testProperty "arr (1, fixed)"                         (property $ arr_t1 ~= arr_t1r)+  , testProperty "Arrow Naturality"                       prop_arr_naturality+  , testProperty "composition (0, fixed)"                 (property $ comp_t0 ~= comp_t0r)+  , testProperty "composition (1, fixed)"                 (property $ comp_t1 ~= comp_t1r)+  , testProperty "composition (2, fixed)"                 (property $ comp_t2 ~= comp_t2r)+  , testProperty "composition (3, fixed)"                 (property $ comp_t3 ~= comp_t3r)+  , testProperty "composition (4, fixed)"                 (property $ comp_t4 ~= comp_t4r)+  , testProperty "composition (5, fixed)"                 (property $ comp_t5 ~= comp_t5r)+  , testProperty "Arrows > Composition (1)"               prop_arrow_comp_1+  , testProperty "Arrows > Composition (2)"               prop_arrow_comp_2+  , testProperty "Arrows > Composition (3)"               prop_arrow_comp_3+  , testProperty "first (0, fixed)"                       (property $ first_t0 ~= first_t0r)+  , testProperty "first (1, fixed)"                       (property $ first_t1 ~= first_t1r)+  , testProperty "first (2, fixed)"                       (property $ first_t2 ~= first_t2r)+  , testProperty "first (3, fixed)"                       (property $ first_t3 ~= first_t3r)+  , testProperty "first (4, fixed)"                       (property $ first_t4 ~= first_t4r)+  , testProperty "first (5, fixed)"                       (property $ first_t5 ~= first_t5r)+  , testProperty "Arrows > First (1)"                     prop_arrow_first_1+  , testProperty "Arrows > First (2)"                     prop_arrow_first_2+  , testProperty "second (0, fixed)"                      (property $ second_t0 ~= first_t0r)+  , testProperty "second (1, fixed)"                      (property $ second_t1 ~= first_t1r)+  , testProperty "second (2, fixed)"                      (property $ second_t2 ~= first_t2r)+  , testProperty "second (3, fixed)"                      (property $ second_t3 ~= first_t3r)+  , testProperty "second (4, fixed)"                      (property $ second_t4 ~= first_t4r)+  , testProperty "second (5, fixed)"                      (property $ second_t5 ~= first_t5r)+  , testProperty "Arrows > Second (1)"                    prop_arrow_second_1+  , testProperty "Arrows > Second (2)"                    prop_arrow_second_2+  , testProperty "arrow laws (0, fixed)"                  (property $ laws_t0_lhs ~= laws_t0_rhs)+  , testProperty "Arrows > Identity (0)"                  prop_arrow_id_0+  , testProperty "arrow laws (1, fixed)"                  (property $ laws_t1_lhs ~= laws_t1_rhs)+  , testProperty "Arrows > Identity (2)"                  prop_arrow_id_2+  , testProperty "arrow laws (2, fixed)"                  (property $ laws_t2_lhs ~= laws_t2_rhs)+  , testProperty "Arrows > Associativity"                 prop_arrow_assoc+  , testProperty "arrow laws (3, fixed)"                  (property $ laws_t3_lhs ~= laws_t3_rhs)+  , testProperty "Arrows > Function lifting composition"  prop_arrow_arr_comp+  , testProperty "arrow laws (4, fixed)"                  (property $ laws_t4_lhs ~= laws_t4_rhs)+  , testProperty "Arrows > First"                         prop_arrow_first_3+  , testProperty "arrow laws (5, fixed)"                  (property $ laws_t5_lhs ~= laws_t5_rhs)+  , testProperty "Arrows > Distributivity of First"       prop_arrow_first_distrib+  , testProperty "arrow laws (6, fixed)"                  (property $ laws_t6_lhs ~= laws_t6_rhs)+  , testProperty "Arrows > Commutativity of id on first"  prop_arrow_first_id_comm+  , testProperty "arrow laws (7, fixed)"                  (property $ laws_t7_lhs ~= laws_t7_rhs)+  , testProperty "arrow laws (8, fixed)"                  (property $ laws_t8_lhs ~= laws_t8_rhs)+  , testProperty "Arrows > Nested firsts"                 prop_arrow_first_nested+  , testProperty "loop (0, fixed)"                        (property $ loop_t0  ~= loop_t0r)+  , testProperty "loop (1, fixed)"                        (property $ loop_t1  ~= loop_t1r)+  , testProperty "loop (2, fixed)"                        (property $ loop_t2  ~= loop_t2r)+  , testProperty "loop (3, fixed)"                        (property $ loop_t3  ~= loop_t3r)+  , testProperty "loop (4, fixed)"                        (property $ loop_t4  ~= loop_t4r)+  , testProperty "loop (5, fixed)"                        (property $ loop_t5  ~= loop_t5r)+  , testProperty "loop (6, fixed)"                        (property $ loop_t6  ~= loop_t6r)+  , testProperty "loop (7, fixed)"                        (property $ loop_t7  ~= loop_t7r)+  , testProperty "loop (8, fixed)"                        (property $ loop_t8  ~= loop_t8r)+  , testProperty "loop (9, fixed)"                        (property $ loop_t9  ~= loop_t9r)+  , testProperty "loop (10, fixed)"                       (property $ loop_t10 ~= loop_t10r)+  , testProperty "loop (11, fixed)"                       (property $ loop_t11 ~= loop_t11r)+  , testProperty "loop (12, fixed)"                       (property $ loop_t12 ~= loop_t12r)+  , testProperty "loop (13, fixed)"                       (property $ loop_t13 ~= loop_t13r)+  , testProperty "loop (14, fixed)"                       (property $ loop_t14 ~= loop_t14r)+  , testProperty "loop (15, fixed)"                       (property $ loop_t15 ~= loop_t15r)+  , testProperty "loop (16, fixed)"                       (property $ loop_t16 ~= loop_t16r)+  , testProperty "loop (17, fixed)"                       (property $ loop_t17 ~= loop_t17r)+  , testProperty "loop laws (0, fixed)"                   (property $ looplaws_t0_lhs  ~= looplaws_t0_rhs)+  , testProperty "loop laws (1, fixed)"                   (property $ looplaws_t1_lhs  ~= looplaws_t1_rhs)+  , testProperty "loop laws (2, fixed)"                   (property $ looplaws_t2_lhs  ~= looplaws_t2_rhs)+  , testProperty "loop laws (3, fixed)"                   (property $ looplaws_t3_lhs  ~= looplaws_t3_rhs)+  , testProperty "loop laws (4, fixed)"                   (property $ looplaws_t4_lhs  ~= looplaws_t4_rhs)+  , testProperty "loop laws (5, fixed)"                   (property $ looplaws_t5_lhs  ~= looplaws_t5_rhs)+  ]++-- * Arrow instance and implementation++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+  ]++prop_arrow_1 = forAll myStream $ evalT $+    Always $ prop (arr id, \x y -> x == y)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++-- C1: Arr naturality (testSF1 (arr (+1)))+prop_arr_naturality =+    forAll myStream $ \stream ->+      forAll f $ \f' ->+        evalT (Always (prop (arr (apply f'), \x y -> apply f' x == y)))+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream+        f :: Gen (Fun Int Int)+        f = arbitrary++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+  ]++-- Arrow composition (we use Int to avoid floating-point discrepancies)+prop_arrow_comp_1 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Int)+        myStream = uniDistStream++        sf   = arr (+1) >>> arr (+2)+        pred = (\x y -> x + 3 == y)++-- Arrow composition+prop_arrow_comp_2 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sf   = constant 5.0 >>> arr (+1)+        pred = const (== 6.0)++-- Arrow composition+prop_arrow_comp_3 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = fixedDelayStream 0.25++        sf :: SF a Float+        sf = constant 2.0 >>> integral >>> stepDiff (-0.5)++        pred = const (== 0.5)++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)+  ]++prop_arrow_first_1 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Int)+        myStream = uniDistStream++        sf   = arr dup >>> first (constant 7)+        pred = (\x y -> (7 :: Int, x) == y)++prop_arrow_first_2 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Int)+        myStream = uniDistStream++        sf   = arr dup >>> first (arr (+1))+        pred = (\x y -> (x + 1, x) == y)++-- 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)++prop_arrow_second_1 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Int)+        myStream = uniDistStream++        sf   = arr dup >>> second (constant 7)+        pred = (\x y -> (x, 7 :: Int) == y)++prop_arrow_second_2 =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Int)+        myStream = uniDistStream++        sf   = arr dup >>> second (arr (+1))+        pred = (\x y -> (x, x + 1) == y)++-- 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)++prop_arrow_id_0 =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)+  where sf1 = arr id >>> integral+        sf2 = integral+        pred = arr $ uncurry (==)++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++laws_t1_lhs :: [Double]+laws_t1_lhs = testSF1 (integral >>> arr id)+laws_t1_rhs :: [Double]+laws_t1_rhs = testSF1 (integral)++prop_arrow_id_2 =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)+  where sf1 = integral >>> arr id+        sf2 = integral+        pred = arr $ uncurry (==)++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++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))++prop_arrow_assoc =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)+  where sf1 = (integral >>> arr (*0.5)) >>> integral+        sf2 = integral >>> (arr (*0.5) >>> integral)+        pred = arr $ uncurry (==)++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++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))++prop_arrow_arr_comp =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)+  where sf1 = (arr ((*2.5) . (+3.0)))+        sf2 = (arr (+3.0) >>> arr (*2.5))+        pred = arr (uncurry (==))++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++prop_arrow_2 = forAll myStream $ evalT $+    Always $ prop (sf1 &&& sf2, const $ uncurry (==))+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream+        sf1 = arr (f >>> g)+        sf2 = arr f >>> arr g+        f = (+5)+        g = (/20)++prop_arrow_2' =+    forAll f $ \f' ->+      forAll g $ \g' ->+        forAll myStream $ evalT $+          prop_arrow_2'' (apply f') (apply g')++  where myStream :: Gen (SignalSampleStream Int)+        myStream = uniDistStream++        f, g :: Gen (Fun Int Int)+        f = arbitrary+        g = arbitrary++prop_arrow_2'' f g =+    Always $ prop (sf1 &&& sf2, const $ uncurry (==))+  where sf1 = arr (f >>> g)+        sf2 = arr f >>> arr g++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))++prop_arrow_first_3 =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)+  where sf1 = (arr dup >>> first (arr (*2.5)))+        sf2 = (arr dup >>> arr (fun_prod (*2.5) id))+        pred = uncurry (==)++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++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))))++prop_arrow_first_distrib =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)+  where sf1 = (arr dup >>> (first (integral >>> arr (+3.0))))+        sf2 = (arr dup >>> (first integral >>> first (arr (+3.0))))+        pred = uncurry (==)++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++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))++prop_arrow_first_id_comm =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)+  where sf1 = (arr dup >>> (first integral>>>arr (fun_prod id (+3.0))))+        sf2 = (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral))+        pred = uncurry (==)++        myStream :: Gen (SignalSampleStream Double)+        myStream = uniDistStream++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))++prop_arrow_first_nested =+    forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)+  where+    sf1 = (arr (\x -> ((x,x),())) >>> (first (first integral) >>> arr assoc))+    sf2 = (arr (\x -> ((x,x),())) >>> (arr assoc >>> first integral))++    pred = uncurry (==)++    myStream :: Gen (SignalSampleStream Double)+    myStream = uniDistStream++-- * 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+  ]++-- 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))++-- * Auxiliary++-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)++stepDiff :: Num a => a -> SF a a+stepDiff z = loopPre z (arr (\(x,y) -> (x - y, x)))
+ tests/Test/FRP/Yampa/Loop.hs view
@@ -0,0 +1,135 @@+-- |+-- Description : Test cases for SFs with loops+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Loop+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Loop"+  [ testProperty "loopPre (0, fixed)"      (property $ loopPre_t0 ~= loopPre_t0r)+  , testProperty "loopPre (1, fixed)"      (property $ loopPre_t1 ~= loopPre_t1r)+  , testProperty "loopPre (2, fixed)"      (property $ loopPre_t2 ~= loopPre_t2r)+  , testProperty "loopPre (3, fixed)"      (property $ loopPre_t3 ~= loopPre_t3r)+  , testProperty "loopPre (4, fixed)"      (property $ loopPre_t4 ~= loopPre_t4r)+  , testProperty "loopIntegral (0, fixed)" (property $ loopIntegral_t0 ~= loopIntegral_t0r)+  , testProperty "loopIntegral (1, fixed)" (property $ loopIntegral_t1 ~= loopIntegral_t1r)+  ]++-- * Loops with guaranteed well-defined feedback++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+  ]++-- 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+  ]
+ tests/Test/FRP/Yampa/Scan.hs view
@@ -0,0 +1,461 @@+-- |+-- Description : Test cases for signal functions using scan+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Scan+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Scan"+  [ testProperty "scan (3, fixed)"  (property $ sscan_t3 ~= sscan_t3r)+  , testProperty "scan (0, fixed)"  (property $ sscan_t0 ~= sscan_t0r)+  , testProperty "scan (1, fixed)"  (property $ sscan_t1 ~= sscan_t1r)+  , testProperty "scan (2, fixed)"  (property $ sscan_t2 ~= sscan_t2r)+  , testProperty "scan (4, fixed)"  (property $ sscan_t4 == sscan_t4r)+  , testProperty "scan (5, fixed)"  (property $ sscan_t5 == sscan_t5r)+  , testProperty "scan (6, fixed)"  (property $ sscan_t6 == sscan_t6r)+  , testProperty "scan (7, fixed)"  (property $ sscan_t7 == sscan_t7r)+  , testProperty "scan (8, fixed)"  (property $ sscan_t8 == sscan_t8r)+  , testProperty "scan (9, fixed)"  (property $ sscan_t9 == sscan_t9r)+  , testProperty "scan (10, fixed)" (property $ sscan_t10 == sscan_t10r)+  , testProperty "scan (11, fixed)" (property $ sscan_t11 == sscan_t11r)+  , testProperty "scan (12, fixed)" (property $ sscan_t12 == sscan_t12r)+  , testProperty "scan (13, fixed)" (property $ sscan_t13 ~= sscan_t13r)+  , testProperty "scan (14, fixed)" (property $ sscan_t14 ~= sscan_t14r)+  , testProperty "scan (15, fixed)" (property $ sscan_t15 ~= sscan_t15r)+  , testProperty "scan (16, fixed)" (property $ sscan_t16 ~= sscan_t16r)+  , testProperty "scan (17, fixed)" (property $ sscan_t17 ~= sscan_t17r)+  , testProperty "scan (18, fixed)" (property $ sscan_t18 ~= sscan_t18r)+  ]++-- ** Simple, stateful signal processing++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))++-- 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))++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+  ]
+ tests/Test/FRP/Yampa/Simulation.hs view
@@ -0,0 +1,101 @@+-- |+-- Description : Test cases for FRP.Yampa.Simulation+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Simulation+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef (newIORef, writeIORef, readIORef)++import FRP.Yampa as Yampa++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Simulation"+  [ testProperty "react (fixed)"    (property $ react_t0 ~= react_t0r)+  , testProperty "embed (0, fixed)" (property $ embed_t0 ~= embed_t0r)+  , testProperty "embed (1, fixed)" (property $ embed_t1 ~= embed_t1r)+  ]++-- * 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)+  ]++-- * 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+  ]
+ tests/Test/FRP/Yampa/Switches.hs view
@@ -0,0 +1,1006 @@+{-# LANGUAGE Arrows #-}+-- |+-- Description : Test cases for FRP.Yampa.Switches+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson++-- - Restructure test cases for papallel composition and switches to reflect+--   Yampa structure better. Separate test cases for the generic definitions?+module Test.FRP.Yampa.Switches+    ( tests+    )+  where++import Data.Fixed+import Data.List (findIndex)+import Data.Maybe (fromJust)++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Switches (rpSwitchZ)+import FRP.Yampa.EventS (snap)+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Switches"+  [ testProperty "switch (0, fixed)"    (property $ switch_t0 ~= switch_t0r)+  , testProperty "switch (1, fixed)"    (property $ switch_t1 ~= switch_t1r)+  , testProperty "switch (5, fixed)"    (property $ switch_t5 ~= switch_t5r)+  , testProperty "switch (2, fixed)"    (property $ switch_t2 ~= switch_t2r)+  , testProperty "switch (3, fixed)"    (property $ switch_t3 ~= switch_t3r)+  , testProperty "switch (4, fixed)"    (property $ switch_t4 ~= switch_t4r)+  , testProperty "rswitch (0, fixed)"   (property $ rswitch_t0 ~= rswitch_t0r)+  , testProperty "rswitch (1, fixed)"   (property $ rswitch_t1 ~= rswitch_t1r)+  , testProperty "rswitch (2, fixed)"   (property $ rswitch_t2 ~= rswitch_t2r)+  , testProperty "rswitch (3, fixed)"   (property $ rswitch_t3 ~= rswitch_t3r)+  , testProperty "rswitch (4, fixed)"   (property $ rswitch_t4 ~= rswitch_t4r)+  , testProperty "kswitch (0, fixed)"   (property $ kswitch_t0 ~= kswitch_t0r)+  , testProperty "kswitch (2, fixed)"   (property $ kswitch_t2 ~= kswitch_t2r)+  , testProperty "kswitch (1, fixed)"   (property $ kswitch_t1 ~= kswitch_t1r)+  , testProperty "kswitch (3, fixed)"   (property $ kswitch_t3 ~= kswitch_t3r)+  , testProperty "kswitch (4, fixed)"   (property $ kswitch_t4 ~= kswitch_t4r)+  , testProperty "parB (fixed)"         (property $ coc_t0 ~= coc_t0r)+  , testProperty "parB (qc)"            prop_broadcast+  , testProperty "pswitch (0, fixed)"   (property $ pswitch_t0 ~= pswitch_t0r)+  , testProperty "pswitch (2, fixed)"   (property $ pswitch_t2 ~= pswitch_t2r)+  , testProperty "pswitch (5, fixed)"   (property $ pswitch_t5 ~= pswitch_t5r)+  , testProperty "pswitch (1, fixed)"   (property $ pswitch_t1 ~= pswitch_t1r)+  , testProperty "pswitch (3, fixed)"   (property $ pswitch_t3 ~= pswitch_t3r)+  , testProperty "pswitch (4, fixed)"   (property $ pswitch_t4 ~= pswitch_t4r)+  , testProperty "rpswitch (0, fixed)"  (property $ rpswitch_t0 ~= rpswitch_t0r)+  , testProperty "rpswitch (2, fixed)"  (property $ rpswitch_t2 ~= rpswitch_t2r)+  , testProperty "rpswitch (1, fixed)"  (property $ rpswitch_t1 ~= rpswitch_t1r)+  , testProperty "rpswitch (3, fixed)"  (property $ rpswitch_t3 ~= rpswitch_t3r)+  , testProperty "rpswitch (4, fixed)"  (property $ rpswitch_t4 ~= rpswitch_t4r)+  , testProperty "rpSwitchZ (0, fixed)" (property $ utils_t6 ~= utils_t6r)+  ]++-- * Basic switching++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_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_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)+  ]++prop_switch_t1 =+    forAll myStream $ evalT $+      Always $ SP ((switch_t1rec 42.0 &&& switch_tr) >>> arr same)++  where myStream :: Gen (SignalSampleStream Double)+        myStream = fixedDelayStreamWith f 1.0+        f dt = l!!(floor dt)+        l = [ 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++        same = (uncurry (==))++switch_tr :: SF Double (Double, Double, Double)+switch_tr = proc (a) -> do+  t <- localTime -< ()+  let mt = fromIntegral $ floor (mod' t 4.0)+      v  = case floor (t / 4.0) of+             0 -> 42.0+             1 -> 3.0+             2 -> 4.0+             3 -> 7.0+             _ -> 9.0+  returnA -< (a, mt, v)++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_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+  ]++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+  ]++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_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_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_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+  ]++-- * Parallel composition\/switching (collections)+-- ** With broadcasting++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]+  ]++-- Par with broadcast (collection-oriented combinators)+-- TODO: Add integral to the list of SFs being tested+prop_broadcast =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sf   = parB [identity, (arr (+1))]+        pred = (\x [y,z] -> x == y && (x + 1) == z)++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_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+  ]++-- Variation of the last dpSwitchB test below, 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_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_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]+  ]++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_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_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_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]+  ]++-- * Parallel composition\/switching (lists)+--+-- ** With "zip" routing++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+  ]++-- * Auxiliary++-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)
+ tests/Test/FRP/Yampa/Task.hs view
@@ -0,0 +1,225 @@+-- |+-- Description : Test cases for tasks (Task)+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+-- Very rudimentary testing of Task.++module Test.FRP.Yampa.Task+    ( tests )+  where++import Control.Monad (when, forever)++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Task++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Task"+  [ testProperty "tasks (fixed)" (property $ task_t0 ~= task_t0r)+  , testProperty "tasks (fixed)" (property $ task_t1 ~= task_t0r)  -- Intentionally! task_t0 = task_t1!+  , testProperty "tasks (fixed)" (property $ task_t2 ~= task_t2r)+  , testProperty "tasks (fixed)" (property $ task_t3 ~= task_t3r)+  , testProperty "tasks (fixed)" (property $ task_t4 ~= task_t4r)+  , testProperty "tasks (fixed)" (property $ task_t5 ~= task_t5r)+  , testProperty "tasks (fixed)" (property $ task_t6 ~= task_t6r)+  , testProperty "tasks (fixed)" (property $ task_t7 ~= task_t7r)+  , testProperty "tasks (fixed)" (property $ task_t8 ~= task_t8r)+  ]++-- * The Task type++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)+    ]++-- * Auxiliary++-- | 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/Test/FRP/Yampa/Time.hs view
@@ -0,0 +1,113 @@+-- |+-- Description : Test cases for FRP.Yampa.Time+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson+module Test.FRP.Yampa.Time+    ( tests+    )+  where++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import FRP.Yampa as Yampa+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture++import TestsCommon++tests :: TestTree+tests = testGroup "Regression tests for FRP.Yampa.Time"+  [ testProperty "localTime (fixed)"               (property $ basicsf_t2 ~= basicsf_t2r)+  , testProperty "Basic > localTime"               prop_basic_localtime_increasing+  , testProperty "time (fixed)"                    (property $ basicsf_t3 ~= basicsf_t3r)+  , testProperty "Basic > Time"                    prop_basic_time_increasing+  , testProperty "Basic > Time (fixed delay)"      prop_basic_time_fixed_delay+  , testProperty "Basic > localTime (fixed delay)" prop_basic_localtime_fixed_delay+  ]++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+  ]++prop_basic_localtime_increasing =+    forAll myStream $ evalT $ Always $ prop (sf, const (uncurry (>)))+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sf   :: SF a (Time, Time)+        sf   = loopPre (-1 :: Time) sfI++        sfI :: SF (a,Time) ((Time, Time), Time)+        sfI =  (localTime *** identity) >>> arr resort++        resort :: (Time, Time) -> ((Time,Time),Time)+        resort (newT, oldT) = ((newT, oldT), newT)++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+  ]++-- | Starting with an accumulator of -1, it gets the local+--   time and outputs the time and the accumulator, updating+--   the latter with the local time at every iteration.+--   The predicate checks whether the time is always strictly+--   greater than the acc.+prop_basic_time_increasing =+    forAll myStream $ evalT $ Always $ prop (sf, pred)+  where myStream :: Gen (SignalSampleStream Float)+        myStream = uniDistStream++        sf   :: SF a (Time, Time)+        sf   = loopPre (-1 :: Time) sfI++        sfI :: SF (a,Time) ((Time, Time), Time)+        sfI =  (time *** identity) >>> arr resort++        resort :: (Time, Time) -> ((Time,Time),Time)+        resort (newT, oldT) = ((newT, oldT), newT)++        pred :: a -> (Time, Time) -> Bool+        pred _ (t,o) = (t > o)++prop_basic_time_fixed_delay =+    forAll myStream $ evalT $+      Always (prop (sf25msec, const (== d)))++  where myStream :: Gen (SignalSampleStream Float)+        myStream = fixedDelayStream d++        sf25msec = time >>> stepDiff (-d)++        d :: Time+        d = 0.25++prop_basic_localtime_fixed_delay =+    forAll myStream $ evalT $+      Always (prop (sf25msec, const (== d)))++  where myStream :: Gen (SignalSampleStream Float)+        myStream = fixedDelayStream d++        sf25msec = time >>> stepDiff (-d)++        d :: Time+        d = 0.25++-- * Auxiliary++-- prop :: SF a b -> (a -> b ->+prop (a,b) = SP ((identity &&& a) >>^ uncurry b)++stepDiff :: Num a => a -> SF a a+stepDiff z = loopPre z (arr (\(x,y) -> (x - y, x)))
− tests/Tests.hs 
@@ -1,191 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: Tests.hs,v 1.27 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         Tests                                            *-*       Purpose:         regression tests.				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}---- TODO:--- * Add test cases for Yampa. There should be at least one test case for each---   "non-trivial" entity exported from Yampa.------ * 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---   Yampa structure better. Separate test cases for the generic definitions?--- There are some test cases for Utils. 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 Tests where--import FRP.Yampa--import TestsCommon-import TestsArr-import TestsComp-import TestsFirstSecond-import TestsLaws-import TestsLoop-import TestsLoopLaws-import TestsBasicSF-import TestsSscan-import TestsEvSrc-import TestsCOC-import TestsSwitch-import TestsKSwitch-import TestsRSwitch-import TestsPSwitch-import TestsRPSwitch-import TestsWFG-import TestsAccum-import TestsPre-import TestsDelay-import TestsDer-import TestsLoopPre-import TestsLoopIntegral-import TestsReact-import TestsEmbed-import TestsUtils-import TestsTask------------------------------------------------------------------------------------ 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 Yampa regression tests ..."-    if allGood-      then putStrLn "All tests succeeded!"-      else mapM_ putStrLn failedTests-    return allGood--runSpaceTests :: IO ()-runSpaceTests = do-    putStrLn ""-    putStrLn "Running the Yampa 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/TestsAccum.hs 
@@ -1,361 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsAccum.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                   *-*                                                                            *-*       Module:         TestsAccum					     *-*       Purpose:        Test cases for accumulators			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                           University of Nottingham, 2005                   *-*                                                                            *-******************************************************************************--}--module TestsAccum (-    accum_tr,-    accum_trs,-    accum_st0,-    accum_st0r,-    accum_st1,-    accum_st1r-) where--import Data.Maybe (fromJust)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsArr.hs 
@@ -1,53 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsArr.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsArr                                             *-*       Purpose:        Test cases for arr				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsArr (-    arr_trs,-    arr_tr,-    arr_st0,-    arr_st0r,-    arr_st1,-    arr_st1r-) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsBasicSF.hs 
@@ -1,70 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsBasicSF.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsBasicSF				                         *-*       Purpose:        Test cases for basic signal functions		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsBasicSF (basicsf_trs, basicsf_tr) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsCOC.hs 
@@ -1,57 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsCOC.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsCOC					                         *-*       Purpose:        Test cases for collection-oriented combinators	     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsCOC (coc_tr, coc_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsCommon.hs view
@@ -1,97 +1,82 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{--******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsCommon                                          *-*       Purpose:        Common definitions for the regression test modules.  *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}-+-- |+-- Module      : TestsCommon+-- Description : Common definitions for the regression test modules.+-- Copyright   : Yale University, 2003+-- Authors     : Antony Courtney and Henrik Nilsson module TestsCommon where -import System.IO.Unsafe (unsafePerformIO)-import Data.IORef (newIORef, writeIORef, readIORef)- import FRP.Yampa ---------------------------------------------------------------------------------- Rough equality with instances-------------------------------------------------------------------------------+-- * 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+  (~=) :: 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.+  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.+  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+  () ~= () = True  instance (REq a, REq b) => REq (a,b) where-    (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2+  (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+  (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+  (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+  (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+  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+  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+  (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-+  [] ~= []         = True+  (x:xs) ~= (y:ys) = x ~= y && xs ~= ys+  _      ~= _      = False  ------------------------------------------------------------------------------ -- Testing utilities@@ -100,62 +85,13 @@ 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+  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  ------------------------------------------------------------------------------ -- Some utilities used for testing laws
− tests/TestsComp.hs 
@@ -1,72 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsComp.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsComp					                         *-*       Purpose:        Test cases for (>>>)				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsComp (comp_tr, comp_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsDelay.hs 
@@ -1,89 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsDelay					                         *-*       Purpose:        Test cases for delays				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsDelay (delay_tr, delay_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsDer.hs 
@@ -1,56 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsDer.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsDer					                         *-*       Purpose:        Test cases for derivative			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsDer (der_tr, der_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsEmbed.hs 
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsEmbed.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsEmbed					                         *-*       Purpose:        Test cases for embedding			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsEmbed (embed_tr, embed_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsEvSrc.hs 
@@ -1,584 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsEvSrc.hs,v 1.3 2003/12/19 15:32:22 henrik Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsEvSrc					                         *-*       Purpose:        Test cases for event sources			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsEvSrc (evsrc_trs, evsrc_tr) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsFirstSecond.hs 
@@ -1,128 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsFirstSecond.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsArr                                             *-*       Purpose:        Test cases for first and second			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsFirstSecond (first_trs, first_tr, second_trs, second_tr) where--import Data.Tuple (swap)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsKSwitch.hs 
@@ -1,129 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsKSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsKSwitch				                         *-*       Purpose:        Test cases for kSwitch and dkSwitch		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsKSwitch (kswitch_tr, kswitch_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsLaws.hs 
@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsLaws                                            *-*       Purpose:        Test cases based on the arrow laws		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsLaws (laws_trs, laws_tr) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsLoop.hs 
@@ -1,207 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsLoop.hs,v 1.6 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsLoop					                         *-*       Purpose:        Test cases for loop				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsLoop (loop_trs, loop_tr, loop_st0, loop_st0r,-		      loop_st1, loop_st1r) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsLoopIntegral.hs 
@@ -1,105 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsLoopIntegral.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  A F R P                                   *-*                                                                            *-*       Module:         TestsLoopIntegral				                     *-*       Purpose:        Test cases for loopIntegral			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsLoopIntegral (loopIntegral_tr, loopIntegral_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsLoopLaws.hs 
@@ -1,110 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsLoopLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsLoopLaws                                        *-*       Purpose:        Test cases based on the arrow laws for loop	     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsLoopLaws (looplaws_trs, looplaws_tr) where--import Data.Tuple(swap)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsLoopPre.hs 
@@ -1,63 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsLoopPre.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsLoopPre				                         *-*       Purpose:        Test cases for loopPre				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsLoopPre (loopPre_tr, loopPre_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsPSwitch.hs 
@@ -1,325 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsPSwitch				                         *-*       Purpose:        Test cases for pSwitchB and dpSwitchB		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsPSwitch (-    pswitch_tr,-    pswitch_trs,-    pswitch_st0,-    pswitch_st0r,-    pswitch_st1,-    pswitch_st1r-) where--import Data.List (findIndex)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsPre.hs 
@@ -1,209 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsPre					                         *-*       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 TestsPre (pre_tr, pre_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsRPSwitch.hs 
@@ -1,246 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsRPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsRPSwitch				                         *-*       Purpose:        Test cases for rpSwitchB and drpSwitchB		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsRPSwitch (-    rpswitch_tr,-    rpswitch_trs,-    rpswitch_st0,-    rpswitch_st0r-) where--import Data.Maybe (fromJust)-import Data.List (findIndex)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsRSwitch.hs 
@@ -1,144 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsRSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsRSwitch				                         *-*       Purpose:        Test cases for rSwitch and drSwitch		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsRSwitch (-    rswitch_tr,-    rswitch_trs,-    rswitch_st0,-    rswitch_st0r-) where--import Data.Maybe (fromJust)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsReact.hs 
@@ -1,71 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsReact.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsReact					                         *-*       Purpose:        Test cases for reactimation			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsReact (react_tr, react_trs) where--import System.IO.Unsafe (unsafePerformIO)-import Data.IORef (newIORef, writeIORef, readIORef)--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsSscan.hs 
@@ -1,473 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id$-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsSscan					                         *-*       Purpose:        Test cases for pre sscan	     		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*             Copyright (c) University of Nottingham, 2005                   *-*                                                                            *-******************************************************************************--}--module TestsSscan (sscan_tr, sscan_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/TestsSwitch.hs 
@@ -1,214 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsSwitch					                         *-*       Purpose:        Test cases for switch				     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}-module TestsSwitch (switch_tr, switch_trs) where--import FRP.Yampa-import FRP.Yampa.EventS--import TestsCommon----------------------------------------------------------------------------------- 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/TestsTask.hs 
@@ -1,232 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsTask.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsTask					         *-*       Purpose:        Test cases for tasks (Task)			     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}---- Very rudimentary testing of Task.--module TestsTask (task_tr, task_trs) where--import Control.Monad (when, forever)-import FRP.Yampa-import FRP.Yampa.Task--import TestsCommon----------------------------------------------------------------------------------- Test cases for tasks (Task)---------------------------------------------------------------------------------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/TestsUtils.hs 
@@ -1,372 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsUtils.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsUtils					         *-*       Purpose:        Test cases for utilities (Utilities)	     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}---- Not really intended to test all definitions in the utilities module.--module TestsUtils (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 TestsCommon----------------------------------------------------------------------------------- Test cases for utilities (Utils)----------------------------------------------------------------------------------- Should re-order these test cases to reflect the order in Utils--- 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/TestsWFG.hs 
@@ -1,103 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: TestsWFG.hs,v 1.2 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         TestsWFG					         *-*       Purpose:        Test cases for wave-form generation		     *-*	Authors:	Antony Courtney and Henrik Nilsson		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}--module TestsWFG (wfg_tr, wfg_trs) where--import FRP.Yampa--import TestsCommon----------------------------------------------------------------------------------- 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/YampaQC.hs 
@@ -1,595 +0,0 @@-{-# LANGUAGE GADTs  #-}-{-# LANGUAGE Arrows #-}--- TODO--- Properties in this file have different types.--- It's important to agree on the representation type.------ It may be a bit hard, because some elements from logic are--- provided by QC, while others have to be defined by us.--- For example, connectives like implication and always are--- provided by us, and forAll is in QuickCheck.------ This makes it hard to combine, becase for this language to be--- compositional like logic is we need to make everything accept--- a QuickCheck predicate, which may not be possible or compatible--- with out goals.----module Main where---------------------------------------------------------------------------------import Data.Fixed--import Test.QuickCheck-import Test.QuickCheck.Function-import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.QuickCheck (testProperty)--import FRP.Yampa as Yampa-import FRP.Yampa.EventS (snap)-import FRP.Yampa.Stream-import FRP.Yampa.QuickCheck-import FRP.Yampa.LTLFuture---------------------------------------------------------------------------------main :: IO ()-main = defaultMain tests--tests :: TestTree-tests = testGroup "Yampa QC properties"-    [ testProperty "Identity"                               prop_arr_id-    , testProperty "Arrow Naturality"                       prop_arr_naturality-    , testProperty "Naturality"                             prop_arr_naturality-    , testProperty "Basic > Identity (1)"                   prop_basic_identity_1-    , testProperty "Basic > Identity (2)"                   prop_basic_identity_2-    , testProperty "Basic > Constant"                       prop_basic_constant-    , testProperty "Basic > Initially"                      prop_basic_initially-    , testProperty "Basic > Time"                           prop_basic_time_increasing-    , testProperty "Basic > Time (fixed delay)"             prop_basic_time_fixed_delay-    , testProperty "Basic > localTime"                      prop_basic_localtime_increasing-    , testProperty "Basic > localTime (fixed delay)"        prop_basic_localtime_fixed_delay-    , testProperty "Collections > parB"                     prop_broadcast-    , testProperty "Arrows > Composition (1)"               prop_arrow_comp_1-    , testProperty "Arrows > Composition (2)"               prop_arrow_comp_2-    , testProperty "Arrows > Composition (3)"               prop_arrow_comp_3-    , testProperty "Delays > Zero delay"                    prop_delay_1-    , testProperty "Delays > Small delay"                   prop_delay_2-    -- FIXME: (iperez:) delay_t3 is not here because I can't understand it.-    -- Missing: delay t4 and t5-    , testProperty "Derivatives > Comparison with known derivative (1)" prop_derivative_1-    , testProperty "Derivatives > Comparison with known derivative (2)" prop_derivative_2-    -- Missing: embed-    , testProperty "Events > No event"                      prop_event_noevent-    , testProperty "Events > Now"                           prop_event_now-    , testProperty "Events > After 0.0"                     prop_event_after_0-    -- Missing: a lot of event tests-    , testProperty "Arrows > First (1)"                     prop_arrow_first_1-    , testProperty "Arrows > First (2)"                     prop_arrow_first_2-    , testProperty "Arrows > Second (1)"                    prop_arrow_second_1-    , testProperty "Arrows > Second (2)"                    prop_arrow_second_2-    -- Missing: first and second with integrals-    -- Missing: KSwitch--    , testProperty "Arrows > Identity (0)"                  prop_arrow_id_0-    , testProperty "Arrows > Identity (2)"                  prop_arrow_id_2-    , testProperty "Arrows > Associativity"                 prop_arrow_assoc-    , testProperty "Arrows > Function lifting composition"  prop_arrow_arr_comp-    , testProperty "Arrows > First"                         prop_arrow_first_3-    , testProperty "Arrows > Distributivity of First"       prop_arrow_first_distrib-    , testProperty "Arrows > Commutativity of id on first"  prop_arrow_first_id_comm-    , testProperty "Arrows > Nested firsts"                 prop_arrow_first_nested-    -- Missing: Loop *-    -- Missing: PSwitch-    -- Missing: iPre-    -- Missing: RPSwitch-    -- Missing: RSwitch-    -- Missing: React-    -- Missing: Sscan-    -- Missing: Switch-    -- , testProperty "Switching > t1"                 prop_switch_t1-    -- Missing: Task-    -- Missing: Utils-    -- Missing: WFG-    ]---- * Yampa laws---- ** Arrow laws--prop_arr_id =-   forAll myStream (evalT $ prop_always_equal (arr id) identity)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream---- Yampa's internal test cases---- prop :: SF a b -> (a -> b ->-prop (a,b) = SP ((identity &&& a) >>^ uncurry b)---- Yampa's Arrow Checks---- C1: Arr naturality (testSF1 (arr (+1)))--- C2: Arr naturality (testSF2 (arr (+1)))-prop_arr_naturality =-   forAll myStream $ \stream ->-     forAll f $ \f' ->-       evalT (Always (prop (arr (apply f'), \x y -> apply f' x == y)))- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream-       f :: Gen (Fun Int Int)-       f = arbitrary---- Yampa's Basic SF builders-prop_basic_identity_1 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream-       sf   = identity-       pred = (==)--prop_basic_identity_2 =-   forAll myStream (evalT $ prop_always_equal identity (arr id))- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--prop_basic_constant =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sf   = constant 42.0-       pred = const (== 42.0)--prop_basic_initially =-   forAll myStream $ evalT $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sf   = initially 42.0-       pred = const (== 42.0)---- | Starting with an accumulator of -1, it gets the local---   time and outputs the time and the accumulator, updating---   the latter with the local time at every iteration.---   The predicate checks whether the time is always strictly---   greater than the acc.-prop_basic_time_increasing =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sf   :: SF a (Time, Time)-       sf   = loopPre (-1 :: Time) sfI--       sfI :: SF (a,Time) ((Time, Time), Time)-       sfI =  (time *** identity) >>> arr resort--       resort :: (Time, Time) -> ((Time,Time),Time)-       resort (newT, oldT) = ((newT, oldT), newT)--       pred :: a -> (Time, Time) -> Bool-       pred _ (t,o) = (t > o)--prop_basic_time_fixed_delay =-   forAll myStream $ evalT $-         Always (prop (sf25msec, const (== d)))-- where myStream :: Gen (SignalSampleStream Float)-       myStream = fixedDelayStream d--       sf25msec = time >>> stepDiff (-d)--       d :: Time-       d = 0.25--prop_basic_localtime_increasing =-   forAll myStream $ evalT $ Always $ prop (sf, const (uncurry (>)))- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sf   :: SF a (Time, Time)-       sf   = loopPre (-1 :: Time) sfI--       sfI :: SF (a,Time) ((Time, Time), Time)-       sfI =  (localTime *** identity) >>> arr resort--       resort :: (Time, Time) -> ((Time,Time),Time)-       resort (newT, oldT) = ((newT, oldT), newT)--prop_basic_localtime_fixed_delay =-   forAll myStream $ evalT $-         Always (prop (sf25msec, const (== d)))-- where myStream :: Gen (SignalSampleStream Float)-       myStream = fixedDelayStream d--       sf25msec = time >>> stepDiff (-d)--       d :: Time-       d = 0.25---- Par with broadcast (collection-oriented combinators)--- TODO: Add integral to the list of SFs being tested-prop_broadcast =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sf   = parB [identity, (arr (+1))]-       pred = (\x [y,z] -> x == y && (x + 1) == z)--prop_arrow_1 = forAll myStream $ evalT $-  Always $ prop (arr id, \x y -> x == y)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--prop_arrow_2 = forAll myStream $ evalT $-  Always $ prop (sf1 &&& sf2, const $ uncurry (==))- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream-       sf1 = arr (f >>> g)-       sf2 = arr f >>> arr g-       f = (+5)-       g = (/20)--prop_arrow_2' =- forAll f $ \f' ->-   forAll g $ \g' ->-     forAll myStream $ evalT $- prop_arrow_2'' (apply f') (apply g')-- where myStream :: Gen (SignalSampleStream Int)-       myStream = uniDistStream--       f, g :: Gen (Fun Int Int)-       f = arbitrary-       g = arbitrary--prop_arrow_2'' f g =-  Always $ prop (sf1 &&& sf2, const $ uncurry (==))- where sf1 = arr (f >>> g)-       sf2 = arr f >>> arr g---- Arrow composition (we use Int to avoid floating-point discrepancies)-prop_arrow_comp_1 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Int)-       myStream = uniDistStream--       sf   = arr (+1) >>> arr (+2)-       pred = (\x y -> x + 3 == y)---- Arrow composition-prop_arrow_comp_2 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sf   = constant 5.0 >>> arr (+1)-       pred = const (== 6.0)---- Arrow composition-prop_arrow_comp_3 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Float)-       myStream = fixedDelayStream 0.25--       sf :: SF a Float-       sf = constant 2.0 >>> integral >>> stepDiff (-0.5)--       pred = const (== 0.5)---- Delaying---- | Delaying by 0.0 has no effect-prop_delay_1 =-   forAll myStream $ evalT $ prop_always_equal sfDelayed sf- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sfDelayed = delay 0.0 undefined >>> sf-       sf = arr (+1)---- | Delaying input signal by a small amount will fill in the "blank" signal---   with the given value, which will become also the sample at the initial---   time.-prop_delay_2 =-   forAll myStream $ evalT $-     (prop (sfDelayed, (\x y -> y == initialValue)))- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       sfDelayed = delay 0.0001 initialValue--       initialValue = 17--prop_insert =- forAll initialValueG $ \initialValue ->- forAll finalValueG $ \finalValue ->- forAll myStream $ evalT $-  let sfStep = initialValue --> constant finalValue--  in And (prop (sfStep, const (== initialValue)))-         (Next $ Always $-                   (prop (sfStep, const (== finalValue))))-- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--       initialValueG :: Gen Float-       initialValueG = arbitrary--       finalValueG  :: Gen Float-       finalValueG = arbitrary--prop_derivative_1 =-   forAll myStream $ evalT $-     Next $ Always $ prop ((sfDer &&& sfDerByHand), const close)--  where myStream :: Gen (SignalSampleStream Double)-        myStream = fixedDelayStreamWith (\t -> sin(2 * pi * t)) der_step--        sfDer :: SF Time Time-        sfDer = derivative--        sfDerByHand = localTime >>> arr (\t -> (2 * pi * cos (2 * pi * t)))--        close (x,y) = abs (x-y) < 0.05--prop_derivative_2 =-   forAll myStream $ evalT $-     Next $ Always $ prop ( sfDer &&& sfDerByHand-                          , const close)--  where-    myStream :: Gen (SignalSampleStream Double)-    myStream = fixedDelayStream der_step--    sfDer :: SF Time Time-    sfDer = localTime-              >>> arr (\t -> sin(2*pi*t))-                >>> derivative--    sfDerByHand = localTime-                    >>> arr (\t -> 2*pi*cos (2*pi*t))--    close (x,y) = abs (x-y) < 0.05--der_step = 0.001--stepDiff :: Num a => a -> SF a a-stepDiff z = loopPre z (arr (\(x,y) -> (x - y, x)))---- Events-prop_event_noevent =-   forAll myStream $ evalT $ Always $ prop (sfNever, const (== noEvent))-- where myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream-       sfNever :: SF Float (Event Float)-       sfNever = never--prop_event_now =-   forAll myStream $ evalT $-       -- (sf, p0) /\ O [] (sf, pn)-       And (prop (sf, p0))                 -- Initially-           (Next $ Always $ prop (sf, pn)) -- After first sample-- where sf = Yampa.now 42.0--       p0 x y = y == Event 42.0-       pn x y = y == noEvent--       myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--prop_event_after_0 =-   forAll myStream $ evalT $-       -- (sf, p0) /\ O [] (sf, pn)-       And (prop (sf, p0))                 -- Initially-           (Next $ Always $ prop (sf, pn)) -- After first sample-- where sf = after 0.0 42.0--       p0 x y = y == Event 42.0-       pn x y = y == noEvent--       myStream :: Gen (SignalSampleStream Float)-       myStream = uniDistStream--prop_arrow_first_1 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Int)-       myStream = uniDistStream--       sf   = arr dup >>> first (constant 7)-       pred = (\x y -> (7 :: Int, x) == y)--prop_arrow_first_2 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Int)-       myStream = uniDistStream--       sf   = arr dup >>> first (arr (+1))-       pred = (\x y -> (x + 1, x) == y)--prop_arrow_second_1 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Int)-       myStream = uniDistStream--       sf   = arr dup >>> second (constant 7)-       pred = (\x y -> (x, 7 :: Int) == y)--prop_arrow_second_2 =-   forAll myStream $ evalT $ Always $ prop (sf, pred)- where myStream :: Gen (SignalSampleStream Int)-       myStream = uniDistStream--       sf   = arr dup >>> second (arr (+1))-       pred = (\x y -> (x, x + 1) == y)--prop_arrow_id_0 =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)- where sf1 = arr id >>> integral-       sf2 = integral-       pred = arr $ uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_id_2 =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)- where sf1 = integral >>> arr id-       sf2 = integral-       pred = arr $ uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_assoc =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)- where sf1 = (integral >>> arr (*0.5)) >>> integral-       sf2 = integral >>> (arr (*0.5) >>> integral)-       pred = arr $ uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_arr_comp =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)- where sf1 = (arr ((*2.5) . (+3.0)))-       sf2 = (arr (+3.0) >>> arr (*2.5))-       pred = arr (uncurry (==))--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_first_3 =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)- where sf1 = (arr dup >>> first (arr (*2.5)))-       sf2 = (arr dup >>> arr (fun_prod (*2.5) id))-       pred = uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_first_distrib =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)- where sf1 = (arr dup >>> (first (integral >>> arr (+3.0))))-       sf2 = (arr dup >>> (first integral >>> first (arr (+3.0))))-       pred = uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_first_id_comm =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)- where sf1 = (arr dup >>> (first integral>>>arr (fun_prod id (+3.0))))-       sf2 = (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral))-       pred = uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_arrow_first_nested =-   forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)- where sf1 = (arr (\x -> ((x,x),())) >>> (first (first integral) >>> arr assoc))-       sf2 = (arr (\x -> ((x,x),())) >>> (arr assoc >>> first integral))--       pred = uncurry (==)--       myStream :: Gen (SignalSampleStream Double)-       myStream = uniDistStream--prop_switch_t1 =-  forAll myStream $ evalT $-    Always $ SP ((switch_t1rec 42.0 &&& switch_tr) >>> arr same)--  where myStream :: Gen (SignalSampleStream Double)-        myStream = fixedDelayStreamWith f 1.0-        f dt = l!!(floor dt)-        l = [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--        same = (uncurry (==))---- 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_tr :: SF Double (Double, Double, Double)-switch_tr = proc (a) -> do-   t <- localTime -< ()-   let mt = fromIntegral $ floor (mod' t 4.0)-       v  = case floor (t / 4.0) of-             0 -> 42.0-             1 -> 3.0-             2 -> 4.0-             3 -> 7.0-             _ -> 9.0-   returnA -< (a, mt, v)--infiniteSwitch sf1 sf2 input =-   switched (evalAtZero sf1 input) /= switched (evalAtZero sf2 input)-  where switched = isEvent . snd . fst--switch1 = switch (simpleF)-                 (\_ -> switch1)--simpleF = arr id &&& cond- where cond = arr (const (Event ()))--delayedF = arr id &&& cond- where cond = after 1.5 (Event ())----- * Generic SF predicate building functions---- | Compares two SFs, resulting in true if they are always equal-prop_always_equal sf1 sf2 =-    Always $ SP ((sf1 &&& sf2) >>> arr sameResult)-  where sameResult = uncurry (==)--prop_arr_no_change f xs =-     samples (fst (evalSF (arr f) xs)) == map f (samples xs)---- | Compares two SFs, returning true if they are close enough-prop_always_similar margin sf1 sf2 =-  Always (SP ((sf1 &&& sf2) >>> arr similar))-  where similar (x,y) = abs (x-y) <= margin--sfMeasureIncrement :: Num b => b -> SF a b -> SF a b-sfMeasureIncrement init sf = loopPre init sf'- where sf' = (sf *** identity) >>> arr (\(n, o) -> (n - o, n))--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/testYampaMain.hs 
@@ -1,78 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $Id: testYampaMain.hs,v 1.9 2003/11/10 21:28:58 antony Exp $-******************************************************************************-*                                  Y A M P A                                 *-*                                                                            *-*       Module:         testYampaMain                                        *-*       Purpose:        Main driver routine for running tests.               *-*	Authors:	Henrik Nilsson and Antony Courtney		     *-*                                                                            *-*             Copyright (c) Yale University, 2003                            *-*                                                                            *-******************************************************************************--}-module Main where--import Tests--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--
yampa-test.cabal view
@@ -31,7 +31,7 @@ build-type:    Simple  name:          yampa-test-version:       0.13.4+version:       0.13.5 author:        Ivan Perez maintainer:    ivan.perez@keera.co.uk homepage:      http://github.com/ivanperez-keera/Yampa@@ -45,7 +45,8 @@   .   It contains:   .-  * Debugging signal functions using "Debug.Trace".+  * Debugging signal functions using+    <https://hackage.haskell.org/package/base/docs/Debug-Trace.html Debug.Trace>.   * A definition of Temporal Predicates based on LTL.   * Monitoring signal functions with ptLTL using Signal Predicates.   * A definition of Streams, and a Stream manipulation API.@@ -65,9 +66,9 @@   -- You can disable the regression test suite with -f-test-regression-flag test-regression-  description: Enable regression test suite-  default:     True+flag test-space+  description: Enable space usage test suite+  default:     False   manual:      True  @@ -83,7 +84,7 @@       base               >= 4      && < 5     , normaldistribution     , QuickCheck-    , Yampa              >= 0.13.4 && < 0.14+    , Yampa              >= 0.13.5 && < 0.14    default-language:     Haskell2010@@ -97,8 +98,24 @@     exitcode-stdio-1.0    main-is:-    YampaQC.hs+    Main.hs +  other-modules:+    Test.FRP.Yampa.Basic+    Test.FRP.Yampa.Conditional+    Test.FRP.Yampa.Delays+    Test.FRP.Yampa.EventS+    Test.FRP.Yampa.Hybrid+    Test.FRP.Yampa.Integration+    Test.FRP.Yampa.InternalCore+    Test.FRP.Yampa.Loop+    Test.FRP.Yampa.Scan+    Test.FRP.Yampa.Simulation+    Test.FRP.Yampa.Switches+    Test.FRP.Yampa.Task+    Test.FRP.Yampa.Time+    TestsCommon+   build-depends:       base             < 5     , Cabal            >= 1.19@@ -119,42 +136,15 @@     -Wall  -test-suite regression+test-suite space   type:     exitcode-stdio-1.0    main-is:-    testYampaMain.hs+    Space.hs    other-modules:-    Tests-    TestsAccum-    TestsArr-    TestsBasicSF-    TestsCOC     TestsCommon-    TestsComp-    TestsDelay-    TestsDer-    TestsEmbed-    TestsEvSrc-    TestsFirstSecond-    TestsKSwitch-    TestsLaws-    TestsLoop-    TestsLoopIntegral-    TestsLoopLaws-    TestsLoopPre-    TestsPre-    TestsPSwitch-    TestsReact-    TestsRPSwitch-    TestsRSwitch-    TestsSscan-    TestsSwitch-    TestsTask-    TestsUtils-    TestsWFG    default-language:     Haskell2010@@ -162,7 +152,10 @@   hs-source-dirs:     tests -  if !flag(test-regression)+  ghc-options:+    -Wall++  if !flag(test-space)     buildable:       False   else