問題3.26(後)

sicp

3.26(後)

一個前のエントリの続きです。
今回は表の中の二進木の構造を、バランス木として保持するように変更します。
バランス木として保持しないと、木の深さが表の深さと同じになってしまったりした場合に計算量がリストで保持している時と同じになってしまい、意味がなくなってしまうからです。
SICP p.92にこの問題の解決法が載っています。

この問題を解決する一つの方法は、任意の木を同じ要素を持つ釣合った木に変換する演算を定義することである。
(中略)
この問題の別の解決法の大部分は、探索と挿入が共に$\Theta(\log{n})$ステップで出来る新しいデータ構造を設計することだ。


今回は二進木を使いたいので、前者の演算を定義します。
(後者はB木とかを使うらしいです。)
次のp.92-93の問題2.63及び2.64で、順序づけられたtreeを昇順のlistに変換する手続き、及び順序づけられたリストをin-orderでバランス木に変換する手続きが載っているので、なんか二度手間のような気もするけど、一回リストにバラしてからバランス木に再編するという方法を採ります。


昨日の雑なコードを若干整形しました。
でももうちょっと抽象をうまくできるような気がします。でも疲れたのでやりません。


まず、表の見出しであるtableは今までどおりkeyと表へのポインタの対で与えます(make-local-table)。だから、tableのcdrは二進木のルートを指します。
recordもkeyとvalueの対で構成します。
次に、二進木は二つの対で構成することにします。
一つ目の対はcarがleft-branch,cdrはもう一つ目の対を指します。
二つ目の対はcarがrecord,cdrがright-branchを指します。
二進木はtree-recordがtableなら、tableのkeyによってin-orderに順序づけられた二進木となるようにinsert!します。
tree-recordがrecordならば、recordのkeyによって順序づけられた二進木となります。

(tree-recordがrecordなのかtableなのかについては、与えられたkey-listにkey-listの次元情報をくっつけているため、key-listの次元をnとすれば、そのkey-listによって対応付けられるレコードまで到達するにはn個のtableを必ず経由することになります。なので、あるtableから指されている二進木の中において、そのtree-recordにrecordとtableが混在することは絶対にないことになります。)


次に各内部手続きについて。
b-assocはあるtableが指す二進木について、keywordと一致するkeyを二進木のtree-recordから探し、見つかったらそのtree-recordを、見つからなかったらfalseを返します。
insert!は表への追加です。
insert!中で使っているmake-new-record!は、b-assocがfalseを返したら現在のtableとkey-listを渡し、新しいレコードを作ります。
b-assocが最後までfalseを返さないときは既に値が存在するので、insert!中でrecordにset-cdr!して値を上書きします。
lookupはkey-listに一致する値を返し、それ以外はfalse。dispは見たまま。
tree->list, list->treeもそのまま。
ただし、tree->listは順序づけられたtreeをin-order順序でリストにし、list->treeは順序づけられたlistをin-orderでtreeに変換します。
最後、to-balance-tree!は、tree->listとlist->treeを使って現在のlocal-tableとそれにくっつく全ての二進木をバランス木に変換します。

