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