Quicksort in Continuation Passing Style

Quicksort is ugly. I hate quicksort. Still everyone praises quicksort...
... and Hoare did worse things. Such as Hoare logic. I had to manually verify some short programs using Hoare logic and sometimes I still wake up screaming at night after dreaming pages of Hoare triples.

Well, this is a problem of mine. Back to quicksort... among the elementary sorting algorithms it is one of the more difficult to understand. But it is rather efficient despite its worse case N^2 running time. Moreover, quicksort can be implemented in constant space (well, almost... you still have double recursive calls which means log n, if you consider the stack).

That is why (the idea that quicksort modifies an array in place) some believe functional implementations of quicksort are not quicksort. And I'm not going to argue. I don't care, in fact. Here my concern are the double recursive calls. Normally you could not tail call optimize such a thing (pseudo code from wikipedia):

procedure quicksort(array, left, right)
     if right > left
         select a pivot index //(e.g. pivotIndex := left+(right-left)/2)
         pivotNewIndex := partition(array, left, right, pivotIndex)
         quicksort(array, left, pivotNewIndex - 1)
         quicksort(array, pivotNewIndex + 1, right)

Luckily for us, we can use continuation passing style to trick this into tail call optimizable. Code in continuation passing style is always tail recursive.

Append:

(define cp-append 
  (lambda (lst1 lst2 k)
    (cond ((null? lst1) (k lst2))
          (else (cp-append (cdr lst1) lst2 
                           (lambda (rest)
                             (k (cons (car lst1) rest))))))))

The continuation function for the partition function shall take two parameters.
The first one "accumulates" less than items, the second one greater than items.

(define cp-partition
  (lambda (lst p? k)
    (letrec ([cpp 
              (lambda (lst k)
                (cond
                  ((null? lst) (k '() '()))
                  ((p? (car lst)) 
                   (cpp (cdr lst)
                        (lambda (p-true p-false)
                          (k (cons (car lst) p-true)
                             p-false))))
                  (else
                   (cpp (cdr lst)
                        (lambda (p-true p-false)
                          (k p-true
                             (cons (car lst) p-false)))))))])
      (cpp lst k))))

And eventually, his majesty the quicksort:

(define quicksort
  (lambda  (lst less?)
    (letrec 
        ([qs
          (lambda (lst k)
            (cond
              ((null? lst) (k '()))
              (else
               (let ([pivot (car lst)]
                     [rest (cdr lst)])
                 (cp-partition 
                  rest
                  (lambda (x) (less? x pivot))
                  (lambda (less-than greater-than)
                    (qs greater-than
                        (lambda (sorted-gt)
                          (qs less-than
                              (lambda (sorted-lt)
                                (cp-append
                                 sorted-lt
                                 (cons pivot sorted-gt) k)))))
      (qs lst (lambda (v) v)))))

Although the testing based on random data is a Very Bad Idea, this was the easiest way to rough up my code.

(define (random-list max length)
  (letrec ([rl (lambda (length)
                 (cond ((= length 0) '())
                       (else (cons (random max)
                                   (rl (- length 1))))))])
    (rl length)))

(define (test-quicksort)
  (let ([tests-per-length 50]
        [random-top-integer 1000]
        [list-lengths '(0 1 10 11 25 40 64 128)])
    (for-each 
     (lambda (length)
       (do ([i tests-per-length (- i 1)])
         ((zero? i))
         (let* ([the-list (random-list random-top-integer length)]
                [lt-sorted-list (sort the-list <)]
                [lt-qsorted-list (quicksort the-list <)]
                [gt-sorted-list (sort the-list >)]
                [gt-qsorted-list (quicksort the-list >)])
           (when (not (equal? lt-sorted-list lt-qsorted-list))
             (printf "~a[<]:~n~a~n~a~n~n" the-list
                     lt-sorted-list lt-qsorted-list))
           (when (not (equal? gt-sorted-list gt-qsorted-list))
             (printf "~a[>]:~n~a~n~a~n~n" the-list
                     gt-sorted-list gt-qsorted-list)))))
     list-lengths)))

I tried to avoid racket specific constructs, but I'm not sure that one or two slipped in the testing code.

BTW, here a version with named-let:

(define quicksort
  (lambda  (lst less?) 
    (let qs ([lst lst] [k (lambda (v) v)])
      (cond 
        ((null? lst) (k '()))
        (else
         (let ([pivot (car lst)]
               [rest (cdr lst)])
           (cp-partition 
            rest 
            (lambda (x) (less? x pivot))
            (lambda (less-than greater-than)
              (qs greater-than
                  (lambda (sorted-gt)
                    (qs less-than
                        (lambda (sorted-lt)
                          (cp-append 
                           sorted-lt
                           (cons pivot sorted-gt) k)))))))))))))

Seems I already wrote on Quicksort...