(define (make-table)
  (let ((local-table (cons '**table** '()))
        (insert-count 0)
        (lookup-count 0))
    (define (make-local-table keyword) (cons keyword '()))
    
    (define (make-record key value) (cons key value))
    (define (record? x)
      (if (null? x)
          false
          (if (pair? x)
              (not (pair? (cdr x)))
              false)))
    (define (key record) (car record))
    (define (value record) (cdr record))
    
    (define (make-b-tree left record right) (cons left (cons record right)))
    (define (tree? x) 
      (if (null? x)
          false
          (and (pair? x) (pair? (cdr x)))))
    (define (left-branch tree) (car tree))
    (define (tree-record tree) (cadr tree))
    (define (right-branch tree) (cddr tree))
    (define (set-left-branch! tree new) (set-car! tree new))
    (define (set-tree-record tree new) (set-car! (cdr tree) new))
    (define (set-right-branch! tree new) (set-cdr! (cdr tree) new))
    
    (define small? <)
    (define big? >)
    (define same? =)
    
    (define (add-dimention key-list) (cons (length key-list) key-list))
    
    (define (b-assoc keyword tree)
      (set! lookup-count (+ lookup-count 1))
      (if (null? tree)
          false
          (cond ((small? keyword (key (tree-record tree)))
                 (if (null? (left-branch tree))
                     false
                     (b-assoc keyword (left-branch tree))))
                ((big? keyword (key (tree-record tree)))
                 (if (null? (right-branch tree))
                     false
                     (b-assoc keyword (right-branch tree))))
                ((same? keyword (key (tree-record tree)))
                 (tree-record tree))
                (else
                 (error "the keyword is not ordered" keyword)))))
    
    (define (insert! key-list value table)
      (let ((subtable (b-assoc (car key-list) (cdr table))))
        (if subtable
            (if (null? (cdr key-list))
                (set-cdr! subtable value)
                (insert! (cdr key-list) value subtable))
            (make-new-record! key-list value table))))
    
    (define (make-new-record! key-list value table)
      (define (make-new-table-in-tree keyword tree)
        (cond ((small? keyword (key (tree-record tree)))
               (if (null? (left-branch tree))
                   (begin (set-left-branch! tree
                                            (make-b-tree '()
                                                         (make-local-table keyword)
                                                         '()))
                          (tree-record (left-branch tree)))
                   (make-new-table-in-tree keyword (left-branch tree))))
              ((big? keyword (key (tree-record tree)))
               (if (null? (right-branch tree))
                   (begin (set-right-branch! tree
                                             (make-b-tree '()
                                                          (make-local-table keyword)
                                                          '()))
                          (tree-record (right-branch tree)))
                   (make-new-table-in-tree keyword (right-branch tree))))
              (else
               (error "the key is not ordered, or make-new-record! is used in bad area" keyword))))
      (if (null? (cdr table))
          (if (null? (cdr key-list))
              (set-cdr! table (make-b-tree '() (make-record (car key-list) value) '()))
              (begin 
                (set-cdr! table (make-b-tree '() (make-local-table (car key-list)) '()))
                (make-new-record! (cdr key-list) value (tree-record (cdr table)))))
          (let ((subtable (make-new-table-in-tree (car key-list) (cdr table))))
            (if (null? (cdr key-list))
                (set-cdr! subtable value)
                (make-new-record! (cdr key-list) value subtable)))))                
    
    (define (lookup key-list table)
      (cond ((null? (cdr key-list))
             (let ((record (b-assoc (car key-list) (cdr table))))
               (if record (value record) false)))
            (else
             (let ((subtable (b-assoc (car key-list) (cdr table))))
               (if subtable (lookup (cdr key-list) subtable) false)))))
    (define (disp) local-table)
    (define (tree->list tree)
      (define (copy-to-list tree result-list)
        (if (null? tree)
            result-list
            (copy-to-list (left-branch tree)
                          (cons (tree-record tree)
                                (copy-to-list (right-branch tree)
                                              result-list)))))
      (copy-to-list tree '()))
    
    (define (list->tree elements)
      (define (partial-tree elts n)
        (if (= n 0)
            (cons '() elts)
            (let ((left-size (quotient (- n 1) 2)))
              (let ((left-result (partial-tree elts left-size)))
                (let ((left-tree (car left-result))
                      (non-left-elts (cdr left-result))
                      (right-size (- n (+ left-size 1))))
                  (let ((this-record (car non-left-elts))
                        (right-result (partial-tree (cdr non-left-elts)
                                                    right-size)))
                    (let ((right-tree (car right-result))
                          (remaining-elts (cdr right-result)))
                      (cons (make-b-tree left-tree this-record right-tree)
                            remaining-elts))))))))
      (car (partial-tree elements (length elements))))
    
    (define (to-balance-tree! table)
      (define (iter tree)
        (to-balance-tree! (tree-record tree))
        (if (not (null? (left-branch tree)))
            (iter (left-branch tree)))
        (if (not (null? (right-branch tree)))
            (iter (right-branch tree))))
      (let ((tree-lst (tree->list (cdr table))))
        (set-cdr! table (list->tree tree-lst))
        (if (and (tree? (cdr table))
                 (not (record? (tree-record (cdr table)))))
            (iter (cdr table)))))
    
    (define (dispatch m)
      (cond ((eq? m 'insert!)
             (lambda (x y) (begin (set! insert-count (+ insert-count 1))
                                  (insert! (add-dimention x) y local-table)
                                  (if (= insert-count 10)
                                      (begin (to-balance-tree! local-table)
                                             (set! insert-count 0))))))
            ((eq? m 'lookup)
             (lambda (x) (lookup (add-dimention x) local-table)))
            
            ((eq? m 'lookup-count)
             (lambda (x) (begin (set! lookup-count 0)
                                (let ((result (lookup (add-dimention x) local-table)))
                                  (print result)
                                  (newline)
                                  lookup-count))))
            ((eq? m 'disp) disp)
            (else
             (error "Unknown operation -- LOCAL-TABLE" m))))
    dispatch))

(define t (make-table))
((t 'insert!) '(1 2 3) 'a)
((t 'insert!) '(1 2 4) 'b)

...(略)

((t 'insert!) '(1 2 28) 'z)
((t 'insert!) '(1 2 29) 'aa)
((t 'insert!) '(1 2 30) 'bb)
((t 'insert!) '(1 2 31) 'cc)
((t 'insert!) '(1 2 32) 'dd)


> ((t 'lookup-count) '(1 2 31))
cc
7
> ((t 'lookup-count) '(1 2 32))
dd
8
> ((t 'lookup-count) '(1 2 3))
a
7
> ((t 'lookup-count) '(1 2 10))
h
8
> ((t 'lookup-count) '(1 2 17))
o
4
> ((t 'lookup-count) '(1 2 23))
u
7
> ((t 'disp))
(**table**
  ()
  (3
   ()
   (1
    ()
    (2
     (((() (3 . a) () (4 . b)) (5 . c) (() (6 . d)) (7 . e) () (8 . f))
      (9 . g)
      ((() (10 . h)) (11 . i) () (12 . j))
      (13 . k)
      (() (14 . l))
      (15 . m)
      ()
      (16 . n))
     (17 . o)
     (((() (18 . p)) (19 . q) () (20 . r)) (21 . s) (() (22 . t)) (23 . u) () (24 . v))
     (25 . w)
     ((() (26 . x)) (27 . y) () (28 . z))
     (29 . aa)
     (() (30 . bb))
     (31 . cc)
     ()
     (32 . dd)))))

本当にバランス木となっているか確かめるため、とりあえず30個のレコードを作成しました。
木をバランス木に変換するのは、insert!が10回呼び出されたらという設定にしているので、今回はほぼバランス木になっているはずです。
まず、分かり易くするため、全てのレコードのkey-listを(key-list:(1 2 n))(n = 3, 4, ..., 32)として同一テーブルが指す二進木として保持することにします。
このテーブルがバランス木になっていれば、次元キーが1、第1キーが1、第2キーも1、第3キーは30個なので、lookupによる走査のステップは高々$1+1+1+\lfloor \log_2{30} + 1 \rfloor=8$となるはずです。
lookup-countをいろいろな値で実行すると、そのようになっていることが分かります。


あまりいろいろ試してないのでもしかしたら間違ってるところがあるかもしれないですが、だいたいできたように思います。
多次元表結構便利かもしれないので暇な時に弄ろうと思います。


(12/20 7:35 追記)
いろいろ試してみましたが、レコードの値として対やリストが与えられると上手く動かないですね。
レコードの値として二進木と同じ形のデータが与えられたら、それがtableだと判断してしまうからだと思われます。
これは、tableである対のcarを(table label)のようにして、tableというタグ付けをし、これによってtreeであるかtableであるかの判定をするようにすれば解決すると思います。今はあまりやる気がないのでやりません。
あと、5000個くらいのデータを与えてlookupを試してみましたが、ちゃんと十数回のステップで目的のレコードに辿りつくことが分かりました($\log_2{5000} < 13$なので平均的なデータを与えれば十数回のステップでokなはずです)。