1 (define (test-case actual expected)
2   (newline)
3   (display "Actual:   ")
4   (display actual)
5   (newline)
6   (display "Expected: ")
7   (display expected)
8   (newline))
9 
10 
11 (define (entry tree) (car tree))
12 (define (left-branch tree) (cadr tree))
13 (define (right-branch tree) (caddr tree))
14 (define (make-tree entry left right)
15   (list entry left right))
16 
17 (define (element-of-set? x set)
18   (cond ((null? set) #f)
19 	((= x (entry set)) #t)
20 	((< x (entry set))
21 	 (element-of-set? x (left-branch set)))
22 	((> x (entry set))
23 	 (element-of-set? x (right-branch set)))))
24 
25 (define (adjoin-set x set)
26   (cond ((null? set) (make-tree x '() '()))
27 	((= x (entry set)) set)
28 	((< x (entry set))
29 	 (make-tree (entry set)
30 		    (adjoin-set x (left-branch set))
31 		    (right-branch set)))
32 	((> x (entry set))
33 	 (make-tree (entry set)
34 		    (left-branch set)
35 		    (adjoin-set x (right-branch set))))))
36 
37 (define (tree->list-2 tree)
38   (define (copy-to-list tree result-list)
39     (if (null? tree)
40 	result-list
41 	(copy-to-list (left-branch tree)
42 		      (cons (entry tree)
43 			    (copy-to-list (right-branch tree)
44 					  result-list)))))
45   (copy-to-list tree '()))
46 
47 (define (list->tree elements)
48   (car (partial-tree elements (length elements))))
49 
50 (define (partial-tree elts n)
51   (if (= n 0)
52       (cons '() elts)
53       (let* ((left-size (quotient (- n 1) 2))
54 	     (left-results (partial-tree elts left-size))
55 	     (left-tree (car left-results))
56 	     (right-size (- n (+ left-size 1)))
57 	     (right-result (partial-tree (cddr left-results) right-size))
58 	     (right-tree (car right-result)))
59 	(cons (make-tree (cadr left-results)
60 			 left-tree
61 			 right-tree)
62 	      (cdr right-result)))))
63 	
64 (test-case (list->tree '()) '())
65 (test-case (list->tree '(1)) '(1 () ()))
66 (test-case (list->tree '(1 2 3 4 5 6 7 8 9 10))
67 	   '(5 (2 (1 () ()) (3 () (4 () ()))) (8 (6 () (7 () ())) (9 () (10 () ())))))
68 
69 
70 ;; Exercise 2.65.  Use the results of exercises 2.63 and 2.64 to give O(n) implementations of union-set and intersection-set for sets implemented as (balanced) binary trees.
71 
72 (define (union-set set1 set2)
73   (define (union-set-list list1 list2)
74     (cond ((null? list1) list2)
75 	  ((null? list2) list1)
76 	  (else 
77 	   (let ((l1 (car list1))
78 		 (l2 (car list2)))
79 	     (cond ((= l1 l2) 
80 		    (cons l1 (union-set-list (cdr list1) (cdr list2))))
81 		   ((< l1 l2)
82 		    (cons l1 (union-set-list (cdr list1) list2)))
83 		   ((> l1 l2)
84 		    (cons l2 (union-set-list list1 (cdr list2)))))))))
85   (list->tree (union-set-list (tree->list-2 set1) 
86 			      (tree->list-2 set2))))
87 
88 
89 (test-case (union-set '() '()) '())
90 (test-case (union-set (make-tree 5 '() '()) '()) '(5 () ()))
91 (test-case (union-set '() (make-tree 5 (make-tree 3 '() '()) (make-tree 7 '() '()))) '(5 (3 () ()) (7 () ())))
92 (test-case 
93  (union-set
94   (make-tree 3 
95 	     (make-tree 1 
96 			(make-tree 0 '() '()) 
97 			(make-tree 2 '() '()))
98 	     (make-tree 5 
99 			(make-tree 4 '() '()) 
100 			(make-tree 6 '() '())))
101   (make-tree 1
102 	     '()
103 	     (make-tree 3
104 			'()
105 			(make-tree 5
106 				   '()
107 				   (make-tree 7
108 					      '()
109 					      (make-tree 9
110 							 '()
111 							 '()))))))	     
112  '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
113 (test-case 
114  (union-set
115   '(3 (1 (0 () ())
116 	 (2 () ()))
117       (5 (4 () ())
118 	 (6 () ())))
119   '(1 () (3 () (5 () (7 () (9 () ()))))))
120  '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
121 (test-case
122  (union-set
123   '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ())))))))
124   '(11 (4 (3 (2 () ()) ()) (9 () ())) (12 () (15 (14 (13 () ()) ()) ()))))
125  '(8 (3 (1 () (2 () ())) (5 (4 () ()) (7 () ()))) (12 (10 (9 () ()) (11 () ())) (14 (13 () ()) (15 () ())))))
126 
127 (define (intersection-set set1 set2)
128   (define (intersection-list list1 list2)
129     (if (or (null? list1)
130 	    (null? list2))
131 	'()
132 	(let ((l1 (car list1))
133 	      (l2 (car list2)))
134 	  (cond ((= l1 l2) (cons l1 (intersection-list (cdr list1) (cdr list2))))
135 		((< l1 l2) (intersection-list (cdr list1) list2))
136 		((> l1 l2) (intersection-list list1 (cdr list2)))))))
137   (list->tree (intersection-list (tree->list-2 set1) 
138 				 (tree->list-2 set2))))
139 
140 (test-case (intersection-set '() '()) '())
141 (test-case (intersection-set '(5 () ()) 
142 			     '())
143 	   '())
144 (test-case (intersection-set '()
145 			     '(5 () ())) 
146 	   '())
147 (test-case (intersection-set
148 	    '(3 () ())
149 	    '(5 (3 () ()) (7 () ())))
150 	   '(3 () ()))
151 (test-case (intersection-set
152 	    '(3 (1 (0 () ()) (2 () ())) (5 (4 () ()) (6 () ())))
153 	    '(1 () (3 () (5 () (7 () (9 () ()))))))
154 	   '(3 (1 () ()) (5 () ())))
155 (test-case
156  (intersection-set
157   '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ())))))))
158   '(11 (4 (3 (2 () ()) ()) (9 () ())) (12 () (15 (14 (13 () ()) ()) ()))))
159  '(4 (2 () (3 () ())) (12 (11 () ()) (14 () ()))))
160