赤黒木 (2)
とりあえず get の実装から確認を。
(define (rbtree-get tree key . arg)
(guarantee-rbtree tree)
(or (and-let* ((node (get-node tree key))
( (not (nil? node)) ))
(ref node 'value))
(get-optional arg (error "red-black tree doesn't have an entry for key" key))))テスト見たら失敗する試験しか無いんですね。
ええと ref って手続きがよく分からんのですが、その前に get-node という直下で定義されてる手続き確認した方が良さげ。
(define (get-node tree key)
(let ((key=? (ref tree 'key=?))
(key<? (ref tree 'key<?)))
(let loop ((node (root-of tree)))
(cond ((nil? node) node)
((key<? key (ref node 'key)) (loop (left node)))
((key=? key (ref node 'key)) node)
(else (loop (right node)))))))む、(ref tree 'key=?) みたいなことしてますね。そもそも make-rbtree 見てみた方が良いのか。
(define (make-rbtree key=? key<?) (make <rbtree> :key=? key=? :key<? key<?))
む、node てクラスも定義されてますね。get-node な実装によれば (root-of tree) で node が戻るのかな。root-of は rbtree なクラス定義で記述がありました。クラス定義も引用しておきます。
(define-class <rbtree> (<collection>)
((key=? :init-keyword :key=?
:init-form (error "must supply :key=? keyword"))
(key<? :init-keyword :key<?
:init-form (error "must supply :key<? keyword"))
(root :init-keyword :root
:init-value nil
:accessor root-of))
:metaclass <rbtree-meta>)rbtree の root という属性 (?) を戻すのかどうなのか。つうかよくよく見たら get-node は二分木を単純に探索してるだけですね。やっぱ赤黒木は put する操作がポイントなのに違いない。
とは言え、left とか right とかも微妙に謎。あ、node の属性なのか。node の定義も確認。
(define-class <node> ()
((key :init-keyword :key)
(value :init-keyword :value)
(parent :init-keyword :parent
:init-value nil
:accessor parent)
(color :init-keyword :color
:accessor color)
(left :init-keyword :left
:init-value nil
:accessor left)
(right :init-keyword :right
:init-value nil
:accessor right)))親ノードへのポインタも持っているんですね。基本的にクラスの属性へのアクセスは ref を使って云々、という理解で良いのかな。
(define (black? node)
(or (nil? node)
(eq? (ref node 'color) 'black)))
(define (red? node)
(and (not (nil? node))
(eq? (ref node 'color) 'red)))黒は nil でも良いのか。逆に赤 node は末端には来ない模様。
とゆーことで
核心は rbtree-put! 手続きなのか。
(define (rbtree-put! tree key val)
(guarantee-rbtree tree)
(let* ((key=? (ref tree 'key=?))
(key<? (ref tree 'key<?)))
(let loop ((x (root-of tree)) (y nil))
(cond ((not (nil? x))
(cond ((key=? key (ref x 'key))
(set! (ref x 'value) val))
((key<? key (ref x 'key))
(loop (left x) x))
(else (loop (right x) x))))
((nil? y) ; tree was empty
(set! (root-of tree)
(make <node> :key key :value val :color 'black)))
(else
(let1 node (make <node> :key key :value val :color 'red :parent y)
(if (key<? key (ref y 'key))
(set! (left y) node)
(set! (right y) node))
(put-fixup! tree node)))))))んーと、else なソレは x が nil で y には親がセットされてる形なのか。基本的に rbtree-put! では木を手繰って末端に赤 node を追加しとるの?
どちらかというと put-fixup! の方がアレなのかな。あら、でも x が nil ではないケイスが? って思ったら key=? のケイスだと値がそのまま設定されるのか。
うーん、put-fixup! に渡される tree は node が末端なノードの y の右だか左だかに追加されたソレ、という理解で良いのかな。つうことで核心は put-fixup! になりますね。
put-fixup! 手続き
ええと、ちょっとずつ確認。
(define (put-fixup! tree z)
(let loop ((z z))
(when (red? (parent z))
(let* ((b (eq? (parent z) (left (parent (parent z)))))
(y (right* (parent (parent z)) b)))z は上で見た通り、赤な node になるので親が赤なら云々なのか。ええと、まず b なんですが、z の親と z の親の親の左が同じ、ということは
b
|
+--+--+
| |
a c
|
+--+--+
|
zこうなってると b が真になるのか。逆に以下なら偽なのか。
b
|
+--+--+
| |
c a
|
+--+--+
|
zちなみに (parent z) と z の位置は不問らしい。あと、y に代入されるソレもナニ。
(y (right* (parent (parent z)) b)))
まず、right* が何に束縛されてるか、という事なんですが定義が以下。
(define right*
(getter-with-setter
(lambda (node not-invert?)
(if not-invert? (right node) (left node)))
(lambda (node not-invert? val)
(if not-invert?
(set! (right node) val)
(set! (left node) val)))))getter-with-setter が戻すのは第一引数な手続きとのこと (http://practical-scheme.net/gauche/man/gauche-refj_25.html)。
(lambda (node not-invert?)
(if not-invert? (right node) (left node)))node には (parent (parent z)) が、not-invert? には b の値が渡されるのですがこの手続きが戻すのは z の親ではない方の node になるんですね。
つうかこれ、机上 (?) で手続き見ながらどんな木ができるかを確認した方が良さげなカンジがしてきました。
試験を確認
関係してそうな部分のみ引用。
(test* "make-rbtree" #t
(begin (set! tree1 (make-rbtree = <))
(rbtree? tree1)))
(test* "rbtree-put!" "0"
(begin (rbtree-put! tree1 0 "0")
(rbtree-get tree1 0)))
(test* "rbtree-put!" '("0" "1")
(begin (rbtree-put! tree1 1 "1")
(list (rbtree-get tree1 0)
(rbtree-get tree1 1))))
(test* "rbtree-put!" 'bar
(begin (rbtree-put! tree1 2 'foo)
(rbtree-put! tree1 2 'bar)
(rbtree-get tree1 2)))最初の rbtree-put! で以下なイメージなはず。
((:key 0) (:value "0") (:color 'black) (:parent nil))
無論、left も right も nil です。で、次の (rbtree-put! tree1 1 "1") でどうなるか、というと
(else (loop (right x) x))))
を通過して cond な条件分岐の else なブロックを評価するのか。つうことは
((:key 0) (:value "0") (:color 'black) (:parent nil) (:left nil) (:right ((:key 1) (:value "1") (:color 'red) (:parent 略) (:left nil) (:right nil))))
になるんですが、これが put-fixup! に渡るのか。親は赤ではないのでこのままスルーだな。次に (rbtree-put! tree1 2 'foo) したらどうなるのか。これも key が 1 の右に挿入されるのか。
((:key 0) (:value "0") (:color 'black) (:parent nil)
(:left nil)
(:right ((:key 1) (:value "1") (:color 'red) (:parent 略)
(:left nil)
(:right ((:key 2) (:value "2") (:color 'red) (:parent 略)
(:left nil)
(:right nil))))))これは赤連続してて明らかに微妙。ここで put-fixup! が仕事をするのかな。このケイスだと (when (red? (parent z)) は真ですね。で
(let* ((b (eq? (parent z) (left (parent (parent z)))))
(y (right* (parent (parent z)) b)))がどうなるかというと、b は偽で y は root (node の親の親) の左の nil な要素になるので赤ではないですね。以下なブロックが評価されるのか。
(let1 z (if (eq? z (right* (parent z) b))
(begin0 (parent z)
(left-rotate! tree (parent z) b))
z)
(paint-black! (parent z))
(paint-red! (parent (parent z)))
(right-rotate! tree (parent (parent z)) b))))))let1 で z に束縛されるのは z または z の親か。z はさっき追加された 2 が key の要素のはず。b は偽なので if の条件式は偽になります。つうことは z はそのまんまか。
で、順に
- z の親が黒になる
- z の親の親 (root-node) が赤になる
- right-rotate! 手続き呼び出し
ということになるんですが、親が赤、は仕様てきにあり得んはず。
うう
Gauche てきに rbtree がどんな表現なのかを確認した方が良いかも。
とゆーことで確認してみます。
$ gosh
gosh> (add-load-path ".")
("." "/usr/share/gauche-0.9/site/lib" "/usr/share/gauche-0.9/0.9.1/lib" "/usr/share/gauche/site/lib" "/usr/share/gauche/0.9/lib")
gosh> (use util.rbtree)
#<undef>
gosh> (define tree #f)
tree
gosh> (set! tree (make-rbtree = <))
#<<rbtree> 0x1e9a5e0>
gosh> (rbtree-put! tree 0 "0")
#<undef>
gosh> (ref tree 'root)
#<<node> 0x1e9a140>
gosh> (ref (ref tree 'root) 'key)
0
gosh> (ref (ref tree 'root) 'value)
"0"
gosh> (ref (ref tree 'root) 'parent)
#:nil-4
gosh> (ref (ref tree 'root) 'color)
black
gosh> (ref (ref tree 'root) 'left)
#:nil-4
gosh> (ref (ref tree 'root) 'right)
#:nil-4
gosh> (rbtree-put! tree 1 "1")
#<undef>
gosh> (ref (ref tree 'root) 'key)
0
gosh> (ref (ref tree 'root) 'value)
"0"
gosh> (ref (ref tree 'root) 'parent)
#:nil-4
gosh> (ref (ref tree 'root) 'color)
black
gosh> (ref (ref tree 'root) 'right)
#<<node> 0x1ea3ce0>
gosh> (rbtree-put! tree 1 "1")
#<undef>
gosh>右側に追加されてます。一応トレイスしたナニと同じですね。中身確認。
gosh> (ref (ref (ref tree 'root) 'right) 'key) 1 gosh> (ref (ref (ref tree 'root) 'right) 'value) "1" gosh> (ref (ref (ref tree 'root) 'right) 'parent) #<<node> 0x1e9a140> gosh> (ref (ref (ref tree 'root) 'right) 'color) red gosh> (ref (ref (ref tree 'root) 'right) 'right) #:nil-4 gosh> (ref (ref (ref tree 'root) 'right) 'left) #:nil-4 gosh>
親は root-node ですね。次が問題。
gosh> (rbtree-put! tree 2 'foo) #<undef> gosh> (ref (ref tree 'root) 'right) #<<node> 0x1eac1f0> gosh> (ref (ref tree 'root) 'left) #<<node> 0x1e9a140> gosh>
平衡になっているのが分かります。
gosh> (ref (ref tree 'root) 'key) 1 gosh> (ref (ref (ref tree 'root) 'right) 'key) 2 gosh> (ref (ref (ref tree 'root) 'left) 'key) 0 gosh>
今日はスデに限界気味なんですが、これを元にもう少し確認してみるかもしれません。とりあえずエントリ投入。
