Binary heap (Scheme)

From LiteratePrograms
Jump to: navigation, search

This program is under development.
Please help to debug it. When debugging
is complete, remove the {{develop}} tag.

This is an implementation of a binary min-heap that uses a user-supplied comparison predicate so it can hold different types of elements.

We'll use an array representation of the binary heap; scheme vectors are heterogenous. We also have to store the current heap size and the heap comparison predicate. So our heap data structure will be a three-element vector: a comparison predicate, the array holding the heap's elements and a number representing the heap size. The choice of a vector instead of a fancier record type ensures R5RS standard compliance.

First, some convenient accessor and utility functions for our heap data structure:

(define (heap-size heap)
  (vector-ref heap 2))

(define (heap-vect heap)
  (vector-ref heap 1))

(define (heap-read heap)
  (vector-ref (vector-ref heap 1) 0))

(define (heap-< heap index1 index2)
  (let ((vect (heap-vect heap)))
    ((vector-ref heap 0) (vector-ref vect index1) (vector-ref vect index2))))

(define (heap-swap! heap index1 index2) 
  (let* ((vect (heap-vect heap))
         (val1 (vector-ref vect index1)))
         (begin
           (vector-set! vect index1 (vector-ref vect index2))
           (vector-set! vect index2 val1))))

The heap-< function lets us conveniently compare elements by their index.

Our heap implementation must take care of managing the vector representation of the heap, so we provide a vector-resize function so our heap can grow:

(define (vector-resize vect new-size)
  (define (overwrite-vector alist avector position)
    (if (null? alist) avector
        (begin
          (vector-set! avector position (car alist))
          (overwrite-vector (cdr alist) avector (+ position 1)))))
  (overwrite-vector (vector->list vect) (make-vector new-size) 0))

With the preliminaries out of the way, we can implement the actual heap. Our heap will support two operations: heap insertion and root deletion.

Heap insertion is accomplished by adding the element at the bottom of the heap and moving it up until the heap property is satisfied (that is, until its parent is smaller than itself).

So we need a function that, given a position in the heap, checks to see if the heap property holds for it and its parent. If it doesn't, it swaps the element at this position with its parent, moving it up, and repeats this until the heap property is satisfied.

The heap property is satisfied if:

1) The element is at the root position (has no parent). 2) The element is larger than its parent.

The code IS redundant, but prevents an infinite loop if the predicate is <= instead of <. Suggestions?

(define (heap-move-up heap position)
    (let ((parent (quotient (- position 1) 2)))
      (cond ((or (= position 0) (heap-< heap parent position))  
             'end-move-up)
            ((heap-< heap position parent)
             (begin
               (heap-swap! heap position parent)
               (heap-move-up heap parent)))
            (else 'end-move-up))))

Once we have this function, insertion is easy: we first check to see if the array holding our heap is big enough to accomodate the new element. If it isn't, we resize it to twice its old size (the + 1 copes with with the size=0 initial case).

Then we insert the new element at the last position in the heap, update the heap size, and call the heap-move-up function to restore the heap structure.

(define (heap-insert! heap elem)
  (let ((size (heap-size heap)))
    (begin 
      (if (> (+ size 1) (vector-length (vector-ref heap 1)))
          (vector-set! heap 1 (vector-resize (vector-ref heap 1) (* 2 (+ 1 size)))))
      (vector-set! (vector-ref heap 1) size elem)
      (vector-set! heap 2 (+ size 1))
      (heap-move-up heap size))))

Root deletion is accomplished by deleting the root element, moving the last element in the heap into root position, and then restoring heap structure. So we need a function that, given a position in the heap, restores the heap property by moving the element down until the heap property holds. There are 3 cases:

1) The position being considered is the last position in the heap. In that case, the heap property holds trivially.

2) The position being considered is the last position in the heap but one. In that case, check its single child: if the child is smaller, swap the elements. If not, the heap property holds.

3) The position being considered has two children. If a child is smaller, swap the element with the smallest of its two children. If not, the heap property holds.

(define (heap-move-down heap position)
    (let ((lchild (+ (* 2 position) 1))
          (rchild (+ (* 2 position) 2))
          (size (heap-size heap))
          (swap! (lambda (pos child)
                   (begin
                     (heap-swap! heap pos child)
                     (heap-move-down heap child)))))
      (cond ((> lchild (- size 1))
             'end-move-down)
            ((> rchild (- size 1))
             (if (heap-< heap lchild position)
                 (swap! position lchild)
                 'end-move-down))
             (else
              (let ((smallest-child (if (heap-< heap lchild rchild) lchild rchild)))
                (if (heap-< heap smallest-child position)
                    (swap! position smallest-child)
                    'end-move-down))))))

Now we have heap-move-down, root deletion is easy. We simply

1) remember the element at the root,

2) swap the root element and the last element in the heap

3) decrease the heap size by 1

4) restore heap structure using heap-move-down

5) return the element that was the root before deletion.

(define (heap-extract-root! heap)
  (let ((size (heap-size heap)) (old-root (heap-read heap)))
    (begin
      (heap-swap! heap 0 (- size 1))
      (vector-set! heap 2 (- size 1))
      (heap-move-down heap 0)
      old-root)))

The important binary heap logic is done. Now, we need a function that makes a heap structure given a list of elements and a comparison predicate:

(define (make-heap elem-list lt-predicate)
  (define (heap-fill heap alist)
    (if (null? alist) heap
        (begin
          (heap-insert! heap (car alist))
          (heap-fill heap (cdr alist)))))
  (let ((new-heap (make-vector 3)))
    (begin
      (vector-set! new-heap 0 lt-predicate)
      (vector-set! new-heap 1 (make-vector 0))
      (vector-set! new-heap 2 0)
      (heap-fill new-heap elem-list))))

The heap implementation is complete.

Now, let's implement heapsort to test our heap implementation:

(define (heap-sort alist apred)
  (define (extract-until aheap)
    (if (= 0 (heap-size aheap)) '()
        (cons (heap-extract-root! aheap) (extract-until aheap))))
  (extract-until (make-heap alist apred)))

And let's test it in the repl:

> (heap-sort '(3 5 7 0 6 5 34 3 6 9 67 5 4 4 3 1 2 3) <)
(0 1 2 3 3 3 3 4 4 5 5 5 6 6 7 9 34 67)
Download code
hijacker
hijacker
hijacker
hijacker