Programming Praxis

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))))
      pm))

  (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)
#t

As a test, we instrumented the code by adding a counter to the comparison function. Averaged over ten runs, sorting a vector with 2²⁰ = 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 http://programmingpraxis.codepad.org/WrCRgnp4. We’ll add vector-sort! to the Standard Prelude.

Pages: 1 2