Welcome to the CHICKEN Scheme pasting service

Example:
-------
(include "binary_heap2")
(import (prefix binary-heap2 heap:))

(let [(h (heap:make-binary-heap initial-size: 1))]
  (print h)
  (heap:insert h 10 'foo)
  (heap:insert h 100 'bar)
  (print h)
  (print (heap:extract-max h))
  (print (heap:heap-max h))
  (print h))

Output:
------
#,(bin-heap size: 0 capacity: 1)
#,(bin-heap size: 2 capacity: 2)
(100 . bar)
(10 . foo)
#,(bin-heap size: 1 capacity: 2)

(let [(h (heap:make-binary-heap initial-size: 1 more?-and-min-key: (list < +inf)))]
  (print h)
  (heap:insert h 10 'foo)
  (heap:insert h 100 'bar)
  (print h)
  (print (heap:extract-max h))
  (print (heap:heap-max h))
  (print h))

Output:
------
#,(bin-heap size: 1 capacity: 2)
#,(bin-heap size: 0 capacity: 1)
#,(bin-heap size: 2 capacity: 2)
(10 . foo)
(100 . bar)
#,(bin-heap size: 1 capacity: 2)

(module
 binary-heap2 ;; There already exists an egg with the name binary-heap
 (make-binary-heap
  insert
  heap-size
  heap-max
  extract-max)
 
 (import chicken scheme)
 (import extras)

 ;; The heap is stored in a vector where the nodes are
 ;; cons cells. The car is the key of the node and the value
 ;; is in cdr.
 ;; The implementation follows CLRS pretty closely.
 
 (define-record bin-heap
   size
   array
   more?
   min-key)
 
 (define-record-printer (bin-heap x out)
   (fprintf out "#,(bin-heap size: ~S capacity: ~S)"
	    (bin-heap-size x)
	    (vector-length (bin-heap-array x))))

 (define *growth-factor* 2)

 (define-syntax get-key
   (lambda (e r c)
     `(car (vector-ref ,(cadr e) ,(caddr e)))))

 (define-syntax set-key
   (lambda (e r c)
     `(set-car! (vector-ref ,(cadr e) ,(caddr e)) ,(cadddr e))))

 (define-syntax get-val
   (lambda (e r c)
     `(cdr (vector-ref ,(cadr e) ,(caddr e)))))

 (define-syntax set-val
   (lambda (e r c)
     `(set-cdr! (vector-ref ,(cadr e) ,(caddr e)) ,(cadddr e))))

 (define-syntax parent
   (lambda (e r c)
     `(,(r 'arithmetic-shift) ,(cadr e) -1)))

 (define-syntax left
   (lambda (e r c)
     `(,(r 'arithmetic-shift) ,(cadr e) 1)))

 (define-syntax right
   (lambda (e r c)
     `(,(r 'add1) (,(r 'arithmetic-shift) ,(cadr e) 1))))

 (define-syntax swap
   (lambda (e r c)
     (let [(array (cadr e))
	   (i (caddr e))
	   (j (cadddr e))]
       `(let [(x (vector-ref ,array ,i))]
	  (vector-set! ,array
		       ,i (vector-ref ,array ,j))
	  (vector-set! ,array
		       ,j x)))))

 (define (init-array array start end)
   (do [(i start (add1 i))]
	((> i end) array)
      (vector-set! array i (cons #f #f))))

 (define (make-binary-heap #!key (initial-size 32)
			   (more?-and-min-key (list > -inf))) 
   (make-bin-heap 0
		  (init-array (make-vector initial-size) 0 (sub1 initial-size))
		  (car more?-and-min-key)
		  (cadr more?-and-min-key)))

 (define (max-heapify array size i more?)
   (let [(l (left i))
	 (r (right i))
	 (largest i)]
     (if (and (> size l)
	      (more? (get-key array l)
		     (get-key array largest)))
	 (set! largest l))
     (if (and (> size r)
	      (more? (get-key array r)
		     (get-key array largest)))
	 (set! largest r))
     (if (not (= i largest))
	 (begin
	   (swap array largest i)
	   (max-heapify array size largest more?)))))

 (define (heap-size heap)
   (bin-heap-size heap))

 (define (heap-max heap)
   (vector-ref (bin-heap-array heap) 0))

 (define (extract-max heap)
   (let [(x (vector-ref (bin-heap-array heap) 0))]
     (bin-heap-size-set! heap (sub1 (bin-heap-size heap)))
     (swap (bin-heap-array heap) 0 (bin-heap-size heap))
     (max-heapify (bin-heap-array heap) (bin-heap-size heap) 0 (bin-heap-more? heap))
     x))

 
 (define (heap-increase-key array i key more?)
   (if (more? (get-key array i) key)
       (error heap-increase-key "New key was smaller than the old one."))
   (set-key array i key)
   (let loop []
     (if (and (< 0 i)
	      (more? (get-key array i)
		     (get-key array (parent i))))
	 (begin
	   (swap array i (parent i))
	   (set! i (parent i))
	   (loop)))))

 (define (grow-heap heap)
   (let [(last-i (vector-length (bin-heap-array heap)))
	 (old-v (bin-heap-array heap))
	 (new-v (make-vector (* *growth-factor*
				 (vector-length (bin-heap-array heap)))))]
     (init-array new-v (vector-length old-v) (sub1 (vector-length new-v)))
     (do [(i 0 (add1 i))]
	 ((= i last-i)
	  (bin-heap-array-set! heap new-v))
       (vector-set! new-v i (vector-ref old-v i)))))

 (define (insert heap key val)
   (if (> (vector-length (bin-heap-array heap))
	  (bin-heap-size heap))
       (begin
	 (set-key (bin-heap-array heap) (bin-heap-size heap) (bin-heap-min-key heap))
	 (set-val (bin-heap-array heap) (bin-heap-size heap) val)
	 (heap-increase-key (bin-heap-array heap)
			    (bin-heap-size heap)
			    key
			    (bin-heap-more? heap))
	 (bin-heap-size-set! heap (add1 (bin-heap-size heap))))
       (begin
	 (grow-heap heap)
	 (insert heap key val)))))