llrb.scm

(define (make-node data key)
  (define (node data key color left right)
    (lambda (m)
      (cond
            ((eq? m 'left) left)
            ((eq? m 'right) right)
            ((eq? m 'data) data)
            ((eq? m 'key) key)
            ((eq? m 'color) color)
            ((eq? m 'set-color) (lambda (x) (set! color x)))
            ((eq? m 'set-data) (lambda (x) (set! data x)))
            ((eq? m 'set-left) (lambda (x) (set! left x)))
            ((eq? m 'set-right) (lambda (x) (set! right x))))))
  (node data key 'red '() '()))
(define (rotate-right node)
  (let ((new-node (node 'left)))
    ((node 'set-left) (new-node 'right))
    ((new-node 'set-right) node)
    ((new-node 'set-color) (node 'color))
    ((node 'set-color) 'red)
    new-node))
(define (rotate-left node)
  (let ((new-node (node 'right)))
    ((node 'set-right) (new-node 'left))
    ((new-node 'set-left) node)
    ((new-node 'set-color) (node 'color))
    ((node 'set-color) 'red)
    new-node))
(define (is-red? n) (if (null? n) #f (eq? (n 'color) 'red)))
(define (color-flip node)
  (define (flip n) ((n 'set-color) (if (is-red? n) 'black 'red)))
  (flip node)
  (flip (node 'left))
  (flip (node 'right)))
(define (fix-up node)
  (if (not (null? node))
      (begin
       (if (is-red? (node 'right)) (set! node (rotate-left node)))
       (if (and (is-red? (node 'left)) 
                (is-red? ((node 'left) 'left))) (set! node (rotate-right node)))
       (if (and (is-red? (node 'left))
                (is-red? (node 'right))) (color-flip node))))
  node)
(define (is-black? n) (not (is-red? n)))
(define (move-red-left node)
  (color-flip node)
  (if (is-red? ((node 'right) 'left))
        ((node 'set-right (rotate-right (node 'right)))
         (set! node (rotate-left node))
         (color-flip node)))
  node)
(define (move-red-right node)
  (color-flip node)
  (if (is-red? ((node 'left) 'left))
      ((set! node (rotate-right node))
       (color-flip node)))
  node)
(define (insert node data key compare)
  (define (insert-node node)
    (cond ((null? node) (make-node data key))
          (else 
           (let ((cmp (compare key (node 'key))))
             (cond ((= cmp 0) ((node 'set-data) data))
                   ((< cmp 0) ((node 'set-left) (insert-node (node 'left))))
                   (else ((node 'set-right) (insert-node (node 'right)))))
             (fix-up node)))))
  (insert-node node))
(define (remove-min root)
  (define min-elem '())
  (define (remove-min-from node)
    (if (null? (node 'left)) (begin (set! min-elem node) '())
        (begin
          (if (and (is-black? (node 'left))
                   (is-black? ((node 'left) 'left))) 
              (set! node (move-red-left node)))
          ((node 'set-left) (remove-min-from (node 'left)))
          (fix-up node))))
  (let ((new-root (remove-min-from root)))
    (cons new-root min-elem)))
(define (remove-max node)
  (define max-elem '())
  (define (remove-max-from node)
    (if (is-red? (node 'left)) (set! node (rotate-right node)))
    (if (null? (node 'right)) (begin (set! max-elem node) '())
        (begin 
          (if (and (is-black? (node 'right))
                   (is-black? ((node 'right) 'left)))
              (set! node (move-red-right node)))
          ((node 'set-right) (remove-max-from (node 'right)))
          (fix-up node))))
  (let ((new-root (remove-max-from root)))
    (cons new-root max-elem)))
(define (remove root key compare)
  (define removed-node '())
  (define transplant-proc '())
  (define (proceed-with node link)
    (set! transplant-proc (node link))
    ((node (if (eq? link 'left) 'set-left 'set-right)) (remove-node (node link))) node)
  (define (go-to-left-subtree node)
    (if (and (not (is-red? (node 'left)))
             (not (is-red? ((node 'left) 'left))))
        (set! node (move-red-left node)))
    (proceed-with node 'left))
  (define (go-to-right-subtree node)
    (if (is-red? (node 'left)) (set! node (rotate-right node))) 
    (if (and (= (compare key (node 'key)) 0) (null? (node 'right))) '()
        (begin
          (if (and (not (is-red? (node 'right)))
                   (not (is-red? ((node 'right) 'left)))) 
              (set! node (move-red-right node)))
          (if (= (compare key (node 'key)) 0)
              (let* ((minimum (remove-min (node 'right)))
                     (sub-tree (car minimum))
                     (min-node (cdr minimum)))
               (begin
                 ((min-node 'set-left) (node 'left))
                 ((min-node 'set-right) sub-tree)
                 ((min-node 'set-color) (node 'color))
                 (if (procedure? transplant-proc) (transplant-proc min-node))
                 (set! removed-node node)
                 (set! node min-node)))
              (proceed-with node 'right))
          node)))
  (define (remove-node node)
      (fix-up 
       (if (< (compare key (node 'key)) 0)
           (go-to-left-subtree node)
           (go-to-right-subtree node))))
  (let ((new-root (remove-node root)))
    (cons new-root removed-node)))