OberonCore

import Control.Monad (when)
import Control.Monad.ST
import Data.Array.ST
import Data.Array.IArray
import Data.Array.MArray
import System.IO.Unsafe
 
qsort :: (IArray a e,Ix i,Enum i,Ord e) => a i e -> a i e
qsort arr = processArray quickSort arr
 
processArray
    :: (IArray a e,IArray b e,Ix i)
    => (forall s. (STArray s) i e -> ST s ()) -> a i e -> b i e
processArray f (arr :: a i e) = runST (do
                arr' <- thaw arr :: ST s (STArray s i e)
                f arr'
                unsafeFreeze arr')
 
quickSort :: (MArray a e m, Ix i, Enum i, Ord e) => a i e -> m ()
quickSort arr = case bounds arr of (lo,hi) -> qsort lo hi
    where qsort lo hi | lo >= hi  = return ()
                      | otherwise = do
              p <- readArray arr hi
              l <- mainLoop p lo hi
              swap l hi
              qsort lo (pred l)
              qsort (succ l) hi
           
          mainLoop p l h | l >= h    = return l
                         | otherwise = do
              l' <- doTil (\l' b -> l' < h && b <= p) succ l                 
              h' <- doTil (\h' b -> h' > l' && b >= p) pred h
              when (l' < h') $
                  swap l' h'
              mainLoop p l' h'
         
          doTil pred op ix = do
              b <- readArray arr ix
              if pred ix b then doTil pred op (op ix) else return ix
 
          swap xi yi = do
              x <- readArray arr xi
              readArray arr yi >>= writeArray arr xi
              writeArray arr yi x

void qsort(int a[], int lo, int hi) {
{
  int h, l, p, t;

  if (lo < hi) {
    l = lo;
    h = hi;
    p = a[hi];

    do {
      while ((l < h) && (a[l] <= p))
          l = l+1;
      while ((h > l) && (a[h] >= p))
          h = h-1;
      if (l < h) {
          t = a[l];
          a[l] = a[h];
          a[h] = t;
      }
    } while (l < h);

    t = a[l];
    a[l] = a[hi];
    a[hi] = t;

    qsort( a, lo, l-1 );
    qsort( a, l+1, hi );
  }
}