source: project/pairing-heap/trunk/pairing-heap.scm @ 5784

Last change on this file since 5784 was 5784, checked in by wmfarr, 13 years ago

Importing pairing-heap egg.

File size: 7.8 KB
Line 
1#| pairing-heap.scm
2
3Copyright 2007 Will M. Farr <farr@mit.edu>.
4
5Provided under a BSD license:
6
7Redistribution and use in source and binary forms, with or without
8modification, are permitted provided that the following conditions are
9met:
10
111. Redistributions of source code must retain the above copyright
12notice, this list of conditions and the following disclaimer.
13
142. Redistributions in binary form must reproduce the above copyright
15notice, this list of conditions and the following disclaimer in the
16documentation and/or other materials provided with the distribution.
17
183. The name of the author may not be used to endorse or promote
19products derived from this software without specific prior written
20permission.
21
22THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
23IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
24WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
25DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
26INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
27(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
28SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
30STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
31IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32POSSIBILITY OF SUCH DAMAGE. 
33|# 
34
35(declare 
36 (inline)
37 (lambda-lift)
38 (usual-integrations)
39 (export pairing-heap?
40         pairing-heap-empty
41         pairing-heap-empty?
42         pairing-heap-min 
43         pairing-heap-merge
44         pairing-heap-insert
45         pairing-heap-remove-min
46         pairing-heap-fold
47         pairing-heap-sort))
48
49(use srfi-1)
50
51;; Each pairing heap stores a suspension (i.e. (delay ...)) of its own
52;; remove-min.  This is necessary because (pairing-heap-remove-min h)
53;; has amortized bounds: on average it takes O(log(n)) time, but in
54;; rare cases it may take O(n) time.  Because heaps are persistent,
55;; the (pairing-heap-remove-min operation may be called multiple times
56;; on *the same heap*.  Therefore, we must ensure that the result is
57;; memoized, and subsequent calls take O(1) time to avoid repeatedly
58;; doing O(n) work.
59(define-record %ph compare elt remove-min-heap)
60(define-record %ph-elt min sub-heaps)
61
62(define *empty-elt* (gensym 'empty-elt))
63
64(define pairing-heap? %ph?)
65
66(define (pairing-heap-empty compare)
67  (make-%ph compare *empty-elt* (delay (error 'pairing-heap-remove-min
68                                              "cannot remove min from empty heap"))))
69
70(define (pairing-heap-empty? h)
71  (eq? *empty-elt* (%ph-elt h)))
72
73(define (pairing-heap-min h)
74  (%ph-elt-min (%ph-elt h)))
75
76(define (<? compare obj1 obj2)
77  (fx< (compare obj1 obj2) 0))
78
79(define (sub-heaps h)
80  (%ph-elt-sub-heaps (%ph-elt h)))
81
82(define (pairing-heap-merge h1 h2)
83  (cond
84   ((pairing-heap-empty? h2) h1)
85   ((pairing-heap-empty? h1) h2)
86   (else
87    (let ((compare (%ph-compare h1))
88          (m1 (pairing-heap-min h1))
89          (m2 (pairing-heap-min h2)))
90      (if (<? compare m1 m2)
91          (let ((h (make-%ph compare
92                             (make-%ph-elt m1 (cons h2 (sub-heaps h1)))
93                             #f)))
94            (%ph-remove-min-heap-set! h (delay (%remove-min h)))
95            h)
96          (let ((h (make-%ph compare
97                             (make-%ph-elt m2 (cons h1 (sub-heaps h2)))
98                             #f)))
99            (%ph-remove-min-heap-set! h (delay (%remove-min h)))
100            h))))))
101
102(define (pairing-heap-insert elt ph)
103  (let ((compare (%ph-compare ph)))
104    (pairing-heap-merge
105     (make-%ph compare
106               (make-%ph-elt elt '())
107               (delay (pairing-heap-empty compare)))
108     ph)))
109
110;; %remove-min does the actual work (pairing-heap-remove-min only
111;; forces a suspension of %remove-min).  We first merge adjascent
112;; pairs of sub-heaps, and then merge the entire list of merged-pairs
113;; into a single heap.
114(define (%remove-min h)
115  (let ((merged-pairs
116         (let pair-loop ((hs (sub-heaps h))
117                         (merged-hs '()))
118           (cond
119            ((null? hs) merged-hs)
120            ((null? (cdr hs)) (cons (car hs) merged-hs))
121            (else
122             (pair-loop
123              (cddr hs)
124              (cons (pairing-heap-merge (car hs) (cadr hs))
125                    merged-hs)))))))
126    (fold pairing-heap-merge (pairing-heap-empty (%ph-compare h)) merged-pairs)))
127
128;; Just force (%remove-min h).
129(define (pairing-heap-remove-min h)
130  (force (%ph-remove-min-heap h)))
131
132(define (pairing-heap-fold kons knil h)
133  (if (pairing-heap-empty? h)
134      knil
135      (fold (lambda (sub-heap acc)
136              (pairing-heap-fold kons acc sub-heap))
137            (kons (%ph-elt-min (%ph-elt h)) knil)
138            (sub-heaps h))))
139
140(define (pairing-heap-sort compare list-or-vector)
141  (if (list? list-or-vector)
142      (sort-list compare list-or-vector)
143      (sort-vector compare list-or-vector)))
144
145(define (sort-list compare list)
146  (let ((rev-compare (lambda (obj1 obj2) (fx* -1 (compare obj1 obj2)))))
147    (let ((h (fold pairing-heap-insert (pairing-heap-empty rev-compare) list)))
148      (let loop ((sorted-elts '())
149                 (h h))
150        (if (pairing-heap-empty? h)
151            sorted-elts
152            (loop (cons (pairing-heap-min h) sorted-elts)
153                  (pairing-heap-remove-min h)))))))
154
155(define (sort-vector compare vec)
156  (let* ((n (vector-length vec))
157         (h (let h-loop ((h (pairing-heap-empty compare))
158                         (i 0))
159              (if (fx>= i n)
160                  h
161                  (h-loop (pairing-heap-insert (vector-ref vec i) h)
162                          (fx+ i 1))))))
163    (let ((result (make-vector n)))
164      (let result-loop ((i 0)
165                        (h h))
166        (if (fx>= i n)
167            result
168            (begin
169              (vector-set! result i (pairing-heap-min h))
170              (result-loop (fx+ i 1) (pairing-heap-remove-min h))))))))
171
172#|
173Tests:
174
175(define my-< (lambda (n1 n2)
176               (cond
177                ((fx< n1 n2) -1)
178                ((fx= n1 n2) 0)
179                (else 1))))
180
181(define my-> (lambda (n1 n2) (fx* -1 (my-< n1 n2))))
182
183(pairing-heap? (fold pairing-heap-insert (pairing-heap-empty my-<) '(1 2 3 4)))
184
185(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(1 2 3 4))))
186  (lset= =
187         '(1 2 3 4)
188         (pairing-heap-fold cons '() h)))
189
190(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(1 2 3 4))))
191  (= (pairing-heap-min h) 1))
192
193(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(4 3 2 1))))
194  (and (= (pairing-heap-min h) 1)
195       (= (pairing-heap-min
196           (pairing-heap-remove-min h))
197          2)))
198
199(let ((heap-sort
200       (lambda (list)
201         (let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) list)))
202           (let loop ((result '()) (h h))
203             (if (pairing-heap-empty? h)
204                 (reverse result)
205                 (loop (cons (pairing-heap-min h) result)
206                       (pairing-heap-remove-min h))))))))
207  (apply < (heap-sort '(10 9 8 5 7 6 4 2 1 3))))
208
209(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(10 9 8 5 7 6 4 2 1 3))))
210  (eq? (pairing-heap-remove-min h) (pairing-heap-remove-min h)))
211
212(let ((heap-sort
213       (lambda (list)
214         (let ((h (fold pairing-heap-insert (pairing-heap-empty my->) list)))
215           (let loop ((result '()) (h h))
216             (if (pairing-heap-empty? h)
217                 (reverse result)
218                 (loop (cons (pairing-heap-min h) result)
219                       (pairing-heap-remove-min h))))))))
220  (apply > (heap-sort '(10 9 8 5 7 6 4 2 1 3))))
221
222(apply > (pairing-heap-sort my-> '(10 9 8 5 7 6 4 2 1 3)))
223(apply > (vector->list (pairing-heap-sort my-> (vector 10 9 8 5 7 6 4 2 1 3))))
224(apply < (pairing-heap-sort my-< '(10 9 8 5 7 6 4 2 1 3)))
225(apply < (vector->list (pairing-heap-sort my-< (vector 10 9 8 5 7 6 4 2 1 3))))
226|#
Note: See TracBrowser for help on using the repository browser.