content: {-# LANGUAGE CPP #-}
  -- |
  -- Description : Test cases for FRP.Yampa.Delays
  -- 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.Delays
      ( tests
      )
    where
  
  #if __GLASGOW_HASKELL__ < 710
  import Control.Applicative ((<*>))
  import Data.Functor        ((<$>))
  #endif
  import Test.QuickCheck
  import Test.Tasty (TestTree, testGroup)
  import Test.Tasty.QuickCheck (testProperty)
  
  import FRP.Yampa as Yampa
  import FRP.Yampa.Stream
  import FRP.Yampa.QuickCheck
  import FRP.Yampa.LTLFuture
  
  import TestsCommon
  
  tests :: TestTree
  tests = testGroup "Regression tests for FRP.Yampa.Delays"
    [ testProperty "pre (qc)"                propPre
    , testProperty "iPre (0, fixed)"         (property $ pre_t0 ~= pre_t0r)
    , testProperty "iPre (1, fixed)"         (property $ pre_t1 ~= pre_t1r)
    , testProperty "iPre (2, fixed)"         (property $ pre_t2 ~= pre_t2r)
    , testProperty "iPre (3, fixed)"         (property $ pre_t3 == pre_t3r)
    , testProperty "iPre (4, fixed)"         (property $ pre_t4 == pre_t4r)
    , testProperty "iPre (5, fixed)"         (property $ pre_t5 == pre_t5r)
    , testProperty "iPre (6, fixed)"         (property $ pre_t6 == pre_t6r)
    , testProperty "iPre (7, fixed)"         (property $ pre_t7 == pre_t7r)
    , testProperty "iPre (8, fixed)"         (property $ pre_t8 == pre_t8r)
    , testProperty "fby (qc)"                propFby
    , testProperty "delay (0, fixed)"        (property $ delay_t0 ~= delay_t0r)
    , testProperty "delay (1, fixed)"        (property $ delay_t1 ~= delay_t1r)
    , testProperty "delay (2, fixed)"        (property $ delay_t2 ~= delay_t2r)
    , testProperty "delay (3, fixed)"        (property $ delay_t3 ~= delay_t3r)
    , testProperty "delay (4, fixed)"        (property $ delay_t4 == delay_t4r)
    , testProperty "delay (5, fixed)"        (property $ delay_t5 ~= delay_t5r)
    , testProperty "delay (zero delay, qc)"  prop_delay_1
    , testProperty "delay (small delay, qc)" prop_delay_2
    ]
  
  -- * Basic delays
  
  propPre :: Property
  propPre =
      forAll initialValueG $ \initialValue ->
      forAll myStream $ evalT $
        -- The behavior of pre is always the same as iPre after the first sample.
        -- The value at time zero is undefined, so we don't need to test it.
        Next $ Always $ SP $ (==) <$> pre <*> iPre initialValue
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      initialValueG :: Gen Float
      initialValueG = arbitrary
  
  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
            ]
  
  propFby :: Property
  propFby =
      forAll initialValueG $ \initialValue ->
      forAll myStream $ evalT $
        -- fby is just a convenience function for iPre with composition
        Always $ SP $ (==) <$> fby initialValue sf <*> (sf >>> iPre initialValue)
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      initialValueG :: Gen Float
      initialValueG = arbitrary
  
      -- We pick the integral because it exploits the case where the SF has to be
      -- turned off sooner or later (it would produce different results if turned
      -- on at inconsistent times between fby and >>> iPre).
      sf :: SF Float Float
      sf = integral
  
  -- * Timed delays
  
  delay_t0 = testSF1 (delay 0.0 undefined)
  delay_t0r =
    [ 0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0
    , 15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0
    ]
  
  delay_t1 = testSF1 (delay 0.0001 17)
  delay_t1r =
    [ 17.0,0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0
    , 15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0
    ]
  
  delay_t2 = testSF2 (delay 0.0001 17)
  delay_t2r =
    [ 17.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0
    , 3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0
    ]
  
  delay_t3 = testSF1 (time
                      >>> arr (\t -> sin (0.5 * t * pi + pi))
                      >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x'))
                                >>> second (delay 0.0001 0.0)))
  delay_t3r =
    take 25
         (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ]
          in tail (scanl max 0 xs))
  
  dts_t4 = take 15 (repeat 0.1)
           ++ [0.5, 0.5]
           ++ take 15 (repeat 0.1)
           ++ [2.0]
           ++ take 20 (repeat 0.1)
  
  input_t4 = (0, [ (dt, Just i) | (dt, i) <- zip dts_t4 [1..] ])
  
  delay_t4, delay_t4r :: [Int]
  delay_t4 = take 100 (embed (delay 1.05 (-1)) input_t4)
  delay_t4r =
    [ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 -- 0.0 s -- 0.9 s
    , -1,  0,  1,  2,  3,  4                 -- 1.0 s -- 1.5 s
    ,  9,                 14, 15, 15, 15, 15 -- 2.0 s -- 2.9 s
    , 15, 16, 16, 16, 16, 16, 17, 18, 19, 20 -- 3.0 s -- 3.9 s
    , 21                                     -- 4.0 s
    , 32, 32, 32, 32, 32, 32, 32, 32, 32, 32 -- 6.0 s -- 6.9 s
    , 32, 33, 34, 35, 36, 37, 38, 39, 40, 41 -- 7.0 s -- 7.9 s
    , 42                                     -- 8.0 s
    ]
  
  delay_t5 = take 100 (drop 6 (embed sf (deltaEncode 0.1 (repeat ()))))
    where
      sf = time >>> arr (\t -> sin (2*pi*t)) >>> delay 0.55 (-1.0)
  
  delay_t5r = take 100 (drop 6 (embed sf (deltaEncode 0.1 (repeat ()))))
    where
      sf = time >>> arr (\t -> sin (2*pi*(t-0.6)))
  
  -- | Delaying by 0.0 has no effect
  prop_delay_1 =
      forAll myStream $ evalT $ prop_always_equal sfDelayed sf
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      sfDelayed = delay 0.0 undefined >>> sf
      sf = arr (+1)
  
  -- | Delaying input signal by a small amount will fill in the "blank" signal
  --   with the given value, which will become also the sample at the initial
  --   time.
  prop_delay_2 =
      forAll myStream $ evalT $
        (prop (sfDelayed, (\x y -> y == initialValue)))
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      sfDelayed = delay 0.0001 initialValue
  
      initialValue = 17
  
  -- * Auxiliary
  
  -- prop :: SF a b -> (a -> b ->
  prop (a,b) = SP ((identity &&& a) >>^ uncurry b)
  
  -- | Compares two SFs, resulting in true if they are always equal
  prop_always_equal sf1 sf2 =
      Always $ SP ((sf1 &&& sf2) >>> arr sameResult)
    where
      sameResult = uncurry (==)
  