1 665c255d 2023-08-04 jrmu (define (make-table)
 2 665c255d 2023-08-04 jrmu   (define local-table '())
 3 665c255d 2023-08-04 jrmu   (define make-record cons)
 4 665c255d 2023-08-04 jrmu   (define key-record car)
 5 665c255d 2023-08-04 jrmu   (define value-record cdr)
 6 665c255d 2023-08-04 jrmu   (define (make-tree entry left right) 
 7 665c255d 2023-08-04 jrmu     (list entry let right)) 
 8 665c255d 2023-08-04 jrmu   (define entry car)
 9 665c255d 2023-08-04 jrmu   (define left-branch cadr)
10 665c255d 2023-08-04 jrmu   (define right-branch caddr)
11 665c255d 2023-08-04 jrmu   (define key=? equal?)
12 665c255d 2023-08-04 jrmu   (define (list<? l1 l2)
13 665c255d 2023-08-04 jrmu     (andmap key<? l1 l2))
14 665c255d 2023-08-04 jrmu   (define (key<? key1 key2)
15 665c255d 2023-08-04 jrmu     (cond ((and (string? key1)
16 665c255d 2023-08-04 jrmu 		(string? key2)) (string<? key1 key2))
17 665c255d 2023-08-04 jrmu 	  ((and (number? key1)
18 665c255d 2023-08-04 jrmu 		(number? key2)) (< key1 key2))
19 665c255d 2023-08-04 jrmu 	  ((and (char? key1)
20 665c255d 2023-08-04 jrmu 		(char? key2)) (char<? key1 key2))
21 665c255d 2023-08-04 jrmu 	  (else (error "Unsupported key types -- KEY<?" key1 key2))))
22 665c255d 2023-08-04 jrmu   (define (element-of-set? x set)
23 665c255d 2023-08-04 jrmu     (cond ((null? set) false)
24 665c255d 2023-08-04 jrmu 	  ((key=? (key-record x) (key-record (entry set))) true)
25 665c255d 2023-08-04 jrmu 	  ((key<? (key-record x) (key-record (entry set))) 
26 665c255d 2023-08-04 jrmu 	   (element-of-set? x (left-branch set)))
27 665c255d 2023-08-04 jrmu 	  (else
28 665c255d 2023-08-04 jrmu 	   (element-of-set? x (right-branch set)))))
29 665c255d 2023-08-04 jrmu   (define (adjoin-set x set)
30 665c255d 2023-08-04 jrmu     (cond ((null? set) (make-tree x '() '()))
31 665c255d 2023-08-04 jrmu 	  ((key=? (key-record x) (key-record (entry set))) set)
32 665c255d 2023-08-04 jrmu 	  ((key<? (key-record x) (key-record (entry set)))
33 665c255d 2023-08-04 jrmu 	   (make-tree (entry set)
34 665c255d 2023-08-04 jrmu 		      (adjoin-set x (left-branch set))
35 665c255d 2023-08-04 jrmu 		      (right-branch set)))
36 665c255d 2023-08-04 jrmu 	  (else
37 665c255d 2023-08-04 jrmu 	   (make-tree (entry set)
38 665c255d 2023-08-04 jrmu 		      (left-branch set)
39 665c255d 2023-08-04 jrmu 		      (adjoin-set x (right-branch set))))))
40 665c255d 2023-08-04 jrmu   (define (lookup key records)
41 665c255d 2023-08-04 jrmu     (if (null? records)
42 665c255d 2023-08-04 jrmu 	false
43 665c255d 2023-08-04 jrmu 	(let* ((record (entry records))
44 665c255d 2023-08-04 jrmu 	       (key-entry (key-record record)))
45 665c255d 2023-08-04 jrmu 	  (cond ((key=? key key-entry) (value-record record))
46 665c255d 2023-08-04 jrmu 		((key<? key key-entry) (lookup key (left-branch records)))
47 665c255d 2023-08-04 jrmu 		(else (lookup key (right-branch records)))))))
48 665c255d 2023-08-04 jrmu   (define (insert! key value)
49 665c255d 2023-08-04 jrmu     (set! local-table
50 665c255d 2023-08-04 jrmu 	  (adjoin-set (cons key value)
51 665c255d 2023-08-04 jrmu 		      local-table)))
52 665c255d 2023-08-04 jrmu   (define (dispatch m)
53 665c255d 2023-08-04 jrmu     (cond ((eq? m 'lookup)
54 665c255d 2023-08-04 jrmu 	   (lambda (key)
55 665c255d 2023-08-04 jrmu 	     (lookup key local-table)))
56 665c255d 2023-08-04 jrmu 	  ((eq? m 'insert!) insert!)
57 665c255d 2023-08-04 jrmu 	  ((eq? m 'print) local-table)
58 665c255d 2023-08-04 jrmu 	  (else (error "Unknown operation -- TABLE" m))))
59 665c255d 2023-08-04 jrmu   dispatch)
60 665c255d 2023-08-04 jrmu