QuickSort.hs

{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Monad
import           Control.Monad.Fix
import           Control.Monad.Primitive
import           Criterion
import           Criterion.Main
import           Data.List
import           Data.STRef
import           Data.Vector.Unboxed         hiding (filter, forM_, (++))
import qualified Data.Vector.Unboxed.Mutable as M
import           Debug.Trace
import           GHC.ST
import           System.Random
import           Test.QuickCheck
import           Test.QuickCheck.Instances

qs :: Ord a => [a] -> [a]
qs [] = []
qs (x:xs) = qs left ++ [x] ++ qs right
  where
     left  = filter (<x) xs
     right = filter (>=x) xs

quickSort :: Vector Int -> Vector Int
quickSort = modify f
  where
    f :: (Ord a, PrimMonad m, Unbox a) => MVector (PrimState m) a -> m ()
    f v = qsort v 0 (M.length v - 1)
      where
        qsort a low high =
          when (low < high) $ do
            p <- partition a low high
            qsort a low (p - 1)
            qsort a (p + 1) high

        partition a low high = do
          pivot <- M.read a high
          ix <- go low (high-1) low pivot a
          M.swap a high ix
          return ix
        go l h i pivot a =
          if l <= h
            then do
               aj <- M.read a l
               if aj <= pivot
                 then do
                   M.swap a l i
                   go (l+1) h (i+1) pivot a
                 else
                   go (l+1) h i pivot a
            else
              return i

test = quickCheck $ \(v :: Vector Int) ->
  (quickSort v) == (fromList $ sort (toList v))

main = do
  k <- Control.Monad.replicateM 1000 $ randomRIO (1,1000 :: Int)
  let k' = fromList k
  defaultMain [
    bgroup "sorting" [
          bench "linked list quicksort nf"   $ nf qs k
        , bench "in-place quicksort nf"      $ nf quickSort k'
        , bench "linked list quicksort whnf" $ whnf qs k
        , bench "in-place quicksort whnf"    $ whnf quickSort k'
        ]
    ]