|
{-# LANGUAGE FlexibleContexts, QuantifiedConstraints, ScopedTypeVariables, TupleSections #-} |
|
import Control.Monad |
|
import Control.Monad.ST |
|
import Data.Array.Base |
|
import Data.Array.ST |
|
import Criterion.Main |
|
import Data.Foldable |
|
import qualified Data.IntMap.Strict as IM |
|
import qualified Data.List as L |
|
import qualified Data.Map.Strict as M |
|
import qualified Data.Sequence as Seq |
|
import qualified Data.Vector.Algorithms.Intro as VA |
|
import qualified Data.Vector.Unboxed as VU |
|
|
|
main :: IO () |
|
main = defaultMain |
|
[ env (pure testxs) $ \xs -> bgroup "[Int]" |
|
[ bench "Data.List.sort" $ whnf (benchSort L.sort) xs |
|
, bench "Seq sort" $ whnf (benchSort seqSort) xs |
|
, bench "IntMap sort" $ whnf (benchSort intMapSort) xs |
|
, bench "Vector sort" $ whnf (benchSort vecSort) xs |
|
, bench "msortU" $ whnf (benchSort msortU) xs |
|
] |
|
, env (pure testys) $ \ys -> bgroup "[(Int, Int)]" |
|
[ bench "Data.List.sort" $ whnf (benchSort L.sort) ys |
|
, bench "Seq sort" $ whnf (benchSort seqSort) ys |
|
, bench "Map sort" $ whnf (benchSort mapSort) ys |
|
, bench "Vector sort" $ whnf (benchSort vecSort) ys |
|
, bench "msort" $ whnf (benchSort msort) ys |
|
] |
|
, env (pure testxs) $ \xs -> bgroup "[Int] !! 100" |
|
[ bench "Data.List.sort" $ whnf (benchSortIndex L.sort xs) 100 |
|
] |
|
] |
|
where |
|
n = 200000 |
|
testxs = take n $ iterate ((`mod` 1000000007) . (*12345)) 1 :: [Int] |
|
testys = zip testxs [1..] :: [(Int, Int)] |
|
|
|
benchSort :: ([a] -> [a]) -> [a] -> Int |
|
benchSort sortf xs = length (sortf xs) |
|
{-# NOINLINE benchSort #-} |
|
|
|
benchSortIndex :: ([a] -> [a]) -> [a] -> Int -> a |
|
benchSortIndex sortf xs i = sortf xs !! i |
|
{-# NOINLINE benchSortIndex #-} |
|
|
|
seqSort :: Ord a => [a] -> [a] |
|
seqSort = toList . Seq.unstableSort . Seq.fromList |
|
|
|
intMapSort :: [Int] -> [Int] |
|
intMapSort = IM.assocs . IM.fromListWith (+) . map (,1) >=> \(k, v) -> replicate v k |
|
|
|
mapSort :: Ord a => [a] -> [a] |
|
mapSort = M.assocs . M.fromListWith (+) . map (,1) >=> \(k, v) -> replicate v k |
|
|
|
vecSort :: (VU.Unbox a, Ord a) => [a] -> [a] |
|
vecSort xs = VU.toList $ VU.create $ do |
|
v <- VU.thaw (VU.fromList xs) |
|
VA.sort v |
|
pure v |
|
|
|
-- Merge sort implementations below from |
|
-- https://github.com/meooow25/haccepted/blob/master/src/Sort.hs |
|
|
|
msort :: Ord e => [e] -> [e] |
|
msort = msortBy compare |
|
|
|
msortBy :: (e -> e -> Ordering) -> [e] -> [e] |
|
msortBy cmp xs = elems $ runSTArray $ do |
|
a <- listArrayST (1, length xs) xs |
|
mergeSort a cmp |
|
pure a |
|
|
|
msortU :: (Ord e, forall s. MArray (STUArray s) e (ST s), IArray UArray e) => [e] -> [e] |
|
msortU = msortUBy compare |
|
|
|
msortUBy :: (forall s. MArray (STUArray s) e (ST s), IArray UArray e) |
|
=> (e -> e -> Ordering) -> [e] -> [e] |
|
msortUBy cmp xs = elems $ runSTUArray $ do |
|
a <- listUArrayST (1, length xs) xs |
|
mergeSort a cmp |
|
pure a |
|
|
|
mergeSort :: forall a e m. (MArray a e m) => a Int e -> (e -> e -> Ordering) -> m () |
|
mergeSort a cmp = do |
|
n <- getNumElements a |
|
b :: a Int e <- newArray_ (1, n) |
|
let merge l m r = foldM_ f (l, m) [l .. r-1] where |
|
f (i, j) k |
|
| i >= m = takej |
|
| j >= r = takei |
|
| otherwise = do |
|
o <- cmp <$> unsafeRead a i <*> unsafeRead a j |
|
if o /= GT then takei else takej |
|
where |
|
takei = (i + 1, j) <$ (unsafeWrite b k =<< unsafeRead a i) |
|
takej = (i, j + 1) <$ (unsafeWrite b k =<< unsafeRead a j) |
|
forM_ (takeWhile (<n) $ iterate (*2) 1) $ \w -> do |
|
forM_ [0, 2*w .. n-1] $ \i -> merge i ((i + w) `min` n) ((i + 2*w) `min` n) |
|
forM_ [0 .. n-1] $ \i -> unsafeRead b i >>= unsafeWrite a i |
|
{-# INLINE mergeSort #-} |
