Semi-parallel pseudo-randomized in-place quicksort in Haskell.

QuickSort.hs

{-# LANGUAGE UnicodeSyntax #-}
module Main (main) where

import Control.Applicative ((<$>))
import Control.Monad (foldM, when)
import Control.Monad.ST (ST)
import Control.Parallel (par)
import Data.Array (elems)
import Data.Array.ST (STArray, newListArray, readArray, runSTArray, writeArray)
import Data.Char (toUpper)
import Data.Maybe (fromJust)
import System.Environment (getArgs)
import System.IO (hSetBuffering, BufferMode(LineBuffering, NoBuffering), stdout, stdin)
import System.Random (randomRIO)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Lazy.Char8 as BS

main ∷ IO ()
main = do
  hSetBuffering stdout NoBuffering
  hSetBuffering stdin NoBuffering
  putStr "Reading input… "
  φ:_ ← getArgs
  xs ← map (fst . fromJust . BS.readInt) . BS.lines <$> BS.readFile φ
  putStrLn "Ok!"
  putStr "Sorting array… "
  let ys = sort xs
  ys `seq` putStrLn "Ok!"
  putStr "Print array [y/N]: "
  ς ← getChar
  when (toUpper ς == 'Y') $ do
    hSetBuffering stdout LineBuffering
    print ys
  putStrLn ""

sort ∷ Ord α ⇒ [α] → [α]
sort xs = elems $ runSTArray $ do
  μ ← newListArray (1, τ) xs
  sortST μ 1 τ
  where τ = length xs

sortST ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s (STArray s Int α)
sortST μ ν τ
  | τ - ν < 1 = return μ
  | otherwise = do
      ι ← partition μ ν τ
      sortST μ ν (pred ι) `par` sortST μ (succ ι) τ

partition ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s Int
partition μ ν τ = do
  let i = randomPivotIndex
  π ← readArray μ i
  swapArray μ ν i
  ι ← foldM (swaps π) ν [succ ν..τ]
  swapArray μ ν ι
  return ι
  where swaps π α β = do
          φ ← readArray μ β
          if (φ < π)
            then do
              swapArray μ (succ α) β
              return (succ α)
            else
              return α

        randomPivotIndex = unsafePerformIO $ randomRIO (ν, τ)

swapArray ∷ STArray s Int α → Int → Int → ST s ()
swapArray μ α β = do
  γ ← readArray μ α
  δ ← readArray μ β
  writeArray μ α δ
  writeArray μ β γ

{-# LANGUAGE UnicodeSyntax #-}
module QuicksortSupki where

import Control.Monad (foldM)
import Control.Monad.ST (ST)
import Data.Array (elems)
import Data.Array.ST (STArray, newListArray, readArray, runSTArray, writeArray)

sort ∷ Ord α ⇒ [α] → [α]
sort xs = elems $ runSTArray $ do
  μ ← newListArray (1, τ) xs
  sortST μ 1 τ
  where τ = length xs

sortST ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s (STArray s Int α)
sortST μ ν τ
  | τ - ν < 1 = return μ
  | otherwise = do
      ι ← partition μ ν τ
      sortST μ ν (pred ι)
      sortST μ (succ ι) τ

partition ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s Int
partition μ ν τ = do
  π ← readArray μ ν
  ι ← foldM (swaps π) ν [succ ν..τ]
  swapArray μ ν ι
  return ι
  where swaps π α β = do
          φ ← readArray μ β
          if (φ < π)
            then do
              swapArray μ (succ α) β
              return (succ α)
            else
              return α

swapArray ∷ STArray s Int α → Int → Int → ST s ()
swapArray μ α β = do
  γ ← readArray μ α
  δ ← readArray μ β
  writeArray μ α δ
  writeArray μ β γ

---

import QuicksortSupki (sort)

main = print . length . sort $ [10000,9999..1]

And finally

$> ghc -O2 --make exercise02.hs -fforce-recomp 
[1 of 2] Compiling QuicksortSupki   ( QuicksortSupki.hs, QuicksortSupki.o )
[2 of 2] Compiling Main             ( exercise02.hs, exercise02.o )
Linking exercise02 ...

$> time ./exercise02 
10000

real    0m11.155s
user    0m11.010s
sys 0m0.110s

Иди песни пиши, дебил.

…

On 06/19/2012 06:03 PM, Dmitry Malikov wrote: ``` haskell {-# LANGUAGE UnicodeSyntax #-} module QuicksortSupki where import Control.Monad (foldM) import Control.Monad.ST (ST) import Data.Array (elems) import Data.Array.ST (STArray, newListArray, readArray, runSTArray, writeArray) sort ∷ Ord α ⇒ [α] → [α] sort xs = elems $ runSTArray $ do μ ← newListArray (1, τ) xs sortST μ 1 τ where τ = length xs sortST ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s (STArray s Int α) sortST μ ν τ | τ - ν< 1 = return μ | otherwise = do ι ← partition μ ν τ sortST μ ν (pred ι) sortST μ (succ ι) τ partition ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s Int partition μ ν τ = do π ← readArray μ ν ι ← foldM (swaps π) ν [succ ν..τ] swapArray μ ν ι return ι where swaps π α β = do φ ← readArray μ β if (φ< π) then do swapArray μ (succ α) β return (succ α) else return α swapArray ∷ STArray s Int α → Int → Int → ST s () swapArray μ α β = do γ ← readArray μ α δ ← readArray μ β writeArray μ α δ writeArray μ β γ ``` --- ``` haskell import QuicksortSupki (sort) main = print . length . sort $ [10000,9999..1] ``` And finally ``` $> ghc -O2 --make exercise02.hs -fforce-recomp [1 of 2] Compiling QuicksortSupki ( QuicksortSupki.hs, QuicksortSupki.o ) [2 of 2] Compiling Main ( exercise02.hs, exercise02.o ) Linking exercise02 ... $> time ./exercise02 10000 real 0m11.155s user 0m11.010s sys 0m0.110s --- Reply to this email directly or view it on GitHub: https://gist.github.com/2702473 ```