1module Random1283 (main) where
2
3import Control.Concurrent
4import Control.Monad
5import Data.Sequence (Seq, ViewL(..), empty, fromList, viewl, (<|), (|>), (><))
6import System.Random
7
8-- This test
9
10threads, samples :: Int
11threads = 4
12samples = 5000
13
14main :: IO ()
15main = loopTest threads samples
16
17loopTest :: Int -> Int -> IO ()
18loopTest t s = do
19  isClean <- testRace t s
20  unless isClean $ putStrLn "race condition!"
21
22testRace :: Int -> Int -> IO Bool
23testRace t s = do
24  ref <- liftM (take (t*s) . randoms) getStdGen
25  iss <- threadRandoms t s
26  return (isInterleavingOf (ref::[Int]) iss)
27
28threadRandoms :: Random a => Int -> Int -> IO [[a]]
29threadRandoms t s = do
30  vs <- sequence $ replicate t $ do
31    v <- newEmptyMVar
32    _ <- forkIO (sequence (replicate s randomIO) >>= putMVar v)
33    return v
34  mapM takeMVar vs
35
36isInterleavingOf :: Eq a => [a] -> [[a]] -> Bool
37isInterleavingOf xs' yss' = iio xs' (viewl $ fromList yss') EmptyL where
38  iio (x:xs) ((y:ys) :< yss) zss
39    | x /= y = iio (x:xs) (viewl yss) (viewl (fromViewL zss |> (y:ys)))
40    | x == y = iio xs (viewl ((ys <| yss) >< fromViewL zss)) EmptyL
41  iio xs ([] :< yss) zss = iio xs (viewl yss) zss
42  iio [] EmptyL EmptyL = True
43  iio _ _ _ = False
44
45fromViewL :: ViewL a -> Seq a
46fromViewL EmptyL = empty
47fromViewL (x :< xs) = x <| xs
48
49