yampa-test-0.13.5: tests/Space.hs
-- |
-- Module : Space
-- Description : Space tests.
-- Copyright : Yale University, 2003
-- Authors : Henrik Nilsson and Antony Courtney
module Main where
import FRP.Yampa
import Data.List (findIndex)
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef (newIORef, writeIORef, readIORef)
import TestsCommon (REq(..))
main :: IO ()
main = do
putStrLn ""
putStrLn "Running the Yampa space tests ..."
putStrLn "Testing the space behaviour. This may take a LONG time."
putStrLn "Observe the process size using some tool like top."
putStrLn "The process should not grow significantly."
putStrLn "Emitted success/failure indications signify termination"
putStrLn "and whether or not the right result was obtained. They do"
putStrLn "not necessarily indicate that the space behaviour is correct"
putStrLn "(i.e., absence of leaks)."
putStrLn ""
rst "arr" 0 arr_st0 arr_st0r
rst "arr" 1 arr_st1 arr_st1r
rst "loop" 0 loop_st0 loop_st0r
rst "loop" 1 loop_st1 loop_st1r
rst "rswitch" 0 rswitch_st0 rswitch_st0r
rst "pswitch" 0 pswitch_st0 pswitch_st0r
rst "pswitch" 1 pswitch_st1 pswitch_st1r
rst "rpswitch" 0 rpswitch_st0 rpswitch_st0r
rst "accum" 0 accum_st0 accum_st0r
rst "accum" 1 accum_st1 accum_st1r
where
rst n i st str = do
putStrLn ("Running " ++ n ++ "_st" ++ show i ++ " ...")
if st ~= str then
putStrLn "Success!"
else
-- We probably won't get here in case of a (space) failure ...
putStrLn "Failure!"
-- AC: here because I had trouble running ghci:
-- fixTest :: IO ()
-- fixTest =
-- let vs = loop_t17
-- in putStrLn ("loop_t17 output: " ++ show vs)
-- * Test cases for arr
arr_st0 = testSFSpaceLeak 2000000 (arr (+1))
arr_st0r = 1000000.5
arr_st1 = testSFSpaceLeak 2000000 identity
arr_st1r = 999999.5
-- * Test cases for loop
loop_acc :: SF (Double, Double) (Double, Double)
loop_acc = arr (\(x, y)->(x+y, x+y))
loop_st0 = testSFSpaceLeak 2000000
(loop (second (iPre 0) >>> loop_acc))
loop_st0r = 9.999995e11
-- 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_st1 :: Double
loop_st1 = testSFSpaceLeak 2000000
(loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x + x + x + x + x + x + x,noEvent)) >>> (iPre (25, noEvent)))
loop_st1r = 999999.5
-- * Test cases for rSwitch and drSwitch
rswitch_sawTooth :: SF a Double
rswitch_sawTooth =
loop (second (arr (>=5.0)
>>> edge
>>> arr (`tag` ramp))
>>> drSwitch ramp
>>> arr dup)
where
ramp :: SF a Double
ramp = constant 1.0 >>> integral
rswitch_st0 = testSFSpaceLeak 2000000 rswitch_sawTooth
rswitch_st0r = 4.75
-- * Test cases for pSwitchB and dpSwitchB
-- Starts three "ramps" with different phase. As soon as one exceeds a
-- threshold, it's restarted, while the others are left alone. The
-- observaton of the output is done via the loop (rather than the directly
-- from the outputs of the signal functions in the collection), thus the
-- use of a delayed switch is essential.
pswitch_ramp :: Double -> SF a Double
pswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase)
-- We assume that only one signal function will reach the limit at a time.
pswitch_limit :: Double -> SF ((a, [Double]), b) (Event Int)
pswitch_limit x = arr (snd . fst) >>> arr (findIndex (>=x)) >>> edgeJust
pswitch_t4rec :: [SF (a, [Double]) Double]
-> Int
-> SF (a, [Double]) [Double]
pswitch_t4rec sfs n =
dpSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs)
(pswitch_limit 2.99)
pswitch_t4rec
-- Variation of the test above, with direct observation (not via loop) and
-- immediate switch.
--
-- We assume that only one signal function will reach the limit at a time.
pswitch_limit2 :: Double -> SF (a, [Double]) (Event Int)
pswitch_limit2 x = arr snd >>> arr (findIndex (>=x)) >>> edgeJust
pswitch_t5rec :: [SF (a, [Double]) Double]
-> Int
-> SF (a, [Double]) [Double]
pswitch_t5rec sfs n =
pSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs)
(pswitch_limit2 2.99)
pswitch_t5rec
pswitch_st0 = testSFSpaceLeak 1000000 (loop sf)
where
sf :: SF (a, [Double]) ([Double],[Double])
sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]
(pswitch_limit 2.99)
pswitch_t4rec
>>> arr dup
pswitch_st0r = [1.5,2.5,0.5]
pswitch_st1 = testSFSpaceLeak 1000000 (loop sf)
where
sf :: SF (a, [Double]) (([Double], Double), [Double])
sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0]
(pswitch_limit2 2.99)
pswitch_t5rec)
&&& (arr snd >>> arr sum))
>>> arr (\(xs, y) -> ((xs, y), xs))
pswitch_st1r = ([1.5,2.5,0.5],4.5)
-- * Test cases for rpSwitchB and drpSwitchB
-- Starts three "ramps" with different phase. As soon as one exceeds a
-- threshold, it's restarted, while the others are left alone. The observaton
-- of the output is done via a loop, thus the use of a delayed switch is
-- essential.
rpswitch_ramp :: Double -> SF a Double
rpswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase)
-- We assume that only one signal function will reach the limit at a time.
rpswitch_limit :: Double -> SF [Double] (Event ([SF a Double]->[SF a Double]))
rpswitch_limit x = arr (findIndex (>=x)) >>> edgeJust >>> arr (fmap restart)
where
restart n = \sfs -> take n sfs ++ [rpswitch_ramp 0.0] ++ drop (n+1) sfs
rpswitch_st0 = testSFSpaceLeak 1000000 (loop sf)
where
sf :: SF (a, [Double]) ([Double],[Double])
sf = (second (rpswitch_limit 2.99)
>>> drpSwitchB [ rpswitch_ramp 0.0
, rpswitch_ramp 1.0
, rpswitch_ramp 2.0
]
) >>> arr dup
rpswitch_st0r = [1.5,2.5,0.5]
-- * Test cases for accumulators
accum_st0 :: Double
accum_st0 = testSFSpaceLeak 1000000
(repeatedly 1.0 1.0
>>> accumBy (+) 0.0
>>> hold (-99.99))
accum_st0r = 249999.0
accum_st1 :: Double
accum_st1 = testSFSpaceLeak 1000000
(arr dup
>>> first (repeatedly 1.0 1.0)
>>> arr (\(e,a) -> tag e a)
>>> accumFilter accumFun 0.0
>>> hold (-99.99))
where
accumFun c a | even (floor a) = (c+a, Just (c+a))
| otherwise = (c, Nothing)
accum_st1r = 6.249975e10
------------------------------------------------------------------------------
-- Test harness for space behaviour
------------------------------------------------------------------------------
{-
-- Test for space leaks.
-- Carefully defined in an attempt to defeat fully lazy lambda lifting.
-- Seems to work, but may be unsafe if the compiler decides to optimize
-- aggressively.
testSFSpaceLeak :: Int -> SF Double a -> a
testSFSpaceLeak n sf = embed sf (deltaEncodeBy (~=) 0.25 [(seq n 0.0)..]) !! n
-}
-- Using embed/deltaEncode seems to be a bad idea since fully lazy
-- lambda lifting often results in lifting a big input list to the top
-- level in the form of a CAF. Using reactimate and avoiding constructing
-- input/output lists should be more robust.
testSFSpaceLeak :: Int -> SF Double a -> a
testSFSpaceLeak n sf = unsafePerformIO $ do
countr <- newIORef 0
inputr <- newIORef undefined
outputr <- newIORef undefined
let init = do
let input0 = 0.0
writeIORef inputr input0
count <- readIORef countr
writeIORef countr (count + 1)
return input0
sense _ = do
input <- readIORef inputr
let input' = input + 0.5
writeIORef inputr input'
count <- readIORef countr
writeIORef countr (count + 1)
return (0.25, Just input')
actuate _ output = do
writeIORef outputr output
_input <- readIORef inputr
count <- readIORef countr
return (count >= n)
reactimate init sense actuate sf
-- return output
readIORef outputr