1 665c255d 2023-08-04 jrmu ;; 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.)
3 665c255d 2023-08-04 jrmu (define (test-case actual expected)
5 665c255d 2023-08-04 jrmu (display "Actual: ")
6 665c255d 2023-08-04 jrmu (display actual)
8 665c255d 2023-08-04 jrmu (display "Expected: ")
9 665c255d 2023-08-04 jrmu (display expected)
12 665c255d 2023-08-04 jrmu (define (make-tree key value)
13 665c255d 2023-08-04 jrmu (list key value '() '()))
14 665c255d 2023-08-04 jrmu (define (tree-key tree)
16 665c255d 2023-08-04 jrmu (define (tree-value tree)
17 665c255d 2023-08-04 jrmu (cadr tree))
18 665c255d 2023-08-04 jrmu (define (left-branch tree)
19 665c255d 2023-08-04 jrmu (caddr tree))
20 665c255d 2023-08-04 jrmu (define (right-branch tree)
21 665c255d 2023-08-04 jrmu (cadddr tree))
22 665c255d 2023-08-04 jrmu (define (set-tree-value! tree value)
23 665c255d 2023-08-04 jrmu (set-car! (cdr tree) value))
24 665c255d 2023-08-04 jrmu (define (insert-left-branch! tree key value)
25 665c255d 2023-08-04 jrmu (set-car! (cddr tree)
26 665c255d 2023-08-04 jrmu (make-tree key value)))
27 665c255d 2023-08-04 jrmu (define (insert-right-branch! tree key value)
28 665c255d 2023-08-04 jrmu (set-car! (cdddr tree)
29 665c255d 2023-08-04 jrmu (make-tree key value)))
31 665c255d 2023-08-04 jrmu ;; (define family-tree (make-tree 'me 'aaron))
32 665c255d 2023-08-04 jrmu ;; (insert-left-branch! family-tree 'mom 'amy)
33 665c255d 2023-08-04 jrmu ;; (insert-right-branch! family-tree 'dad 'james)
34 665c255d 2023-08-04 jrmu ;; (insert-left-branch! (left-branch family-tree) 'grandma '?)
35 665c255d 2023-08-04 jrmu ;; (insert-right-branch! (left-branch family-tree) 'grandpa 'sean)
36 665c255d 2023-08-04 jrmu ;; (insert-left-branch! (right-branch family-tree) 'grandma '??)
37 665c255d 2023-08-04 jrmu ;; (insert-right-branch! (right-branch family-tree) 'grandpa 'yuandu)
38 665c255d 2023-08-04 jrmu ;; (test-case (tree-value (right-branch (left-branch family-tree))) 'sean)
39 665c255d 2023-08-04 jrmu ;; (test-case (tree-key (left-branch (right-branch family-tree))) 'grandma)
40 665c255d 2023-08-04 jrmu ;; (test-case (tree-value (right-branch family-tree)) 'james)
41 665c255d 2023-08-04 jrmu ;; (set-tree-value! (right-branch family-tree) 'chen-min)
42 665c255d 2023-08-04 jrmu ;; (test-case (tree-value (right-branch family-tree)) 'chen-min)
44 665c255d 2023-08-04 jrmu (define (make-table less-thanp)
45 665c255d 2023-08-04 jrmu (let ((local-table '()))
46 665c255d 2023-08-04 jrmu (define (assoc key tree)
47 665c255d 2023-08-04 jrmu (cond ((null? tree) false)
48 665c255d 2023-08-04 jrmu ((less-thanp key (tree-key tree)) (assoc key (left-branch tree)))
49 665c255d 2023-08-04 jrmu ((less-thanp (tree-key tree) key) (assoc key (right-branch tree)))
50 665c255d 2023-08-04 jrmu (else tree))) ;equality
51 665c255d 2023-08-04 jrmu (define (lookup key)
52 665c255d 2023-08-04 jrmu (let ((match (assoc key local-table)))
54 665c255d 2023-08-04 jrmu (tree-value match)
56 665c255d 2023-08-04 jrmu (define (insert! key value)
57 665c255d 2023-08-04 jrmu (define (insert-tree! tree)
58 665c255d 2023-08-04 jrmu (cond ((less-thanp key (tree-key tree))
59 665c255d 2023-08-04 jrmu (if (null? (left-branch tree))
60 665c255d 2023-08-04 jrmu (insert-left-branch! tree key value)
61 665c255d 2023-08-04 jrmu (insert-tree! (left-branch tree))))
62 665c255d 2023-08-04 jrmu ((less-thanp (tree-key tree) key)
63 665c255d 2023-08-04 jrmu (if (null? (right-branch tree))
64 665c255d 2023-08-04 jrmu (insert-right-branch! tree key value)
65 665c255d 2023-08-04 jrmu (insert-tree! (right-branch tree))))
66 665c255d 2023-08-04 jrmu (else (set-tree-value! tree value)))) ;; equality
67 665c255d 2023-08-04 jrmu (if (null? local-table)
68 665c255d 2023-08-04 jrmu (set! local-table (make-tree key value))
69 665c255d 2023-08-04 jrmu (insert-tree! local-table)))
70 665c255d 2023-08-04 jrmu (define (dispatch m)
71 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup) lookup)
72 665c255d 2023-08-04 jrmu ((eq? m 'insert!) insert!)
73 665c255d 2023-08-04 jrmu ((eq? m 'debug-print) local-table)
74 665c255d 2023-08-04 jrmu (else (error "Unknown request -- MAKE-TABLE" m))))
77 665c255d 2023-08-04 jrmu (define (insert! key value table)
78 665c255d 2023-08-04 jrmu ((table 'insert!) key value))
79 665c255d 2023-08-04 jrmu (define (lookup key table)
80 665c255d 2023-08-04 jrmu ((table 'lookup) key))
82 665c255d 2023-08-04 jrmu (define israel-sons (make-table <))
83 665c255d 2023-08-04 jrmu (insert! 3 'levi israel-sons)
84 665c255d 2023-08-04 jrmu (insert! 5 'dan israel-sons)
85 665c255d 2023-08-04 jrmu (test-case (lookup 3 israel-sons) 'levi)
86 665c255d 2023-08-04 jrmu (test-case (lookup 5 israel-sons) 'dan)
87 665c255d 2023-08-04 jrmu (test-case (lookup 12 israel-sons) false)
88 665c255d 2023-08-04 jrmu (test-case (lookup 11 israel-sons) false)
89 665c255d 2023-08-04 jrmu (test-case (lookup 1 israel-sons) false)
90 665c255d 2023-08-04 jrmu (insert! 12 'benjamin israel-sons)
91 665c255d 2023-08-04 jrmu (insert! 11 'joseph israel-sons)
92 665c255d 2023-08-04 jrmu (insert! 1 'reuben israel-sons)
93 665c255d 2023-08-04 jrmu (test-case (lookup 12 israel-sons) 'benjamin)
94 665c255d 2023-08-04 jrmu (test-case (lookup 11 israel-sons) 'joseph)
95 665c255d 2023-08-04 jrmu (test-case (lookup 1 israel-sons) 'reuben)
96 665c255d 2023-08-04 jrmu (insert! 2 'simeon israel-sons)
97 665c255d 2023-08-04 jrmu (test-case (lookup 3 israel-sons) 'levi)
98 665c255d 2023-08-04 jrmu (insert! 8 'asher israel-sons)
99 665c255d 2023-08-04 jrmu (insert! 7 'gad israel-sons)
100 665c255d 2023-08-04 jrmu (insert! 6 'naphtali israel-sons)
101 665c255d 2023-08-04 jrmu (insert! 9 'issachar israel-sons)
102 665c255d 2023-08-04 jrmu (insert! 10 'zebulun israel-sons)
103 665c255d 2023-08-04 jrmu (insert! 4 'judah israel-sons)
104 665c255d 2023-08-04 jrmu (test-case (lookup 4 israel-sons) 'judah)
105 665c255d 2023-08-04 jrmu (test-case (lookup 8 israel-sons) 'asher)
106 665c255d 2023-08-04 jrmu (test-case (lookup 13 israel-sons) false)
107 665c255d 2023-08-04 jrmu (insert! 12 'manasseh israel-sons)
108 665c255d 2023-08-04 jrmu (insert! 13 'ephraim israel-sons)
109 665c255d 2023-08-04 jrmu (insert! 11 'benjamin israel-sons)
110 665c255d 2023-08-04 jrmu (test-case (lookup 12 israel-sons) 'manasseh)
111 665c255d 2023-08-04 jrmu (test-case (lookup 13 israel-sons) 'ephraim)
112 665c255d 2023-08-04 jrmu (test-case (israel-sons 'debug-print)
113 665c255d 2023-08-04 jrmu '(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 () ())))))
115 665c255d 2023-08-04 jrmu (define by-mother (make-table string<?))
116 665c255d 2023-08-04 jrmu (insert! "leah" 'reuben by-mother)
117 665c255d 2023-08-04 jrmu (test-case (lookup "leah" by-mother) 'reuben)
118 665c255d 2023-08-04 jrmu (insert! "leah" 'simeon by-mother)
119 665c255d 2023-08-04 jrmu (test-case (lookup "leah" by-mother) 'simeon)
120 665c255d 2023-08-04 jrmu (insert! "zilpah" 'gad by-mother)
121 665c255d 2023-08-04 jrmu (insert! "bilhah" 'dan by-mother)
122 665c255d 2023-08-04 jrmu (insert! "rachel" 'joseph by-mother)
123 665c255d 2023-08-04 jrmu (test-case (lookup "zilpah" by-mother) 'gad)
124 665c255d 2023-08-04 jrmu (test-case (lookup "bilhah" by-mother) 'dan)
125 665c255d 2023-08-04 jrmu (test-case (lookup "rachel" by-mother) 'joseph)
