Ticket #3331: Time.hs

File Time.hs, 2.2 KB (added by igloo, 6 years ago)
Line 
1
2{-# LANGUAGE BangPatterns              #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4
5module Main (main) where
6
7import Data.List (foldl')
8import Data.Bits
9import System.CPUTime
10
11import A (runQueue, zenQ, zdeQ)
12
13stats :: [Double] -> (Double, Double, Double)
14stats = foldl' (\(!s0,!s1,!s2) x -> (s0+1,s1+x,s2+x*x)) (0,0,0)
15
16stddev :: (Double, Double, Double) -> Double
17stddev (s0, s1, s2) = sqrt (s0 * s2 - s1 * s1) / s0
18
19avg :: (Double, Double, Double) -> Double
20avg (s0, s1, _s2) = s1 / s0
21
22qfib :: Int -> Int
23qfib n = snd . foldl' fib' (1, 0) $ dropWhile not $
24            [testBit n k | k <- let s = bitSize n in [s-1,s-2..0]]
25    where
26        fib' (f, g) p
27            | p         = (f*(f+2*g), ss)
28            | otherwise = (ss, g*(2*f-g))
29            where ss = f*f+g*g
30
31test :: String -> Bool -> IO Integer
32test string val = do
33  start <- getCPUTime
34  if val then return () else error ("Failed test: " ++ string)
35  end <- getCPUTime
36  return $! (end - start) `div` cpuTimePrecision
37
38test' :: String -> (Int -> Bool) -> Int -> Int -> IO ()
39test' string f i n = do
40  ts <- mapM (test string . f) (replicate n i)
41  putStr string
42  putStr "\nTimings: "
43  print ts
44  putStr "Sum:     "
45  print (sum ts)
46  putStr "Minimum: "
47  print (minimum ts)
48  putStr "Maximum: "
49  print (maximum ts)
50  let s = stats (map fromIntegral ts)
51  putStr "Mean:    "
52  print (avg s)
53  putStr "Stddev:  "
54  print (stddev s)
55
56fromQueue :: (Tree Integer Integer -> [Tree Integer Integer]) -> Int -> Bool
57fromQueue f n = Prelude.length (f (fib n)) == qfib n - 1
58
59main :: IO ()
60main = test' "allison" (fromQueue allison) 34 20
61
62allison :: Tree Integer Integer -> [Tree Integer Integer]
63allison tree = A.runQueue (handle tree >> explore)
64  where
65    handle   (Leaf   _      ) = return ()
66    handle t@(Branch _ _ _  ) = A.zenQ t
67
68    explore = do
69      branch <- A.zdeQ
70      case branch of
71        Nothing -> return ()
72        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore
73        Just (Leaf _) -> error "XXX"
74
75data  Tree a b
76   =  Leaf    a
77   |  Branch  b (Tree a b) (Tree a b)
78      deriving (Eq,Show)
79
80fib :: Int -> Tree Integer Integer
81fib n = fibs !! (n - 1)
82  where
83    fibs = Leaf 0 : Leaf 0 : zipWith3 Branch [1..] fibs (tail fibs)
84