content: -- |
  -- 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
  