(define (make-table)
(let ((local-table (cons '*table* '())))
(define (make-tree entry left right) (list entry left right))
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (key record) (car record))
(define (value record) (cdr record))
(define (update! record new-value) (set-cdr! record new-value))
(define (assoc3 given-key records)
(if (null? records) #f
(let ((record (entry records)))
(cond ((= given-key (key record)) record)
((< given-key (key record)) (assoc3 given-key (left-branch records)))
((> given-key (key record)) (assoc3 given-key (right-branch records)))))))
(define (adjoin-tree! rec tree)
(if (null? tree)
(error "ADJOIN-TREE! called with nil. this is not a tree.")
(let ((record (entry tree)))
(cond ((= (key rec) (key record)) (update! record (value rec)))
((< (key rec) (key record))
(if (null? (left-branch tree))
(set-car! (cdr tree) (make-tree rec '() '()))
(adjoin-tree! rec (left-branch tree))))
((> (key rec) (key record))
(if (null? (right-branch tree))
(set-car! (cddr tree) (make-tree rec '() '()))
(adjoin-tree! rec (right-branch tree))))))))
(define (lookup-iter keys table)
(if (null? keys)
(value table)
(let ((subtable (assoc3 (car keys) (value table))))
(if subtable
(lookup-iter (cdr keys) subtable)
#f))))
(define (lookup keys)
(lookup-iter keys local-table))
(define (compose-table keys value)
(if (null? (cdr keys))
(cons (car keys) value)
(cons (car keys) (make-tree (compose-table (cdr keys) value) '() '()))))
(define (insert!-iter keys given-value table)
(let ((subtable (assoc3 (car keys) (value table))))
(if subtable
(if (null? (cdr keys))
(update! subtable given-value)
(insert!-iter (cdr keys) given-value subtable))
(if (null? (value table))
(set-cdr! table (make-tree (compose-table keys given-value) '() '()))
(adjoin-tree! (compose-table keys given-value)
(value table))))))
(define (insert! keys value)
(insert!-iter keys value local-table)
'ok)
(define (show)
local-table)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
((eq? m 'show) show)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define tree-table (make-table))
(define get (tree-table 'lookup-proc))
(define put (tree-table 'insert-proc!))
(put '(1 2 3 4) 'v-1-2-3-4)
(put '(1 2 3 5) 'v-1-2-3-5)
(put '(1 2 3 2) 'v-1-2-3-2)
(put '(1 2 3 3) 'v-1-2-3-3)
(put '(1 2 3 123) 'v-1-2-3-123)
(put '(1 2 3 6) 'v-1-2-3-6)
((tree-table 'show))
(get '(1 2 3 4))
(put '(1 2 2) 'v-1-2-2)
(get '(1 2 2))
((tree-table 'show))
