yampa-test-0.13.5: tests/Test/FRP/Yampa/InternalCore.hs
-- |
-- Description : Test cases for FRP.Yampa.InternalCore
-- Copyright : Yale University, 2003
-- Authors : Antony Courtney and Henrik Nilsson
module Test.FRP.Yampa.InternalCore
( tests
)
where
import Test.QuickCheck
import Test.QuickCheck.Function
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Data.Tuple (swap)
import FRP.Yampa as Yampa
import FRP.Yampa.Stream
import FRP.Yampa.QuickCheck
import FRP.Yampa.LTLFuture
import TestsCommon
tests :: TestTree
tests = testGroup "Regression tests for FRP.Yampa.InternalCore"
[ testProperty "arr (0, fixed)" (property $ arr_t0 ~= arr_t0r)
, testProperty "arr (1, fixed)" (property $ arr_t1 ~= arr_t1r)
, testProperty "Arrow Naturality" prop_arr_naturality
, testProperty "composition (0, fixed)" (property $ comp_t0 ~= comp_t0r)
, testProperty "composition (1, fixed)" (property $ comp_t1 ~= comp_t1r)
, testProperty "composition (2, fixed)" (property $ comp_t2 ~= comp_t2r)
, testProperty "composition (3, fixed)" (property $ comp_t3 ~= comp_t3r)
, testProperty "composition (4, fixed)" (property $ comp_t4 ~= comp_t4r)
, testProperty "composition (5, fixed)" (property $ comp_t5 ~= comp_t5r)
, testProperty "Arrows > Composition (1)" prop_arrow_comp_1
, testProperty "Arrows > Composition (2)" prop_arrow_comp_2
, testProperty "Arrows > Composition (3)" prop_arrow_comp_3
, testProperty "first (0, fixed)" (property $ first_t0 ~= first_t0r)
, testProperty "first (1, fixed)" (property $ first_t1 ~= first_t1r)
, testProperty "first (2, fixed)" (property $ first_t2 ~= first_t2r)
, testProperty "first (3, fixed)" (property $ first_t3 ~= first_t3r)
, testProperty "first (4, fixed)" (property $ first_t4 ~= first_t4r)
, testProperty "first (5, fixed)" (property $ first_t5 ~= first_t5r)
, testProperty "Arrows > First (1)" prop_arrow_first_1
, testProperty "Arrows > First (2)" prop_arrow_first_2
, testProperty "second (0, fixed)" (property $ second_t0 ~= first_t0r)
, testProperty "second (1, fixed)" (property $ second_t1 ~= first_t1r)
, testProperty "second (2, fixed)" (property $ second_t2 ~= first_t2r)
, testProperty "second (3, fixed)" (property $ second_t3 ~= first_t3r)
, testProperty "second (4, fixed)" (property $ second_t4 ~= first_t4r)
, testProperty "second (5, fixed)" (property $ second_t5 ~= first_t5r)
, testProperty "Arrows > Second (1)" prop_arrow_second_1
, testProperty "Arrows > Second (2)" prop_arrow_second_2
, testProperty "arrow laws (0, fixed)" (property $ laws_t0_lhs ~= laws_t0_rhs)
, testProperty "Arrows > Identity (0)" prop_arrow_id_0
, testProperty "arrow laws (1, fixed)" (property $ laws_t1_lhs ~= laws_t1_rhs)
, testProperty "Arrows > Identity (2)" prop_arrow_id_2
, testProperty "arrow laws (2, fixed)" (property $ laws_t2_lhs ~= laws_t2_rhs)
, testProperty "Arrows > Associativity" prop_arrow_assoc
, testProperty "arrow laws (3, fixed)" (property $ laws_t3_lhs ~= laws_t3_rhs)
, testProperty "Arrows > Function lifting composition" prop_arrow_arr_comp
, testProperty "arrow laws (4, fixed)" (property $ laws_t4_lhs ~= laws_t4_rhs)
, testProperty "Arrows > First" prop_arrow_first_3
, testProperty "arrow laws (5, fixed)" (property $ laws_t5_lhs ~= laws_t5_rhs)
, testProperty "Arrows > Distributivity of First" prop_arrow_first_distrib
, testProperty "arrow laws (6, fixed)" (property $ laws_t6_lhs ~= laws_t6_rhs)
, testProperty "Arrows > Commutativity of id on first" prop_arrow_first_id_comm
, testProperty "arrow laws (7, fixed)" (property $ laws_t7_lhs ~= laws_t7_rhs)
, testProperty "arrow laws (8, fixed)" (property $ laws_t8_lhs ~= laws_t8_rhs)
, testProperty "Arrows > Nested firsts" prop_arrow_first_nested
, testProperty "loop (0, fixed)" (property $ loop_t0 ~= loop_t0r)
, testProperty "loop (1, fixed)" (property $ loop_t1 ~= loop_t1r)
, testProperty "loop (2, fixed)" (property $ loop_t2 ~= loop_t2r)
, testProperty "loop (3, fixed)" (property $ loop_t3 ~= loop_t3r)
, testProperty "loop (4, fixed)" (property $ loop_t4 ~= loop_t4r)
, testProperty "loop (5, fixed)" (property $ loop_t5 ~= loop_t5r)
, testProperty "loop (6, fixed)" (property $ loop_t6 ~= loop_t6r)
, testProperty "loop (7, fixed)" (property $ loop_t7 ~= loop_t7r)
, testProperty "loop (8, fixed)" (property $ loop_t8 ~= loop_t8r)
, testProperty "loop (9, fixed)" (property $ loop_t9 ~= loop_t9r)
, testProperty "loop (10, fixed)" (property $ loop_t10 ~= loop_t10r)
, testProperty "loop (11, fixed)" (property $ loop_t11 ~= loop_t11r)
, testProperty "loop (12, fixed)" (property $ loop_t12 ~= loop_t12r)
, testProperty "loop (13, fixed)" (property $ loop_t13 ~= loop_t13r)
, testProperty "loop (14, fixed)" (property $ loop_t14 ~= loop_t14r)
, testProperty "loop (15, fixed)" (property $ loop_t15 ~= loop_t15r)
, testProperty "loop (16, fixed)" (property $ loop_t16 ~= loop_t16r)
, testProperty "loop (17, fixed)" (property $ loop_t17 ~= loop_t17r)
, testProperty "loop laws (0, fixed)" (property $ looplaws_t0_lhs ~= looplaws_t0_rhs)
, testProperty "loop laws (1, fixed)" (property $ looplaws_t1_lhs ~= looplaws_t1_rhs)
, testProperty "loop laws (2, fixed)" (property $ looplaws_t2_lhs ~= looplaws_t2_rhs)
, testProperty "loop laws (3, fixed)" (property $ looplaws_t3_lhs ~= looplaws_t3_rhs)
, testProperty "loop laws (4, fixed)" (property $ looplaws_t4_lhs ~= looplaws_t4_rhs)
, testProperty "loop laws (5, fixed)" (property $ looplaws_t5_lhs ~= looplaws_t5_rhs)
]
-- * Arrow instance and implementation
arr_t0 = testSF1 (arr (+1))
arr_t0r =
[ 1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0
, 17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0
]
arr_t1 = testSF2 (arr (+1))
arr_t1r =
[ 1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0
, 4.0,4.0,5.0,5.0,5.0,5.0,5.0
]
prop_arrow_1 = forAll myStream $ evalT $
Always $ prop (arr id, \x y -> x == y)
where myStream :: Gen (SignalSampleStream Float)
myStream = uniDistStream
-- C1: Arr naturality (testSF1 (arr (+1)))
prop_arr_naturality =
forAll myStream $ \stream ->
forAll f $ \f' ->
evalT (Always (prop (arr (apply f'), \x y -> apply f' x == y)))
where myStream :: Gen (SignalSampleStream Float)
myStream = uniDistStream
f :: Gen (Fun Int Int)
f = arbitrary
comp_t0 = testSF1 ((arr (+1)) >>> (arr (+2)))
comp_t0r :: [Double]
comp_t0r =
[ 3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0
, 18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0
]
comp_t1 = testSF2 ((arr (+1)) >>> (arr (+2)))
comp_t1r :: [Double]
comp_t1r =
[ 3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0,4.0,5.0,5.0,5.0,5.0,5.0
, 6.0,6.0,6.0,6.0,6.0,7.0,7.0,7.0,7.0,7.0
]
comp_t2 = testSF1 ((constant 5.0) >>> (arr (+1)))
comp_t2r :: [Double]
comp_t2r =
[ 6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0
, 6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0
]
comp_t3 = testSF2 ((constant 5.0) >>> (arr (+1)))
comp_t3r :: [Double]
comp_t3r =
[ 6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0
, 6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0
]
-- Integration by the rectangle rule or trapezoid rule makes no difference.
comp_t4 = testSF1 ((constant 2.0) >>> integral)
comp_t4r :: [Double]
comp_t4r =
[ 0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5
, 9.0,9.5,10.0,10.5,11.0,11.5,12.0
]
-- Same result as above.
comp_t5 = testSF2 ((constant 2.0) >>> integral)
comp_t5r :: [Double]
comp_t5r =
[ 0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5
, 9.0,9.5,10.0,10.5,11.0,11.5,12.0
]
-- Arrow composition (we use Int to avoid floating-point discrepancies)
prop_arrow_comp_1 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Int)
myStream = uniDistStream
sf = arr (+1) >>> arr (+2)
pred = (\x y -> x + 3 == y)
-- Arrow composition
prop_arrow_comp_2 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Float)
myStream = uniDistStream
sf = constant 5.0 >>> arr (+1)
pred = const (== 6.0)
-- Arrow composition
prop_arrow_comp_3 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Float)
myStream = fixedDelayStream 0.25
sf :: SF a Float
sf = constant 2.0 >>> integral >>> stepDiff (-0.5)
pred = const (== 0.5)
first_t0 :: [(Int,Double)]
first_t0 = testSF1 (arr dup >>> first (constant 7))
first_t0r :: [(Int,Double)]
first_t0r =
[ (7,0.0), (7,1.0), (7,2.0), (7,3.0), (7,4.0)
, (7,5.0), (7,6.0), (7,7.0), (7,8.0), (7,9.0)
, (7,10.0), (7,11.0), (7,12.0), (7,13.0), (7,14.0)
, (7,15.0), (7,16.0), (7,17.0), (7,18.0), (7,19.0)
, (7,20.0), (7,21.0), (7,22.0), (7,23.0), (7,24.0)
]
first_t1 :: [(Int,Double)]
first_t1 = testSF2 (arr dup >>> first (constant 7))
first_t1r :: [(Int,Double)]
first_t1r =
[ (7,0.0), (7,0.0), (7,0.0), (7,0.0), (7,0.0)
, (7,1.0), (7,1.0), (7,1.0), (7,1.0), (7,1.0)
, (7,2.0), (7,2.0), (7,2.0), (7,2.0), (7,2.0)
, (7,3.0), (7,3.0), (7,3.0), (7,3.0), (7,3.0)
, (7,4.0), (7,4.0), (7,4.0), (7,4.0), (7,4.0)
]
first_t2 :: [(Double,Double)]
first_t2 = testSF1 (arr dup >>> first (arr (+1)))
first_t2r =
[ (1.0,0.0), (2.0,1.0), (3.0,2.0), (4.0,3.0), (5.0,4.0)
, (6.0,5.0), (7.0,6.0), (8.0,7.0), (9.0,8.0), (10.0,9.0)
, (11.0,10.0), (12.0,11.0), (13.0,12.0), (14.0,13.0), (15.0,14.0)
, (16.0,15.0), (17.0,16.0), (18.0,17.0), (19.0,18.0), (20.0,19.0)
, (21.0,20.0), (22.0,21.0), (23.0,22.0), (24.0,23.0), (25.0,24.0)
]
first_t3 :: [(Double,Double)]
first_t3 = testSF2 (arr dup >>> first (arr (+1)))
first_t3r =
[ (1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0)
, (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0)
, (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0)
, (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0)
, (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0)
]
first_t4 :: [(Double,Double)]
first_t4 = testSF1 (arr dup >>> first integral)
first_t4r =
[ (0.0,0.0), (0.0,1.0), (0.25,2.0), (0.75,3.0), (1.5,4.0)
, (2.5,5.0), (3.75,6.0), (5.25,7.0), (7.0,8.0), (9.0,9.0)
, (11.25,10.0), (13.75,11.0), (16.5,12.0), (19.5,13.0), (22.75,14.0)
, (26.25,15.0), (30.0,16.0), (34.0,17.0), (38.25,18.0), (42.75,19.0)
, (47.5,20.0), (52.5,21.0), (57.75,22.0), (63.25,23.0), (69.0,24.0)
]
first_t5 :: [(Double,Double)]
first_t5 = testSF2 (arr dup >>> first integral)
first_t5r =
[ (0.0,0.0), (0.0,0.0), (0.0,0.0), (0.0,0.0), (0.0,0.0)
, (0.0,1.0), (0.25,1.0), (0.5,1.0), (0.75,1.0), (1.0,1.0)
, (1.25,2.0), (1.75,2.0), (2.25,2.0), (2.75,2.0), (3.25,2.0)
, (3.75,3.0), (4.5,3.0), (5.25,3.0), (6.0,3.0), (6.75,3.0)
, (7.5,4.0), (8.5,4.0), (9.5,4.0), (10.5,4.0), (11.5,4.0)
]
prop_arrow_first_1 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Int)
myStream = uniDistStream
sf = arr dup >>> first (constant 7)
pred = (\x y -> (7 :: Int, x) == y)
prop_arrow_first_2 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Int)
myStream = uniDistStream
sf = arr dup >>> first (arr (+1))
pred = (\x y -> (x + 1, x) == y)
-- Test cases for second
-- These should mirror the test cases for first.
second_t0 :: [(Int,Double)]
second_t0 = testSF1 (arr dup >>> second (constant 7) >>> arr swap)
second_t1 :: [(Int,Double)]
second_t1 = testSF2 (arr dup >>> second (constant 7) >>> arr swap)
second_t2 :: [(Double,Double)]
second_t2 = testSF1 (arr dup >>> second (arr (+1)) >>> arr swap)
second_t3 :: [(Double,Double)]
second_t3 = testSF2 (arr dup >>> second (arr (+1)) >>> arr swap)
second_t4 :: [(Double,Double)]
second_t4 = testSF1 (arr dup >>> second integral >>> arr swap)
second_t5 :: [(Double,Double)]
second_t5 = testSF2 (arr dup >>> second integral >>> arr swap)
prop_arrow_second_1 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Int)
myStream = uniDistStream
sf = arr dup >>> second (constant 7)
pred = (\x y -> (x, 7 :: Int) == y)
prop_arrow_second_2 =
forAll myStream $ evalT $ Always $ prop (sf, pred)
where myStream :: Gen (SignalSampleStream Int)
myStream = uniDistStream
sf = arr dup >>> second (arr (+1))
pred = (\x y -> (x, x + 1) == y)
-- For a description of the laws, see e.g. Ross Paterson: Embedding a Class of
-- Domain-Specific Languages in a Functional Language.
-- Only a very rudimentary sanity check. Obviously not intended to "prove"
-- this implementation indeed do respect the laws.
laws_t0_lhs :: [Double]
laws_t0_lhs = testSF1 (arr id >>> integral)
laws_t0_rhs :: [Double]
laws_t0_rhs = testSF1 (integral)
prop_arrow_id_0 =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)
where sf1 = arr id >>> integral
sf2 = integral
pred = arr $ uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
laws_t1_lhs :: [Double]
laws_t1_lhs = testSF1 (integral >>> arr id)
laws_t1_rhs :: [Double]
laws_t1_rhs = testSF1 (integral)
prop_arrow_id_2 =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)
where sf1 = integral >>> arr id
sf2 = integral
pred = arr $ uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
laws_t2_lhs :: [Double]
laws_t2_lhs = testSF1 ((integral >>> arr (*0.5)) >>> integral)
laws_t2_rhs :: [Double]
laws_t2_rhs = testSF1 (integral >>> (arr (*0.5) >>> integral))
prop_arrow_assoc =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)
where sf1 = (integral >>> arr (*0.5)) >>> integral
sf2 = integral >>> (arr (*0.5) >>> integral)
pred = arr $ uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
laws_t3_lhs :: [Double]
laws_t3_lhs = testSF1 (arr ((*2.5) . (+3.0)))
laws_t3_rhs :: [Double]
laws_t3_rhs = testSF1 (arr (+3.0) >>> arr (*2.5))
prop_arrow_arr_comp =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> pred)
where sf1 = (arr ((*2.5) . (+3.0)))
sf2 = (arr (+3.0) >>> arr (*2.5))
pred = arr (uncurry (==))
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
prop_arrow_2 = forAll myStream $ evalT $
Always $ prop (sf1 &&& sf2, const $ uncurry (==))
where myStream :: Gen (SignalSampleStream Float)
myStream = uniDistStream
sf1 = arr (f >>> g)
sf2 = arr f >>> arr g
f = (+5)
g = (/20)
prop_arrow_2' =
forAll f $ \f' ->
forAll g $ \g' ->
forAll myStream $ evalT $
prop_arrow_2'' (apply f') (apply g')
where myStream :: Gen (SignalSampleStream Int)
myStream = uniDistStream
f, g :: Gen (Fun Int Int)
f = arbitrary
g = arbitrary
prop_arrow_2'' f g =
Always $ prop (sf1 &&& sf2, const $ uncurry (==))
where sf1 = arr (f >>> g)
sf2 = arr f >>> arr g
laws_t4_lhs :: [(Double, Double)]
laws_t4_lhs = testSF1 (arr dup >>> first (arr (*2.5)))
laws_t4_rhs :: [(Double, Double)]
laws_t4_rhs = testSF1 (arr dup >>> arr ((*2.5) *** id))
prop_arrow_first_3 =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)
where sf1 = (arr dup >>> first (arr (*2.5)))
sf2 = (arr dup >>> arr (fun_prod (*2.5) id))
pred = uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
laws_t5_lhs :: [(Double, Double)]
laws_t5_lhs = testSF1 (arr dup >>> (first (integral >>> arr (+3.0))))
laws_t5_rhs :: [(Double, Double)]
laws_t5_rhs = testSF1 (arr dup >>> (first integral >>> first (arr (+3.0))))
prop_arrow_first_distrib =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)
where sf1 = (arr dup >>> (first (integral >>> arr (+3.0))))
sf2 = (arr dup >>> (first integral >>> first (arr (+3.0))))
pred = uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
laws_t6_lhs :: [(Double, Double)]
laws_t6_lhs = testSF1 (arr dup >>> (first integral >>> arr (id *** (+3.0))))
laws_t6_rhs :: [(Double, Double)]
laws_t6_rhs = testSF1 (arr dup >>> (arr (id *** (+3.0)) >>> first integral))
prop_arrow_first_id_comm =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)
where sf1 = (arr dup >>> (first integral>>>arr (fun_prod id (+3.0))))
sf2 = (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral))
pred = uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
laws_t7_lhs :: [Double]
laws_t7_lhs = testSF1 (arr dup >>> (first integral >>> arr fst))
laws_t7_rhs :: [Double]
laws_t7_rhs = testSF1 (arr dup >>> (arr fst >>> integral))
laws_t8_lhs :: [(Double, (Double, ()))]
laws_t8_lhs = testSF1 (arr (\x -> ((x,x),()))
>>> (first (first integral) >>> arr assoc))
laws_t8_rhs :: [(Double, (Double, ()))]
laws_t8_rhs = testSF1 (arr (\x -> ((x,x),()))
>>> (arr assoc >>> first integral))
prop_arrow_first_nested =
forAll myStream $ evalT $ Always $ SP ((sf1 &&& sf2) >>> arr pred)
where
sf1 = (arr (\x -> ((x,x),())) >>> (first (first integral) >>> arr assoc))
sf2 = (arr (\x -> ((x,x),())) >>> (arr assoc >>> first integral))
pred = uncurry (==)
myStream :: Gen (SignalSampleStream Double)
myStream = uniDistStream
-- * Test cases for loop
loop_acc :: SF (Double, Double) (Double, Double)
loop_acc = arr (\(x, y)->(x+y, x+y))
loop_t0 :: [Double]
loop_t0 = testSF1 (loop (constant (42.0, 43.0)))
loop_t0r =
[ 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0
, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0
, 42.0, 42.0, 42.0, 42.0, 42.0
]
loop_t1 :: [Double]
loop_t1 = testSF1 (loop identity)
loop_t1r =
[ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0
, 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0
, 20.0, 21.0, 22.0, 23.0, 24.0
]
loop_t2 :: [Time]
loop_t2 = testSF1 (loop (first localTime))
loop_t2r =
[ 0.0, 0.25, 0.5, 0.75, 1.0
, 1.25, 1.5, 1.75, 2.0, 2.25
, 2.5, 2.75, 3.0, 3.25, 3.5
, 3.75, 4.0, 4.25, 4.5, 4.75
, 5.0, 5.25, 5.5, 5.75, 6.0
]
-- AC, 10-March-2002: I think this is the simplest test that will
-- fail with AltST.
loop_t3 :: [Time]
loop_t3 = testSF1 (loop (second (iPre 0)))
loop_t3r =
[ 0.0, 1.0, 2.0, 3.0, 4.0
, 5.0, 6.0, 7.0, 8.0, 9.0
, 10.0, 11.0, 12.0, 13.0, 14.0
, 15.0, 16.0, 17.0, 18.0, 19.0
, 20.0, 21.0, 22.0, 23.0, 24.0
]
loop_t4 :: [Double]
loop_t4 = testSF1 (loop (second (iPre 0) >>> loop_acc))
loop_t4r =
[ 0.0, 1.0, 3.0, 6.0, 10.0
, 15.0, 21.0, 28.0, 36.0, 45.0
, 55.0, 66.0, 78.0, 91.0, 105.0
, 120.0, 136.0, 153.0, 171.0, 190.0
, 210.0, 231.0, 253.0, 276.0, 300.0
]
loop_t5 :: [Double]
loop_t5 = testSF2 (loop (second (iPre 0) >>> loop_acc))
loop_t5r =
[ 0.0, 0.0, 0.0, 0.0, 0.0
, 1.0, 2.0, 3.0, 4.0, 5.0
, 7.0, 9.0, 11.0, 13.0, 15.0
, 18.0, 21.0, 24.0, 27.0, 30.0
, 34.0, 38.0, 42.0, 46.0, 50.0
]
loop_t6 :: [Double]
loop_t6 = testSF1 (loop (iPre (0,0) >>> first localTime >>> loop_acc))
loop_t6r =
[ 0.0, 0.25, 0.75, 1.5, 2.5
, 3.75, 5.25, 7.0, 9.0, 11.25
, 13.75, 16.5, 19.5, 22.75, 26.25
, 30.0, 34.0, 38.25, 42.75, 47.5
, 52.5, 57.75, 63.25, 69.0, 75.0
]
loop_t7 :: [Double]
loop_t7 = testSF1 (loop (loop_acc >>> second (iPre 0)))
loop_t7r = loop_t4r
loop_t8 :: [Double]
loop_t8 = testSF2 (loop (loop_acc >>> second (iPre 0)))
loop_t8r = loop_t5r
loop_t9 :: [Double]
loop_t9 = testSF1 (loop (first localTime >>> loop_acc >>> iPre (0,0)))
loop_t9r =
[ 0.0, 0.0, 0.25, 0.75, 1.5
, 2.5, 3.75, 5.25, 7.0, 9.0
, 11.25, 13.75, 16.5, 19.5, 22.75
, 26.25, 30.0, 34.0, 38.25, 42.75
, 47.5, 52.5, 57.75, 63.25, 69.0
]
loop_t10 :: [Double]
loop_t10 = testSF1 (loop (loop_acc >>> second (iPre 0) >>> identity))
loop_t10r = loop_t4r
loop_t11 :: [Double]
loop_t11 = testSF2 (loop (loop_acc >>> second (iPre 0) >>> identity))
loop_t11r = loop_t5r
loop_t12 :: [Double]
loop_t12 = testSF1 (loop (first localTime
>>> loop_acc
>>> iPre (0,0)
>>> identity))
loop_t12r = loop_t9r
-- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration.
-- Values as given by using exp directly:
-- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413
loop_t13 :: [Double]
loop_t13 =
let es = embed (loop (second integral >>> arr (\(_, x) -> (x + 1, x + 1))))
(deltaEncode 0.001 (repeat ()))
in [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
loop_t13r = [1.0,2.71692, 7.38167, 20.05544, 54.48911, 148.04276]
loop_t14 :: [Double]
loop_t14 =
let es = embed (loop (arr (\(_, x) -> (x + 1, x + 1)) >>> second integral))
(deltaEncode 0.001 (repeat ()))
in [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
loop_t14r = loop_t13r
loop_t15 :: [Double]
loop_t15 =
let es = embed (loop (arr (\(_, x) -> (x + 1, x + 1))
>>> second integral
>>> identity))
(deltaEncode 0.001 (repeat ()))
in [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000]
loop_t15r = loop_t13r
-- A generator for factorial: The least-fixed point of this function is
-- the factorial function.
factGen f n = if (n==0) then 1 else n*f(n-1)
-- Can we use loop to construct a fixed point?
loop_t16 :: [Int]
loop_t16 = testSF1 (loop $ arr (\ (_,f) -> (f 4,factGen f)))
loop_t16r =
[24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24]
-- A simple loop test taken from MiniYampa:
-- This results in pulling on the fed-back output during evaluation, because
-- switch is strict in its input sample:
loop_t17 :: [Double]
loop_t17 = testSF1 (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x,noEvent)) >>> (iPre (25, noEvent)))
loop_t17r =
[ 0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0
, 16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0
]
-- For a description of the laws, see Ross Paterson: Embedding a Class of
-- Domain-Specific Languages in a Functional Language.
-- Only a very rudimentary sanity check. Obviously not intended to "prove"
-- this implementation indeed do respect the laws.
simple_loop :: ((a,c) -> (b,c)) -> (a -> b)
simple_loop f a = b
where
(b, c) = f (a, c)
-- Left tightening
looplaws_t0_f = second integral >>> arr swap
looplaws_t0_h :: Fractional a => SF a a
looplaws_t0_h = arr (+10.0)
looplaws_t0_lhs :: [Double]
looplaws_t0_lhs = testSF1 (loop (first looplaws_t0_h >>> looplaws_t0_f))
looplaws_t0_rhs :: [Double]
looplaws_t0_rhs = testSF1 (looplaws_t0_h >>> loop looplaws_t0_f)
-- Right tightening
looplaws_t1_f = second integral >>> arr swap
looplaws_t1_h :: Fractional a => SF a a
looplaws_t1_h = arr (+10.0)
looplaws_t1_lhs :: [Double]
looplaws_t1_lhs = testSF1 (loop (looplaws_t1_f >>> first looplaws_t1_h))
looplaws_t1_rhs :: [Double]
looplaws_t1_rhs = testSF1 (loop looplaws_t1_f >>> looplaws_t1_h)
-- Sliding
-- Used to work with only signature t2_f :: Fractional a -> SF a a
looplaws_t2_f :: SF (Double, Double) (Double, Double)
looplaws_t2_f = integral
looplaws_t2_k = id *** (+42.0)
looplaws_t2_lhs :: [Double]
looplaws_t2_lhs = testSF1 (loop (looplaws_t2_f >>> arr looplaws_t2_k))
looplaws_t2_rhs :: [Double]
looplaws_t2_rhs = testSF1 (loop (arr looplaws_t2_k >>> looplaws_t2_f))
-- Vanishing
-- The lazy pattern matching (~) is necessary to avoid a black hole in the
-- RHS due to premature forcing of tuples. As far as I can tell, loop is
-- as lazy as it can be, and this problem could not have been solved by
-- "fixing" the loop definition.
looplaws_t3_f = second integral
>>> first (arr swap)
>>> arr (\ ~((a,b),c) -> ((a,c),b))
looplaws_t3_lhs :: [Double]
looplaws_t3_lhs = testSF1 (loop (loop looplaws_t3_f))
looplaws_t3_rhs :: [Double]
looplaws_t3_rhs = testSF1 (loop (arr assocInv >>> looplaws_t3_f >>> arr assoc))
-- Superposing
looplaws_t4_f = second integral >>> arr swap
looplaws_t4_lhs :: [(Double,Double)]
looplaws_t4_lhs = testSF1 (arr dup >>> (second (loop looplaws_t4_f)))
looplaws_t4_rhs :: [(Double, Double)]
looplaws_t4_rhs = testSF1 (arr dup >>> (loop (arr assoc
>>> second looplaws_t4_f
>>> arr assocInv)))
-- Extension
looplaws_t5_f = \(a,c) -> (take 5 c, a : c)
looplaws_t5_lhs :: [[Double]]
looplaws_t5_lhs = testSF1 (loop (arr looplaws_t5_f))
looplaws_t5_rhs :: [[Double]]
looplaws_t5_rhs = testSF1 (arr (simple_loop looplaws_t5_f))
-- * Auxiliary
-- prop :: SF a b -> (a -> b ->
prop (a,b) = SP ((identity &&& a) >>^ uncurry b)
stepDiff :: Num a => a -> SF a a
stepDiff z = loopPre z (arr (\(x,y) -> (x - y, x)))