scheme 学习:红黑树

这几天继续学习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)    

)