/usr/lib/rb-tree.scm is in scheme9 2013.11.26-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; Placed in the Public Domain
;
; (make-rbt procedure) ==> rb-tree
; (rbt-find rb-tree object) ==> object | #f
; (rbt-insert rb-tree object1 object2) ==> rb-tree
; (rbt-rebuild rb-tree object) ==> rb-tree
; (rbt-remove rb-tree object) ==> rb-tree
;
; These procedures implement Red-Black Trees.
;
; MAKE-RBT returns an empty tree that uses PROCEDURE as an ordering
; predicate. If you plan, for instance, to use strings as keys, use
; STRING<? as a predicate.
;
; RBT-FIND locates the value associated with the key OBJECT in the
; given RB-TREE and returns it. When the key is not contain in the
; tree, it returns #F.
;
; RBT-INSERT returns a new rb-tree with OBJECT2 inserted into Rb-TREE
; under the key OBJECT1.
;
; RBT-REBUILD rebuilds the given tree and returns it. The original
; tree remains unchanged.
;
; RBT-REMOVE creates a new tree from RB-TREE with the key OBJECT
; removed. In fact, this procedure only marks the key as "inactive",
; i.e. it is left in the tree, but cannot be found any longer. To
; remove inactive nodes, use RBT-REBUILD.
;
; Example: (let ((tree (fold-left
; (lambda (t k)
; (rbt-insert t k (make-string k #\x)))
; (make-rbt <)
; '(1 2 3 4 5 6 7))))
; (rbt-find tree 5)) ==> "xxxxx"
(load-from-library "hof.scm")
(load-from-library "package.scm")
(load-from-library "matcher.scm")
(load-from-library "define-structure.scm")
(define-structure rbt-type pred data)
(define-matcher rbt-balance
(('black v1 ; Bv1
('red v2 ; / \
('red v3 l3 r3) ; Rv2 r1
r2) ; / \
r1) ; Rv3 r2
=> `(red ,v2 ; / \
(black ,v3 ,l3 ,r3) ; l3 r3
(black ,v1 ,r2 ,r1)))
(('black v1 ; Bv1
l1 ; / \
('red v2 ; l1 Rv2
l2 ; / \
('red v3 l3 r3))) ; l2 Rv3
=> `(red ,v2 ; / \
(black ,v1 ,l1 ,l2) ; l3 r3
(black ,v3 ,l3 ,r3)))
(('black v1 ; Bv1
('red v2 ; / \
l2 ; Rv2 r1
('red v3 l3 r3)) ; / \
r1) ; l2 Rv3
=> `(red ,v3 ; / \
(black ,v2 ,l2 ,l3) ; l3 r3
(black ,v1 ,r3 ,r1)))
(('black v1 ; Bv1
l1 ; / \
('red v2 ; l1 Rv2
('red v3 l3 r3) ; / \
r2)) ; Rv3 r2
=> `(red ,v3 ; / \
(black ,v1 ,l1 ,l3) ; l3 r3
(black ,v2 ,r3 ,r2)))
(tree
=> tree))
(package red-black-tree
(:import make-rbt-type
rbt-type-pred
rbt-type-data
rbt-balance)
(:export rbt-insert
rbt-remove
rbt-rebuild
rbt-find
make-rbt)
(:make-aliases)
(define (make-rbt pred)
(make-rbt-type pred '()))
(define (make-rb-tree color key value left right active)
(list color (list key value active) left right))
(define rbt-color car)
(define rbt-key caadr)
(define rbt-value cadadr)
(define rbt-active (compose car cddadr))
(define rbt-left caddr)
(define rbt-right cadddr)
(define (find tree p x)
(cond ((null? tree) #f)
((p x (rbt-key tree))
(find (rbt-left tree) p x))
((p (rbt-key tree) x)
(find (rbt-right tree) p x))
((rbt-active tree)
(rbt-value tree))
(else
#f)))
(define (rbt-find rbt x)
(find (rbt-type-data rbt)
(rbt-type-pred rbt)
x))
(define (insert tree p k v)
(letrec
((ins
(lambda (tree)
(cond ((null? tree)
(make-rb-tree 'red k v '() '() #t))
((p k (rbt-key tree))
(rbt-balance
(make-rb-tree
(rbt-color tree)
(rbt-key tree)
(rbt-value tree)
(ins (rbt-left tree))
(rbt-right tree)
#t)))
((p (rbt-key tree) k)
(rbt-balance
(make-rb-tree
(rbt-color tree)
(rbt-key tree)
(rbt-value tree)
(rbt-left tree)
(ins (rbt-right tree))
#t)))
(else
(make-rb-tree
(rbt-color tree)
k
v
(rbt-left tree)
(rbt-right tree)
#t))))))
(let ((new (ins tree)))
(make-rb-tree 'black
(rbt-key new)
(rbt-value new)
(rbt-left new)
(rbt-right new)
#t))))
(define (rbt-insert rbt k v)
(make-rbt-type (rbt-type-pred rbt)
(insert (rbt-type-data rbt)
(rbt-type-pred rbt)
k
v)))
(define (rebuild tree p)
(letrec
((reb
(lambda (in out)
(cond ((null? in) out)
((rbt-active in)
(let* ((out (reb (rbt-left in) out))
(out (insert out p (rbt-key in) (rbt-value in)))
(out (reb (rbt-right in) out)))
out))
(else
(let* ((out (reb (rbt-left in) out))
(out (reb (rbt-right in) out)))
out))))))
(reb tree '())))
(define (rbt-rebuild rbt)
(make-rbt-type (rbt-type-pred rbt)
(rebuild (rbt-type-data rbt)
(rbt-type-pred rbt))))
(define (remove tree p x)
(letrec
((rem
(lambda (tree)
(cond ((null? tree)
tree)
((p x (rbt-key tree))
(make-rb-tree
(rbt-color tree)
(rbt-key tree)
(rbt-value tree)
(rem (rbt-left tree))
(rbt-right tree)
#t))
((p (rbt-key tree) x)
(make-rb-tree
(rbt-color tree)
(rbt-key tree)
(rbt-value tree)
(rbt-left tree)
(rem (rbt-right tree))
#t))
(else
(make-rb-tree
(rbt-color tree)
(rbt-key tree)
(rbt-value tree)
(rbt-left tree)
(rbt-right tree)
#f))))))
(rem tree)))
(define (rbt-remove rbt x)
(make-rbt-type (rbt-type-pred rbt)
(remove (rbt-type-data rbt)
(rbt-type-pred rbt)
x))))
|