{-# LANGUAGE CPP #-}
-- |
-- Description : Test cases for FRP.Yampa.Simulation
-- Copyright   : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004
-- Authors     : Antony Courtney, Henrik Nilsson
module Test.FRP.Yampa.Simulation
    ( tests
    )
  where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<*>))
import Data.Functor        ((<$>))
#endif

import Data.Maybe       (fromMaybe)
import Data.Traversable (mapAccumL)

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)

import FRP.Yampa as Yampa

import FRP.Yampa.QuickCheck (uniDistStream)
import FRP.Yampa.Stream     (FutureSampleStream, SignalSampleStream)

import TestsCommon

tests :: TestTree
tests = testGroup "Regression tests for FRP.Yampa.Simulation"
  [ testProperty "reactimate (fixed)"    (property $ react_t0 ~= react_t0r)
  , testProperty "react, reactInit (qc)" testReact
  , testProperty "embed (0, qc)"         testEmbed
  , testProperty "embedSynch (0, fixed)" (property $ embed_t0 ~= embed_t0r)
  , testProperty "embedSynch (1, fixed)" (property $ embed_t1 ~= embed_t1r)
  , testProperty "deltaEncode (0, qc)"   testDeltaEncode
  , testProperty "deltaEncodeBy (0, qc)" testDeltaEncodeBy
  , testProperty "evalAtZero (0, qc)"    testEvalAtZero
  , testProperty "evalAt (0, qc)"        testEvalAt
  , testProperty "evalFuture (0, qc)"    testEvalFuture
  ]

-- * 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)
  ]

-- ** Low-level reactimation interface

testReact :: Property
testReact =
    forAll myStream $ \s ->
    forAllBlind randomSF $ \sf ->
      ioProperty $ do
        outs <- reactEmbed sf s
        let outsE = embed sf (structure s)
        return $ outs == outsE

  where

    myStream :: Gen (SignalSampleStream Integer)
    myStream = uniDistStream

    reactEmbed :: SF a b -> SignalSampleStream a -> IO [b]
    reactEmbed sf s@(s0, ss) = do
        outsRef <- newIORef []

        let init = return s0

            actuate _ _ b = modifyIORef outsRef (++ [b]) >> return False

            -- For each sample, add a Just to the value of the sample make the
            -- input compatible with what 'react' expects, and use 'react' to
            -- run one step of the simulation.
            reactEmbed' :: ReactHandle a b -> FutureSampleStream a -> IO ()
            reactEmbed' rh = mapM_ (react rh . second Just)

        reactHandle <- reactInit init actuate sf
        reactEmbed' reactHandle ss
        readIORef outsRef

    structure :: (a, [(b, a)]) -> (a, [(b, Maybe a)])
    structure (x, xs) = (x, map (second Just) xs)

-- * Embedding

testEmbed :: Property
testEmbed = testEmbedPointwise
       .&&. testEmbedSum

  where

    testEmbedPointwise :: Property
    testEmbedPointwise =
      forAllBlind function $ \f ->
      forAll myStream $ \stream ->
        property $
          embed (arr f) (structure stream) == fmap f (plain stream)

    testEmbedSum :: Property
    testEmbedSum =
      forAll myStream $ \stream ->
        property $
          let left :: [Integer]
              left = embed sf (structure stream)

              sf :: SF Integer Integer
              sf = loopPre 0 (arr (dup . uncurry (+)))

              right :: [Integer]
              right = summation (plain stream)

          in left == right

    myStream :: Gen (SignalSampleStream Integer)
    myStream = uniDistStream

    function :: Gen (Integer -> Integer)
    function = arbitrary

    -- Make each element the sum of all elements up to that point.
    summation :: [Integer] -> [Integer]
    summation =
      -- We add the accumulator to the current value (+), and make that the new
      -- value AND the new accumulator (dup).
       snd . mapAccumL ((dup .) . (+)) 0

    plain :: SignalSampleStream a -> [a]
    plain (x, xs) = x : fmap snd xs

    structure :: (a, [(b, a)]) -> (a, [(b, Maybe a)])
    structure (x, xs) = (x, map (second Just) xs)

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
  ]

