1 ;; 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. 
2 
3 (define (make-table same-key?)
4   (define (assoc key records)
5     (cond ((null? records) false)
6 	  ((same-key? key (caar records)) (car records))
7 	  (else (assoc key (cdr records)))))
8   (let ((local-table (list '*table*)))
9     (define (lookup key-1 key-2)
10       (let ((subtable (assoc key-1 (cdr local-table))))
11         (if subtable
12             (let ((record (assoc key-2 (cdr subtable))))
13               (if record
14                   (cdr record)
15                   false))
16             false)))
17     (define (insert! key-1 key-2 value)
18       (let ((subtable (assoc key-1 (cdr local-table))))
19         (if subtable
20             (let ((record (assoc key-2 (cdr subtable))))
21               (if record
22                   (set-cdr! record value)
23                   (set-cdr! subtable
24                             (cons (cons key-2 value)
25                                   (cdr subtable)))))
26             (set-cdr! local-table
27                       (cons (list key-1
28                                   (cons key-2 value))
29                             (cdr local-table)))))
30       'ok)    
31     (define (dispatch m)
32       (cond ((eq? m 'lookup-proc) lookup)
33             ((eq? m 'insert-proc!) insert!)
34             (else (error "Unknown operation -- TABLE" m))))
35     dispatch))
36 
37 (define operation-table (make-table (lambda (x y) (< (abs (- x y)) 0.1))))
38 (define get (operation-table 'lookup-proc))
39 (define put (operation-table 'insert-proc!))
40 
41 (define (test-case actual expected)
42   (newline)
43   (display "Actual:   ")
44   (display actual)
45   (newline)
46   (display "Expected: ")
47   (display expected)
48   (newline))
49 
50 (put 4 3 '4x3=12)
51 (test-case (get 4.01 2.99) '4x3=12)
52 (test-case (get 4 3) '4x3=12)
53 (put 4.01 2.99 '4.01x2.99=11.9899)
54 (test-case (get 4.01 2.99) '4.01x2.99=11.9899)
55 (test-case (get 4 3) '4.01x2.99=11.9899)
56 (test-case (get 4.11 3.0) false)
57 (put 8.06 2.06 '8.06x2.06=16.6036)
58 (put 7.94 1.94 '7.94x1.94=15.4036)
59 
60 ; note that most recent definition is pulled first, regardless of which is closer
61 (test-case (get 8 2) '7.94x1.94=15.4036) 
62 (test-case (get 8.039 2.039) '7.94x1.94=15.4036) 
63 (test-case (get 8.041 2.041) '8.06x2.06=16.6036)
64 (test-case (get 8.159 2.159) '8.06x2.06=16.6036)
65 (test-case (get 7.85 1.85) '7.94x1.94=15.4036) 
66 
67