数据结构(scheme) -- 抽象数据类型(ADT) -- 平衡二叉树(AVL-Tree)

http://zh.wikipedia.org/wiki/AVL

; Balanced-binary-tree (AVL tree)
; ==================================================
> (define b (btree))                ; (() . 0)
> (btree-add b (list 1 "one"))      ; (((1 "one") (() . 0) (() . 0)) . 1)
> (btree-add b (list 3 "three"))
> (btree-add b (list 2 "two"))     
> (btree-add b (list 4 "four"))
> (btree-add b (list 5 "five"))
> (btree-add b (list 6 "six"))
> (btree-add b (list 7 "seven"))
> b
(((4 "four")
  (((2 "two")
    (((1 "one") (() . 0) (() . 0)) . 1)
    (((3 "three") (() . 0) (() . 0)) . 1))
   .
   2)
  (((6 "six")
    (((5 "five") (() . 0) (() . 0)) . 1)
    (((7 "seven") (() . 0) (() . 0)) . 1))
   .
   2))
 .
 3)
> (btree-height b)                  ; 3
> (btree-remove b 4)
> b
(((5 "five")
  (((2 "two")
    (((1 "one") (() . 0) (() . 0)) . 1)
    (((3 "three") (() . 0) (() . 0)) . 1))
   .
   2)
  (((6 "six") (() . 0) (((7 "seven") (() . 0) (() . 0)) . 1))
   .
   2))
 .
 3)
> (btree-update b (list 6 "six year"))
> (btree-get b 6)                   ; (list 6 "six year")


; ====================================================
(define (btree) (cons '() 0))
(define (btree-empty? b) (null? (car b)))
(define (btree-root b) (car (car b)))
(define (btree-set-root b e) (set-car! (car b) e))
(define (btree-left b) (cadr (car b)))
(define (btree-set-left b lb) (set-car! (cdr (car b)) lb))
(define (btree-right b) (caddr (car b)))
(define (btree-set-right b rb) (set-car! (cdr (cdr (car b))) rb))
(define (btree-height b) (cdr b))

(define (btree-update-height b)
  (if (not (btree-empty? b))
      (set-cdr! b (+ 1 (max (btree-height (btree-left b))
                            (btree-height (btree-right b)))))))

(define (btree-factor b) 
  (if (btree-empty? b)
      0
      (- (btree-height (btree-left b))
         (btree-height (btree-right b)))))

(define (key-cmp m n) (- (car m) (car n)))

(define (btree-get b key)
  (if (btree-empty? b)
      '()
      (let* ((r (btree-root b))
             (res (key-cmp (list key) r)))
        (cond
          ((= res 0) r)
          ((< res 0) (btree-get (btree-left b) key))
          (else (btree-get (btree-right b) key))))))

(define (btree-update b e)
  (let ((r (btree-get b (car e))))
    (if (not (null? r))
        (set-car! (cdr r) (cadr e)))))

(define (btree-add b e)
  (if (btree-empty? b)
      (begin 
        (set-car! b (list e (btree) (btree)))
        (set-cdr! b 1))
      (let ((res (key-cmp e (btree-root b))))
        (if (not (= res 0)) 
            (begin
              (btree-add ((if (< res 0) btree-left btree-right) b) e)
              (btree-balance b))))))

(define (btree-remove b key)
  (define (find p next)
    (if (btree-empty? (next p))
        (btree-root p)
        (find (next p) next)))
  (if (not (btree-empty? b))
      (let* ((res (key-cmp (list key) (btree-root b)))
             (f (btree-factor b))
             (p ((if (> f 0) btree-left btree-right) b)))
        (cond
          ((= res 0)
           (if (btree-empty? p)
               (begin
                 (set-car! b '())
                 (set-cdr! b 0))
               (let ((r (find p (if (> f 0) btree-right btree-left))))
                 (btree-set-root b r)
                 (btree-remove p (car r)))))
          ((< res 0)
           (btree-remove (btree-left b) key))
          (else
            (btree-remove (btree-right b) key)))
        (btree-balance b))))

(define (btree-balance b)
  (let ((f (btree-factor b)))
    (cond 
      ((= f -2)
       (let* ((p (btree-right b))
              (rp (btree-root p)))
         (if (< (btree-factor p) 0)
             (begin
               (btree-set-root p (btree-root b))
               (btree-set-root b rp)
               (btree-set-right b (btree-right p))
               (btree-set-right p (btree-left p))
               (btree-set-left p (btree-left b))
               (btree-set-left b p))
             (let* ((np (btree-left p))
                    (nrp (btree-root np)))
               (btree-set-root np (btree-root b))
               (btree-set-root b nrp)
               (btree-set-left p (btree-right np))
               (btree-set-right np (btree-left np))
               (btree-set-left np (btree-left b))
               (btree-set-left b np)
               (btree-update-height np)))
         (btree-update-height p)))
      ((= f 2) 
       (let* ((p (btree-left b))
              (rp (btree-root p)))
         (if (> (btree-factor p) 0)
             (begin
               (btree-set-root p (btree-root b))
               (btree-set-root b rp)
               (btree-set-left b (btree-left p))
               (btree-set-left p (btree-right p))
               (btree-set-right p (btree-right b))
               (btree-set-right b p))
             (let* ((np (btree-right p))
                    (nrp (btree-root np)))
               (btree-set-root np (btree-root b))
               (btree-set-root b nrp)
               (btree-set-right p (btree-left np))
               (btree-set-left np (btree-right np))
               (btree-set-right np (btree-right b))
               (btree-set-right b np)
               (btree-update-height np)))
         (btree-update-height p))))
    (btree-update-height b)))