問題3-26

これまで通り scheme でテーブルを実装するわけですけど，テーブルといっても 2次元ハッシュ(連想配列)としての話になっている．
今回は，それぞれの連想配列のキーを二分木にしてしまおうぜ!って問題だったのでした．

テーブル全体を1つの型で作ってしまおうとか考えていたので，まずはその型であるノードを作った．
とりあえず，キーと値と{左,右}部分木へのポインタさえ持たせればいいかな．

(define (make-node given-key given-value given-left-tree given-right-tree)
  (let ((key given-key)
	(value given-value)
	(left-tree given-left-tree)
	(right-tree given-right-tree))
    (define (set-value given-value)
      (set! value given-value))
    (define (set-left-tree tree)
      (begin (set! left-tree tree)
	     dispatch))
    (define (set-right-tree tree)
      (begin (set! right-tree tree)
	     dispatch))
    (define (dispatch m)
      (cond ((eq? m 'get-key) key)
	    ((eq? m 'get-value) value)
	    ((eq? m 'get-left-tree) left-tree)
	    ((eq? m 'get-right-tree) right-tree)
	    ((eq? m 'set-value) set-value)
	    ((eq? m 'set-left-tree) set-left-tree)
	    ((eq? m 'set-right-tree) set-right-tree)
	    (else (error "Unknown operation - TABLE" m ))))
    dispatch))

次に実際にテーブルを作る．

(define (make-binaty-tree-table)
  (let ((local-table (make-node "*table*" '() '() '())))
    (define (assoc key node prev-node)
      (cond ((null? node) 
	     (cons #f prev-node))
	    ((equal? key (node 'get-key))
	     (cons #t node))
	    ((string<? key (node 'get-key))
	     (assoc key (node 'get-left-tree) node))
	    (else
	     (assoc key (node 'get-right-tree) node))))

    (define (append-tree node tree)
      (let ((node-key (node 'get-key))
	    (tree-key (tree 'get-key)))
	(if (string<? tree-key node-key)
	    ((node 'set-left-tree) tree)
	    ((node 'set-right-tree) tree))))

    (define (lookup key-1 key-2)
      (let ((luresult-1 (assoc key-1 (local-table 'get-value) local-table)))
        (if (car luresult-1)
            (let ((luresult-2 (assoc key-2 
				     ((cdr luresult-1) 'get-value)
				     (cdr luresult-1))))
              (if (car luresult-2)
		  ((cdr luresult-2) 'get-value)
                  #f))
	    #f)))

    (define (insert! key-1 key-2 value)
      (let ((luresult-1 (assoc key-1 (local-table 'get-value) local-table)))
        (if (car luresult-1)
            (let ((luresult-2 (assoc key-2 
				     ((cdr luresult-1) 'get-value)
				     (cdr luresult-1))))
              (if (car luresult-2)
		  (((cdr luresult-2) 'set-value) value)
		  (append-tree (cdr luresult-2)
			       (make-node key-2 value '() '()))))
	    (let ((new-table (make-node key-1
					(make-node key-2 value '() '())
					'()
					'())))
	      (if (null? (local-table 'get-value))
		  ((local-table 'set-value) new-table)
		  (append-tree (cdr luresult-1) new-table))))
	'ok))

    (define (dispatch m)
      (cond ((eq? m 'lookup) lookup)
            ((eq? m 'insert!) insert!)
	    ((eq? m 'print) (print local-table))
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

あとはヘルパ関数的なのを用意しとけばいいんだと思いました．

(define table (make-binaty-tree-table))
(define (insert! key-1 key-2 value)
  ((table 'insert!) key-1 key-2 value))
(define (lookup key-1 key-2)
  ((table 'lookup) key-1 key-2))

てすてす．

(insert! "abc" "def" 6)     # ok
(insert! "bcd" "aaa" 10)    # ok
(lookup "abc" "def")        # 6
(lookup "bcd" "aaa")        # 10
(insert! "abc" "hik" 22)    # ok
(lookup "abc" "hik")        # 22
(insert! "abc" "lll" 3000)  # ok
(lookup "abc" "lll")        # 3000