diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,24 @@ +2022-06-07 Ivan Perez + * 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 * yampa-test.cabal: Version bump (0.13.4) (#203), syntax rules (#196), add regression tests (#201). diff --git a/src/FRP/Yampa/LTLFuture.hs b/src/FRP/Yampa/LTLFuture.hs --- a/src/FRP/Yampa/LTLFuture.hs +++ b/src/FRP/Yampa/LTLFuture.hs @@ -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 diff --git a/src/FRP/Yampa/LTLPast.hs b/src/FRP/Yampa/LTLPast.hs --- a/src/FRP/Yampa/LTLPast.hs +++ b/src/FRP/Yampa/LTLPast.hs @@ -10,7 +10,6 @@ module FRP.Yampa.LTLPast where ------------------------------------------------------------------------------- import FRP.Yampa -- | True if both inputs are True. diff --git a/src/FRP/Yampa/QuickCheck.hs b/src/FRP/Yampa/QuickCheck.hs --- a/src/FRP/Yampa/QuickCheck.hs +++ b/src/FRP/Yampa/QuickCheck.hs @@ -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) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] diff --git a/tests/Space.hs b/tests/Space.hs new file mode 100644 --- /dev/null +++ b/tests/Space.hs @@ -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 diff --git a/tests/Test/FRP/Yampa/Basic.hs b/tests/Test/FRP/Yampa/Basic.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Basic.hs @@ -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 (==) diff --git a/tests/Test/FRP/Yampa/Conditional.hs b/tests/Test/FRP/Yampa/Conditional.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Conditional.hs @@ -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 + ] diff --git a/tests/Test/FRP/Yampa/Delays.hs b/tests/Test/FRP/Yampa/Delays.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Delays.hs @@ -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 (==) diff --git a/tests/Test/FRP/Yampa/EventS.hs b/tests/Test/FRP/Yampa/EventS.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/EventS.hs @@ -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) diff --git a/tests/Test/FRP/Yampa/Hybrid.hs b/tests/Test/FRP/Yampa/Hybrid.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Hybrid.hs @@ -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! diff --git a/tests/Test/FRP/Yampa/Integration.hs b/tests/Test/FRP/Yampa/Integration.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Integration.hs @@ -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) diff --git a/tests/Test/FRP/Yampa/InternalCore.hs b/tests/Test/FRP/Yampa/InternalCore.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/InternalCore.hs @@ -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))) diff --git a/tests/Test/FRP/Yampa/Loop.hs b/tests/Test/FRP/Yampa/Loop.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Loop.hs @@ -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 + ] diff --git a/tests/Test/FRP/Yampa/Scan.hs b/tests/Test/FRP/Yampa/Scan.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Scan.hs @@ -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 + ] diff --git a/tests/Test/FRP/Yampa/Simulation.hs b/tests/Test/FRP/Yampa/Simulation.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Simulation.hs @@ -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 + ] diff --git a/tests/Test/FRP/Yampa/Switches.hs b/tests/Test/FRP/Yampa/Switches.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Switches.hs @@ -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) diff --git a/tests/Test/FRP/Yampa/Task.hs b/tests/Test/FRP/Yampa/Task.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Task.hs @@ -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 diff --git a/tests/Test/FRP/Yampa/Time.hs b/tests/Test/FRP/Yampa/Time.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FRP/Yampa/Time.hs @@ -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))) diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -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) - - - diff --git a/tests/TestsAccum.hs b/tests/TestsAccum.hs deleted file mode 100644 --- a/tests/TestsAccum.hs +++ /dev/null @@ -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 diff --git a/tests/TestsArr.hs b/tests/TestsArr.hs deleted file mode 100644 --- a/tests/TestsArr.hs +++ /dev/null @@ -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 diff --git a/tests/TestsBasicSF.hs b/tests/TestsBasicSF.hs deleted file mode 100644 --- a/tests/TestsBasicSF.hs +++ /dev/null @@ -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 diff --git a/tests/TestsCOC.hs b/tests/TestsCOC.hs deleted file mode 100644 --- a/tests/TestsCOC.hs +++ /dev/null @@ -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 diff --git a/tests/TestsCommon.hs b/tests/TestsCommon.hs --- a/tests/TestsCommon.hs +++ b/tests/TestsCommon.hs @@ -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 diff --git a/tests/TestsComp.hs b/tests/TestsComp.hs deleted file mode 100644 --- a/tests/TestsComp.hs +++ /dev/null @@ -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 diff --git a/tests/TestsDelay.hs b/tests/TestsDelay.hs deleted file mode 100644 --- a/tests/TestsDelay.hs +++ /dev/null @@ -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 diff --git a/tests/TestsDer.hs b/tests/TestsDer.hs deleted file mode 100644 --- a/tests/TestsDer.hs +++ /dev/null @@ -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 diff --git a/tests/TestsEmbed.hs b/tests/TestsEmbed.hs deleted file mode 100644 --- a/tests/TestsEmbed.hs +++ /dev/null @@ -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 diff --git a/tests/TestsEvSrc.hs b/tests/TestsEvSrc.hs deleted file mode 100644 --- a/tests/TestsEvSrc.hs +++ /dev/null @@ -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 diff --git a/tests/TestsFirstSecond.hs b/tests/TestsFirstSecond.hs deleted file mode 100644 --- a/tests/TestsFirstSecond.hs +++ /dev/null @@ -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 diff --git a/tests/TestsKSwitch.hs b/tests/TestsKSwitch.hs deleted file mode 100644 --- a/tests/TestsKSwitch.hs +++ /dev/null @@ -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 diff --git a/tests/TestsLaws.hs b/tests/TestsLaws.hs deleted file mode 100644 --- a/tests/TestsLaws.hs +++ /dev/null @@ -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 diff --git a/tests/TestsLoop.hs b/tests/TestsLoop.hs deleted file mode 100644 --- a/tests/TestsLoop.hs +++ /dev/null @@ -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 diff --git a/tests/TestsLoopIntegral.hs b/tests/TestsLoopIntegral.hs deleted file mode 100644 --- a/tests/TestsLoopIntegral.hs +++ /dev/null @@ -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 diff --git a/tests/TestsLoopLaws.hs b/tests/TestsLoopLaws.hs deleted file mode 100644 --- a/tests/TestsLoopLaws.hs +++ /dev/null @@ -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 diff --git a/tests/TestsLoopPre.hs b/tests/TestsLoopPre.hs deleted file mode 100644 --- a/tests/TestsLoopPre.hs +++ /dev/null @@ -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 diff --git a/tests/TestsPSwitch.hs b/tests/TestsPSwitch.hs deleted file mode 100644 --- a/tests/TestsPSwitch.hs +++ /dev/null @@ -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) diff --git a/tests/TestsPre.hs b/tests/TestsPre.hs deleted file mode 100644 --- a/tests/TestsPre.hs +++ /dev/null @@ -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 diff --git a/tests/TestsRPSwitch.hs b/tests/TestsRPSwitch.hs deleted file mode 100644 --- a/tests/TestsRPSwitch.hs +++ /dev/null @@ -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] diff --git a/tests/TestsRSwitch.hs b/tests/TestsRSwitch.hs deleted file mode 100644 --- a/tests/TestsRSwitch.hs +++ /dev/null @@ -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 diff --git a/tests/TestsReact.hs b/tests/TestsReact.hs deleted file mode 100644 --- a/tests/TestsReact.hs +++ /dev/null @@ -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 diff --git a/tests/TestsSscan.hs b/tests/TestsSscan.hs deleted file mode 100644 --- a/tests/TestsSscan.hs +++ /dev/null @@ -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 diff --git a/tests/TestsSwitch.hs b/tests/TestsSwitch.hs deleted file mode 100644 --- a/tests/TestsSwitch.hs +++ /dev/null @@ -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 - diff --git a/tests/TestsTask.hs b/tests/TestsTask.hs deleted file mode 100644 --- a/tests/TestsTask.hs +++ /dev/null @@ -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 - diff --git a/tests/TestsUtils.hs b/tests/TestsUtils.hs deleted file mode 100644 --- a/tests/TestsUtils.hs +++ /dev/null @@ -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 diff --git a/tests/TestsWFG.hs b/tests/TestsWFG.hs deleted file mode 100644 --- a/tests/TestsWFG.hs +++ /dev/null @@ -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 diff --git a/tests/YampaQC.hs b/tests/YampaQC.hs deleted file mode 100644 --- a/tests/YampaQC.hs +++ /dev/null @@ -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) diff --git a/tests/testYampaMain.hs b/tests/testYampaMain.hs deleted file mode 100644 --- a/tests/testYampaMain.hs +++ /dev/null @@ -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 - - diff --git a/yampa-test.cabal b/yampa-test.cabal --- a/yampa-test.cabal +++ b/yampa-test.cabal @@ -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 + . * 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