mergetest

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

import Data.List (unfoldr)
import System.Random (randomR, StdGen, split, newStdGen)
import Control.Monad (replicateM)
import Control.Parallel.Strategies
import Criterion.Main
import Data.Foldable(foldr')

randGens :: Int -> IO([StdGen])
randGens n = let
    f 0 _ = Nothing
    f n (split -> (x, x')) = Just (x, (n - 1, x'))
    in do
        seed <- newStdGen
        return $ unfoldr (uncurry f) (n, seed)


randomList :: Int -> StdGen -> [Int]
randomList n s
    | n == 0 = []
    | otherwise = r : randomList (n - 1) s' where
        (r, s') = randomR (0, n) s


main :: IO ()
main = do
    seeds <- ([7..] `zip`) <$> randGens 17
    let xs = map (\(i, g) -> randomList (2 ^ i) g) seeds
    defaultMain [
            bgroup "mergesort" $ map (\x -> bench (show $ 2 ^ (7 + x)) $ whnf sort $ xs !! x) [0..16]
        ,   bgroup "mergesort(s)" $ map (\x -> bench (show $ 2 ^ (7 + x)) $ whnf sort' $ xs !! x) [0..16]
        ]


merge :: (Ord a) => [a] -> [a] -> [a]
merge xs [] = xs
merge [] ys = ys
merge (x:xs) (y:ys)
    | x <= y =  x : merge xs (y:ys)
    | otherwise = y : merge (x:xs) ys


pairList :: [[a]] -> [([a], [a])]
pairList (x1:x2:xs) = (x1, x2) : pairList xs
pairList (x:xs) = [(x, [])]
pairList [] = []


sort :: (Ord a) => [a] -> [a]
sort xs = k . map (:[]) $ xs where
    f = parMap rpar (uncurry merge)
    k [x] = x
    k xs = k . f . pairList $ xs


sort' :: (Ord a) => [a] -> [a]
sort' xs = k . map (:[]) $ xs where
    f = map (uncurry merge)
    k [x] = x
    k xs = k . f . pairList $ xs