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 (define (make-leaf symbol weight)
11   (list 'leaf symbol weight))
12 (define (leaf? object)
13   (eq? (car object) 'leaf))
14 (define (symbol-leaf x) (cadr x))
15 (define (weight-leaf x) (caddr x))
16 
17 (define (make-code-tree left right)
18   (list left
19 	right
20 	(append (symbols left) (symbols right))
21 	(+ (weight left) (weight right))))
22 
23 (define (left-branch tree) (car tree))
24 (define (right-branch tree) (cadr tree))
25 (define (symbols tree)
26   (if (leaf? tree)
27       (list (symbol-leaf tree))
28       (caddr tree)))
29 (define (weight tree)
30   (if (leaf? tree)
31       (weight-leaf tree)
32       (cadddr tree)))
33 
34 (define (decode bits tree)
35   (define (decode-1 bits current-branch)
36     (if (null? bits)
37 	'()
38 	(let ((next-branch
39 	       (choose-branch (car bits) current-branch)))
40 	  (if (leaf? next-branch)
41 	      (cons (symbol-leaf next-branch)
42 		    (decode-1 (cdr bits) tree))
43 	      (decode-1 (cdr bits) next-branch)))))
44   (decode-1 bits tree))
45 (define (choose-branch bit branch)
46   (cond ((= bit 0) (left-branch branch))
47 	((= bit 1) (right-branch branch))
48 	(else (error "bad bit -- CHOOSE-BRANCH" bit))))
49 
50 (define (adjoin-set x set)
51   (cond ((null? set) (list x))
52 	((< (weight x) (weight (car set))) (cons x set))
53 	(else (cons (car set)
54 		    (adjoin-set x (cdr set))))))
55 (define (make-leaf-set pairs)
56   (if (null? pairs)
57       '()
58       (let ((pair (car pairs)))
59 	(adjoin-set (make-leaf (car pair)
60 			       (cadr pair))
61 		    (make-leaf-set (cdr pairs))))))
62 
63 (define (encode message tree)
64   (if (null? message)
65       '()
66       (append (encode-symbol (car message) tree)
67 	      (encode (cdr message) tree))))
68 
69 (define (element-of-set x set)
70   (and (not (null? set))
71        (or (equal? x (car set))
72 	   (element-of-set x (cdr set)))))
73 
74 (define (encode-symbol sym tree)
75   (cond ((null? tree) (error "empty tree"))
76 	((not (element-of-set sym (symbols tree))) 
77 	 (error "symbol not in tree"))
78 	((leaf? tree) '())
79 	((element-of-set sym (symbols (left-branch tree))) 
80 	 (cons 0 (encode-symbol sym (left-branch tree))))
81 	((element-of-set sym (symbols (right-branch tree)))
82 	 (cons 1 (encode-symbol sym (right-branch tree))))))
83 
84 (define sample-tree
85   (make-code-tree (make-leaf 'A 4)
86                   (make-code-tree
87                    (make-leaf 'B 2)
88                    (make-code-tree (make-leaf 'D 1)
89                                    (make-leaf 'C 1)))))
90 (define sample-tree-2
91   (make-code-tree (make-leaf 'A 4)
92                   (make-code-tree
93                    (make-leaf 'B 2)
94                    (make-code-tree (make-leaf 'E 1)
95                                    (make-leaf 'C 1)))))
96 
97 (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
98 (define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0))
99 (define sample-symbols '(A D A B B C A))
100 (define sample-symbols-2 '(E C B A B E E A B B A A C A))
101 
102 ;; (test-case (decode sample-message sample-tree) sample-symbols)
103 ;; (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
104 ;; ;; (test-case (encode sample-symbols '()) "error: empty tree")
105 ;; ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
106 ;; (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
107 ;; (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
108 
109 ;; Exercise 2.69.  The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm.
110 
111 (define (generate-huffman-tree pairs)
112   (successive-merge (make-leaf-set pairs)))
113 
114 ;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.) 
115 
116 (define (successive-merge leaf-set)
117   (cond ((null? leaf-set) (error "no leaves in leaf-set"))
118 	((null? (cdr leaf-set)) (car leaf-set))
119 	(else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) 
120 							    (car leaf-set))
121 					    (cddr leaf-set))))))
122 
123 
124 ;; (test-case (generate-huffman-tree '()) "no leaves in leaf-set")
125 (test-case (generate-huffman-tree '((A 8))) '(leaf A 8))
126 (test-case (generate-huffman-tree '((A 8) (B 3))) '((leaf A 8) (leaf B 3) (A B) 11)) ;; we'll put the element that appears later in the set of leaves on the left side of the tree by default
127 (test-case (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1)))
128 	   '((((leaf B 3)
129 	       ((leaf C 1) (leaf D 1) (C D) 2)
130 	       (B C D)
131 	       5)
132 	      (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
133 	      (B C D E F G H)
134 	      9)
135 	     (leaf A 8)
136 	     (B C D E F G H A)
137 	     17))
138 
139 ;; ((leaf H 1) (leaf G 1) (leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) (leaf B 3) (leaf A 8))
140 ;; ((leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) (leaf B 3) (leaf A 8))
141 ;; ((leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) (leaf B 3) (leaf A 8))
142 ;; (((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) ((leaf C 1) (leaf D 1) (C D) 2) (leaf B 3) (leaf A 8))
143 ;; (((leaf C 1) (leaf D 1) (C D) 2)
144 ;;  (leaf B 3)
145 ;;  (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
146 ;;  (leaf A 8))
147 ;; ((((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
148 ;;  ((leaf B 3)
149 ;;   ((leaf C 1) (leaf D 1) (C D) 2)
150 ;;   (B C D)
151 ;;   5)
152 ;;  (leaf A 8))
153 ;; ((leaf A 8)
154 ;;  (((leaf B 3)
155 ;;    ((leaf C 1) (leaf D 1) (C D) 2)
156 ;;    (B C D)
157 ;;    5)
158 ;;   (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
159 ;;   (B C D E F G H)
160 ;;   9))
161 ;; (((((leaf B 3)
162 ;;    ((leaf C 1) (leaf D 1) (C D) 2)
163 ;;    (B C D)
164 ;;    5)
165 ;;   (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
166 ;;   (B C D E F G H)
167 ;;   9)
168 ;;   (leaf A 8)
169 ;;   (B C D E F G H A)
170 ;;   17))
171 ;; ((((leaf B 3)
172 ;;    ((leaf C 1) (leaf D 1) (C D) 2)
173 ;;    (B C D)
174 ;;    5)
175 ;;   (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
176 ;;   (B C D E F G H)
177 ;;   9)
178 ;;   (leaf A 8)
179 ;;   (B C D E F G H A)
180 ;;   17)