(module pairing-heap mzscheme
(require (lib "unit.ss")
(lib "67.ss" "srfi")
(lib "42.ss" "srfi")
(prefix l: (lib "list.ss" "srfi" "1")))
(provide pairing-heap^ compare^ pairing-heap@)
(define-signature pairing-heap^
(min insert remove-min merge empty? heap heap? fold elements sort))
(define-signature compare^
(compare))
(define pairing-heap@
(unit (import compare^)
(export (rename pairing-heap^ (my-heap heap) (my-heap? heap?)))
(define-struct empty-heap
() #f)
(define-struct heap
(min sub-heaps removed-min-heap) #f)
(define (make-heap* min sub-heaps)
(make-heap min sub-heaps (delay (l:fold merge (my-heap) (merge-pairs sub-heaps)))))
(define empty? empty-heap?)
(define (my-heap? obj)
(or (empty-heap? obj)
(heap? obj)))
(define min heap-min)
(define merge
(case-lambda
((h) h)
((h1 h2)
(cond
((empty? h1) h2)
((empty? h2) h1)
(else
(let ((m1 (min h1))
(m2 (min h2)))
(if<=? (compare m1 m2)
(make-heap* m1 (cons h2 (heap-sub-heaps h1)))
(make-heap* m2 (cons h1 (heap-sub-heaps h2))))))))
((h1 h2 . hs)
(apply merge (merge h1 h2) hs))))
(define my-heap
(case-lambda
(() (make-empty-heap))
((obj) (make-heap* obj '()))
(objs
(apply merge (map my-heap objs)))))
(define insert
(case-lambda
((obj h) (merge (make-heap* obj '()) h))
(objs
(let loop ((rem-objs-and-heap (cdr objs))
(h (make-heap (car objs) '())))
(if (null? (cdr rem-objs-and-heap))
(merge h (car rem-objs-and-heap))
(loop (cdr rem-objs-and-heap) (merge (my-heap (car rem-objs-and-heap)) h)))))))
(define (merge-pairs list-o-heaps)
(cond
((null? list-o-heaps) (list (my-heap)))
((null? (cdr list-o-heaps)) (list (car list-o-heaps)))
(else
(cons (merge (car list-o-heaps) (cadr list-o-heaps))
(merge-pairs (cddr list-o-heaps))))))
(define (remove-min h)
(force (heap-removed-min-heap h)))
(define (fold kons knil h)
(if (empty? h)
knil
(l:fold (lambda (sub-h accu)
(fold kons accu sub-h))
(kons (min h) knil)
(heap-sub-heaps h))))
(define (elements h)
(fold cons '() h))
(define (sort list-or-vector)
(if (vector? list-or-vector)
(sort-vector list-or-vector)
(sort-list list-or-vector)))
(define (sort-vector vec)
(let* ((n (vector-length vec))
(result (make-vector n)))
(let loop ((i 0) (h (fold-ec (my-heap) (:vector elt vec) elt insert)))
(if (>= i n)
result
(begin
(vector-set! result i (min h))
(loop (+ i 1) (remove-min h)))))))
(define (sort-list lis)
(let loop ((sorted-elts '())
(h (l:fold insert (my-heap) lis)))
(if (empty? h)
(reverse sorted-elts)
(loop (cons (min h) sorted-elts)
(remove-min h))))))))