{-# LANGUAGE BangPatterns #-}

module Main where

import qualified BinaryTree as T
import qualified BreadthFirstSearch as BFS
import qualified Data.Char as Char
import Data.List
import Data.Bits
import System.CPUTime
import System.Environment

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

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

avg (s0,s1,s2) = s1 / s0

fib :: Int -> Int
fib 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 val = do
  start <- getCPUTime
  if val then return () else error ("Failed test: " ++ string)
  end <- getCPUTime
  return $! (end - start) `div` cpuTimePrecision

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 f n = length (f (T.fib n)) == fib n - 1

fromUnit  f n = (f (T.fib n)) == ()

main = do
  xs <- getArgs
  case xs of
    (a1:a2:a3:_)
        | all Char.isDigit a2 && all Char.isDigit a3
        -> do_test a1 (read a2) (read a3)
    _ -> help_message

do_test a1 i n
 = case a1 of
   "direct"         -> test' a1 (fromQueue BFS.direct        ) i n
   "allison"        -> test' a1 (fromQueue BFS.allison       ) i n
   "allison2"       -> test' a1 (fromQueue BFS.allison2      ) i n
   "corec1"         -> test' a1 (fromQueue BFS.corec1        ) i n
   "corec2"         -> test' a1 (fromQueue BFS.corec2        ) i n
   "st"             -> test' a1 (fromUnit  BFS.stq           ) i n
   "sidechan1"      -> test' a1 (fromQueue BFS.sidechan1     ) i n
   "sidechan2"      -> test' a1 (fromQueue BFS.sidechan2     ) i n
   "twostack"       -> test' a1 (fromUnit  BFS.twostack      ) i n
   "two_cpst"       -> test' a1 (fromUnit  BFS.twostack_cpst ) i n
   "two_list"       -> test' a1 (fromQueue BFS.twostack_list ) i n
   "okasaki"        -> test' a1 (fromUnit  BFS.okasaki       ) i n
   "okasaki_list"   -> test' a1 (fromQueue BFS.okasaki_list  ) i n
   "sequence"       -> test' a1 (fromUnit  BFS.sequence      ) i n
   "sequence_list"  -> test' a1 (fromQueue BFS.sequence_list ) i n
   "sequence2"      -> test' a1 (fromUnit  BFS.sequence2     ) i n
   _ -> help_message

help_message = do
  putStr   "Usage:  Time <test> <input> <number_of_trials>"
  putStr "\n<test> is one of:"
  putStr "\n   direct     for a corecursive traversal without using a monad"
  putStr "\n   allison    Control.Monad.Queue.Allison"
  putStr "\n   allison2     as above, but uses deQ_break instead of deQ"
  putStr "\n   corec1       Control.Monad.Queue.Corec, does not demand result of ()"
  putStr "\n   corec2       as above, but demands ()"
  putStr "\n   sidechan1    SideChannelQ, like corec1"
  putStr "\n   sidechan2    like corec2"
  putStr "\n   twostack     Two-Stack queues without a monad"
  putStr "\n   two_cpst     uses Two-Stack queues inside a CpSt monad"
  putStr "\n   two_list     produces a list of elements enqueued"
  putStr "\n   okasaki      Data.Queue.Okasaki"
  putStr "\n   okasaki_list"
  putStr "\n   sequence     Data.Sequence"
  putStr "\n   sequence_list"
  putStr "\n   sequence2    The wrong way to use sequence as a queue"
  putStr "\n"
  putStr "\ne.g.  Test direct 30 10"
  putStr "\n        runs direct on the 30th fibbonacci tree 10 times"
  putStr "\n      Test direct 30 10 +RTS -H500M -sstderr"
  putStr "\n        as above, but uses a 500MB heap,  and prints runtime stats"
  putStr "\n"