sicp-ex-3.25



<< Previous exercise (3.24) | Index | Next exercise (3.26) >>


eric4brs

The answer posted by Genovia below fails in two respects. First you cannot insert a new value in an existing location.

 (table-insert! mytable 'a 1 1) 
 (table-insert! mytable 'a 1 1) 

The second table-insert! fails. Second you cannot add a value to a location that contains a sub-tree. That is, Genovia's node does not support both a value and a sub-tree.

 (table-insert! mytable 'a 1 1) 
 (table-insert! mytable 'b 1)  

The second table insert fails. The following solution supports both of these cases. It also supports delete. It also supports a draw function if you are lucky enough to use an implementation that supports diagramming. I've included my test cases which exercise node containing value and sub-tree, changing a value, deleting a value, and drawing table (commented in case your implementation doesn't support draw)

 (define (make-table) 
   (let ((local-table (list '*table* nil))) 
  
   (define (assoc key records) 
     (cond ((null? records) false) 
           ((equal? records '(())) false) 
           ((equal? key (car (car records))) (car records)) 
           (else (assoc key (cdr records))))) 
   (define (find subtable keys) 
     (let ((record (assoc (car keys) (cdr (cdr subtable))))) 
       (if record 
         (if (null? (cdr keys)) 
           (list nil record) 
           (find record (cdr keys))) 
         (list keys subtable)))) 
   (define (new-branch! table keys value) 
       (define (recurse keys value) 
         (if (null? (cdr keys)) 
           (cons (car keys) (list value)) 
           (cons (car keys) (list nil (recurse (cdr keys) value))))) 
       (if (not (pair? keys)) 
         #f 
         (set-cdr! (cdr table) (cons (recurse keys value) (cdr (cdr table)))))) 
  
   (define (display) 
     (draw local-table)) 
   (define (insert! keys value) 
     (let ((find-result (find local-table keys))) 
       (let ((subkeys (car find-result)) 
             (subtable (car (cdr find-result)))) 
         (if (null? subkeys) 
           (set-car! (cdr subtable) value) 
           (new-branch! subtable subkeys value)))) 
     'ok)        
   (define (lookup keys) 
     (let ((find-result (find local-table keys))) 
       (let ((subkeys (car find-result)) 
             (subtable (car (cdr find-result)))) 
       (if (null? subkeys) 
         (let ((value (car (cdr subtable)))) 
           (if (equal? value nil) 
             #f 
             value)) 
         #f)))) 
  
   (define (dispatch m) 
       (cond ((eq? m 'lookup) lookup) 
             ((eq? m 'insert!) insert!) 
             ((eq? m 'draw) (display)) 
             (else (error "Unknown operation -- MAKE-TABLE" m)))) 
   dispatch)) 
  
 (define t-t-t-t (make-table)) 
 (define (table-insert! value . keys) 
   ((t-t-t-t 'insert!) keys value)) 
 (define (table-delete! . keys) 
   ((t-t-t-t 'insert!) keys nil)) 
 (define (table-lookup . keys) 
   ((t-t-t-t 'lookup) keys)) 
 (define (table-draw) 
   (t-t-t-t 'draw)) 
  
 (table-insert! 'a 1 1) 
 (table-lookup 1 1) 
 (table-insert! 'b 2) 
 (table-insert! 'c 3) 
 (table-insert! 'c 2 3 4) 
 (table-insert! 'd 2 3 5) 
 (table-insert! 'e 2 3 6) 
 (table-lookup 3 4) 
 (table-lookup 2 3) 
 (table-lookup 2 3 4) 
 (table-lookup 1) 
 (table-insert! 'x 1 1) 
 (table-insert! 'y 2 3 4) 
 (table-lookup 1 1) 
 (table-lookup 2 3 4) 
 (table-delete! 2 3 4) 
 (table-lookup 2 3 4) 
 ;; (table-draw) 

Your tests should yield:

 ok 
 a 
 ok 
 ok 
 ok 
 ok 
 ok 
 #f 
 #f 
 c 
 #f 
 ok 
 ok 
 x 
 y 
 ok 
 #f 
  
 ;;I think the answer below by Anonymous is wrong because it's just for the one-dimensional table, the exercise requires for a arbitrary n-dimensional table. 
  
 (define (make-table) 
   (let ((local-table (list '*table*))) 
     (define (assoc key records) 
       (cond ((null? records) false) 
             ((equal? key (caar records)) (car records)) 
             (else (assoc key (cdr records))))) 
  
     (define (lookup key-list) 
       (define (iter keys table) 
         (cond ((null? keys) false) ;;为空时 
               ((null? (cdr keys))  ;;只有一个key时 
                (let ((record (assoc (car keys) (cdr table)))) 
                  (if record 
                      (cdr record) 
                      false))) 
               (else                    ;;有多个key时,先取出一个,用于找到subtable,然后剩下的再循环再 
                (let ((subtable (assoc (car keys) (cdr table)))) 
                  (if subtable 
                      (iter (cdr keys) subtable) 
                      false))))) 
       (iter key-list local-table)) 
  
     (define (insert! value key-list) 
       (define (iter keys table) 
         (cond ((null? table)    ;;这是当没有找到key对应的subtable时,需要创建新的subtable 
                (if (null? (cdr keys)) 
                    (cons (car keys) value) 
                    (list (car keys) (iter (cdr keys) '())))) 
               ((null? (cdr keys)) ;;只有一个key 
                   (let ((record (assoc (car keys) (cdr table)))) 
                     (if record 
                         (set-cdr! record value) 
                         (set-cdr! table 
                                   (cons (cons (car keys) value) 
                                         (cdr table)))))) 
               (else            ;;有多个key 
                (let ((subtable (assoc (car keys) (cdr table)))) 
                  (if subtable 
                      (iter (cdr keys) subtable) 
                      (set-cdr! table 
                                (cons (list (car keys) 
                                            (iter (cdr keys) '()))   ;;这里是关键,没找到subtable时,创建新的,然后循环(cdr keys) 
                                      (cdr table)))))))) 
       (iter key-list local-table) 
       'ok)     
     (define (dispatch m) 
       (cond ((eq? m 'lookup-proc) lookup) 
             ((eq? m 'insert-proc!) insert!) 
             (else (error "Unknown operation -- TABLE" m)))) 
     dispatch)) 
  
 (define (lookup table . key-list) ((table 'lookup-proc) key-list)) 
 (define (insert! table value . key-list) ((table 'insert-proc!) value key-list)) 
  
  
  
  
 (define (fold-left op init seq) 
   (define (iter ans rest) 
     (if (null? rest) 
         ans 
         (iter (op ans (car rest)) 
               (cdr rest)))) 
   (iter init seq)) 
  
 (define (make-table same-key?) 
   (define (associate key records) 
     (cond ((null? records) #f) 
           ((same-key? key (caar records)) (car records)) 
           (else (associate key (cdr records))))) 
  
   (let ((the-table (list '*table*))) 
     (define (lookup keys) 
       (define (lookup-record record-list key) 
         (if record-list 
             (let ((record (associate key record-list))) 
               (if record 
                   (cdr record) 
                   #f)) 
             #f)) 
       (fold-left lookup-record (cdr the-table) keys)) 
  
     (define (insert! keys value) 
       (define (descend table key) 
         (let ((record (associate key (cdr table)))) 
           (if record 
               record 
               (let ((new (cons (list key) 
                                (cdr table)))) 
                 (set-cdr! table new) 
                 (car new))))) 
       (set-cdr! (fold-left descend the-table keys) 
                 value)) 
  
     ;; N.B. PRINT will break if a record has a list structure for a value. 
     (define (print) 
       (define (indent tabs) 
         (for-each (lambda (x) (display #\tab)) (iota tabs))) 
  
       (define (print-record rec level) 
         (indent level) 
         (display (car rec)) 
         (display ": ") 
         (if (list? rec) 
             (begin (newline) 
                    (print-table rec (1+ level))) 
             (begin (display (cdr rec)) 
                    (newline)))) 
              
       (define (print-table table level) 
         (if (null? (cdr table)) 
             (begin (display "-no entries-") 
                    (newline)) 
             (for-each (lambda (record) 
                         (print-record record level)) 
                       (cdr table)))) 
  
       (print-table the-table 0)) 
  
     (define (dispatch m) 
       (cond ((eq? m 'lookup) lookup) 
             ((eq? m 'insert!) insert!) 
             ((eq? m 'print) print) 
             (else (error "Undefined method" m)))) 
  
     dispatch)) 
⇒(define op-table (make-table eq?))
⇒(define put (op-table 'insert!))
⇒(define get (op-table 'lookup))
⇒((op-table 'print))
-no entries-
⇒(put '(letters a) 97)  ; Two dimensions
⇒(put '(letters b) 98)
⇒(put '(math +) 43)
⇒(put '(math -) 45)
⇒(put '(math *) 42)
⇒(put '(greek majiscule Λ) 923)  ; Three dimensions
⇒(put '(greek miniscule λ) 955)
⇒(put '(min) 42)  ; One dimension
⇒(put '(max) 955)
⇒(get '(min))
42
⇒(get '(letters b))
98
⇒(get '(greek majiscule Λ))
923
⇒(get '(dfashoigrar asdfasdf retaqw))
#f
⇒((op-table 'print))
max: 955
min: 42
greek: 
        majiscule: 
                Λ: 923
        miniscule: 
                λ: 955
math: 
        +: 43
        *: 42
        -: 45
letters: 
        a: 97
        b: 98

  
  
  
 ;;; another solution to have some variety 
 (define (make-table) 
   (list '*table)) 
  
 (define (lookup table keys) 
   (define (lookup-helper remaining-keys last-found) 
     (cond ((null? remaining-keys) 
            (cdr last-found)) 
           (else 
             (let ((next (assoc (car remaining-keys) (cdr last-found)))) 
               (if next  
                   (lookup-helper (cdr remaining-keys) next)  
                   false))))) 
   (lookup-helper keys table)) 
  
 (define (insert! table keys value) 
     (define (insert-helper remaining-keys last-found) 
       (if (null? (cdr remaining-keys)) 
           ;;; when (cdr remaining-keys) is null, we should update 
           ;;; or create a record 
           (let ((record (assoc (car remaining-keys) (cdr last-found)))) 
             (if record 
                 (set-cdr! record value) 
                 (set-cdr! last-found 
                           (cons (cons (car remaining-keys) value) 
                                 (cdr last-found))))) 
           ;;; when (cdr remaining-keys) is not null, we should find 
           ;;; or create tables 
           (let ((next-table (assoc (car remaining-keys) (cdr last-found)))) 
             (if next-table 
                 (insert-helper (cdr remaining-keys) next-table) 
                 (let ((new-table (list (car remaining-keys)))) 
                   (set-cdr! last-found 
                             (cons new-table 
                                   (cdr last-found))) 
                   (insert-helper (cdr remaining-keys) new-table)))))) 
     (insert-helper keys table) 
   'ok) 
  

@meteorgan - Yes, it will work, but everything will be saved in the same 1D table, which is not the point of the exercise I think



I don't think we need change the procedure make-table. If we use a list as the key, all things can keep the same.

Yes, I agree if we just use lists for keys; nothing needs to be changed. However, the exercise intends to implement arbitrary dimension tables (generalizing from 2D).




another solution

    
 (define (make-table same-key?) 
   (let ((local-table (list '*table*))) 
  
     (define (assoc key records) 
       (cond ((null? records) #false) 
             ((same-key? key (caar records)) 
              (car records)) 
             (else (assoc key (cdr records))))) 
  
     (define (lookup keys) 
       (define (iter remain-keys records) 
         (cond 
          ((null? remain-keys) records) 
          ((not (pair? records)) #false) 
          (else (let ((record (assoc (car remain-keys) records))) 
                  (if record 
                      (iter (cdr remain-keys) (cdr record)) 
                      #false))))) 
       (iter keys (cdr local-table))) 
  
     (define (insert! keys value) 
       (define (iter ks records) 
         (cond 
          ((null? ks) (set-cdr! records value)) 
          ((or (null? (cdr records)) (not (pair? (cdr records)))) 
           (set-cdr! records (list (cons (car ks) '()) )) 
           (iter (cdr ks) (cadr records))) 
          (else 
           (let ((record (assoc (car ks) (cdr records)))) 
             (if record 
                 (iter (cdr ks) record) 
                 (begin (set-cdr! records 
                                  (cons (list (car ks)) 
                                        (cdr records))) 
                        (iter (cdr ks) (cadr records)))))))) 
       (iter keys local-table)) 
  
     (define (dispatch m) 
       (cond 
        ((eq? m 'lookup) lookup) 
        ((eq? m 'insert!) insert!))) 
     dispatch)) 
  
 (define (lookup keys table) 
   ((table 'lookup) keys)) 
 (define (insert! keys value table) 
   ((table 'insert!) keys value)) 

  
  
  
 (define (is-table? value) 
   (and (pair? value) (eq? (car value) '*table*))) 
  
 (define (lookup keys table) 
   (cond ((null? keys) (if (is-table? table) #f table)) 
         ((not (is-table? table)) #f) 
         (else (let ((record (assoc (car keys) (cdr table)))) 
                 (if record 
                     (lookup (cdr keys) (cdr record)) 
                     #f))))) 
  
 (define (insert! keys value table) 
   (if (null? keys) 
       table 
       (let ((record (assoc (car keys) (cdr table)))) 
         (if (= (length keys) 1) 
             (if (not record) 
                 (set-cdr! table (cons (cons (car keys) value) (cdr table))) 
                 (set-cdr! record value)) 
             (if (not record) 
                 (let ((new-table (cons '*table* '()))) 
                   (set-cdr! table (cons 
                                    (cons (car keys) new-table) 
                                    (cdr table))) 
                   (insert! (cdr keys) value new-table)) 
                 (if (is-table? (cdr record)) 
                     (insert! (cdr keys) value (cdr record)) 
                     (let ((new-table (cons '*table* '()))) 
                       (set-cdr! record new-table) 
                       (insert! (cdr keys) value new-table)))))))) 
  
  
 (define table (cons '*table* '())) 
  
  
  
 (insert! (list 'math '+) "add" table) 
 (insert! (list 'math '-) "sub" table) 
  
 (lookup (list 'math '-) table) 
  
 (insert! (list 'math '-) "new-sub" table) 
 (lookup (list 'math '-) table) 
  
 (insert! '(c1 c2 c3) 22 table) 
  
 (lookup (list 'math '+) table) 
 (lookup (list 'k1 'k2 'k3) table) 
 (lookup (list 'k1 'k2 'k3 'k4) table) 
 (lookup '(c1 c2 c3) table) 
  
  

  
 ;nested tables 
 ;final values are always wrapped into a table 
 ;so that a cdr of a record is always a table 
 ;this allows to store prefix-equal keys without conflicts 
 ;say, the table handles keys (1 2) and (1 2 3) just fine 
 ;but the code is not very readable imo 
 (define (empty-table) 
   (list 'head)) 
  
 (define (table-body table) 
   (cdr table)) 
  
 (define (append-table! table key value) 
   (let ((newpair (cons key value))) 
        (set-cdr! table (cons newpair (table-body table))))) 
  
 (define special-key 'xxx) 
  
 (define (insert! table keys value) 
    (if (null? keys) 
      (let ((record (assoc special-key (table-body table)))) 
             (if (eq? record #f) 
                 (append-table! table special-key value) 
                 (set-cdr! record value))) 
      (let ((record (assoc (car keys) (table-body table)))) 
           (cond ((eq? record #f) 
                  (append-table! table (car keys) (empty-table)) 
                  (insert! (cdadr table) (cdr keys) value)) ;call insert on the newly appended sub-table 
                 (else (insert! (cdr record) (cdr keys) value)))))) 
  
 (define (lookup table keys) 
         (if (null? keys) 
             (let ((record (assoc special-key (table-body table)))) 
                  (if (eq? record #f) 
                      #f 
                      (cdr record))) 
             (let ((record (assoc (car keys) (table-body table)))) 
                  (if (eq? record #f) 
                      #f 
                      (lookup (cdr record) (cdr keys)))))) 
  
 (define t (empty-table)) 
 (insert! t '(1 2) 'a) 
 (insert! t '(1) 'b) 
 (lookup t '(1 2)) 

My solution. Simple recursion is enough for this exercise.

  
 (define (make-table) 
   (let ((local-table (list '*table*))) 
     (define (lookup keys) 
       (define (iter keys table) 
         (let ((subtable (assoc (car keys) (cdr table)))) 
           (if subtable 
               (cond ((null? (cdr keys)) (cdr subtable)) 
                     (else 
                      (iter (cdr keys) subtable))) 
             false))) 
       (iter keys local-table)) 
      
     (define (gen-new-list keys value) 
         (if (null? (cdr keys)) 
             (cons (car keys) value) 
             (list (car keys) (gen-new-list (cdr keys) value)))) 
      
     (define (insert! keys value) 
       (define (iter keys table) 
         (let ((subtable (assoc (car keys) (cdr table)))) 
           (if subtable 
               (cond ((null? (cdr keys)) 
                      (set-cdr! subtable value)) 
                     (else 
                      (iter (cdr keys) subtable))) 
               (set-cdr! table (cons (gen-new-list keys value) (cdr table))))) 
         'ok) 
       (iter keys local-table)) 
    
   (define (dispatch m) 
     (cond ((eq? m 'lookup-proc) lookup) 
           ((eq? m 'insert-proc!) insert!) 
           ((eq? m 'display) (display local-table)) 
           (else (error "Unknown operation -- TABLE" m)))) 
   dispatch)) 

My make-it-as-concise-as-possible version.

  
 (define (make-table) 
   (let ((local-table (list '*table*))) 
     (define (lookup subtable key-list) 
       (cond ((not subtable) #f) 
             ((null? key-list) (if (list? subtable) subtable (cdr subtable))) 
             (else (lookup (assoc (car key-list) (cdr subtable)) (cdr key-list))))) 
  
     (define (insert! subtable key-list value) 
       (if (null? key-list) 
         (set-cdr! subtable value) 
         (let ((cur-key (car key-list)) 
               (rest-keys (cdr key-list)) 
               (subtable-rest (if (list? subtable) (cdr subtable) '()))) 
           (let ((record (assoc cur-key subtable-rest))) 
             (if (not record) 
               (begin 
                 (set! record (list cur-key)) 
                 (set-cdr! subtable (cons record subtable-rest)))) 
             (insert! record rest-keys value))))) 
  
  
     (define (dispatch m) 
       (cond ((eq? m 'lookup-proc) (lambda (key-list) (lookup local-table key-list))) 
             ((eq? m 'insert-proc!) (lambda (key-list value) (insert! local-table key-list value))) 
             (else (error "Unknown operation -- TABLE" m)))) 
     dispatch)) 
  
  

  
  
  
  
  
 (define (make-table same-key?) 
  
     (define (new-table name) (list name)) 
      
  
     (define (table-add! table new-record) 
         (set-cdr! table (cons new-record (cdr table))) 
         table) 
      
  
     (define (table-add-rec! table keys-list value) 
         (cond ((null? keys-list) 
                 (set-cdr! table value) 
                 table) 
             (else 
                 (table-add! 
                     table 
                     (table-add-rec! 
                         (new-table (car keys-list)) 
                         (cdr keys-list) 
                         value))))) 
    
  
     (define (assoc- key records) 
         (cond ((null? records) #f) 
             ((same-key? key (caar records)) 
                 (car records)) 
             (else 
                 (assoc- key (cdr records))))) 
      
     (let ((local-table (new-table '*table*))) 
      
  
         (define (lookup keys-list) 
             (define (rec now-table now-keys) 
                 (if (null? now-keys) 
                     (cdr now-table) 
                     (let ((subtable (assoc- (car now-keys) (cdr now-table)))) 
                         (if subtable 
                             (rec subtable (cdr now-keys)) 
                             #f)))) 
                              
             (let ((len (length keys-list))) 
                 (let ((subtable (assoc- len (cdr local-table)))) 
                     (if subtable 
                         (rec subtable keys-list) 
                         #f)))) 
          
  
         (define (insert! keys-list value) 
             (define (rec now-table now-keys) 
                 (if (null? now-keys) 
                     (set-cdr! now-table value) 
                     (let ((subtable (assoc- (car now-keys) (cdr now-table)))) 
                         (if subtable 
                             (rec subtable (cdr now-keys)) 
                             (table-add-rec! now-table now-keys value))))) 
  
             (let ((len (length keys-list))) 
                 (let ((subtable (assoc- len (cdr local-table)))) 
                     (if subtable 
                         (rec subtable keys-list) 
                         (table-add! 
                             local-table 
                             (table-add-rec! 
                                 (new-table len) 
                                 keys-list value))))) 
             'done) 
                  
  
         (define (dispatch m) 
             (cond ((eq? m 'lookup-proc) lookup) 
                 ((eq? m 'insert-proc!) insert!) 
                 (else (error "Unknown operation -- TABLE" m)))) 
          
         dispatch)) 
          
 (define operation-table (make-table equal?)) 
 (define get (operation-table 'lookup-proc)) 
 (define put (operation-table 'insert-proc!))