testDeltaEncode :: Property
testDeltaEncode = testDeltaEncodeSamples
             .&&. testDeltaEncodeTimes

  where

    -- True if the samples produced by deltaEncode are not altered
    testDeltaEncodeSamples :: Property
    testDeltaEncodeSamples =
      forAll randomTime $ \t ->
      forAll randomSamples $ \s ->
        property $ s == streamSamples (deltaEncode t s)

    -- True if the times produced by deltaEncode are not altered
    testDeltaEncodeTimes :: Property
    testDeltaEncodeTimes =
      forAll randomTime $ \t ->
      forAll randomSamples $ \s ->
        property $ all (== t) $ streamTimes (deltaEncode t s)

testDeltaEncodeBy :: Property
testDeltaEncodeBy = testDeltaEncodeBySamples
               .&&. testDeltaEncodeByTimes

  where

    -- True if the samples produced by deltaEncodeBy are not altered
    testDeltaEncodeBySamples :: Property
    testDeltaEncodeBySamples =
        forAll randomTime $ \t ->
        forAll randomSamples $ \s ->
        forAllBlind randomPredicate $ \f ->
          -- Compare all samples, pair-wise, between the list encoded (s) and
          -- the resulting signal samples, using the predicate (f).
          property $ simplifyBy f s == streamSamples (deltaEncodeBy f t s)

      where

        -- Simplify a stream by using an equality predicate function.
        --
        -- The function simplifyBy models the behavior of deltaEncodeBy, which
        -- uses the equality function to compare values. Note that
        -- deltaEncodeBy carries the last value forward even if the equality
        -- was successful (i.e., even if the output for that step is Nothing).
        -- Consequently, when the current value is compared with the last value
        -- to determine if the output must be a Nothing or a Just, the current
        -- value is not compared to the last value for which the equality test
        -- failed, but rather, to the very last value.
        --
        -- The behavior of deltaEncodeBy may appear unsual when the equality
        -- predicate function provided is not transitive.
        simplifyBy :: (a -> a -> Bool) -> [a] -> [a]
        simplifyBy f []     = []
        simplifyBy f (x:xs) = x : simplifyBy' f x x xs
          where
            simplifyBy' :: (a -> a -> Bool) -> a -> a -> [a] -> [a]
            simplifyBy' f _acc _cmp [] = []
            simplifyBy' f acc  cmp  (x:xs)
              | f x cmp   = acc : simplifyBy' f acc x xs
              | otherwise = x : simplifyBy' f x x xs

    -- True if the times produced by deltaEncodeBy are not altered
    testDeltaEncodeByTimes :: Property
    testDeltaEncodeByTimes =
      forAll randomTime $ \t ->
      forAll randomSamples $ \s ->
      forAllBlind randomPredicate $ \f ->
        property $ all (== t) $ streamTimes (deltaEncodeBy f t s)

    -- Predicate on two integer arguments
    randomPredicate :: Gen (Integer -> Integer -> Bool)
    randomPredicate = arbitrary

-- * Debugging / Step by step simulation

testEvalAtZero :: Property
testEvalAtZero = testEvalAtZero1
            .&&. testEvalAtZero2

  where

    testEvalAtZero1 :: Property
    testEvalAtZero1 =
      forAllBlind randomSF $ \sf ->
      forAll arbitrary $ \x ->
        fst (evalAtZero sf x) == head (embed sf (x, []))

    testEvalAtZero2 :: Property
    testEvalAtZero2 =
      forAllBlind randomSF2 $ \sf ->
      forAll arbitrary $ \x ->
        fst (evalAtZero sf x) == head (embed sf (x, []))

