Merge pull request #33 from thomie/master
[packages/random.git] / tests / random1283.hs
1 import Control.Concurrent
2 import Control.Monad hiding (empty)
3 import Data.Sequence (ViewL(..), empty, fromList, viewl, (<|), (|>), (><))
4 import System.Random
5
6 -- This test
7
8 threads = 4
9 samples = 5000
10
11 main = loopTest threads samples
12
13 loopTest t s = do
14 isClean <- testRace t s
15 when (not isClean) $ putStrLn "race condition!"
16
17 testRace t s = do
18 ref <- liftM (take (t*s) . randoms) getStdGen
19 iss <- threadRandoms t s
20 return (isInterleavingOf (ref::[Int]) iss)
21
22 threadRandoms :: Random a => Int -> Int -> IO [[a]]
23 threadRandoms t s = do
24 vs <- sequence $ replicate t $ do
25 v <- newEmptyMVar
26 forkIO (sequence (replicate s randomIO) >>= putMVar v)
27 return v
28 mapM takeMVar vs
29
30 isInterleavingOf xs yss = iio xs (viewl $ fromList yss) EmptyL where
31 iio (x:xs) ((y:ys) :< yss) zss
32 | x /= y = iio (x:xs) (viewl yss) (viewl (fromViewL zss |> (y:ys)))
33 | x == y = iio xs (viewl ((ys <| yss) >< fromViewL zss)) EmptyL
34 iio xs ([] :< yss) zss = iio xs (viewl yss) zss
35 iio [] EmptyL EmptyL = True
36 iio _ _ _ = False
37
38 fromViewL (EmptyL) = empty
39 fromViewL (x :< xs) = x <| xs
40