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 μ β γ

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

…

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