#|  pairing-heap.ss: Pairing heap unit.
    Copyright (C) Will M. Farr <farr@mit.edu>

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Lesser General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU Lesser General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
|#

(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?)))
          
          ;; A heap is
          ;;  | (make-empty-heap)      
          ;;  | (make-heap min (list sub-heap ...) delayed-remove-min-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))))))))