leftist-heap.scm
```;;; leftist-heap.scm  --  Jens Axel Søgaard  --  28th dec 2005

;;; LEFTIST HEAP [Okasaki, p.17-20]

; A *Leftist heap* is a heap-ordered binary tree with the /leftist property/:
; The rank of any left child is at least as large as the rank of its right sibling.
; The *rank* of a node is the length of the its *right spine*, which is the
; rightmost path from the node to an empty node.

;;; Time             worst case
;  delete-min         O(log n)
;  empty              O(1)
;  empty?             O(1)
;  find-min           O(1)
;  insert             O(log n)
;  union              O(log n)

(module leftist-heap mzscheme
(require
(lib "67.ss" "srfi")
(lib "42.ss" "srfi")
(only (lib "list.ss") foldl))

;;; DATA DEFINITION

; A HEAP is either
;    (make-heap-empty cmp)
; or
;    (make-heap-node cmp rank elm left right)
; where
;   cmp  is a compare function,
;   rank is an integer, and
;   left and right are heaps.

(define-struct heap              (compare))
(define-struct (heap-empty heap) ())
(define-struct (heap-node heap)  (rank elm left right))

;;; CORE HEAP OPERATIONS

(define empty
(case-lambda
[()    (make-heap-empty (current-compare))]
[(cmp) (make-heap-empty cmp)]))

(define empty? heap-empty?)

(define (rank h)
(if (empty? h)
0
(heap-node-rank h)))

(define (make x a b)
(let ([ra (rank a)]
[rb (rank b)]
[cmp (heap-compare a)])
(if (>= ra rb)
(make-heap-node cmp (add1 rb) x a b)
(make-heap-node cmp (add1 ra) x b a))))

(define (union h1 h2)
(cond
[(empty? h1) h2]
[(empty? h2) h1]
[else        (let ([x (heap-node-elm h1)]
[y (heap-node-elm h2)])
(if<=? ((heap-compare h1) x y)
(make x (heap-node-left h1) (union (heap-node-right h1) h2))
(make y (heap-node-left h2) (union h1 (heap-node-right h2)))))]))

(define (insert x h)
(let ([cmp (heap-compare h)])
(union (make-heap-node cmp 1 x (make-heap-empty cmp) (make-heap-empty cmp))
h)))

(define (delete x h)
(define (delete/sf x h s f)
(cond
[(empty? h)
(s h)]
[(=? (heap-compare h) x (heap-node-elm h))
(s (union (heap-node-left h) (heap-node-right h)))]
[(<? (heap-compare h) x (heap-node-elm h))
(f)]
[else
(let ([cmp (heap-compare h)])
(let ([y (heap-node-elm h)]
[l (heap-node-left h)]
[r (heap-node-right h)])
(delete/sf x l
(lambda (h1) (s (make y h1 r)))
(lambda ()   (delete/sf x r
(lambda (h1) (s (make y l h1)))
(lambda () (f)))))))]))
(delete/sf x h
(lambda (h1) h1)
(lambda ()   h)))

(define (delete-all x h)
(define (delete-all/sf x h s f)
(cond
[(empty? h)
(s h)]
[(=? (heap-compare h) x (heap-node-elm h))
(s (union (delete-all x (heap-node-left h))
(delete-all x (heap-node-right h))))]
[(<? (heap-compare h) x (heap-node-elm h))
(f)]
[else
(let ([cmp (heap-compare h)])
(let ([y (heap-node-elm h)]
[l (heap-node-left h)]
[r (heap-node-right h)])
(delete-all/sf x l
(lambda (l1) (s (delete-all/sf x r
(lambda (r1) (make y l1 r1))
(lambda ()   (make y l1 r)))))
(lambda ()   (delete-all/sf x r
(lambda (r1) (s (make y l r1)))
(lambda ()   (f)))))))]))
(delete-all/sf x h
(lambda (h1) h1)
(lambda ()   h)))

(define (find-min h)
(heap-node-elm h))

(define (delete-min h)
(union (heap-node-left h) (heap-node-right h)))

(define (get x h)
(let ([cmp (heap-compare h)])
(define (inner-get h s f)
(if (empty? h)
(f)
(if=? (cmp x (heap-node-elm h))
(s (heap-node-elm h))
(inner-get (heap-node-left h) s
(lambda () (inner-get (heap-node-right h) s
f))))))
(inner-get h (lambda (x) x) (lambda () #f))))

;;;
;;; EXTRA OPERATIONS
;;;

(define (delete* xs h)
(foldl delete h xs))

(define (elements h)
(fold cons '() h))

(define (fold f b h)
(if (empty? h)
b
(fold f
(fold f
(f (heap-node-elm h) b)
(heap-node-left h))
(heap-node-right h))))

(define (count x h)
(let ([cmp (heap-compare h)])
(fold (lambda (y s)
(if=? (cmp x y)
s))
0 h)))

(define (-heap . xs)
(list->heap xs))

(define (insert* xs h)
(union (list->heap (heap-compare h) xs) h))

(define list->heap
; time: O(n)
(case-lambda
[(l)     (list->heap (current-compare) l)]
[(cmp l) (let* ([e  (empty cmp)]
[hs (map (lambda (x) (insert x e)) l)])
; (list heap) -> (list heap)
;  merge adjacent pairs of heaps
(define (merge-pairs hs)
(cond
[(or (null? hs)
(null? (cdr hs))) hs]
[else (cons (union (car hs) (cadr hs))
(merge-pairs (cddr hs)))]))
(if (null? hs)
e
(let loop ([hs hs])
; merge adjacent pairs of heaps until one is left
(cond
[(null? hs)       '()]
[(null? (cdr hs)) (car hs)]
[else             (loop (merge-pairs hs))]))))]))

; select : set -> element
(define (select s)
(if (empty? s)
(error 'select "can't select an element from an empty heap")
(find-min s)))

(define singleton
(case-lambda
[(x)     (insert x (empty))]
[(cmp x) (insert x (make-heap-empty cmp))]))

(define (size h)
; NOTE: T(size)=O(n)
(cond
[(heap-empty? h) 0]
[else            (+ (size (heap-node-left h))
1
(size (heap-node-right h)))]))

;;;
;;; support for srfi-42
;;;

(define-syntax heap-ec
(syntax-rules ()
[(heap-ec cmp etc1 etc ...)
(fold-ec (empty cmp) etc1 etc ... insert)]))

(define-syntax :heap
(syntax-rules (index)
((:heap cc var (index i) arg)
(:parallel cc (:stack var arg) (:integers i)) )
((:heap cc var arg)
(:do cc
(let ())
((t arg))
(not (empty? t))
(let ((var (find-min t))))
#t
((delete-min t)) ))))

(define (:heap-dispatch args)
(cond
[(null? args)
'heap]
[(and  (heap? (car args)))
(:generator-proc (:heap (car args)))]
[else
#f]))

(:-dispatch-set!
(dispatch-union (:-dispatch-ref) :heap-dispatch))

(require "signatures/heap-signature.scm")
(provide-heap)

)
```