Programming Praxis

We begin with some simple utility functions:

(define node vector) ; rank item kids
(define (rank n) (vector-ref n 0))
(define (item n) (vector-ref n 1))
(define (kids n) (vector-ref n 2))
(define empty (list))
(define empty? null?)

Linking assumes that two heaps have the same rank; we can enforce that condition because link is only called internally, never by client code. The lesser element becomes the root of the new heap:

(define (link lt? h1 h2)
  (if (not (lt? (item h1) (item h2)))
      (node (add1 (rank h1))
            (item h2)
            (cons h1 (kids h2)))
      (node (add1 (rank h1))
            (item h1)
            (cons h2 (kids h1)))))

The insert function builds a singleton heap, then calls an auxiliary function to perform the insertion. Insert-tree iterates through the list of trees, linking as it goes, until it finds a “hole” in the ranks. This process propagates through the list in a similar way to the “carry” in binary addition, an analogy that Okasaki exploits fruitfully in his book:

(define (insert-tree lt? t ts)
  (if (null? ts) (list t)
    (if (< (rank t) (rank (car ts))) (cons t ts)
      (insert-tree lt? (link lt? t (car ts)) (cdr ts)))))

(define (insert lt? x ts)
  (insert-tree lt? (node 0 x (list)) ts))

Merge recurs through the trees, calling insert-tree when it finds two of equal rank:

(define (merge lt? ts1 ts2)
  (cond ((empty? ts1) ts2)
        ((empty? ts2) ts1)
        ((< (rank (car ts1)) (rank (car ts2)))
          (cons (car ts1) (merge lt? (cdr ts1) ts2)))
        ((< (rank (car ts2)) (rank (car ts1)))
          (cons (car ts2) (merge lt? ts1 (cdr ts2))))
        (else (insert-tree lt? (link lt? (car ts1) (car ts2))
                               (merge lt? (cdr ts1) (cdr ts2))))))

Remove-min-tree cdrs through the list of trees until it finds the minimum, which is simple since the trees are in order, returning multiple values when it finds the minimum:

(define (remove-min-tree lt? ts)
  (cond ((null? ts) (error 'remove-min-tree "empty"))
        ((null? (cdr ts)) (values (car ts) (list)))
        (else (call-with-values
                (lambda () (remove-min-tree lt? (cdr ts)))
                (lambda (t-prime ts-prime)
                  (if (not (lt? (item (car ts)) (item t-prime)))
                      (values t-prime (cons (car ts) ts-prime))
                      (values t-prime ts-prime)))))))

Find-min is simple. Delete-min calls merge to do the hard work; note the reversal, because the list of trees is kept in decreasing order:

(define (find-min lt? ts)
  (call-with-values
    (lambda () (remove-min-tree lt? ts))
    (lambda (t ts) (item t))))

(define (delete-min lt? ts)
  (call-with-values
    (lambda () (remove-min-tree lt? ts))
    (lambda (h ts) (merge lt? (reverse (kids h)) ts))))

As an example of the library, we write functions from-list, to-list, and sort:

(define (from-list lt? xs)
  (let ((h empty))
    (do ((xs xs (cdr xs))) ((null? xs) h)
      (set! h (insert lt? (car xs) h)))))

(define (to-list lt? ts)
  (let loop ((ts ts) (xs (list)))
    (if (empty? ts) (reverse xs)
      (loop (delete-min lt? ts)
            (cons (find-min lt? ts) xs)))))

(define (sort lt? xs)
  (to-list lt? (from-list lt? xs)))

And here it is at work:

> (sort '(3 7 6 1 5 2 4))
(1 2 3 4 5 6 7)

When you implement the library, you will find that it’s not particularly fast; in particular, you would prefer an O(1) function for find-min, which is after all the reason you want a heap library. Okasaki goes on to describe several improvements to these binomial heaps; perhaps we will see them in future exercises.

You can run the program at http://programmingpraxis.codepad.org/IgEKV5iJ.

Pages: 1 2