1 665c255d 2023-08-04 jrmu ;; Exercise 3.24. In the table implementations above, the keys are tested for equality using equal? (called by assoc). This is not always the appropriate test. For instance, we might have a table with numeric keys in which we don't need an exact match to the number we're looking up, but only a number within some tolerance of it. Design a table constructor make-table that takes as an argument a same-key? procedure that will be used to test ``equality'' of keys. Make-table should return a dispatch procedure that can be used to access appropriate lookup and insert! procedures for a local table.
3 665c255d 2023-08-04 jrmu (define (make-table same-key?)
4 665c255d 2023-08-04 jrmu (define (assoc key records)
5 665c255d 2023-08-04 jrmu (cond ((null? records) false)
6 665c255d 2023-08-04 jrmu ((same-key? key (caar records)) (car records))
7 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
8 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
9 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
10 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
11 665c255d 2023-08-04 jrmu (if subtable
12 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
14 665c255d 2023-08-04 jrmu (cdr record)
17 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
18 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
19 665c255d 2023-08-04 jrmu (if subtable
20 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
22 665c255d 2023-08-04 jrmu (set-cdr! record value)
23 665c255d 2023-08-04 jrmu (set-cdr! subtable
24 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
25 665c255d 2023-08-04 jrmu (cdr subtable)))))
26 665c255d 2023-08-04 jrmu (set-cdr! local-table
27 665c255d 2023-08-04 jrmu (cons (list key-1
28 665c255d 2023-08-04 jrmu (cons key-2 value))
29 665c255d 2023-08-04 jrmu (cdr local-table)))))
31 665c255d 2023-08-04 jrmu (define (dispatch m)
32 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
33 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
34 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
37 665c255d 2023-08-04 jrmu (define operation-table (make-table (lambda (x y) (< (abs (- x y)) 0.1))))
38 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
39 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
41 665c255d 2023-08-04 jrmu (define (test-case actual expected)
43 665c255d 2023-08-04 jrmu (display "Actual: ")
44 665c255d 2023-08-04 jrmu (display actual)
46 665c255d 2023-08-04 jrmu (display "Expected: ")
47 665c255d 2023-08-04 jrmu (display expected)
50 665c255d 2023-08-04 jrmu (put 4 3 '4x3=12)
51 665c255d 2023-08-04 jrmu (test-case (get 4.01 2.99) '4x3=12)
52 665c255d 2023-08-04 jrmu (test-case (get 4 3) '4x3=12)
53 665c255d 2023-08-04 jrmu (put 4.01 2.99 '4.01x2.99=11.9899)
54 665c255d 2023-08-04 jrmu (test-case (get 4.01 2.99) '4.01x2.99=11.9899)
55 665c255d 2023-08-04 jrmu (test-case (get 4 3) '4.01x2.99=11.9899)
56 665c255d 2023-08-04 jrmu (test-case (get 4.11 3.0) false)
57 665c255d 2023-08-04 jrmu (put 8.06 2.06 '8.06x2.06=16.6036)
58 665c255d 2023-08-04 jrmu (put 7.94 1.94 '7.94x1.94=15.4036)
60 665c255d 2023-08-04 jrmu ; note that most recent definition is pulled first, regardless of which is closer
61 665c255d 2023-08-04 jrmu (test-case (get 8 2) '7.94x1.94=15.4036)
62 665c255d 2023-08-04 jrmu (test-case (get 8.039 2.039) '7.94x1.94=15.4036)
63 665c255d 2023-08-04 jrmu (test-case (get 8.041 2.041) '8.06x2.06=16.6036)
64 665c255d 2023-08-04 jrmu (test-case (get 8.159 2.159) '8.06x2.06=16.6036)
65 665c255d 2023-08-04 jrmu (test-case (get 7.85 1.85) '7.94x1.94=15.4036)
