<< Previous exercise (3.24) | Index | Next exercise (3.26) >>
just need a little change to make the process recursive.
(define (make-table) (define local-table (cons '*table* '())) (define (get-key table) (caaar table)) (define (get-value item) (if (pair? (car item)) (if (null? (cdar item)) #f (cdar item)) #f)) (define (change-value item value) (set-cdr! (car item) value)) (define (add-subtable table key value) (set-cdr! table (cons (cons (cons key value) '()) (cdr table)))) (define (assoc key table) (cond ((null? table) #f) ((= key (get-key table)) (car table)) (else (assoc key (cdr table))))) (define (lookup keys) (define (iter keys table) (if (null? keys) (begin (display table) (get-value table)) (let ((result (assoc (car keys) (cdr table)))) (if result (iter (cdr keys) result) #f)))) (iter keys local-table)) (define (insert! value keys) (define (iter value keys table) (let ((result (assoc (car keys) (cdr table)))) (if (null? (cdr keys)) (if result (change-value result value) (add-subtable table (car keys) value)) (if result (iter value (cdr keys) result) (begin (add-subtable table (car keys) '()) (iter value (cdr keys) (cadr table))))))) (iter value keys local-table)) (define (dispatch m) (cond ((eq? m 'insert!) insert!) ((eq? m 'lookup) lookup) ((eq? m 'print) (display local-table)))) dispatch) (define (insert! x value . keys) ((x 'insert!) value keys)) (define (lookup x . keys) ((x 'lookup) keys)) (define (print t) (t 'print)) (define (delete! t . keys) ((x 'insert!) '() keys)) (define t (make-table)) (insert! t 'a 1 1) (lookup t 1 1) (insert! t 'b 2) (insert! t 'c 3) (insert! t 'c 2 3 4) (insert! t 'd 2 3 5) (insert! t 'e 2 3 6) (lookup t 3 4) (lookup t 2 3) (lookup t 2 3 4) (lookup t 1) (insert! t 'x 1 1) (insert! t 'y 2 3 4) (lookup t 1 1) (lookup t 2 3 4) (lookup t 2 3 4)
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!))
Maybe not exactly in the spirit of the exercise, but I noticed that changing the "Two dimenstional table" structure to just accomodate for nested one dimensional tables (i.e. an extra (cons *table ..) after the key) makes the code very straightforward
; insert! and lookup from the one dimensional table implementation (define (table? t) (and (pair? t) (eq? '*table* (car t)))) (define (lookup-generic table key . rest-of-keys) (let ((subtable-or-record (lookup key table))) (cond ((not subtable-or-record) false) ((null? rest-of-keys) subtable-or-record) ((table? subtable-or-record) (apply lookup-generic subtable-or-record rest-of-keys)) (else (error "LOOKUP-GENERIC key is not a subtable" key subtable-or-record))))) (define (insert-generic! table value key . rest-of-keys) (if (null? rest-of-keys) ; on the last key (insert! key value table) (let ((subtable-or-record (lookup key table))) (if (table? subtable-or-record) (apply insert-generic! subtable-or-record value rest-of-keys) (let ((new-subtable (make-table))) (insert! key new-subtable table) (apply insert-generic! new-subtable value rest-of-keys))))))
Actually, your idea is so brilliant, it reuses existing code maximally, and distinguishs a subtable with a record.
#lang sicp
(define (make-table same-key?)
(let ((local-table (list '*table*)))
(define (s-assoc key-x? key records)
(cond ((null? records) false)
((not (key-x? records)) (s-assoc key-x? key (cdr records)))
((same-key? key (caar records)) (car records))
(else (s-assoc key-x? key (cdr records)))))
(define (key-table? record)
(pair? (cdr record)))
(define (key-value? record)
(not (pair? (cdr record))))
(define (rec-lookup i-table key rest-of-keys)
(let ((subtable (s-assoc key-table? key (cdr i-table))))
(cond ((null? rest-of-keys) (lookup i-table key))
(subtable (rec-lookup subtable (car rest-of-keys) (cdr rest-of-keys)))
(else false))))
(define (lookup i-table key)
(let ((record (s-assoc key-value? key (cdr i-table))))
(if record
(cdr record)
false)))
(define (rec-insert! i-table value key rest-of-keys )
(let ((subtable (s-assoc key-table? key (cdr i-table))))
(cond ((null? rest-of-keys) (insert! i-table key value))
(subtable (rec-insert! (cdr subtable)
value
(car rest-of-keys)
(cdr rest-of-keys)))
(else (begin (set-cdr! i-table
(cons (list key)
(cdr i-table)))
(rec-insert! (cadr i-table)
value
(car rest-of-keys)
(cdr rest-of-keys))))))
'ok)
(define (insert! i-table key value)
(let ((record (s-assoc key-value? key (cdr i-table))))
(if record
(set-cdr! record value)
(set-cdr! i-table (cons (cons key value)
(cdr i-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc)
(lambda (key . key-list) (rec-lookup local-table
key key-list )))
((eq? m 'insert-proc!)
(lambda (value key . key-list) (rec-insert! local-table
value
key
key-list )))
(else (error "Unknown operation: TABLE" m))))
dispatch))
(define (predicat? test-key tbl-key)
(= test-key tbl-key))
(define tbl (make-table predicat?))
((tbl 'insert-proc!) 155 21)
((tbl 'lookup-proc) 21)
((tbl 'insert-proc!) 255 21 21)
((tbl 'lookup-proc) 21 21)
((tbl 'lookup-proc) 21)
((tbl 'insert-proc!) 355 21)
((tbl 'lookup-proc) 21 21)
((tbl 'insert-proc!) 355 21)
((tbl 'lookup-proc) 21)
((tbl 'lookup-proc) 22)
((tbl 'lookup-proc) 22 22)
((tbl 'insert-proc!) 455 22 22)
((tbl 'lookup-proc) 22 22)
((tbl 'insert-proc!) 555 22 22)
((tbl 'lookup-proc) 22 22)
Only two of the twelve solutions below pass a torture test as of Feb 2023. Please see the full report for methodology details and the findings of this analysis.