sicp-ex-3.25



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


Genovia

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




ada

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

Yasser Hussain

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

Annonymous

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

GP

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