SICP問題3.26

内部の表を順序付けられていないリスト表現から二進木での表現に変更する
二進木での表現は2.3.3節辺りを参考に。
2.3.3節での二進木の表現では (entry left right)だったのを(record left right)にする。
record は (識別子 . entry) とし、entry が値の場合は('value . 値), entryがツリーの場合は ('tree . 次の階層のツリーへのポインタ)として実装する

(define (make-table)
  (let ((local-table (list '*table )))
    (define (make-record key entry)
      (cons key entry))
    (define (make-value-record key value)
      (make-record key (cons 'value value)))
    (define (make-tree-record key tree)
      (make-record key (cons 'tree tree)))

    (define (rec-key record) (car record))
    (define (rec-body record) (cdr record))
    (define (rec-label record) (car (rec-body record)))
    (define (rec-entry record) (cdr (rec-body record)))

    (define (record tree) (car tree))
    (define (left-branch tree) (cadr tree))
    (define (right-branch tree) (caddr tree))

    (define (make-tree record left right)
      (list record left right))
    (define (set-left-branch! tree left)
      (set-cdr! tree (list (right-branch tree) left))
      )
    (define (set-right-branch! tree right)
      (set-cdr! tree (list right (left-branch tree)))
      )
    (define (set-record! tree new-record)
      (set-car! tree new-record))

    (define (tree-record? record)
      (eq? 'tree (rec-label record)))
    (define (value-record? record)
      (eq? 'value (rec-label record)))

    (define key-lt? <)
    (define key-gt? >)
    (define key-eq? =)

    (define (local-assoc key tree)
      (cond ((null? tree) #f)
            ((key-eq? key (rec-key (record tree)))
             tree)
            ((key-gt? key (rec-key (record tree)))
             (local-assoc key (left-branch tree)))
            ((key-lt? key (rec-key (record tree)))
             (local-assoc key (right-branch tree)))
            (else #f)))

    (define (lookup-iter key-list tree)
      (if (null? key-list)
          #f
          (let ((match-tree (local-assoc (car key-list) tree)))
            (if match-tree
                (if (null? (cdr key-list))
                    match-tree
                    (if (tree-record? (record match-tree))
                        (lookup-iter (cdr key-list) 
                                     (rec-entry (record match-tree)))
                        #f))
                #f))))
    (define (lookup key-list)
      (let ((result (lookup-iter key-list (cdr local-table))))
        (if result
            (if (value-record? (record result))
                (rec-entry (record result))
                #f)
            #f)))

    (define (make-new-tree key-list value)
      (let ((h-tree '()))
        (let ((r-key-list (reverse key-list)))
          (define (iter rk-list tree)
            (if (not (pair? rk-list))
                tree
                (if (null? tree)
                    (iter (cdr rk-list)
                          (make-tree 
                           (make-value-record (car rk-list) value) '() '()))
                    (iter (cdr rk-list)
                          (make-tree 
                           (make-tree-record (car rk-list) tree) '() '())))))
          (iter r-key-list h-tree))))

    (define (insert-iter! key-list value tree)
      (let ((new-tree (make-new-tree key-list value)))
        (if (null? key-list)
            #f
            (if (null? tree)
                (set! tree new-tree)
                (if (null? (cdr key-list))
                    (cond ((key-eq? (car key-list) (rec-key (record tree)))
                           (set-record! tree
                                        (make-value-record (car key-list) value)))
                          ((key-lt? (car key-list) (rec-key (record tree)))
                           (if (null? (left-branch tree))
                               (set-left-branch! tree new-tree)
                               (insert-iter! key-list value (left-branch tree))))
                          ((key-gt? (car key-list) (rec-key (record tree)))
                           (if (null? (right-branch tree))
                               (set-right-branch! tree new-tree)
                               (insert-iter! key-list value (right-branch tree))))
                          (else #f))
                    (cond ((key-eq? (car key-list) (rec-key (record tree)))
                           (if (tree-record? (record tree))
                               (insert-iter! (cdr key-list) value
                                             (rec-entry (record tree)))
                               (set-record! tree
                                            (record new-tree))))
                          ((key-lt? (car key-list) (rec-key (record tree)))
                           (if (null? (left-branch tree))
                               (set-left-branch! tree new-tree)
                               (insert-iter! key-list value (left-branch tree))))
                          ((key-gt? (car key-list) (rec-key (record tree)))
                           (if (null? (right-branch tree))
                               (set-right-branch! tree new-tree)
                               (insert-iter! key-list value (right-branch tree))))
                          (else #f)))))))

    (define (insert! key-list value)
      (if (null? (cdr local-table))
          (set-cdr! local-table (make-new-tree key-list value))
          (insert-iter! key-list value (cdr local-table)))
      'ok)
    
    (define (print)
      (display local-table))

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

テスト

(define x (make-table))
; x
((x 'insert-proc!) '(1 2 3) 'a)
; ok
((x 'print-table))
; (*table (1 tree (2 tree (3 value . a) () ()) () ()) () ())#<undef>
((x 'lookup-proc) '(1 2 3))
; a
((x 'lookup-proc) '(1 2))
; #f
((x 'insert-proc!) '(1 2 3) 'b)
; ok
((x 'lookup-proc) '(1 2 3))
; b
((x 'print-table))
; (*table (1 tree (2 tree (3 value . b) () ()) () ()) () ())#<undef>
((x 'insert-proc!) '(1 2) 'c)
; ok
((x 'print-table))
; (*table (1 tree (2 value . c) () ()) () ())#<undef>
((x 'insert-proc!) '(1 2 3 4) 'd)
; ok
((x 'lookup-proc) '(1 2 3 4))
; d
((x 'print-table))
; (*table (1 tree (2 tree (3 tree (4 value . d) () ()) () ()) () ()) () ())#<undef>
((x 'insert-proc!) '(1 2 4) 'e)
; ok
((x 'lookup-proc) '(1 2 4))
; e
((x 'print-table))
; (*table (1 tree (2 tree (3 tree (4 value . d) () ()) ((4 value . e) () ()) ()) () ()) () ())#<undef>
((x 'lookup-proc) '(1 2 3 4))
; d
((x 'insert-proc!) '(1 2 4 5) 'f)
; ok
((x 'print-table))
; (*table (1 tree (2 tree (3 tree (4 value . d) () ()) ((4 tree (5 value . f) () ()) () ()) ((4 value . e) () ())) () ()) () ())#<undef>
((x 'lookup-proc) '(1 2 4 5))
; f
((x 'insert-proc!) '(1 1) 'g)
; ok
((x 'print-table))
; (*table (1 tree (2 tree (3 tree (4 value . d) () ()) ((4 tree (5 value . f) () ()) () ()) ((4 value . e) () ())) () ((1 value . g) () ())) () ())#<undef>
((x 'insert-proc!) '(2 1) 'h)
; ok
((x 'lookup-proc) '(2 1))
; h
((x 'lookup-proc) '(1 2 3 4))
; d
((x 'lookup-proc) '(1 2 4))
; #f
((x 'lookup-proc) '(1 1))
; g

ソース汚いけど、飽きたので取り合えずOKということで…。