sicp-ex-3.26



<< Previous exercise (3.25) | Index | Next exercise (3.27) >>


flamingo

  
  
 ;; 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)

Solution for multi-dimensional tables

  
 ; 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)) 

Solution using mutable trees

  
 (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)) 
  
  


GP

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)