diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +2022-04-07 Ivan Perez + * yampa-test.cabal: Version bump (0.13.4) (#203), syntax rules (#196), + add regression tests (#201). + * tests/YampaQC.hs: Remove incorrect tests (#198). + * tests/: Add regression tests (#201). + 2021-10-07 Ivan Perez * yampa-test.cabal: Version bump (0.13.3). diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,191 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsAccum.hs @@ -0,0 +1,361 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsArr.hs @@ -0,0 +1,53 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsBasicSF.hs @@ -0,0 +1,70 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsCOC.hs @@ -0,0 +1,57 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsCommon.hs @@ -0,0 +1,170 @@ +{-# 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 where + +import System.IO.Unsafe (unsafePerformIO) +import Data.IORef (newIORef, writeIORef, readIORef) + +import FRP.Yampa + +------------------------------------------------------------------------------ +-- Rough equality with instances +------------------------------------------------------------------------------ + +-- Rough equality. Only intended to be good enough for test cases in this +-- module. + +class REq a where + (~=) :: a -> a -> Bool + +epsilon :: Fractional a => a +epsilon = 0.0001 + +instance REq Float where + x ~= y = abs (x - y) < epsilon -- A relative measure should be used. + +instance REq Double where + x ~= y = abs (x - y) < epsilon -- A relative measure should be used. + +instance REq Int where + (~=) = (==) + +instance REq Integer where + (~=) = (==) + +instance REq Bool where + (~=) = (==) + +instance REq Char where + (~=) = (==) + +instance REq () where + () ~= () = True + +instance (REq a, REq b) => REq (a,b) where + (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2 + +instance (REq a, REq b, REq c) => REq (a,b,c) where + (x1,x2,x3) ~= (y1,y2,y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 + +instance (REq a, REq b, REq c, REq d) => REq (a,b,c,d) where + (x1,x2,x3,x4) ~= (y1,y2,y3,y4) = x1 ~= y1 + && x2 ~= y2 + && x3 ~= y3 + && x4 ~= y4 + +instance (REq a, REq b, REq c, REq d, REq e) => REq (a,b,c,d,e) where + (x1,x2,x3,x4,x5) ~= (y1,y2,y3,y4,y5) = x1 ~= y1 + && x2 ~= y2 + && x3 ~= y3 + && x4 ~= y4 + && x5 ~= y5 + +instance REq a => REq (Maybe a) where + Nothing ~= Nothing = True + (Just x) ~= (Just y) = x ~= y + _ ~= _ = False + +instance REq a => REq (Event a) where + NoEvent ~= NoEvent = True + (Event x) ~= (Event y) = x ~= y + _ ~= _ = False + +instance (REq a, REq b) => REq (Either a b) where + (Left x) ~= (Left y) = x ~= y + (Right x) ~= (Right y) = x ~= y + _ ~= _ = False + +instance REq a => REq [a] where + [] ~= [] = True + (x:xs) ~= (y:ys) = x ~= y && xs ~= ys + _ ~= _ = False + + +------------------------------------------------------------------------------ +-- Testing utilities +------------------------------------------------------------------------------ + +testSF1 :: SF Double a -> [a] +testSF1 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 [0.0..])) + + +testSF2 :: SF Double a -> [a] +testSF2 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 input)) + where + -- The initial 0.0 is just for result compatibility with an older + -- version. + input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] :: [Int] ] + freq = 5 + + +------------------------------------------------------------------------------ +-- Test harness for space behaviour +------------------------------------------------------------------------------ + +{- +-- Test for space leaks. +-- Carefully defined in an attempt to defeat fully lazy lambda lifting. +-- Seems to work, but may be unsafe if the compiler decides to optimize +-- aggressively. +testSFSpaceLeak :: Int -> SF Double a -> a +testSFSpaceLeak n sf = embed sf (deltaEncodeBy (~=) 0.25 [(seq n 0.0)..]) !! n +-} + + +-- Using embed/deltaEncode seems to be a bad idea since fully lazy +-- lambda lifting often results in lifting a big input list to the top +-- level in the form of a CAF. Using reactimate and avoiding constructing +-- input/output lists should be more robust. + +testSFSpaceLeak :: Int -> SF Double a -> a +testSFSpaceLeak n sf = unsafePerformIO $ do + countr <- newIORef 0 + inputr <- newIORef undefined + outputr <- newIORef undefined + let init = do + let input0 = 0.0 + writeIORef inputr input0 + count <- readIORef countr + writeIORef countr (count + 1) + return input0 + sense _ = do + input <- readIORef inputr + let input' = input + 0.5 + writeIORef inputr input' + count <- readIORef countr + writeIORef countr (count + 1) + return (0.25, Just input') + actuate _ output = do + writeIORef outputr output + _input <- readIORef inputr + count <- readIORef countr + return (count >= n) + reactimate init sense actuate sf + + -- return output + readIORef outputr + +------------------------------------------------------------------------------ +-- Some utilities used for testing laws +------------------------------------------------------------------------------ + +fun_prod f g = \(x,y) -> (f x, g y) + +assoc :: ((a,b),c) -> (a,(b,c)) +assoc ((a,b),c) = (a,(b,c)) + +assocInv :: (a,(b,c)) -> ((a,b),c) +assocInv (a,(b,c)) = ((a,b),c) diff --git a/tests/TestsComp.hs b/tests/TestsComp.hs new file mode 100644 --- /dev/null +++ b/tests/TestsComp.hs @@ -0,0 +1,72 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsDelay.hs @@ -0,0 +1,89 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsDer.hs @@ -0,0 +1,56 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsEmbed.hs @@ -0,0 +1,62 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsEvSrc.hs @@ -0,0 +1,584 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsFirstSecond.hs @@ -0,0 +1,128 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsKSwitch.hs @@ -0,0 +1,129 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsLaws.hs @@ -0,0 +1,90 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsLoop.hs @@ -0,0 +1,207 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsLoopIntegral.hs @@ -0,0 +1,105 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsLoopLaws.hs @@ -0,0 +1,110 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsLoopPre.hs @@ -0,0 +1,63 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsPSwitch.hs @@ -0,0 +1,325 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsPre.hs @@ -0,0 +1,209 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsRPSwitch.hs @@ -0,0 +1,246 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsRSwitch.hs @@ -0,0 +1,144 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsReact.hs @@ -0,0 +1,71 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsSscan.hs @@ -0,0 +1,473 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsSwitch.hs @@ -0,0 +1,214 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsTask.hs @@ -0,0 +1,232 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsUtils.hs @@ -0,0 +1,372 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/TestsWFG.hs @@ -0,0 +1,103 @@ +{-# 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 --- a/tests/YampaQC.hs +++ b/tests/YampaQC.hs @@ -36,8 +36,7 @@ tests :: TestTree tests = testGroup "Yampa QC properties" - [ testProperty "SF based on (**2) equal to SF on (^2))" prop_arr_law1 - , testProperty "Identity" prop_arr_id + [ testProperty "Identity" prop_arr_id , testProperty "Arrow Naturality" prop_arr_naturality , testProperty "Naturality" prop_arr_naturality , testProperty "Basic > Identity (1)" prop_basic_identity_1 @@ -95,10 +94,6 @@ -- * Yampa laws -- ** Arrow laws -prop_arr_law1 = - forAll myStream (evalT $ prop_always_equal (arr (**2)) (arr (^2))) - where myStream :: Gen (SignalSampleStream Float) - myStream = uniDistStream prop_arr_id = forAll myStream (evalT $ prop_always_equal (arr id) identity) diff --git a/tests/testYampaMain.hs b/tests/testYampaMain.hs new file mode 100644 --- /dev/null +++ b/tests/testYampaMain.hs @@ -0,0 +1,78 @@ +{-# 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 @@ -1,6 +1,45 @@ -name: yampa-test -version: 0.13.3 -synopsis: Testing library for Yampa. +-- Copyright (c) 2017, Ivan Perez +-- +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- * Neither the name of Ivan Perez nor the names of other contributors may +-- be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. +cabal-version: >= 1.10 +build-type: Simple + +name: yampa-test +version: 0.13.4 +author: Ivan Perez +maintainer: ivan.perez@keera.co.uk +homepage: http://github.com/ivanperez-keera/Yampa +license: BSD3 +license-file: LICENSE +-- copyright +category: Testing +synopsis: Testing library for Yampa. description: Testing and debugging library for Yampa. . @@ -15,44 +54,118 @@ A detailed explanation of these ideas is included in the ICFP 2017 paper . -homepage: http://github.com/ivanperez-keera/Yampa -license: BSD3 -license-file: LICENSE -author: Ivan Perez -maintainer: ivan.perez@keera.co.uk --- copyright: -category: Testing -build-type: Simple -extra-source-files: CHANGELOG +extra-source-files: + CHANGELOG -cabal-version: >=1.10 +source-repository head + type: git + location: git://github.com/ivanperez-keera/Yampa.git + subdir: yampa-test + + +-- You can disable the regression test suite with -f-test-regression +flag test-regression + description: Enable regression test suite + default: True + manual: True + + library - exposed-modules: FRP.Yampa.Debug - FRP.Yampa.LTLFuture - FRP.Yampa.LTLPast - FRP.Yampa.Stream - FRP.Yampa.QuickCheck - build-depends: base >=4 && <5, - Yampa >= 0.13.3 && < 0.14, - QuickCheck, - normaldistribution - hs-source-dirs: src - default-language: Haskell2010 + exposed-modules: + FRP.Yampa.Debug + FRP.Yampa.LTLFuture + FRP.Yampa.LTLPast + FRP.Yampa.QuickCheck + FRP.Yampa.Stream + build-depends: + base >= 4 && < 5 + , normaldistribution + , QuickCheck + , Yampa >= 0.13.4 && < 0.14 + + default-language: + Haskell2010 + + hs-source-dirs: + src + + test-suite yampa-quicheck - type: exitcode-stdio-1.0 - main-is: YampaQC.hs - ghc-options: -Wall - default-language: Haskell2010 + type: + exitcode-stdio-1.0 - hs-source-dirs: tests + main-is: + YampaQC.hs + build-depends: - base < 5, - random, - Cabal >= 1.19, - QuickCheck, - tasty, - tasty-quickcheck, - Yampa, - yampa-test + base < 5 + , Cabal >= 1.19 + , QuickCheck + , random + , tasty + , tasty-quickcheck + , Yampa + , yampa-test + + default-language: + Haskell2010 + + hs-source-dirs: + tests + + ghc-options: + -Wall + + +test-suite regression + type: + exitcode-stdio-1.0 + + main-is: + testYampaMain.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 + + hs-source-dirs: + tests + + if !flag(test-regression) + buildable: + False + else + build-depends: + base + , Yampa