source: project/release/5/sdl-base/trunk/heap.scm @ 35609

Last change on this file since 35609 was 35609, checked in by megane, 6 months ago

sdl-base: Initial C5 port

File size: 1.6 KB
Line 
1;; Leftist Heaps, implemented from section 3.1 of "Purely Functional
2;; Data Structures", by Chris Okasaki.
3
4;; Algebraic type. '() is used as the base case.
5(define-record-type heap-node
6  (make-heap-node* rank element left right)
7  heap-node?
8  (rank heap-node-rank)
9  (element heap-node-element)
10  (left heap-node-left)
11  (right heap-node-right))
12
13(define (empty-heap) '())
14
15(define (heap? h)
16  (or (null? h)
17      (heap-node? h)))
18
19(define (heap-empty? h)
20  (null? h))
21
22(define (heap-minimum h)
23  (if (heap-empty? h)
24      (error "heap-minimum: empty heap" h)
25      (heap-node-element h)))
26
27(define (heap->tree h)
28  (if (null? h)
29      '()
30      (list (heap-node-element h)
31            (heap->tree (heap-node-left h))
32            (heap->tree (heap-node-right h)))))
33
34(define (heap-functor elt<=)
35  (define (rank h)
36    (if (null? h)
37        0
38        (heap-node-rank h)))
39
40  (define (make-node elt left right)
41    (let ((lrank (rank left))
42          (rrank (rank right)))
43      (if (>= lrank rrank)
44          (make-heap-node* (+ rrank 1) elt left right)
45          (make-heap-node* (+ lrank 1) elt right left))))
46
47  (define (heap-insert elt h)
48    (heap-merge h
49                (make-heap-node* 1 elt '() '())))
50
51  (define (heap-merge h1 h2)
52    (cond
53     ((heap-empty? h1) h2)
54     ((heap-empty? h2) h1)
55     (else
56      (let ((elt1 (heap-node-element h1))
57            (elt2 (heap-node-element h2)))
58        (if (elt<= elt1 elt2)
59            (make-node elt1 (heap-node-left h1) (heap-merge (heap-node-right h1) h2))
60            (make-node elt2 (heap-node-left h2) (heap-merge h1 (heap-node-right h2))))))))
61
62  (define (heap-delete-minimum h)
63    (heap-merge (heap-node-left h)
64                (heap-node-right h)))
65
66  (values heap-insert
67          heap-merge
68          heap-delete-minimum))
Note: See TracBrowser for help on using the repository browser.