; red-black trees
(define (tree c k v l r) (vector c k v l r))
(define empty (tree 'black 'nil 'nil 'nil 'nil))
(define (empty? t) (eqv? t empty))
(define (color t) (vector-ref t 0))
(define (key t) (vector-ref t 1))
(define (value t) (vector-ref t 2))
(define (lkid t) (vector-ref t 3))
(define (rkid t) (vector-ref t 4))
(define (red? c) (eqv? c 'red))
(define (black? c) (eqv? c 'black))
(define (lookup lt? t k)
(cond ((empty? t) #f)
((lt? k (key t)) (lookup lt? (lkid t) k))
((lt? (key t) k) (lookup lt? (rkid t) k))
(else (cons (key t) (value t)))))
(define (insert lt? t k v)
(define (ins t)
(cond ((empty? t) (tree 'red k v empty empty))
((lt? k (key t))
(balance (color t) (key t) (value t) (ins (lkid t)) (rkid t)))
((lt? (key t) k)
(balance (color t) (key t) (value t) (lkid t) (ins (rkid t))))
(else (tree (color t) k v (lkid t) (rkid t)))))
(let ((z (ins t)))
(tree 'black (key z) (value z) (lkid z) (rkid z))))
(define (balance c k v l r)
(cond ((and (black? c) (red? (color l)) (red? (color (lkid l))))
(tree 'red (key l) (value l)
(tree 'black (key (lkid l)) (value (lkid l))
(lkid (lkid l)) (rkid (lkid l)))
(tree 'black k v (rkid l) r)))
((and (black? c) (red? (color l)) (red? (color (rkid l))))
(tree 'red (key (rkid l)) (value (rkid l))
(tree 'black (key l) (value l) (lkid l) (lkid (rkid l)))
(tree 'black k v (rkid (rkid l)) r)))
((and (black? c) (red? (color r)) (red? (color (lkid r))))
(tree 'red (key (lkid r)) (value (lkid r))
(tree 'black k v l (lkid (lkid r)))
(tree 'black (key r) (value r) (rkid (lkid r)) (rkid r))))
((and (black? c) (red? (color r)) (red? (color (rkid r))))
(tree 'red (key r) (value r)
(tree 'black k v l (lkid r))
(tree 'black (key (rkid r)) (value (rkid r))
(lkid (rkid r)) (rkid (rkid r)))))
(else (tree c k v l r))))
(define (enlist t)
(let enlist ((t t) (xs '()))
(cond ((empty? t) xs)
((and (empty? (lkid t)) (empty? (rkid t)))
(cons (cons (key t) (value t)) xs))
(else (enlist (lkid t)
(cons (cons (key t) (value t))
(enlist (rkid t) xs)))))))
(define t
(insert <
(insert <
(insert <
(insert <
(insert <
empty
2 "b")
5 "e")
3 "c")
4 "d")
1 "a"))
(display (lookup < t 7)) (newline)
(display (lookup < t 4)) (newline)
(display (enlist t)) (newline)