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)) |
---|