{-# OPTIONS_GHC -O2 -fbang-patterns #-}
module Main where

import System.CPUTime
import System.IO
import System.Environment
import System.Random
import Data.List( partition, sort, unfoldr )

import Control.Parallel.Strategies
import Control.Arrow

import qualified Data.Map as Map




-- functions to benchmark

treeSort = concatMap (reverse . snd) . Map.toAscList
           . Map.fromListWith (++) . map (\x -> (x,[x]))


yhcSort :: (Ord a) => [a] -> [a]
yhcSort = sortByYhc compare

sortByYhc cmp = mergeAll . sequences
  where
    sequences (a:b:xs)
      | a `cmp` b == GT = descending b [a]  xs
      | otherwise       = ascending  b [a] xs
    sequences xs = [xs]

    descending a as (b:bs)
      | a `cmp` b == GT = descending b (a:as) bs
    descending a as bs  = (a:as): sequences bs

    ascending a as (b:bs)
      | a `cmp` b /= GT = ascending b (a:as) bs
    ascending a as bs   = rev as [a] : sequences bs

    rev (x:xs) ys = rev xs (x:ys)
    rev [] ys = ys

    mergeAll [x] = x
    mergeAll xs  = mergeAll (mergePairs xs)

    mergePairs (a:b:xs) = merge a b: mergePairs xs
    mergePairs xs       = xs

    merge as@(a:as') bs@(b:bs')
      | a `cmp` b == GT = b:merge as  bs'
      | otherwise       = a:merge as' bs
    merge [] bs         = bs
    merge as []         = as



-- begin benchmark making code

makeBenchs benchs xs = do
 let (funcNames, funcs) = unzip benchs
 tBegin <- getCPUTime
 timers <- mapM (\f-> print (f xs) >> getCPUTime) funcs
 let times = zipWith (-) timers (tBegin:timers)
     sortedResults = sort $ zip times funcNames
     minT = fromIntegral $ fst $ head sortedResults
     scaled = map (((/minT) . fromIntegral) *** id) sortedResults
 hPutStr stderr $ unlines $ map show scaled --sortedResults

onRandom eltCnt = do
 gen <- getStdGen
 let xs = take eltCnt (randomRs (1::Int, bigNum) gen) `using` rnf
 xs `seq` return xs

onSorted eltCnt = do
 gen <- getStdGen
 let xs = take eltCnt (randomRs (1::Int, bigNum) gen) `using` rnf
     sxs = sort xs `using` rnf
 xs `seq` sxs `seq` return sxs

onRevsorted eltCnt = do
 gen <- getStdGen
 let xs = take eltCnt (randomRs (1::Int, bigNum) gen) `using` rnf
     sxs = reverse (sort xs `using` rnf)
 xs `seq` sxs `seq` return sxs


bigNum = 1000000 :: Int

-- end of benchmark making code


sortFunctions = [("sort",sort),("treeSort",treeSort),("yhcSort", yhcSort)]

mainOnSorted = makeBenchs sortFunctions
             =<< onSorted . read . head =<< getArgs


mainOnRevsorted = makeBenchs sortFunctions
                =<< onRevsorted . read . head =<< getArgs
                  

mainOnRandom = makeBenchs sortFunctions
             =<< onRandom . read . head =<< getArgs



main = mainOnSorted -- however, you can always use -main-is flag.

--