sicp-ex-3.26

  
  
 ;; node == ( ( pair key value ) left-ptr right-ptr ) 
  
 (define (entry tree) (car tree)) 
 (define (left-branch tree) (cadr tree)) 
 (define (right-branch tree) (caddr tree)) 
  
 (define (make-tree entry left right) 
   (list entry left right)) 
  
 (define (adjoin-set x set) 
   (cond ((null? set) (make-tree x '() '())) 
         ((= (car x) (car (entry set))) set) 
         ((< (car x) (car (entry set))) 
          (make-tree (entry set) 
                     (adjoin-set x (left-branch set)) 
                     (right-branch set))) 
         ((> (car x) (car (entry set))) 
          (make-tree (entry set) 
                     (left-branch set) 
                     (adjoin-set x (right-branch set)))))) 
  
 (define (make-table) 
   (let ((local-table '())) 
      
     (define (lookup key records) 
       (cond ((null? records) #f) 
             ((= key (car (entry records))) (entry records)) 
             ((< key (car (entry records))) (lookup key (left-branch records))) 
             ((> key (car (entry records))) (lookup key (right-branch records))))) 
      
     (define (insert! key value) 
       (let ((record (lookup key local-table))) 
         (if record 
             (set-cdr! record value) 
             (set! local-table (adjoin-set (cons key value) local-table))))) 
      
     (define (get key) 
       (lookup key local-table)) 
      
     (define (dispatch m) 
       (cond ((eq? m 'get-proc) get) 
             ((eq? m 'insert-proc) insert!) 
             ((eq? m 'print) local-table) 
             (else (error "Undefined operation -- TABLE" m)))) 
     dispatch)) 
  
 (define table (make-table)) 
 (define get (table 'get-proc)) 
 (define put (table 'insert-proc)) 

⇒(put 43 'a)
⇒(put 42 'b)
⇒(put 41 'c)
⇒(put 67 'z)
⇒(put 88 'e)

⇒(table 'print)
((43 . a)
 ((42 . b) ((41 . c) () ()) ())
 ((67 . z) () ((88 . e) () ())))

⇒(get 88)
(88 . e)

  
 ; helper methods 
  
 (define (make-record key value) 
   (list (cons key value) nil nil)) 
 (define (get-key record) (caar record)) 
 (define (get-value record) (cdar record)) 
 (define (set-key! record new-key) (set-car! (car record) new-key)) 
 (define (set-value! record new-value) (set-cdr! (car record) new-value)) 
 (define (get-left record) (cadr record)) 
 (define (get-right record) (caddr record)) 
 (define (set-left! record new-left) (set-car! (cdr record) new-left)) 
 (define (set-right! record new-right) (set-car! (cddr record) new-right)) 
  
 (define (assoc key records) 
   (cond ((null? records) false) 
         ((equal? key (get-key records)) (get-value records)) 
         ((< key (get-key records)) (assoc key (get-left records))) 
         (else (assoc key (get-right records))))) 
  
 (define (add-record key value table) 
   (define (iter record parent set-action) 
     (cond ((null? record) (let ((new (make-record key value))) 
                             (set-action parent new) 
                             (car new))) 
           ((equal? key (get-key record)) (set-value! record value) 
                                          (car record)) 
           ((< key (get-key record)) (iter (get-left record) record set-left!)) 
           (else (iter (get-right record) record set-right!)))) 
   (iter (cdr table) table set-cdr!)) 
  
 ; the procedure 
  
 (define (make-table) 
  
   (let ((local-table (list '*table*))) 
  
     (define (lookup keys) 
       (define (iter keys records) 
         (if (null? keys) records 
           (let ((found (assoc (car keys) records))) 
             (if found (iter (cdr keys) found) 
               false)))) 
       (iter keys (cdr local-table))) 
  
     (define (insert! keys value) 
       (define (iter keys subtable) 
         (cond ((null? (cdr keys)) (add-record (car keys) value subtable)) 
               (else (let ((new (add-record (car keys) nil subtable))) 
                       (iter (cdr keys) new))))) 
       (iter keys local-table) 
       'ok) 
  
     (define (print) (display local-table) (newline)) 
  
     (define (dispatch m) 
       (cond ((eq? m 'lookup-proc) lookup) 
             ((eq? m 'insert-proc!) insert!) 
             ((eq? m 'print) print) 
             (error "Unknown operation - TABLE" m))) 
     dispatch)) 
  
 (define operation-table (make-table)) 
 (define get (operation-table 'lookup-proc)) 
 (define put (operation-table 'insert-proc!)) 
 (define print-table (operation-table 'print)) 

  
 (define (entry tree) (car tree)) 
 (define (left-branch tree) (caar tree)) 
 (define (right-branch tree) (caddr tree)) 
 (define (make-tree entry-record left right) 
   (list entry-record left right)) 
  
 (define (adjoin-set x set) 
   (cond ((null? set) (make-tree x '() '())) 
         ((< (car x) (car (entry set))) 
          (let (left (left-branch set)) 
            (set! left (adjoin-set x left)))) 
         ((> (car x) (car (entry set))) 
          (let (right (right-branch set)) 
            (set right (adjoin-set x right)))))) 
  
 (define (assoc key record-tree) 
   (cond ((null? record-tree) false) 
         ((eq? key (car (entry record-tree)) (entry record-tree))) 
         ((< key (car (entry record-tree)) (assoc key (left-branch record-tree)))) 
         ((> key (car (entry record-tree)) (assoc key (right-branch record-tree)))))) 
  
  
 (define (make-table) 
   (let (local-table (list '*table*)) 
     (define (look-up key) 
       (let ((record (assoc key (cdr local-table)))) 
         (if record 
             (cdr record) 
             false))) 
  
     (define (insert! key value) 
       (let ((record (assoc key (cdr local-table)))) 
         (if record 
             (set-cdr! record value) 
             (adjoin-set (cons key value) (cdr local-table))) 
         'ok)) 
  
  
     (define (dispatch m) 
       (cond ((eq? m 'lookup-proc) look-up) 
             ((eq? m 'insert-proc!) insert!) 
             (else "No such operation on table" m))) 
     dispatch)) 
  
  

I like the above solution from sam with internal "assoc", because it hides the common logic of two separate steps (lookup and insert) using procedural abstraction, which is what we have learnt in Chap 1. However it is still not ideal, as it requires an additional definition for "adjoin-set", which repeats some similar logic under "assoc". In fact, if a key cannot be found in a tree, it needs to traverse the tree twice to insert the value. The first round only checks if the key is in the tree. Then it goes over the tree again to insert it in the proper position, if the key dose not existed.

I am wondering if there is an even higher level of abstraction that encapsulates the similar code between "assoc" and "adjoin-set".

My solution dose not go along this direction. I simply let the similar code be naked and presented in lookup and insert!. But I tried to write the two parts of the code in a symmetrical way that have a similar structure. With this way, we gain some readability even without procedural abstraction. For small program like this, it works fine.

In addition, I create one more abstraction layer of node, which improves a bit readability and provides some flexibility for different ways of tree implementation.

  
 (define (make-table) 
   (define (entry tree) (car tree)) 
   (define (left-branch tree) (cadr tree)) 
   (define (right-branch tree) (caddr tree)) 
   (define (make-tree entry left right) 
     (list entry left right)) 
  
   (define (node-key entry) 
     (car entry)) 
   (define (node-value entry) 
     (cdr entry)) 
   (define (make-node key value) 
     (cons key value)) 
   (define (set-value! node value) 
     (set-cdr! node value)) 
  
   (let ((root (list ))) 
  
     (define (lookup key) 
       (define (iter tree) 
         (cond ((null? tree) false) 
               (else 
                (let ((node (entry tree)) 
                      (left (left-branch tree)) 
                      (right (right-branch tree))) 
                  (cond ((= key (node-key node)) (node-value node)) 
                        ((< key (node-key node)) (iter left)) 
                        ((> key (node-key node)) (iter right))))))) 
       (iter root)) 
  
     (define (insert! key value) 
       (define (iter tree) 
         (cond ((null? tree) (make-tree (make-node key value) '() '())) 
               (else 
                (let ((node (entry tree)) 
                      (left (left-branch tree)) 
                      (right (right-branch tree))) 
                  (cond ((= key (node-key node)) 
                         (set-value! node value) 
                         tree) 
                        ((< key (node-key node))  
                         (make-tree node (iter left) right)) 
                        ((> key (node-key node)) 
                         (make-tree node left (iter right)))))))) 
       (set! root (iter root))) 
  
     (define (dispatch m) 
       (cond ((eq? m 'lookup-proc) lookup) 
             ((eq? m 'insert-proc!) insert!) 
             ((eq? m 'display) (display root) (newline)) 
             (else (error "Unknown operation -- TREE" m)))) 
  
     dispatch)) 
  
 (define (show tree) (tree 'display)) 
 (define (lookup tree key) ((tree 'lookup-proc) key)) 
 (define (insert! tree key value) ((tree 'insert-proc!) key value)) 
  
 ;; TESTING 
 (define t (make-table)) 
 (show t) 
 (insert! t 7 'a) 
 (show t) 
 (insert! t 3 'b) 
 (show t) 
 (insert! t 9 'c) 
 (show t) 
 (insert! t 5 'd) 
 (show t) 
 (insert! t 1 'e) 
 (show t) 
 (insert! t 11 'f) 
 (show t) 
 (lookup t 5) 
 (lookup t 1) 
 (lookup t 9) 
 (insert! t 9 'xxx) 
 (lookup t 9) 
 (lookup t 27) 

This works with nested trees, meaning the value of an entry in a tree can either be a single value or another binary tree that can be searched via the lookup procedure. You add nested trees by providing more than one key to the list of keys for an entry using the insert procedure!

NOTE: You will see a lot of debugging data if you run this without removing the display statements.

 #lang sicp 
 (define (new-table) 
   (define (make-entry key value) (cons key value)) 
   (define (entry tree) (caar tree)) 
   (define (left-branch tree) (cadr tree)) 
   (define (right-branch tree) (caddr tree)) 
   (define (make-tree entry left right) 
     (list entry left right)) 
   (define (make-tree-node x) (make-tree x '() '())) 
    
   (define (set-left-branch! tree entry) (set-car! (cdr tree) entry)) 
   (define (set-right-branch! tree entry) (set-car! (cddr tree) entry)) 
    
   (let ((table (list '*table*))) 
      
     (define (lookup keys) 
       (let ((record (assoc keys (cdr table)))) 
         (if record 
             (cdr record) 
             false))) 
      
     (define (assoc keys records) 
       (define (handle-matches keys record) 
         (cond ((null? keys) record) 
               ((pair? (cdr record)) (assoc keys (cdr record))) 
               (else #f))) 
       (display (list "assoc params" "KEYS:" keys "RECORDS:" records))(newline) 
       (cond ((or (null? records) (null? (car records))) false) 
             ((equal? (car keys) (caar records)) 
              (handle-matches (cdr keys) (car records))) 
             ((< (car keys) (caar records)) 
              (assoc keys (left-branch records)))         
             (else (assoc keys (right-branch records))))) 
      
     (define (nest-trees-for-remaining-keys keys value) 
       (display (list "null-set-handler params" "keys:" keys "value:" value)) 
       (newline) 
       (if (null? keys) value 
           (make-tree-node (make-entry (car keys) (nest-trees-for-remaining-keys (cdr keys) value))))) 
      
     ;(keys) -> atom b-> atom b|table a b-> atom b|table a b  
     (define (match-handler keys value entry) 
       (display (list "match-handler params" "keys:" keys "entry:" entry)) 
       (newline) 
       (cond ((null? keys) value) 
             ((pair? entry) (adjoin-set! keys value entry)) 
             (else (nest-trees-for-remaining-keys keys value)))) 
      
     (define (adjoin-set! keys value set) 
       (display (list "adjoin-set:" set)) 
       (newline) 
       (let ((new-key (car keys))) 
         (cond ((null? set) (nest-trees-for-remaining-keys keys value)) 
               ((eq? new-key (caar set)) 
                (set-cdr! (car set) (match-handler (cdr keys) value (cdar set))) 
                set) 
               ((< new-key (entry set)) 
                (set-left-branch! set (adjoin-set! keys value (left-branch set))) 
                set) 
               ((> new-key (entry set)) 
                (set-right-branch! set (adjoin-set! keys value (right-branch set))) 
                set)))) 
      
     (define (insert-tree! keys value) 
       (display (list "INSERT TREE PARAMS:" keys value table)) 
       (set-cdr! table (adjoin-set! keys value (cdr table))) 
       (display table) 
       'ok) 
      
     (define (print) (display table)(newline)) 
     (define (dispatch m) 
       (cond ((eq? m 'lookup) (lambda (keys)(lookup keys))) 
             ((eq? m 'print) print) 
             ((eq? m 'insert) (lambda (keys value) (insert-tree! keys value))) 
             (else "Invalid command"))) 
     dispatch)) 
  
 ;PROCEDURAL INTERFACES 
 (define t4 (new-table)) 
 (define (insert! table keys value) 
   ((table 'insert) keys value)) 
 (define (print table) 
   ((table 'print))) 
 (define (lookup table keys) 
   ((table 'lookup) keys)) 
  
 ;TESTS 
 (insert! t4 '(76 -456) 'jesuit) 
 (insert! t4 '(76 -834) 'chomsky) 
 (insert! t4 '(76 -1000) 'regime) 
 (insert! t4 '(50 1/2) 'francoi) 
 (insert! t4 '(50 1/2 .333) 'twei) 
 (insert! t4 '(50 1/2 .666) 'cambodia) 
 (lookup t4 '(50 1/2 .333)) ;twei 
 (lookup t4 '(76 -456)) ;false because it should have been overwritten 
 (insert! t4 '(76 -456) 'carmelite) 
 (print t4);(*table* (76 (-456 . carmelite) ((-834 . chomsky) ((-1000 . regime) () ()) ()) ()) ((50 (1/2 (0.333 . twei) () ((0.666 . cambodia) () ())) () ()) () ()) ()) 

     antix21:~/src/scheme/solutions2 % racket -i -p neil/sicp 
     Welcome to Racket v7.9 [bc]. 
     > (load "joe") 
     > (define t1 (make-table)) 
     > (insert! t1 (list 379) '(1 . 2)) 
     'ok 
     > (insert! t1 (list 379 666) 1.618) 
     ; mcar: contract violation 
     ;   expected: mpair? 
     ;   given: 1 
     ; [,bt for context] 

forgot about the existence of assoc when doing this... fun exercise nonetheless

  
 (define (binary-tree-table) 
   (let ((head '())) 
     (define (make-node key value) 
       (list key value '() '())) ;; (key value left right) 
     (define (get-key node) (car node)) 
     (define (get-value node) (cadr node)) 
     (define (left node) (caddr node)) 
     (define (right node) (cadddr node)) 
     (define (set-left! node ptr) (set-car! (cddr node) ptr)) 
     (define (set-right! node ptr) (set-car! (cdddr node) ptr)) 
     (define (set-value! node val) (set-car! (cdr node) val)) 
     (define (leaf? node) 
       (and (null? (left node)) (null? (right node)))) 
     (define (lookup key) ;; returns value if key in tree else #f 
       (define (iter node) 
         (cond ((null? node) #f) 
               ((eq? key (get-key node)) (get-value node)) 
               ((leaf? node) #f) 
               (else (iter (if (> key (get-key node)) 
                               (right node) 
                               (left node)))))) 
       (iter head)) 
     (define (insert key value)  
       (let ((new-node (make-node key value))) 
         (define (iter node) 
           (cond ((= key (get-key node)) (set-value! node value)) 
                 ((> key (get-key node)) 
                  (if (null? (right node)) 
                      (set-right! node new-node) 
                      (iter (right node)))) 
                 (else (if (null? (left node)) 
                           (set-left! node new-node) 
                           (iter (left node)))))) 
         (if (null? head) 
             (set! head new-node) 
             (iter head)))) 
     (define (dispatch m) 
       (cond ((eq? m 'insert) insert) 
             ((eq? m 'lookup) lookup) 
             ((eq? m 'head) head) 
             (else (error "incorrect usage" m)))) 
     dispatch)) 
  
 (define table (binary-tree-table)) 
 (define (insert table key value) 
   ((table 'insert) key value)) 
 (define (lookup table key) 
   ((table 'lookup) key)) 
  
 ;; tests 
 (insert table 5 'y) 
 (insert table 3 'o) 
 (insert table 8 'a) 
 (insert table 4 'b) 
 (table 'head)  ;; (5 y (3 o () (4 b () ())) (8 a () ())) 
 (lookup table 4) ;; b 
 (lookup table 5) ;; y 
 (lookup data 6) ;; #f 
  

Nothing profound here. One thing new is that the function to compare keys is a formal parameter, facilitating "keys that can be ordered in some way (e.g. alphabetically)." A testbench and analysis of all solutions above is here.

 (define (make-table cmpfunc) 
     (define root-tree '()) 
     (define st-uninitialized #f)  ; the result returned for unsuccessful lookup 
     (define (st-beget k v)  (list k '() '() v)) 
     (define (st-get-key st)   (car st))    ; 1st element 
     (define (st-lefthead st)  (cdr st))    ; 2nd element 
     (define (st-righthead st) (cddr st))   ; 3rd element 
     (define (st-get-value st) (cadddr st)) ; 4th element 
     (define (st-leftsubtree st)  (car (st-lefthead st))) 
     (define (st-rightsubtree st) (car (st-righthead st))) 
     (define (st-set-value st val) (set-car! (cdddr st) val)) 
  
     (define (st-graft head k v) 
         (if (null? (car head)) 
             (set-car! head (st-beget k v)) 
             (st-insert (car head) k v)) 
     ) 
     (define (st-insert st key val)  ; contract is "st (the subtree) is always non-null" 
       (let ((result (cmpfunc (st-get-key st) key))) 
           (cond ((< result 0) (st-graft (st-righthead st) key val)) 
                 ((> result 0) (st-graft (st-lefthead st) key val)) 
                 (else (st-set-value st val)))) 
     ) 
     (define (st-lookup st key)  ; contract is "st may or may not be null" 
         (if (null? st) 
             st-uninitialized 
             (let ((result (cmpfunc (st-get-key st) key))) 
                 (cond ((< result 0) (st-lookup (st-rightsubtree st) key)) 
                       ((> result 0) (st-lookup (st-leftsubtree st)  key)) 
                       (else (st-get-value st))))) 
     ) 
     (define (st-root-insert key val) 
         (if (null? root-tree) 
             (set! root-tree (st-beget key val)) 
             (st-insert root-tree key val)) 
     ) 
     (define (dispatch m) 
         (cond ((eq? m 'insert) st-root-insert) 
               ((eq? m 'lookup) (lambda (key) (st-lookup root-tree key))) 
               ((eq? m 'dump) root-tree) ; debugging 
               (else (error "Error: unknown dispatch message -- btable" m))) 
     ) 
     dispatch 
 ) 
 (define (insert! bt key val) ((bt 'insert) key val)) 
 (define (lookup  bt key)     ((bt 'lookup) key))