; maxiphobic heaps
(define mh-node vector) ; size item lkid rkid
(define-syntax mh-size (syntax-rules () ((_ mh) (vector-ref mh 0))))
(define-syntax mh-item (syntax-rules () ((_ mh) (vector-ref mh 1))))
(define-syntax mh-lkid (syntax-rules () ((_ mh) (vector-ref mh 2))))
(define-syntax mh-rkid (syntax-rules () ((_ mh) (vector-ref mh 3))))
(define mh-empty (mh-node 0 'mh-empty 'mh-empty 'mh-empty))
(define (mh-empty? mh) (eqv? mh mh-empty))
(define (mh-merge lt? mh1 mh2)
(cond ((mh-empty? mh1) mh2) ((mh-empty? mh2) mh1)
(else (if (lt? (mh-item mh1) (mh-item mh2))
(let ((mhs (mh-biggest (mh-lkid mh1) (mh-rkid mh1) mh2)))
(mh-node (+ (mh-size mh1) (mh-size mh2))
(mh-item mh1) (car mhs)
(apply mh-merge lt? (cdr mhs))))
(let ((mhs (mh-biggest mh1 (mh-lkid mh2) (mh-rkid mh2))))
(mh-node (+ (mh-size mh1) (mh-size mh2))
(mh-item mh2) (car mhs)
(apply mh-merge lt? (cdr mhs))))))))
(define (mh-biggest mh1 mh2 mh3)
(if (< (mh-size mh1) (mh-size mh2))
(if (< (mh-size mh2) (mh-size mh3))
(list mh3 mh1 mh2)
(list mh2 mh1 mh3))
(if (< (mh-size mh1) (mh-size mh3))
(list mh3 mh1 mh2)
(list mh1 mh2 mh3))))
(define (mh-insert lt? x mh)
(mh-merge lt? (mh-node 1 x mh-empty mh-empty) mh))
(define (mh-find-min mh)
(if (mh-empty? mh)
(error 'mh-find-min "empty maxiphobic heap")
(mh-item mh)))
(define (mh-delete-min lt? mh)
(if (mh-empty? mh)
(error 'mh-delete-min "empty maxiphobic heap")
(mh-merge lt? (mh-lkid mh) (mh-rkid mh))))
(define (mh-sort lt? xs)
(let loop1 ((xs xs) (mh mh-empty))
(if (pair? xs)
(loop1 (cdr xs) (mh-insert lt? (car xs) mh))
(let loop2 ((mh mh) (zs '()))
(if (mh-empty? mh)
(reverse zs)
(loop2 (mh-delete-min lt? mh)
(cons (mh-find-min mh) zs)))))))
(display (mh-sort > '(3 1 7 2 5 6 4)))