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 (generate-huffman-tree pairs)
85   (successive-merge (make-leaf-set pairs)))
86 
87 (define (successive-merge leaf-set)
88   (cond ((null? leaf-set) (error "no leaves in leaf-set"))
89 	((null? (cdr leaf-set)) (car leaf-set))
90 	(else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set) 
91 							    (car leaf-set))
92 					    (cddr leaf-set))))))
93 
94 ;; Exercise 2.70.  The following eight-symbol alphabet with associated relative frequencies was designed to efficiently encode the lyrics of 1950s rock songs. (Note that the ``symbols'' of an ``alphabet'' need not be individual letters.)
95 
96 ;; A 2 NA 16
97 ;; BOOM 1 SHA 3
98 ;; GET 2 YIP 9
99 ;; JOB 2 WAH 1
100 ;; Use generate-huffman-tree (exercise 2.69) to generate a corresponding Huffman tree, and use encode (exercise 2.68) to encode the following message:
101 
102 (test-case (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))
103 	   '((((((leaf get 2) (leaf job 2) (get job) 4)
104 		(leaf sha 3)
105 		(get job sha) 
106 		7)
107 	       (((leaf boom 1) (leaf wah 1) (boom wah) 2)
108 		(leaf a 2)
109 		(boom wah a)
110 		4)
111 	       (get job sha boom wah a)
112 	       11)
113 	      (leaf yip 9)
114 	      (get job sha boom wah a yip)
115 	      20)
116 	     (leaf na 16)
117 	     (get job sha boom wah a yip na)
118 	     36))
119 (test-case (encode '(get a job sha na na na na na na na na get a job sha na na na na na na na na wah yip yip yip yip yip yip yip yip yip sha boom)
120 		   (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))))
121 	   '(0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 0 0 1 0 0 1 0 0))
122 
123 ;; GET 00000
124 ;; JOB 00001
125 ;; SHA 0001
126 ;; BOOM 00100
127 ;; WAH 00101
128 ;; A 0011
129 ;; YIP 01
130 ;; NA 1
131 
132 ;; Get a job
133 
134 ;; Sha na na na na na na na na
135 
136 ;; Get a job
137 
138 ;; Sha na na na na na na na na
139 
140 ;; Wah yip yip yip yip yip yip yip yip yip
141 
142 ;; Sha boom
143 
144 ;; How many bits are required for the encoding? What is the smallest number of bits that would be needed to encode this song if we used a fixed-length code for the eight-symbol alphabet? 
145 
146 ;; 5 bits are required at most for encoding a symbol, which is actually 2 bits more than fixed-length code
147 
148 ;; Overall, though, only 84 bits are required using Huffman encoding vs. 108 bits for fixed-length code