这几天继续学习scheme，scheme中虽然有hashtable但没有类似C++中的map,于是把C版本中的红黑树移植到scheme(中间也发现了C版本中的一些问题，暂时懒得调整了^()^)
以作为后序set和表格驱动设计中表格的基础数据结构.
虽说这个红黑树在C版本中是调试好的了，但移植过来还是花费了我一天多的时间，中间出现各种小问题，苦于并不熟悉如何调试scheme程序，所以进度十分缓慢.
(注：代码中大量使用set-car!所以无法再racket中运行，当然也可以调整rbnode的表示形式，不使用list来表示各字段，只使用set!修改字段的内容以使得可以被
racket支持)
(begin(define nil-node (list 0 0 'black '() '() '()));红黑树节点的定义;节点结构如下;(key (val (color (parent (left (right nil)))))) (define (make-rb-node key val)(list key val 'red '() '() '()))(define (get-key rbnode)(car rbnode))(define (get-val rbnode)(cadr rbnode))(define (set-val! rbnode val)(set-car! (cdr rbnode) val))(define (get-color rbnode)(caddr rbnode))(define (set-color! rbnode color)(set-car! (cddr rbnode) color))(define (get-parent rbnode)(cadddr rbnode)) (define (set-parent! rbnode parent)(if (not (equal? rbnode nil-node))(set-car! (cdddr rbnode) parent)))(define (get-left rbnode)(car (cddddr rbnode)))(define (set-left! rbnode left)(if (not (equal? rbnode nil-node))(set-car! (cddddr rbnode) left)))(define (get-right rbnode)(cadr (cddddr rbnode)))(define (set-right! rbnode right)(if (not (equal? rbnode nil-node))(set-car! (cdr (cddddr rbnode)) right)))(define (color-flip rbnode)(if (and (not (null? (get-left rbnode)))(not (null? (get-right rbnode))))(begin (set-color! rbnode 'red)(set-color! (get-left rbnode) 'black)(set-color! (get-right rbnode) 'black)#t)#f) );红黑树定义;(root (size nil)) (define (make-rbtree comp-function);(let ((rbtree (list nil 0 nil)))(let ((root nil-node)(size 0)(cmp-function comp-function))(define (rbtree-get-root) root)(define (rbtree-set-root! new-root) (set! root new-root))(define (rbtree-get-size) size)(define (rbtree-insert key val)(define rbnode (make-rb-node key val))(define child_link '())(define parent nil-node)(define cmp cmp-function)(define (iter cur)(if (equal? cur nil-node) #t(begin(set! parent cur)(let ((ret (cmp key (get-key cur))))(cond ((= 0 ret) #f)(else (if (< ret 0) (begin (set! child_link (cddddr cur))(set! cur (get-left cur)))(begin (set! child_link (cdr (cddddr cur)))(set! cur (get-right cur)))) (iter cur)))))))(if (not (iter (rbtree-get-root))) #f(begin(set-left! rbnode nil-node)(set-right! rbnode nil-node)(set-parent! rbnode parent)(if (not (null? child_link)) (set-car! child_link rbnode))(set! size (+ 1 size))(if (= 1 size)(rbtree-set-root! rbnode))(insert-fix-up rbnode)#t)))(define (rbtree-find-imp key)(define (iter node)(define cmp cmp-function)(if (equal? node nil-node)'()(let ((ret (cmp key (get-key node))))(cond ((= 0 ret) node)((= -1 ret) (iter (get-left node)))(else (iter (get-right node)))))))(if (= 0 size) '()(iter root)))(define (rbtree-find key)(define ret (rbtree-find-imp key))(if (null? ret) ret (get-val ret)))(define (rbtree-remove key)(define rbnode (rbtree-find-imp key))(if (null? rbnode)'()(rbtree-delete rbnode))rbnode );获取用于代替将被删除节点的节点 (define (get-replace-node rbnode)(cond ((and (equal? (get-left rbnode) nil-node)(equal? (get-right rbnode) nil-node))rbnode)((not (equal? (get-right rbnode) nil-node)) (minimum (get-right rbnode))) (else (maxmum (get-left rbnode)))))(define (rbtree-delete rbnode)(define x (get-replace-node rbnode));用x替代rbnode的位置(define rb-parent (get-parent rbnode));rbnode的父亲(define x-parent (get-parent x));x的父亲 (define x-old-color (get-color x))(define fix-node nil-node)(if (equal? nil-node (get-left x))(set! fix-node (get-right x))(set! fix-node (get-left x)))(if (not (equal? x rbnode));如果x与rbnode不是同一个节点 (begin;x的父亲不是rbnode,将x的孩子交给它的父亲 (if (not (equal? x-parent rbnode))(let ((child (if (not (equal? nil-node (get-left x)))(get-left x)(get-right x))))(set-parent! child x-parent) (if (equal? x (get-left x-parent)) (set-left! x-parent child) (set-right! x-parent child))))(if (not (equal? nil-node rb-parent));如果rb-parent不为nil让x成为rb-parent的孩子 (begin(if (equal? rbnode (get-left rb-parent))(set-left! rb-parent x)(set-right! rb-parent x))(set-parent! x rb-parent) );否则将x父亲设为nil (set-parent! x nil-node));将rbnode的孩子移交给x (let ((rb-left (get-left rbnode))(rb-right (get-right rbnode)))(if (not (equal? nil-node rb-left))(begin (set-left! x rb-left)(set-parent! rb-left x)))(if (not (equal? nil-node rb-right))(begin (set-right! x rb-right)(set-parent! rb-right x)))) ));将rbnode的所有关系清除 (set-left! rbnode nil-node)(set-right! rbnode nil-node)(set-parent! rbnode nil-node)(if (equal? root rbnode)(rbtree-set-root! x))(set! size (- size 1)) (if (and (equal? nil-node fix-node) (eq? x-old-color 'black))(delete-fix-up fix-node)) )(define (rotate-left rbnode)(define parent (get-parent rbnode))(define right (get-right rbnode))(if (not (equal? nil-node right))(begin(set-right! rbnode (get-left right))(set-parent! (get-left right) rbnode)(if (equal? root rbnode) (rbtree-set-root! right)(begin(if (equal? rbnode (get-left parent))(set-left! parent right)(set-right! parent right))))(set-parent! right parent)(set-parent! rbnode right)(set-left! right rbnode)#t)#f))(define (rotate-right rbnode)(define parent (get-parent rbnode))(define left (get-left rbnode))(if (not (equal? nil-node left))(begin(set-left! rbnode (get-right left))(set-parent! (get-right left) rbnode)(if (equal? root rbnode) (rbtree-set-root! left)(begin(if (equal? rbnode (get-left parent))(set-left! parent left)(set-right! parent left))))(set-parent! left parent)(set-parent! rbnode left)(set-right! left rbnode)#t)#f))(define (insert-fix-up rbnode)(define (iter n)(if (eq? (get-color (get-parent n)) 'black)(set-color! root 'black)(begin(let ((parent (get-parent n))(grand_parent (get-parent (get-parent n))))(if (equal? parent (get-left grand_parent))(begin(let ((ancle (get-right grand_parent)))(if (eq? (get-color ancle) 'red)(begin (color-flip grand_parent) (set! n grand_parent))(begin (if (equal? n (get-right parent))(begin (set! n parent)(rotate-left n)))(set-color! (get-parent n) 'black)(set-color! (get-parent (get-parent n)) 'red)(rotate-right (get-parent (get-parent n)))))) )(begin(let ((ancle (get-left grand_parent)))(if (eq? (get-color ancle) 'red)(begin (color-flip grand_parent) (set! n grand_parent))(begin (if (equal? n (get-left parent))(begin (set! n parent)(rotate-right n)))(set-color! (get-parent n) 'black)(set-color! (get-parent (get-parent n)) 'red)(rotate-left (get-parent (get-parent n)))))) )))(iter n))))(iter rbnode))(define (delete-fix-up rbnode)(define (iter n)(if (not (and (not (equal? n root))(not (equal? (get-color n) 'red))))(set-color! n 'black)(begin(let ((parent (get-parent n)))(if (equal? n (get-left parent))(begin(let ((w (get-right parent)))(if (eq? 'red (get-color w))(begin(set-color! w 'black)(set-color! parent 'red)(rotate-left parent)(set! w (get-right parent))))(if (and (eq? 'black (get-color (get-left w)))(eq? 'black (get-color (get-right w))))(begin (set-color! w 'red)(set! n parent))(begin(if (eq? (get-color (get-right w)) 'black)(begin(set-color! (get-left w) 'black)(set-color! w 'red)(rotate-right w)(set! w (get-right parent))))(set-color! w (get-color parent))(set-color! parent 'black)(set-color! (get-right w) 'black)(rotate-left parent)(set! n root) ))))(begin(let ((w (get-left parent)))(if (eq? 'red (get-color w))(begin(set-color! w 'black)(set-color! parent 'red)(rotate-right parent)(set! w (get-left parent))))(if (and (eq? 'black (get-color (get-left w)))(eq? 'black (get-color (get-right w))))(begin (set-color! w 'red)(set! n parent))(begin(if (eq? (get-color (get-left w)) 'black)(begin(set-color! (get-right w) 'black)(set-color! w 'red)(rotate-left w)(set! w (get-left parent))))(set-color! w (get-color parent))(set-color! parent 'black)(set-color! (get-left w) 'black)(rotate-right parent)(set! n root) )))))) (iter n))))(iter rbnode))(define (minimum rbnode)(define (minimum-imp rbnode)(if (equal? (get-left rbnode) nil-node)rbnode(minimum-imp (get-left rbnode))))(minimum-imp rbnode))(define (maxmum rbnode)(define (maxmum-imp rbnode)(if (equal? (get-right rbnode) nil-node)rbnode(maxmum-imp (get-right rbnode))))(maxmum-imp rbnode)) (define (successor rbnode)(define (iter parent node)(if (and (not (equal? parent nil-node))(equal? (get-right parent) node))(iter (get-parent parent) parent)parent))(if (not (equal? (get-right rbnode) nil-node))(minimum (get-right rbnode))(iter (get-parent rbnode) rbnode))) (define (node-next rbnode)(display (get-key rbnode))(newline)(if (null? rbnode) '()(begin(let ((succ (successor rbnode)))(if (equal? succ nil-node) '() succ))))) (define (rbtree->array)(define (iter rbnode ret)(if (null? rbnode) ret(iter (node-next rbnode) (cons (get-val rbnode) ret))))(iter (minimum root) '())) (lambda (op . arg)(cond ((eq? op 'find) (rbtree-find (car arg)))((eq? op 'remove) (rbtree-remove (car arg)))((eq? op 'insert) (rbtree-insert (car arg) (cadr arg)))((eq? op 'size) size)((eq? op 'root) (get-key root))((eq? op 'tree->array-desc) (rbtree->array))((eq? op 'tree->array-asc) (reverse (rbtree->array)))(else "bad op")))))(define (default-cmp a b)(cond ((= a b) 0)((< a b) -1)(else 1)))(define r (make-rbtree default-cmp))(r 'insert 1 1)(r 'insert 4 4)(r 'insert 5 5)(r 'insert 11 11)(r 'insert 15 15)(r 'insert 8 8)(r 'insert 2 2)(r 'insert 3 3)(r 'insert 6 6)(r 'insert 7 7) )
)
