harropsort3.hs

-- 1) Upgraded to Data.Time 2) Added some timings. 3) 10 million. 
-- Otherwise unchanged
-- Result: 14 seconds versus 70 seconds for List.sort, 2.1 GB ram used

-- google: haskell etl
-- > https://www.reddit.com/r/ocaml/comments/3ifwe9/what_are_ocamlers_critiques_of_haskell/
-- > https://www.reddit.com/r/haskell/comments/3inqzk/an_optimal_haskell_quicksort/
-- > http://flyingfrogblog.blogspot.com/2010/08/parallel-generic-quicksort-in-haskell.html
{-# LANGUAGE FlexibleContexts #-}
-- import System.Time
import Data.Time
import System.Random
import Data.Array.IO
import Control.Monad
import Control.Concurrent
import Control.Exception
import qualified Data.List as L

bool t _ True = t
bool _ f False = f

swap arr i j = do
  (iv, jv) <- liftM2 (,) (readArray arr i) (readArray arr j)
  writeArray arr i jv
  writeArray arr j iv

background task = do
  m <- newEmptyMVar
  forkIO (task >>= putMVar m)
  return $ takeMVar m

parallel fg bg = do
  wait <- background bg
  fg >> wait

sort arr left right = when (left < right) $ do
  pivot <- read right
  loop pivot left (right - 1) (left - 1) right
  where
    read = readArray arr
    sw = swap arr
    find n pred i = bool (find n pred (n i)) (return i) . pred i =<< read i
    move op d i pivot = bool (return op)
                        (sw (d op) i >> return (d op)) =<<
                        liftM (/=pivot) (read i)
    swapRange px x nx y ny = if px x then sw x y >> swapRange px (nx x) nx (ny y) ny else return y
    loop pivot oi oj op oq = do
      i <- find (+1) (const (<pivot)) oi
      j <- find (subtract 1) (\idx cell -> cell>pivot && idx/=left) oj
      if i < j
        then do
          sw i j
          p <- move op (+1) i pivot
          q <- move oq (subtract 1) j pivot
          loop pivot (i + 1) (j - 1) p q
        else do
          sw i right
          nj <- swapRange (<op) left (+1) (i-1) (subtract 1)
          ni <- swapRange (>oq) (right-1) (subtract 1) (i+1) (+1)
          let thresh = 1024000
              strat = if nj - left < thresh || right - ni < thresh
                      then (>>)
                      else parallel
          sort arr left nj `strat` sort arr ni right

timed :: IO b -> IO (Double, b)
timed act = do
  before <- getCurrentTime
  x <- act
  after <- getCurrentTime
  return (fromRational . toRational $ diffUTCTime after before, x)

main = do
  let n = 10000000
  putStrLn "Making rands"
  (timing, arr) <- timed $ newListArray (0, n-1) =<< replicateM n (randomRIO (0, n) >>= evaluate)
  putStrLn $ "creating random array took " ++ show timing ++ " seconds"
  elems <- getElems arr
  putStrLn "Now starting sort"
  (timing, _) <- timed $ sort (arr :: IOArray Int Int) 0 (n-1)
  putStrLn $ "Sort took " ++ show timing ++ " seconds"
  (timing, _ ) <- timed $ print . (L.sort elems ==) =<< getElems arr
  putStrLn $ "comparison (and List.sort) took " ++ show timing ++ " seconds"