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

; 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)))