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 ;; Exercise 2.68.  The encode procedure takes as arguments a message and a tree and produces the list of bits that gives the encoded message.
64 
65 (define (encode message tree)
66   (if (null? message)
67       '()
68       (append (encode-symbol (car message) tree)
69 	      (encode (cdr message) tree))))
70 
71 (define (element-of-set x set)
72   (and (not (null? set))
73        (or (equal? x (car set))
74 	   (element-of-set x (cdr set)))))
75 
76 ;; (test-case (element-of-set 'A '()) #f)
77 ;; (test-case (element-of-set 'A '(1 B C D)) #f)
78 ;; (test-case (element-of-set 'A '(1 A B C)) #t)
79 
80 (define (encode-symbol sym tree)
81   (cond ((null? tree) (error "empty tree"))
82 	((not (element-of-set sym (symbols tree))) 
83 	 (error "symbol not in tree"))
84 	((leaf? tree) '())
85 	((element-of-set sym (symbols (left-branch tree))) 
86 	 (cons 0 (encode-symbol sym (left-branch tree))))
87 	((element-of-set sym (symbols (right-branch tree)))
88 	 (cons 1 (encode-symbol sym (right-branch tree))))))
89 
90 ;; (define (encode-symbol sym tree)
91 ;;   (cond ((null? tree) (error "empty tree"))
92 ;; 	((leaf? tree) '())
93 ;; 	((element-of-set sym (symbols (left-branch tree))) 
94 ;; 	 (cons 0 (encode-symbol sym (left-branch tree))))
95 ;; 	((element-of-set sym (symbols (right-branch tree)))
96 ;; 	 (cons 1 (encode-symbol sym (right-branch tree))))
97 ;; 	(else (error "symbol not in tree")))))
98   
99 ;; Encode-symbol is a procedure, which you must write, that returns the list of bits that encodes a given symbol according to a given tree. You should design encode-symbol so that it signals an error if the symbol is not in the tree at all. Test your procedure by encoding the result you obtained in exercise 2.67 with the sample tree and seeing whether it is the same as the original sample message. 
100 
101 (define sample-tree
102   (make-code-tree (make-leaf 'A 4)
103                   (make-code-tree
104                    (make-leaf 'B 2)
105                    (make-code-tree (make-leaf 'D 1)
106                                    (make-leaf 'C 1)))))
107 (define sample-tree-2
108   (make-code-tree (make-leaf 'A 4)
109                   (make-code-tree
110                    (make-leaf 'B 2)
111                    (make-code-tree (make-leaf 'E 1)
112                                    (make-leaf 'C 1)))))
113 
114 (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
115 (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))
116 (define sample-symbols '(A D A B B C A))
117 (define sample-symbols-2 '(E C B A B E E A B B A A C A))
118 (test-case (decode sample-message sample-tree) sample-symbols)
119 
120 (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
121 ;; (test-case (encode sample-symbols '()) "error: empty tree")
122 ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
123 (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
124 (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)