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

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^{20} = 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.