s c h e m a t i c s : c o o k b o o k

(module heap mzscheme
  (provide make-empty empty? find-min insert merge delete-min)

  ; for first, second and rest
  (require (all-except (lib "list.ss" "mzlib") empty?))
  
  ; A PAIRING HEAP is either
  ;    (make-heap <= '() )
  ; or
  ;    (make-heap <= (make-node elm heaps))
  ; where <= is an order on the elements, elm is an element,
  ; and heaps is a list of heap-ordered trees.
  
  (define-struct heap (<= node-or-empty) (make-inspector))
  (define-struct node (elm heaps) (make-inspector))
  
  ; heaps : heap -> (list heap)
  ;  given a non-empty heap H return the list of subheaps
  ;  (for internal use)
  (define (heaps H)
    (node-heaps (heap-node-or-empty H)))
  
  ; make-empty : (element element -> boolean) -> heap
  ;  return an empty heap with <= as element order
  (define (make-empty <=)
    (make-heap <= '()))
  
  ; empty? : heap -> boolean
  ;  is the heap H empty?
  (define (empty? H)
    (and (heap? H)
         (null? (heap-node-or-empty H))))
  
  ; find-min : heap -> element
  ;  return the smallest element of the heap H with relation to
  ;  the heap order <=
  (define (find-min H) 
    (when (empty? H)
      (error "find-min: An empty heap has no root; given " H))
    (node-elm (heap-node-or-empty H)))
    
  ; merge : heap heap -> heap
  (define (merge H1 H2)
    ; return a heap holding the elements of both H1 and H2
    (let ([<= (heap-<= h1)])
      (cond
        [(empty? H1)  H2]
        [(empty? H2)  H1]
        [else         (let ([x (find-min H1)]
                            [y (find-min H2)])
                        (if (<= x y) 
                            (make-heap <= (make-node x (cons H2 (heaps H1))))
                            (make-heap <= (make-node y (cons H1 (heaps H2))))))])))
  
  ; insert : element heap -> heap
  ;  return a new heap holding the elements of the heap H and the element x
  (define (insert H x)
    (merge (make-heap (heap-<= H) (make-node x '()))
           H))
  
  ; merge-heap-pairs : (list heap) -> heap
  ;  return a new heap holding all the elements of the heaps in the list
  (define (merge-heap-pairs <= hs)
    (cond
      [(null? hs)        (make-empty <=)]
      [(null? (rest hs)) (first hs)]
      [else              (merge (merge (first hs) (second hs))
                                (merge-heap-pairs <= (rest (rest hs))))]))
  
  ; delete-min : heap -> heap
  ;  return a new heap holding all the elements of H but the smallest
  (define (delete-min H)
    (make-heap (heap-<= H)
               (heap-node-or-empty (merge-heap-pairs (heap-<= H) (heaps H))))))

(require heap)

(print-struct #t)
(define H (make-empty string<=?))
(insert H "foo")
(insert (insert H "foo") "bar")
(insert (insert (insert H "foo") "bar") "baz")
(insert (insert (insert (insert H "foo") "bar") "baz") "qux")
(find-min (insert (insert (insert (insert H "foo") "bar") "baz") "qux"))
(find-min (delete-min (insert (insert (insert (insert H "foo") "bar") "baz") "qux")))
(find-min (delete-min (delete-min (insert (insert (insert (insert H "foo") "bar") "baz") "qux"))))
(find-min (delete-min (delete-min (delete-min (insert (insert (insert (insert H "foo") "bar") "baz") "qux")))))

(define (heap-sort <= xs)
  (do ([H  (make-empty <=) (insert H (car xs))]
       [xs xs              (cdr xs)])
    [(null? xs) 
     (do ([H  H   (delete-min H)]
          [xs '() (cons (find-min H) xs)])
       [(empty? H) (reverse xs)])]))

(heap-sort string<=? (list "foo" "bar" "baz" "qux"))