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