1 ;; Exercise 3.26.  To search a table as implemented above, one needs to scan through the list of records. This is basically the unordered list representation of section 2.3.3. For large tables, it may be more efficient to structure the table in a different manner. Describe a table implementation where the (key, value) records are organized using a binary tree, assuming that keys can be ordered in some way (e.g., numerically or alphabetically). (Compare exercise 2.66 of chapter 2.) 
2 
3 (define (test-case actual expected)
4   (newline)
5   (display "Actual:   ")
6   (display actual)
7   (newline)
8   (display "Expected: ")
9   (display expected)
10   (newline))
11 
12 (define (make-tree key value)
13   (list key value '() '()))
14 (define (tree-key tree)
15   (car tree))
16 (define (tree-value tree)
17   (cadr tree))
18 (define (left-branch tree)
19   (caddr tree))
20 (define (right-branch tree)
21   (cadddr tree))
22 (define (set-tree-value! tree value)
23   (set-car! (cdr tree) value))
24 (define (insert-left-branch! tree key value)
25   (set-car! (cddr tree)
26 	    (make-tree key value)))
27 (define (insert-right-branch! tree key value)
28   (set-car! (cdddr tree)
29 	    (make-tree key value)))
30 
31 ;; (define family-tree (make-tree 'me 'aaron))
32 ;; (insert-left-branch! family-tree 'mom 'amy)
33 ;; (insert-right-branch! family-tree 'dad 'james)
34 ;; (insert-left-branch! (left-branch family-tree) 'grandma '?)
35 ;; (insert-right-branch! (left-branch family-tree) 'grandpa 'sean)
36 ;; (insert-left-branch! (right-branch family-tree) 'grandma '??)
37 ;; (insert-right-branch! (right-branch family-tree) 'grandpa 'yuandu)
38 ;; (test-case (tree-value (right-branch (left-branch family-tree))) 'sean)
39 ;; (test-case (tree-key (left-branch (right-branch family-tree))) 'grandma)
40 ;; (test-case (tree-value (right-branch family-tree)) 'james)
41 ;; (set-tree-value! (right-branch family-tree) 'chen-min)
42 ;; (test-case (tree-value (right-branch family-tree)) 'chen-min)
43 
44 (define (make-table less-thanp)
45   (let ((local-table '()))
46     (define (assoc key tree)
47       (cond ((null? tree) false)
48 	    ((less-thanp key (tree-key tree)) (assoc key (left-branch tree)))
49 	    ((less-thanp (tree-key tree) key) (assoc key (right-branch tree)))
50 	    (else tree))) ;; equality
51     (define (lookup key)
52       (let ((match (assoc key local-table)))
53 	(if match
54 	    (tree-value match)
55 	    false)))
56     (define (insert! key value)
57       (define (insert-tree! tree)
58 	(if (equalp key (tree-key tree))
59 	    (set-tree-value! tree value)
60 	    (if (less-thanp key (tree-key tree))
61 		(if (null? (left-branch tree))
62 		    (insert-left-branch! tree key value)
63 		    (insert-tree! (left-branch tree)))
64 		(if (null? (right-branch tree))
65 		    (insert-right-branch! tree key value)
66 		    (insert-tree! (right-branch tree))))))
67       (if (null? local-table)
68 	  (set! local-table (make-tree key value))
69 	  (insert-tree! local-table)))
70     (define (dispatch m)
71       (cond ((eq? m 'lookup) lookup)
72 	    ((eq? m 'insert!) insert!)
73 	    ((eq? m 'debug-print) local-table)
74 	    (else (error "Unknown request -- MAKE-TABLE" m))))
75     dispatch))
76 
77 (define (insert! key value table)
78   ((table 'insert!) key value))
79 (define (lookup key table)
80   ((table 'lookup) key))
81 
82 (define israel-sons (make-table = <))
83 (insert! 3 'levi israel-sons)
84 (insert! 5 'dan israel-sons)
85 (test-case (lookup 3 israel-sons) 'levi)
86 (test-case (lookup 5 israel-sons) 'dan)
87 (test-case (lookup 12 israel-sons) false)
88 (test-case (lookup 11 israel-sons) false)
89 (test-case (lookup 1 israel-sons) false)
90 (insert! 12 'benjamin israel-sons)
91 (insert! 11 'joseph israel-sons)
92 (insert! 1 'reuben israel-sons)
93 (test-case (lookup 12 israel-sons) 'benjamin)
94 (test-case (lookup 11 israel-sons) 'joseph)
95 (test-case (lookup 1 israel-sons) 'reuben)
96 (insert! 2 'simeon israel-sons)
97 (test-case (lookup 3 israel-sons) 'levi)
98 (insert! 8 'asher israel-sons)
99 (insert! 7 'gad israel-sons)
100 (insert! 6 'naphtali israel-sons)
101 (insert! 9 'issachar israel-sons)
102 (insert! 10 'zebulun israel-sons)
103 (insert! 4 'judah israel-sons)
104 (test-case (lookup 4 israel-sons) 'judah)
105 (test-case (lookup 8 israel-sons) 'asher)
106 (test-case (lookup 13 israel-sons) false)
107 (insert! 12 'manasseh israel-sons)
108 (insert! 13 'ephraim israel-sons)
109 (insert! 11 'benjamin israel-sons)
110 (test-case (lookup 12 israel-sons) 'manasseh)
111 (test-case (lookup 13 israel-sons) 'ephraim)
112 (test-case (israel-sons 'debug-print) 
113 	   '(3 levi (1 reuben () (2 simeon () ())) (5 dan (4 judah () ()) (12 manasseh (11 benjamin (8 asher (7 gad (6 naphtali () ()) ()) (9 issachar () (10 zebulun () ()))) ()) (13 ephraim () ())))))
114 
115 (define by-mother (make-table string=? string<?))
116 (insert! "leah" 'reuben by-mother)
117 (test-case (lookup "leah" by-mother) 'reuben)
118 (insert! "leah" 'simeon by-mother)
119 (test-case (lookup "leah" by-mother) 'simeon)
120 (insert! "zilpah" 'gad by-mother)
121 (insert! "bilhah" 'dan by-mother)
122 (insert! "rachel" 'joseph by-mother)
123 (test-case (lookup "zilpah" by-mother) 'gad)
124 (test-case (lookup "bilhah" by-mother) 'dan)
125 (test-case (lookup "rachel" by-mother) 'joseph)
126