(package*
rbtree/v1.0.0
(provide:
(define-macro (define-rbtree
rbtree-init!
node->rbtree
insert!
remove!
reposition!
empty?
singleton?
before?
color
color-set!
parent
parent-set!
left
left-set!
right
right-set!
leftmost
leftmost-set!
rightmost
rightmost-set!)
(define (black rbtree) rbtree)
(define (black? rbtree) `(lambda (node) (,color node)))
(define (blacken! rbtree)
`(lambda (node) (,color-set! node ,(black rbtree))))
(define (red) #f)
(define (red?) `(lambda (node) (not (,color node))))
(define (reden!) `(lambda (node) (,color-set! node ,(red))))
(define (copy-color!)
`(lambda (node1 node2) (,color-set! node1 (,color node2))))
(define (exchange-color!)
`(lambda (node1 node2)
(let ((color-node1 (,color node1)))
(,color-set! node1 (,color node2))
(,color-set! node2 color-node1))))
(define (update-parent!)
`(lambda (parent-node old-node new-node)
(if (eq? old-node (,left parent-node))
(,left-set! parent-node new-node)
(,right-set! parent-node new-node))))
(define (rotate! side1 side1-set! side2 side2-set!)
`(lambda (node)
(let ((side2-node (,side2 node)))
(let ((side1-side2-node (,side1 side2-node)))
(,side2-set! node side1-side2-node)
(,parent-set! side1-side2-node node))
(let ((parent-node (,parent node)))
(,side1-set! side2-node node)
(,parent-set! node side2-node)
(,parent-set! side2-node parent-node)
(,(update-parent!) parent-node node side2-node)))))
(define (rotate-left!) (rotate! left left-set! right right-set!))
(define (rotate-right!) (rotate! right right-set! left left-set!))
(define (neighbor side other-side)
`(lambda (node rbtree)
(let ((side-node (,side node)))
(if (eq? side-node rbtree)
(let ((parent-node (,parent node)))
(if (or (eq? parent-node rbtree)
(eq? node (,side parent-node)))
rbtree
parent-node))
(let loop ((x side-node))
(let ((other-side-x (,other-side x)))
(if (eq? other-side-x rbtree) x (loop other-side-x))))))))
(define (insert-below! x)
`(let ((x ,x))
(if (,before? node x)
(insert-left! (,left x) x)
(insert-right! (,right x) x))))
(define (insert-body side1 rotate-side1! side2 rotate-side2!)
`(let ((side2-parent-parent-x (,side2 parent-parent-x)))
(if (,(red?) side2-parent-parent-x)
(begin
(,(blacken! 'rbtree) parent-x)
(,(blacken! 'rbtree) side2-parent-parent-x)
(,(reden!) parent-parent-x)
(loop parent-parent-x))
(let ((y (if (eq? x (,side2 parent-x))
(begin (,rotate-side1! parent-x) (,parent parent-x))
(,parent x))))
(,(blacken! 'rbtree) y)
(let ((parent-y (,parent y)))
(,(reden!) parent-y)
(,rotate-side2! parent-y))))))
(define (remove-body side1 rotate-side1! side2 rotate-side2!)
`(let ((x (let ((side2-parent-node (,side2 parent-node)))
(if (,(red?) side2-parent-node)
(begin
(,(blacken! 'rbtree) side2-parent-node)
(,(reden!) parent-node)
(,rotate-side1! parent-node)
(,side2 parent-node))
side2-parent-node))))
(define (common-case y)
(,(copy-color!) y parent-node)
(,(blacken! 'rbtree) parent-node)
(,(blacken! 'rbtree) (,side2 y))
(,rotate-side1! parent-node)
(,(blacken! 'rbtree) (,left rbtree)))
(if (,(red?) (,side2 x))
(common-case x)
(let ((side1-x (,side1 x)))
(if (,(black? 'rbtree) side1-x)
(begin
(,(reden!) x)
(fixup! (,parent parent-node) parent-node))
(begin
(,(blacken! 'rbtree) side1-x)
(,(reden!) x)
(,rotate-side2! x)
(common-case (,side2 parent-node))))))))
`(begin
(define (,rbtree-init! rbtree)
,@(if leftmost `((,leftmost-set! rbtree rbtree)) `())
(,(blacken! 'rbtree) rbtree)
(,parent-set! rbtree rbtree)
(,left-set! rbtree rbtree)
rbtree)
(define (,node->rbtree node) (or (,color node) (,color (,parent node))))
(define (,insert! rbtree node)
(define (fixup!)
(let loop ((x node))
(let ((parent-x (,parent x)))
(if (,(red?) parent-x)
(let ((parent-parent-x (,parent parent-x)))
(if (eq? parent-x (,left parent-parent-x))
,(insert-body
left
(rotate-left!)
right
(rotate-right!))
,(insert-body
right
(rotate-right!)
left
(rotate-left!)))))))
(,(blacken! 'rbtree) (,left rbtree))
#f)
(define (insert-left! left-x x)
(if (eq? left-x rbtree)
(begin
(,left-set! x node)
(,parent-set! node x)
,@(if leftmost
`((if (eq? x (,leftmost rbtree))
(,leftmost-set! rbtree node)))
`())
(fixup!))
,(insert-below! 'left-x)))
(define (insert-right! right-x x)
(if (eq? right-x rbtree)
(begin
(,right-set! x node)
(,parent-set! node x)
,@(if rightmost
`((if (eq? x (,rightmost rbtree))
(,rightmost-set! rbtree node)))
`())
(fixup!))
,(insert-below! 'right-x)))
(,(reden!) node)
(,left-set! node rbtree)
(,right-set! node rbtree)
(insert-left! (,left rbtree) rbtree)
(,parent-set! rbtree rbtree)
node)
(define (,remove! node)
(let ((rbtree (,node->rbtree node)))
(define (fixup! parent-node node)
(cond ((or (eq? parent-node rbtree) (,(red?) node))
(,(blacken! 'rbtree) node))
((eq? node (,left parent-node))
,(remove-body left (rotate-left!) right (rotate-right!)))
(else
,(remove-body right (rotate-right!) left (rotate-left!)))))
(let ((parent-node (,parent node))
(left-node (,left node))
(right-node (,right node)))
(,parent-set! node #f)
(,left-set! node #f)
(,right-set! node #f)
(cond ((eq? left-node rbtree)
,@(if leftmost
`((if (eq? node (,leftmost rbtree))
(,leftmost-set!
rbtree
(if (eq? right-node rbtree)
parent-node
right-node))))
`())
(,parent-set! right-node parent-node)
(,(update-parent!) parent-node node right-node)
(if (,(black? 'rbtree) node)
(begin
(,(reden!) node)
(fixup! parent-node right-node))))
((eq? right-node rbtree)
,@(if rightmost
`((if (eq? node (,rightmost rbtree))
(,rightmost-set! rbtree left-node)))
`())
(,parent-set! left-node parent-node)
(,(update-parent!) parent-node node left-node)
(,(reden!) node)
(fixup! parent-node left-node))
(else
(let loop ((x right-node) (parent-x node))
(let ((left-x (,left x)))
(if (eq? left-x rbtree)
(begin
(,(exchange-color!) x node)
(,parent-set! left-node x)
(,left-set! x left-node)
(,parent-set! x parent-node)
(,(update-parent!) parent-node node x)
(if (eq? x right-node)
(if (,(black? 'rbtree) node)
(begin
(,(reden!) node)
(fixup! x (,right x))))
(let ((right-x (,right x)))
(,parent-set! right-x parent-x)
(,left-set! parent-x right-x)
(,parent-set! right-node x)
(,right-set! x right-node)
(if (,(black? 'rbtree) node)
(begin
(,(reden!) node)
(fixup! parent-x right-x))))))
(loop left-x x)))))))
(,parent-set! rbtree rbtree)))
(define (,reposition! node)
(let* ((rbtree (,node->rbtree node))
(predecessor-node (,(neighbor left right) node rbtree))
(successor-node (,(neighbor right left) node rbtree)))
(if (or (and (not (eq? predecessor-node rbtree))
(,before? node predecessor-node))
(and (not (eq? successor-node rbtree))
(,before? successor-node node)))
(begin (,remove! node) (,insert! rbtree node)))))
(define (,empty? rbtree) (eq? rbtree (,left rbtree)))
(define (,singleton? rbtree)
(let ((root (,left rbtree)))
(and (not (eq? root rbtree))
(eq? (,left root) rbtree)
(eq? (,right root) rbtree)))))))
(maintainer: "Marc Feeley <feeley at iro.umontreal.ca>")
(author: "Marc Feeley <feeley at iro.umontreal.ca>")
(description: "Red-black trees.")
(keywords: data)
(license: lgpl/v2.1))