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 (define (tree->list-1 tree)
 37 665c255d 2023-08-04 jrmu   (if (null? tree)
 38 665c255d 2023-08-04 jrmu       '()
 39 665c255d 2023-08-04 jrmu       (append (tree->list-1 (left-branch tree))
 40 665c255d 2023-08-04 jrmu 	      (cons (entry tree)
 41 665c255d 2023-08-04 jrmu 		    (tree->list-1 (right-branch tree))))))
 42 665c255d 2023-08-04 jrmu (define (tree->list-2 tree)
 43 665c255d 2023-08-04 jrmu   (define (copy-to-list tree result-list)
 44 665c255d 2023-08-04 jrmu     (if (null? tree)
 45 665c255d 2023-08-04 jrmu 	result-list
 46 665c255d 2023-08-04 jrmu 	(copy-to-list (left-branch tree)
 47 665c255d 2023-08-04 jrmu 		      (cons (entry tree)
 48 665c255d 2023-08-04 jrmu 			    (copy-to-list (right-branch tree)
 49 665c255d 2023-08-04 jrmu 					  result-list)))))
 50 665c255d 2023-08-04 jrmu   (copy-to-list tree '()))
 51 665c255d 2023-08-04 jrmu 
 52 665c255d 2023-08-04 jrmu (define (list->tree elements)
 53 665c255d 2023-08-04 jrmu   (car (partial-tree elements (length elements))))
 54 665c255d 2023-08-04 jrmu 
 55 665c255d 2023-08-04 jrmu (define (partial-tree elts n)
 56 665c255d 2023-08-04 jrmu   (if (= n 0)
 57 665c255d 2023-08-04 jrmu       (cons '() elts)
 58 665c255d 2023-08-04 jrmu       (let ((left-size (quotient (- n 1) 2)))
 59 665c255d 2023-08-04 jrmu 	(let ((left-result (partial-tree elts left-size)))
 60 665c255d 2023-08-04 jrmu 	  (let ((left-tree (car left-result))
 61 665c255d 2023-08-04 jrmu 		(non-left-elts (cdr left-result))
 62 665c255d 2023-08-04 jrmu 		(right-size (- n (+ left-size 1))))
 63 665c255d 2023-08-04 jrmu 	    (let ((this-entry (car non-left-elts))
 64 665c255d 2023-08-04 jrmu 		  (right-result (partial-tree (cdr non-left-elts)
 65 665c255d 2023-08-04 jrmu 					      right-size)))
 66 665c255d 2023-08-04 jrmu 	      (let ((right-tree (car right-result))
 67 665c255d 2023-08-04 jrmu 		    (remaining-elts (cdr right-result)))
 68 665c255d 2023-08-04 jrmu 		(cons (make-tree this-entry left-tree right-tree)
 69 665c255d 2023-08-04 jrmu 		      remaining-elts))))))))
 70 665c255d 2023-08-04 jrmu 
 71 665c255d 2023-08-04 jrmu ;; Exercise 2.65.  Use the results of exercises 2.63 and  2.64 to give (n) implementations of union-set and intersection-set for sets implemented as (balanced) binary trees.41 
 72 665c255d 2023-08-04 jrmu 
 73 665c255d 2023-08-04 jrmu (define (union-set set1 set2)
 74 665c255d 2023-08-04 jrmu   (define (union-set-list list1 list2)
 75 665c255d 2023-08-04 jrmu     (cond ((null? list1) list2)
 76 665c255d 2023-08-04 jrmu 	  ((null? list2) list1)
 77 665c255d 2023-08-04 jrmu 	  (else 
 78 665c255d 2023-08-04 jrmu 	   (let ((l1 (car list1))
 79 665c255d 2023-08-04 jrmu 		 (l2 (car list2)))
 80 665c255d 2023-08-04 jrmu 	     (cond ((= l1 l2) 
 81 665c255d 2023-08-04 jrmu 		    (cons l1 (union-set-list (cdr list1) (cdr list2))))
 82 665c255d 2023-08-04 jrmu 		   ((< l1 l2)
 83 665c255d 2023-08-04 jrmu 		    (cons l1 (union-set-list (cdr list1) list2)))
 84 665c255d 2023-08-04 jrmu 		   ((> l1 l2)
 85 665c255d 2023-08-04 jrmu 		    (cons l2 (union-set-list list1 (cdr list2)))))))))
 86 665c255d 2023-08-04 jrmu   (list->tree (union-set-list (tree->list-2 set1) 
 87 665c255d 2023-08-04 jrmu 			      (tree->list-2 set2))))
 88 665c255d 2023-08-04 jrmu 
 89 665c255d 2023-08-04 jrmu 
 90 665c255d 2023-08-04 jrmu (test-case (union-set '() '()) '())
 91 665c255d 2023-08-04 jrmu (test-case (union-set (make-tree 5 '() '()) '()) '(5 () ()))
 92 665c255d 2023-08-04 jrmu (test-case (union-set '() (make-tree 5 (make-tree 3 '() '()) (make-tree 7 '() '()))) '(5 (3 () ()) (7 () ())))
 93 665c255d 2023-08-04 jrmu (test-case 
 94 665c255d 2023-08-04 jrmu  (union-set
 95 665c255d 2023-08-04 jrmu   (make-tree 3 
 96 665c255d 2023-08-04 jrmu 	     (make-tree 1 
 97 665c255d 2023-08-04 jrmu 			(make-tree 0 '() '()) 
 98 665c255d 2023-08-04 jrmu 			(make-tree 2 '() '()))
 99 665c255d 2023-08-04 jrmu 	     (make-tree 5 
100 665c255d 2023-08-04 jrmu 			(make-tree 4 '() '()) 
101 665c255d 2023-08-04 jrmu 			(make-tree 6 '() '())))
102 665c255d 2023-08-04 jrmu   (make-tree 1
103 665c255d 2023-08-04 jrmu 	     '()
104 665c255d 2023-08-04 jrmu 	     (make-tree 3
105 665c255d 2023-08-04 jrmu 			'()
106 665c255d 2023-08-04 jrmu 			(make-tree 5
107 665c255d 2023-08-04 jrmu 				   '()
108 665c255d 2023-08-04 jrmu 				   (make-tree 7
109 665c255d 2023-08-04 jrmu 					      '()
110 665c255d 2023-08-04 jrmu 					      (make-tree 9
111 665c255d 2023-08-04 jrmu 							 '()
112 665c255d 2023-08-04 jrmu 							 '()))))))	     
113 665c255d 2023-08-04 jrmu  '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
114 665c255d 2023-08-04 jrmu (test-case 
115 665c255d 2023-08-04 jrmu  (union-set
116 665c255d 2023-08-04 jrmu   (make-tree 3 
117 665c255d 2023-08-04 jrmu 	     (make-tree 1 
118 665c255d 2023-08-04 jrmu 			(make-tree 0 '() '()) 
119 665c255d 2023-08-04 jrmu 			(make-tree 2 '() '()))
120 665c255d 2023-08-04 jrmu 	     (make-tree 5 
121 665c255d 2023-08-04 jrmu 			(make-tree 4 '() '()) 
122 665c255d 2023-08-04 jrmu 			(make-tree 6 '() '())))
123 665c255d 2023-08-04 jrmu   (make-tree 1
124 665c255d 2023-08-04 jrmu 	     '()
125 665c255d 2023-08-04 jrmu 	     (make-tree 3
126 665c255d 2023-08-04 jrmu 			'()
127 665c255d 2023-08-04 jrmu 			(make-tree 5
128 665c255d 2023-08-04 jrmu 				   '()
129 665c255d 2023-08-04 jrmu 				   (make-tree 7
130 665c255d 2023-08-04 jrmu 					      '()
131 665c255d 2023-08-04 jrmu 					      (make-tree 9
132 665c255d 2023-08-04 jrmu 							 '()
133 665c255d 2023-08-04 jrmu 							 '()))))))	     
134 665c255d 2023-08-04 jrmu  '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
135 665c255d 2023-08-04 jrmu (test-case
136 665c255d 2023-08-04 jrmu  (union-set
137 665c255d 2023-08-04 jrmu   '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ())))))))
138 665c255d 2023-08-04 jrmu   '(11 (4 (3 () (2 () ())) (9 () ())) (12 () (15 (14 (13 () ()) ()) ()))))
139 665c255d 2023-08-04 jrmu  '(8 (3 (1 () (2 () ())) (5 (4 () ()) (7 () ()))) (12 (10 (9 () ()) (11 () ())) (14 (13 () ()) (15 () ())))))
140 665c255d 2023-08-04 jrmu   
141 665c255d 2023-08-04 jrmu 			(make-tree 0 '() '()) 
142 665c255d 2023-08-04 jrmu 			(make-tree 2 '() '()))
143 665c255d 2023-08-04 jrmu 	     (make-tree 5 
144 665c255d 2023-08-04 jrmu 			(make-tree 4 '() '()) 
145 665c255d 2023-08-04 jrmu 			(make-tree 6 '() '())))