Ticket #3331: Time.hs

{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Main (main) where

import Data.List (foldl')
import Data.Bits
import System.CPUTime

import A (runQueue, zenQ, zdeQ)

stats :: [Double] -> (Double, Double, Double)
stats = foldl' (\(!s0,!s1,!s2) x -> (s0+1,s1+x,s2+x*x)) (0,0,0)

stddev :: (Double, Double, Double) -> Double
stddev (s0, s1, s2) = sqrt (s0 * s2 - s1 * s1) / s0

avg :: (Double, Double, Double) -> Double
avg (s0, s1, _s2) = s1 / s0

qfib :: Int -> Int
qfib n = snd . foldl' fib' (1, 0) $ dropWhile not $
            [testBit n k | k <- let s = bitSize n in [s-1,s-2..0]]
    where
        fib' (f, g) p
            | p         = (f*(f+2*g), ss)
            | otherwise = (ss, g*(2*f-g))
            where ss = f*f+g*g

test :: String -> Bool -> IO Integer
test string val = do
  start <- getCPUTime
  if val then return () else error ("Failed test: " ++ string)
  end <- getCPUTime
  return $! (end - start) `div` cpuTimePrecision

test' :: String -> (Int -> Bool) -> Int -> Int -> IO ()
test' string f i n = do
  ts <- mapM (test string . f) (replicate n i)
  putStr string
  putStr "\nTimings: "
  print ts
  putStr "Sum:     "
  print (sum ts)
  putStr "Minimum: "
  print (minimum ts)
  putStr "Maximum: "
  print (maximum ts)
  let s = stats (map fromIntegral ts)
  putStr "Mean:    "
  print (avg s)
  putStr "Stddev:  "
  print (stddev s)

fromQueue :: (Tree Integer Integer -> [Tree Integer Integer]) -> Int -> Bool
fromQueue f n = Prelude.length (f (fib n)) == qfib n - 1

main :: IO ()
main = test' "allison" (fromQueue allison) 34 20

allison :: Tree Integer Integer -> [Tree Integer Integer]
allison tree = A.runQueue (handle tree >> explore)
  where
    handle   (Leaf   _      ) = return ()
    handle t@(Branch _ _ _  ) = A.zenQ t

    explore = do
      branch <- A.zdeQ
      case branch of
        Nothing -> return ()
        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore
        Just (Leaf _) -> error "XXX"

data  Tree a b
   =  Leaf    a
   |  Branch  b (Tree a b) (Tree a b)
      deriving (Eq,Show)

fib :: Int -> Tree Integer Integer
fib n = fibs !! (n - 1)
  where
    fibs = Leaf 0 : Leaf 0 : zipWith3 Branch [1..] fibs (tail fibs)