testEvalAt :: Property
testEvalAt = testEvalAt1
        .&&. testEvalAt2

  where

    testEvalAt1 :: Property
    testEvalAt1 =
      forAllBlind randomSF $ \sf ->
      forAll arbitrary $ \x1 ->
      forAll arbitrary $ \x2 ->
      forAll randomTime $ \t ->
        let
          -- Value (fst) of simulation after one step with evalAtZero, and
          -- another step with evalAt
          eval1Val = fst $ evalAt (snd (evalAtZero sf x1)) t x2

          -- Second sample (!!1) of result of embedding with stream with two
          -- samples
          embed1Val = (embed sf (x1, [(t, Just x2)])) !! 1

        in eval1Val == embed1Val

    testEvalAt2 :: Property
    testEvalAt2 =
      forAllBlind randomSF2 $ \sf ->
      forAll arbitrary $ \x1 ->
      forAll arbitrary $ \x2 ->
      forAll randomTime $ \t ->
        let
          -- Value (fst) of simulation after one step with evalAtZero, and
          -- another step with evalAt
          eval1Val = fst $ evalAt (snd (evalAtZero sf x1)) t x2

          -- Second sample (!!1) of result of embedding with stream with two
          -- samples
          embed1Val = (embed sf (x1, [(t, Just x2)])) !! 1

        in eval1Val == embed1Val

testEvalFuture :: Property
testEvalFuture = testEvalFuture1
            .&&. testEvalFuture2

  where

    testEvalFuture1 :: Property
    testEvalFuture1 =
        forAllBlind randomSF $ \sf ->
        forAll myStream1 $ \s ->
          unroll sf s == embed sf (structure s)
      where
        myStream1 :: Gen (SignalSampleStream Integer)
        myStream1 = uniDistStream

    testEvalFuture2 :: Property
    testEvalFuture2 =
        forAllBlind randomSF2 $ \sf ->
        forAll myStream2 $ \s ->
          unroll sf s == embed sf (structure s)
      where
        myStream2 :: Gen (SignalSampleStream (Integer, Integer))
        myStream2 = uniDistStream

    -- Apply an SF to a stream of inputs manually, using evalAtZero and
    -- evalFuture, and collect the outputs
    unroll :: SF a b -> (a, [(DTime, a)]) -> [b]
    unroll sf (s1, [])          = [ fst $ evalAtZero sf s1 ]
    unroll sf (s1, (dt, s2):ss) = o1 : unroll sf' (s2, ss)
      where
        (o1, sf') = evalFuture sf s1 dt

    structure :: (a, [(b, a)]) -> (a, [(b, Maybe a)])
    structure (x, xs) = (x, map (second Just) xs)

-- * Auxiliary

-- | Generate a random positive time delta.
randomTime :: Gen Double
randomTime = getPositive <$> arbitrary

-- | Generate multiple random integer samples.
randomSamples :: Gen [Integer]
randomSamples = getNonEmpty <$> arbitrary

-- | Generator of random signal functions on integers.
randomSF :: Gen (SF Integer Integer)
randomSF = oneof [ return identity
                 , pointwiseSF
                 , loopPre <$> arbitrary <*> randomSF2
                 ]

-- | Generator of random signal functions on integer pairs.
randomSF2 :: Gen (SF (Integer, Integer) (Integer, Integer))
randomSF2 = oneof [ return identity
                  , pointwiseSF2
                  ]

-- | Generator of random pointwise signal functions on integers.
pointwiseSF :: Gen (SF Integer Integer)
pointwiseSF = arr <$> arbitrary

-- | Generator of random pointwise signal functions on integer pairs.
pointwiseSF2 :: Gen (SF (Integer, Integer) (Integer, Integer))
pointwiseSF2 = arr <$> arbitrary

-- | Extract the samples from an "optimized" stream.
streamSamples :: (a, [(DTime, Maybe a)]) -> [a]
streamSamples (a, as) = a : streamSamples' a (fmap snd as)
  where
    streamSamples' :: a -> [Maybe a] -> [a]
    streamSamples' acc =
      -- We pick one between the accumulator to the current value
      -- if available (fromMaybe), and make that the new value AND the
      -- new accumulator (dup).
      snd . mapAccumL ((dup .) . fromMaybe) acc

-- | Extract the times from an "optimized" stream.
streamTimes :: (a, [(DTime, Maybe a)]) -> [DTime]
streamTimes = map fst . snd