; binomial heaps

(define node vector) ; rank item kids
(define (rank n) (vector-ref n 0))
(define (item n) (vector-ref n 1))
(define (kids n) (vector-ref n 2))
(define empty (list))
(define empty? null?)

(define (link lt? h1 h2)
  (if (not (lt? (item h1) (item h2)))
      (node (add1 (rank h1))
            (item h2)
            (cons h1 (kids h2)))
      (node (add1 (rank h1))
            (item h1)
            (cons h2 (kids h1)))))

(define (insert-tree lt? t ts)
  (if (null? ts) (list t)
    (if (< (rank t) (rank (car ts))) (cons t ts)
      (insert-tree lt? (link lt? t (car ts)) (cdr ts)))))

(define (insert lt? x ts)
  (insert-tree lt? (node 0 x (list)) ts))

(define (merge lt? ts1 ts2)
  (cond ((empty? ts1) ts2)
        ((empty? ts2) ts1)
        ((< (rank (car ts1)) (rank (car ts2)))
          (cons (car ts1) (merge lt? (cdr ts1) ts2)))
        ((< (rank (car ts2)) (rank (car ts1)))
          (cons (car ts2) (merge lt? ts1 (cdr ts2))))
        (else (insert-tree lt? (link lt? (car ts1) (car ts2))
                               (merge lt? (cdr ts1) (cdr ts2))))))

(define (remove-min-tree lt? ts)
  (cond ((null? ts) (error 'remove-min-tree "empty"))
        ((null? (cdr ts)) (values (car ts) (list)))
        (else (call-with-values
                (lambda () (remove-min-tree lt? (cdr ts)))
                (lambda (t-prime ts-prime)
                  (if (not (lt? (item (car ts)) (item t-prime)))
                      (values t-prime (cons (car ts) ts-prime))
                      (values t-prime ts-prime)))))))

(define (find-min lt? ts)
  (call-with-values
    (lambda () (remove-min-tree lt? ts))
    (lambda (t ts) (item t))))

(define (delete-min lt? ts)
  (call-with-values
    (lambda () (remove-min-tree lt? ts))
    (lambda (h ts) (merge lt? (reverse (kids h)) ts))))

(define (from-list lt? xs)
  (let ((h empty))
    (do ((xs xs (cdr xs))) ((null? xs) h)
      (set! h (insert lt? (car xs) h)))))

(define (to-list lt? ts)
  (let loop ((ts ts) (xs (list)))
    (if (empty? ts) (reverse xs)
      (loop (delete-min lt? ts)
            (cons (find-min lt? ts) xs)))))

(define (sort lt? xs)
  (to-list lt? (from-list lt? xs)))

(display (sort < '(4 8 7 1 5 2 3 6)))

(1 2 3 4 5 6 7 8)