Engineering A Sort Function

February 23, 2010

Scheme doesn’t provide pointers, so we use indexes into the vector. Swap! is a macro that causes its code to be inlined, in the spirit of the Bentley/McIlroy original. Where the original had the pivot selection in-line, we write pv-init and mid3 as functions to simplify the main body of the code. We store the pivot element in a[0], which is one of the options provided by the appendix. We perform an infinite loop with let loop (), and break out of the loop with an unless that calls (loop) but exits the loop if its condition is not satisfied. Otherwise, we have been very faithful to the Bentley/McIlroy original. Here is our solution:

(define (vector-sort! vec comp)
  (define len (vector-length vec))
  (define-syntax v (syntax-rules () ((v k) (vector-ref vec k))))
  (define-syntax v! (syntax-rules () ((v! k x) (vector-set! vec k x))))
  (define-syntax cmp (syntax-rules () ((cmp a b) (comp (v a) (v b)))))
  (define-syntax lt? (syntax-rules () ((lt? a b) (negative? (cmp a b)))))
  (define-syntax swap! (syntax-rules () ((swap! a b)
    (let ((t (v a))) (v! a (v b)) (v! b t)))))
  (define (vecswap! a b s)
    (do ((a a (+ a 1)) (b b (+ b 1)) (s s (- s 1))) ((zero? s))
      (swap! a b)))

  (define (med3 a b c)
    (if (lt? b c)
        (if (lt? b a) (if (lt? c a) c a) b)
        (if (lt? c a) (if (lt? b a) b a) c)))
  (define (pv-init a n)
    (let ((pm (+ a (quotient n 2))))
      (when (> n 7)
        (let ((pl a) (pn (+ a n -1)))
          (when (> n 40)
            (let ((s (quotient n 8)))
              (set! pl (med3 pl (+ pl s) (+ pl s s)))
              (set! pm (med3 (- pm s) pm (+ pm s)))
              (set! pn (med3 (- pn s s) (- pn s) pn))))
          (set! pm (med3 pl pm pn))))

  (let qsort ((a 0) (n len))
    (if (< n 7)
        (do ((pm (+ a 1) (+ pm 1))) ((not (< pm (+ a n))))
          (do ((pl pm (- pl 1)))
              ((not (and (> pl a) (> (cmp (- pl 1) pl) 0))))
            (swap! pl (- pl 1))))
        (let ((pv (pv-init a n)) (r #f)
              (pa a) (pb a) (pc (+ a n -1)) (pd (+ a n -1)))
          (swap! a pv) (set! pv a)
          (let loop ()
            (while (and (<= pb pc) (<= (assign! r (cmp pb pv)) 0))
              (when (= r 0) (swap! pa pb) (set! pa (+ pa 1)))
              (set! pb (+ pb 1)))
            (while (and (>= pc pb) (>= (assign! r (cmp pc pv)) 0))
              (when (= r 0) (swap! pc pd) (set! pd (- pd 1)))
              (set! pc (- pc 1)))
            (unless (> pb pc)
              (swap! pb pc) (set! pb (+ pb 1)) (set! pc (- pc 1)) (loop)))
          (let ((pn (+ a n)))
            (let ((s (min (- pa a) (- pb pa)))) (vecswap! a (- pb s) s))
            (let ((s (min (- pd pc) (- pn pd 1)))) (vecswap! pb (- pn s) s))
            (let ((s (- pb pa))) (when (> s 1) (qsort a s)))
            (let ((s (- pd pc))) (when (> s 1) (qsort (- pn s) s))))))))

While, when and unless are from the Standard Prelude. Assign! mimics the C in-line assignment syntax; it is a macro because the variable being assigned cannot be evaluated at the time it is called:

(define-syntax assign!
  (syntax-rules ()
    ((assign! var expr)
      (begin (set! var expr) var))))

Testing is done with vectors of integers:

(define (make-rand-vec n)
  (let ((v (make-vector n)))
    (do ((i 0 (+ i 1))) ((= i n) v)
      (vector-set! v i (randint n)))))

(define (check-sort? v)
  (let ((n (vector-length v)))
    (let loop ((i 1))
      (cond ((= i n) #t)
            ((< (vector-ref v i)
                (vector-ref v (- i 1))) #f)
            (else (loop (+ i 1)))))))

Here’s an example:

> (define x (make-rand-vec 1024))
> (vector-sort! x (lambda (a b) (- a b)))
> (check-sort? x)

As a test, we instrumented the code by adding a counter to the comparison function. Averaged over ten runs, sorting a vector with 220 = 1048576 random integers uses less than 1.1 n log n= 23068672 comparisons per run, as predicted by Bentley and McIlroy.

You can run the program at We’ll add vector-sort! to the Standard Prelude.

Pages: 1 2

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: