[Haskell-cafe] (flawed?) benchmark : sort

[Chaddaï Fouché]

2008/3/4, Krzysztof Skrzętnicki <gtener at gmail.com>:
> Hi
>
> I was playing with various versions of sorting algorithms. I know it's very
> easy to create flawed benchmark and I don't claim those are good ones.
> However, it really seems strange to me, that sort - library function - is
> actually the worse measured function. I can hardly belive it, and I'd rather
> say I have made a mistake preparing it.
>
> The overall winner seems to be qsort_iv - which is nothing less but old sort
> replaced by mergesort now.
>
> Any clues?

Part of what you may be missing :
-- cut here --
module Main where

import Control.Parallel.Strategies
import Control.Arrow
import System.CPUTime
import System.IO
import System.Environment
import System.Random
import Data.List( partition, sort )

data Tree a =
    Node (Tree a) a (Tree a)
        | Leaf


qsort_i []  = []
qsort_i (x:xs) = qsort_i (filter (< x) xs) ++ [x] ++ qsort_i (filter (>= x) xs)

qsort_ii [] = []
qsort_ii (x:xs) = let (ls,gt) = partition (< x) xs in qsort_ii ls ++
[x] ++ qsort_ii gt

qsort_iii xs = qsort_iii' [] xs
qsort_iii' acc [] = acc
qsort_iii' acc (x:xs) =
    let (ls,gt) = partition (< x) xs in
    let acc' = (x:(qsort_iii' acc gt)) in qsort_iii' acc' ls

qsort_v [] = []
qsort_v (x:xs) = let (xlt, xgt ) = foldl (\ (lt,gt) el -> case compare x el of
                                                            GT -> (el:lt, gt)
                                                            _  -> (lt,
el:gt) ) ([],[]) xs
                 in qsort_v xlt ++ [x] ++ qsort_v xgt

-- zmodyfikowany i
qsort_vi [] = []
qsort_vi (x:xs) = qsort_vi (filter (\y-> compare x y == GT) xs) ++ [x]
++ qsort_vi (filter (\y-> compare x y /= GT) xs)


-- zmodyfikowany iii
qsort_vii xs = qsort_vii' [] xs
qsort_vii' acc [] = acc
qsort_vii' acc (x:xs) =
    let (ls,gt) = partition (\y-> compare x y == GT) xs in
    let acc' = (x:(qsort_vii' acc gt)) in qsort_vii' acc' ls



-- qsort is stable and does not concatenate.
qsort_iv xs = qsort_iv' (compare) xs []

qsort_iv' _   []     r = r
qsort_iv' _   [x]    r = x:r
qsort_iv' cmp (x:xs) r = qpart cmp x xs [] [] r

-- qpart partitions and sorts the sublists
qpart cmp x [] rlt rge r =
    -- rlt and rge are in reverse order and must be sorted with an
    -- anti-stable sorting
    rqsort_iv' cmp rlt (x:rqsort_iv' cmp rge r)
qpart cmp x (y:ys) rlt rge r =
    case cmp x y of
    GT -> qpart cmp x ys (y:rlt) rge r
    _  -> qpart cmp x ys rlt (y:rge) r

-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
rqsort_iv' _   []     r = r
rqsort_iv' _   [x]    r = x:r
rqsort_iv' cmp (x:xs) r = rqpart cmp x xs [] [] r

rqpart cmp x [] rle rgt r =
    qsort_iv' cmp rle (x:qsort_iv' cmp rgt r)
rqpart cmp x (y:ys) rle rgt r =
    case cmp y x of
    GT -> rqpart cmp x ys rle (y:rgt) r
    _  -> rqpart cmp x ys (y:rle) rgt r


-- code by Orcus

-- Zadanie 9 - merge sort
mergeSort :: Ord a => [a] -> [a]
mergeSort []    = []
mergeSort [x]   = [x]
mergeSort xs    = let(l, r) = splitAt (length xs `quot` 2) xs
                  in mergeSortP (mergeSort l) (mergeSort r)

-- funkcja pomocnicza scalajÄ…ca dwie listy uporzÄ…dkowane w jednÄ…
mergeSortP :: Ord a => [a] -> [a] -> [a]
mergeSortP xs []            = xs
mergeSortP [] ys            = ys
mergeSortP (x:xs) (y:ys)
    | x <= y = x:(mergeSortP xs (y:ys))
    | otherwise = y:(mergeSortP (x:xs) ys)

-- Zadanie 10 - tree sort
treeSort :: Ord a => [a] -> [a]
-- pointless po raz drugi
treeSort = (treeSortInorder . treeSortToTree)

treeSortToTree :: Ord a => [a] -> Tree a
treeSortToTree []       = Leaf
treeSortToTree (x:xs)   = let (xlt, xgt) = foldl (\ (lt,gt) el -> case
compare x el of
                                                            GT -> (el:lt, gt)
                                                            _  -> (lt,
el:gt) ) ([],[]) xs
                          in Node (treeSortToTree xlt) x (treeSortToTree xgt)

treeSortInorder :: Ord a => Tree a -> [a]
treeSortInorder Leaf            = []
treeSortInorder (Node l x r)    = (treeSortInorder l) ++ [x] ++
(treeSortInorder r)

-- end code by Orcus

-- 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

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

bigNum = 1000000 :: Int

-- end of benchmark making code

main = makeBenchs [("i",qsort_i),
                   ("ii",qsort_ii),
                   ("iii",qsort_iii),
                   ("iv",qsort_iv),
                   ("v",qsort_v),
                   ("vi",qsort_vi),
                   ("vii",qsort_vii),
                   ("sort",sort),
                   ("mergeSort",mergeSort),
                   ("treeSort",treeSort)]
            =<< onSorted . read . head =<< getArgs

-- cut here --

It could probably be improved (with classics solution (better
selection of the pivot...)), but the mergesort is only 3 times slower
in worse case, and much more regular, if someone needs a faster sort
in a specific case, it isn't hard to code.

-- 
Jedaï