paradox.hs (2349B)
1 {-# LANGUAGE BangPatterns, TemplateHaskell #-} 2 3 import System.Random.MWC 4 import Control.Arrow 5 import Control.Monad 6 import Data.List 7 import System.Exit 8 -- Testing 9 import System.Environment 10 import Test.QuickCheck 11 import Test.QuickCheck.All 12 13 simulate :: Int -> Int -> IO Double 14 simulate ne np = do 15 zs <- withSystemRandom . asGenIO $ \g0 -> replicateM ne 16 . fmap duplicatesPresent $ replicateM np (uniformR (1 :: Int, 365) g0) 17 return . average $ map (\x -> if x then 1 else 0) zs 18 19 main :: IO () 20 main = do 21 args <- getArgs 22 when (args == []) $ putStrLn "(Birthday Paradox Simulator) usage: ./simulate <runTests=True|False>" >> exitSuccess 23 let run = read $ head args :: Bool 24 when run (void runTests) 25 unless run $ do let psim n ne np = do putStrLn $ "run " ++ show n ++ " (" ++ show np ++ " people, " ++ show ne ++ " simulations)" 26 sresult <- simulate ne np 27 putStrLn $ " frequency of " ++ show sresult 28 psim 0 10000 12 29 psim 1 10000 23 30 psim 2 10000 57 31 psim 3 10000 100 32 33 -- Utilities 34 35 average :: Fractional a => [a] -> a 36 average [] = error "average: empty list" 37 average xs = go 0 0 xs 38 where go !s !n [] = s / fromIntegral n 39 go !s !n (x:xs) = go (s + x) (n + 1) xs 40 {-# INLINE average #-} 41 42 duplicatesPresent :: (Eq a, Ord a) => [a] -> Bool 43 duplicatesPresent [] = False 44 duplicatesPresent xs = go h0 t0 45 where go h [] = False 46 go h (t:ts) = h == t || go t ts 47 (h0, t0) = (head &&& tail) (sort xs) 48 {-# INLINE duplicatesPresent #-} 49 50 -- Testing 51 52 prop_averageEqualsNaiveMean :: NonEmptyList Double -> Bool 53 prop_averageEqualsNaiveMean (NonEmpty xs) = 54 average xs == (sum xs / fromIntegral (length xs)) 55 56 prop_averageLiesBetweenExtrema :: NonEmptyList Double -> Bool 57 prop_averageLiesBetweenExtrema (NonEmpty xs) = 58 (minimum xs <= average xs) && (maximum xs >= average xs) 59 60 prop_duplicatesPresentDetectsDuplicates :: [Int] -> Bool 61 prop_duplicatesPresentDetectsDuplicates xs = 62 duplicatesPresent xs == (any (> 1) . map length . group . sort) xs 63 64 qcOptions :: Args 65 qcOptions = stdArgs { maxSuccess = 1000 } 66 67 runTests :: IO Bool 68 runTests = $forAllProperties (quickCheckWithResult qcOptions) 69