-- |
-- Description : Test cases for FRP.Yampa.InternalCore
-- Copyright   : (c) Ivan Perez, 2014-2022
--               (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004
-- Authors     : Antony Courtney, Henrik Nilsson, Ivan Perez
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)))