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

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

Trying unsafe optimizations, but no real improvement; relegated to branches.

File size: 10.2 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 (unsafe)
40 (export pairing-heap?
41         pairing-heap-empty
42         pairing-heap-empty?
43         pairing-heap-min 
44         pairing-heap-merge
45         pairing-heap-insert
46         pairing-heap-remove-min
47         pairing-heap-fold
48         pairing-heap-sort))
49
50(use srfi-1)
51
52(define-macro (my-assert ppred? oobj procedure message . objs)
53  (let ((pred? (gensym 'pred?))
54        (obj (gensym 'obj)))
55    `(let ((,pred? ,ppred?)
56           (,obj ,oobj))
57       (when (not (,pred? ,obj))
58         (error ,procedure ,message ,@objs)))))
59
60;; Each pairing heap stores a suspension (i.e. (delay ...)) of its own
61;; remove-min.  This is necessary because (pairing-heap-remove-min h)
62;; has amortized bounds: on average it takes O(log(n)) time, but in
63;; rare cases it may take O(n) time.  Because heaps are persistent,
64;; the (pairing-heap-remove-min operation may be called multiple times
65;; on *the same heap*.  Therefore, we must ensure that the result is
66;; memoized, and subsequent calls take O(1) time to avoid repeatedly
67;; doing O(n) work.
68(define-record %ph compare elt remove-min-heap)
69(define-record %ph-elt min sub-heaps)
70
71(define *empty-elt* (gensym 'empty-elt))
72
73(define pairing-heap? %ph?)
74
75(define (%pairing-heap-empty compare)
76  (make-%ph compare *empty-elt* (delay (error 'pairing-heap-remove-min
77                                              "cannot remove min from empty heap"))))
78
79(define (pairing-heap-empty compare)
80  (my-assert procedure? 
81             compare
82             'pairing-heap-empty 
83             "expected procedure for comparison, got "
84             compare)
85  (%pairing-heap-empty compare))
86
87(define (%pairing-heap-empty? h)
88  (eq? (%ph-elt h) *empty-elt*))
89
90(define (pairing-heap-empty? h)
91  (my-assert pairing-heap? h 'pairing-heap-empty? "expected pairing-heap, got " h)
92  (%pairing-heap-empty? h))
93
94(define (%pairing-heap-min h)
95  (%ph-elt-min (%ph-elt h)))
96
97(define (pairing-heap-min h)
98  (my-assert (lambda (obj) (not (pairing-heap-empty? obj)))
99             h
100             'pairing-heap-min
101             "cannot take min element of empty pairing heap "
102             h)
103  (%pairing-heap-min h))
104
105(define (<? compare obj1 obj2)
106  (fx< (compare obj1 obj2) 0))
107
108(define (sub-heaps h)
109  (%ph-elt-sub-heaps (%ph-elt h)))
110
111(define (pairing-heap-merge h1 h2)
112  (my-assert pairing-heap?
113             h1
114             'pairing-heap-merge
115             "expected pairing-heap for first argument, got "
116             h1)
117  (my-assert pairing-heap?
118             h2 
119             'pairing-heap-merge
120             "expected pairing-heap for second argument, got "
121             h2)
122  (%pairing-heap-merge h1 h2))
123
124(define (%pairing-heap-merge h1 h2)
125  (cond
126   ((pairing-heap-empty? h2) h1)
127   ((pairing-heap-empty? h1) h2)
128   (else
129    (let ((compare (%ph-compare h1))
130          (m1 (%pairing-heap-min h1))
131          (m2 (%pairing-heap-min h2)))
132      (if (<? compare m1 m2)
133          (let ((h (make-%ph compare
134                             (make-%ph-elt m1 (cons h2 (sub-heaps h1)))
135                             #f)))
136            (%ph-remove-min-heap-set! h (delay (%remove-min h)))
137            h)
138          (let ((h (make-%ph compare
139                             (make-%ph-elt m2 (cons h1 (sub-heaps h2)))
140                             #f)))
141            (%ph-remove-min-heap-set! h (delay (%remove-min h)))
142            h))))))
143
144(define (pairing-heap-insert elt ph)
145  (my-assert pairing-heap?
146             ph
147             'pairing-heap-insert
148             "expected pairing heap for second argument, got "
149             ph)
150  (%pairing-heap-insert elt ph))
151
152(define (%pairing-heap-insert elt ph)
153  (let ((compare (%ph-compare ph)))
154    (%pairing-heap-merge
155     (make-%ph compare
156               (make-%ph-elt elt '())
157               (delay (%pairing-heap-empty compare)))
158     ph)))
159
160;; %remove-min does the actual work (pairing-heap-remove-min only
161;; forces a suspension of %remove-min).  We first merge adjascent
162;; pairs of sub-heaps, and then merge the entire list of merged-pairs
163;; into a single heap.
164(define (%remove-min h)
165  (let ((merged-pairs
166         (let pair-loop ((hs (sub-heaps h))
167                         (merged-hs '()))
168           (cond
169            ((null? hs) merged-hs)
170            ((null? (cdr hs)) (cons (car hs) merged-hs))
171            (else
172             (pair-loop
173              (cddr hs)
174              (cons (%pairing-heap-merge (car hs) (cadr hs))
175                    merged-hs)))))))
176    (fold %pairing-heap-merge (%pairing-heap-empty (%ph-compare h)) merged-pairs)))
177
178;; Just force (%remove-min h).
179(define (pairing-heap-remove-min h)
180  (my-assert pairing-heap?
181             h
182             'pairing-heap-remove-min
183             "expected pairing-heap, got "
184             h)
185  (force (%ph-remove-min-heap h)))
186
187(define (pairing-heap-fold kons knil h)
188  (my-assert procedure? 
189             kons
190             'pairing-heap-fold
191             "expected procedure for first argument, got "
192             kons)
193  (my-assert pairing-heap?
194             h
195             'pairing-heap-fold
196             "expected pairing-heap for third argument, got "
197             h)
198  (%pairing-heap-fold kons knil h))
199
200(define (%pairing-heap-fold kons knil h)
201  (if (%pairing-heap-empty? h)
202      knil
203      (fold (lambda (sub-heap acc)
204              (%pairing-heap-fold kons acc sub-heap))
205            (kons (%ph-elt-min (%ph-elt h)) knil)
206            (sub-heaps h))))
207
208(define (pairing-heap-sort compare list-or-vector)
209  (my-assert procedure?
210             compare
211             'pairing-heap-sort
212             "expected comparison procedure for first argument, got "
213             compare)
214  (my-assert (lambda (obj) (or (vector? obj) (list? obj)))
215             list-or-vector
216             'pairing-heap-sort
217             "expected list or vector for second argument, got "
218             list-or-vector)
219  (if (list? list-or-vector)
220      (sort-list compare list-or-vector)
221      (sort-vector compare list-or-vector)))
222
223(define (sort-list compare list)
224  (let ((rev-compare (lambda (obj1 obj2) (fx* -1 (compare obj1 obj2)))))
225    (let ((h (fold %pairing-heap-insert (%pairing-heap-empty rev-compare) list)))
226      (let loop ((sorted-elts '())
227                 (h h))
228        (if (%pairing-heap-empty? h)
229            sorted-elts
230            (loop (cons (%pairing-heap-min h) sorted-elts)
231                  (pairing-heap-remove-min h)))))))
232
233(define (sort-vector compare vec)
234  (let* ((n (vector-length vec))
235         (h (let h-loop ((h (%pairing-heap-empty compare))
236                         (i 0))
237              (if (fx>= i n)
238                  h
239                  (h-loop (%pairing-heap-insert (vector-ref vec i) h)
240                          (fx+ i 1))))))
241    (let ((result (make-vector n)))
242      (let result-loop ((i 0)
243                        (h h))
244        (if (fx>= i n)
245            result
246            (begin
247              (vector-set! result i (%pairing-heap-min h))
248              (result-loop (fx+ i 1) (pairing-heap-remove-min h))))))))
249
250#|
251Tests:
252
253(define my-< (lambda (n1 n2)
254               (cond
255                ((fx< n1 n2) -1)
256                ((fx= n1 n2) 0)
257                (else 1))))
258
259(define my-> (lambda (n1 n2) (fx* -1 (my-< n1 n2))))
260
261(pairing-heap? (fold pairing-heap-insert (pairing-heap-empty my-<) '(1 2 3 4)))
262
263(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(1 2 3 4))))
264  (lset= =
265         '(1 2 3 4)
266         (pairing-heap-fold cons '() h)))
267
268(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(1 2 3 4))))
269  (= (pairing-heap-min h) 1))
270
271(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(4 3 2 1))))
272  (and (= (pairing-heap-min h) 1)
273       (= (pairing-heap-min
274           (pairing-heap-remove-min h))
275          2)))
276
277(let ((heap-sort
278       (lambda (list)
279         (let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) list)))
280           (let loop ((result '()) (h h))
281             (if (pairing-heap-empty? h)
282                 (reverse result)
283                 (loop (cons (pairing-heap-min h) result)
284                       (pairing-heap-remove-min h))))))))
285  (apply < (heap-sort '(10 9 8 5 7 6 4 2 1 3))))
286
287(let ((h (fold pairing-heap-insert (pairing-heap-empty my-<) '(10 9 8 5 7 6 4 2 1 3))))
288  (eq? (pairing-heap-remove-min h) (pairing-heap-remove-min h)))
289
290(let ((heap-sort
291       (lambda (list)
292         (let ((h (fold pairing-heap-insert (pairing-heap-empty my->) list)))
293           (let loop ((result '()) (h h))
294             (if (pairing-heap-empty? h)
295                 (reverse result)
296                 (loop (cons (pairing-heap-min h) result)
297                       (pairing-heap-remove-min h))))))))
298  (apply > (heap-sort '(10 9 8 5 7 6 4 2 1 3))))
299
300(apply > (pairing-heap-sort my-> '(10 9 8 5 7 6 4 2 1 3)))
301(apply > (vector->list (pairing-heap-sort my-> (vector 10 9 8 5 7 6 4 2 1 3))))
302(apply < (pairing-heap-sort my-< '(10 9 8 5 7 6 4 2 1 3)))
303(apply < (vector->list (pairing-heap-sort my-< (vector 10 9 8 5 7 6 4 2 1 3))))
304|#
Note: See TracBrowser for help on using the repository browser.