yampa-test-0.14.1: tests/Test/FRP/Yampa/Simulation.hs
{-# 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