1 665c255d 2023-08-04 jrmu (define (test-case actual expected)
3 665c255d 2023-08-04 jrmu (display "Actual: ")
4 665c255d 2023-08-04 jrmu (display actual)
6 665c255d 2023-08-04 jrmu (display "Expected: ")
7 665c255d 2023-08-04 jrmu (display expected)
10 665c255d 2023-08-04 jrmu (define (make-leaf symbol weight)
11 665c255d 2023-08-04 jrmu (list 'leaf symbol weight))
12 665c255d 2023-08-04 jrmu (define (leaf? object)
13 665c255d 2023-08-04 jrmu (eq? (car object) 'leaf))
14 665c255d 2023-08-04 jrmu (define (symbol-leaf x) (cadr x))
15 665c255d 2023-08-04 jrmu (define (weight-leaf x) (caddr x))
17 665c255d 2023-08-04 jrmu (define (make-code-tree left right)
20 665c255d 2023-08-04 jrmu (append (symbols left) (symbols right))
21 665c255d 2023-08-04 jrmu (+ (weight left) (weight right))))
23 665c255d 2023-08-04 jrmu (define (left-branch tree) (car tree))
24 665c255d 2023-08-04 jrmu (define (right-branch tree) (cadr tree))
25 665c255d 2023-08-04 jrmu (define (symbols tree)
26 665c255d 2023-08-04 jrmu (if (leaf? tree)
27 665c255d 2023-08-04 jrmu (list (symbol-leaf tree))
28 665c255d 2023-08-04 jrmu (caddr tree)))
29 665c255d 2023-08-04 jrmu (define (weight tree)
30 665c255d 2023-08-04 jrmu (if (leaf? tree)
31 665c255d 2023-08-04 jrmu (weight-leaf tree)
32 665c255d 2023-08-04 jrmu (cadddr tree)))
34 665c255d 2023-08-04 jrmu (define (decode bits tree)
35 665c255d 2023-08-04 jrmu (define (decode-1 bits current-branch)
36 665c255d 2023-08-04 jrmu (if (null? bits)
38 665c255d 2023-08-04 jrmu (let ((next-branch
39 665c255d 2023-08-04 jrmu (choose-branch (car bits) current-branch)))
40 665c255d 2023-08-04 jrmu (if (leaf? next-branch)
41 665c255d 2023-08-04 jrmu (cons (symbol-leaf next-branch)
42 665c255d 2023-08-04 jrmu (decode-1 (cdr bits) tree))
43 665c255d 2023-08-04 jrmu (decode-1 (cdr bits) next-branch)))))
44 665c255d 2023-08-04 jrmu (decode-1 bits tree))
45 665c255d 2023-08-04 jrmu (define (choose-branch bit branch)
46 665c255d 2023-08-04 jrmu (cond ((= bit 0) (left-branch branch))
47 665c255d 2023-08-04 jrmu ((= bit 1) (right-branch branch))
48 665c255d 2023-08-04 jrmu (else (error "bad bit -- CHOOSE-BRANCH" bit))))
50 665c255d 2023-08-04 jrmu (define (adjoin-set x set)
51 665c255d 2023-08-04 jrmu (cond ((null? set) (list x))
52 665c255d 2023-08-04 jrmu ((< (weight x) (weight (car set))) (cons x set))
53 665c255d 2023-08-04 jrmu (else (cons (car set)
54 665c255d 2023-08-04 jrmu (adjoin-set x (cdr set))))))
55 665c255d 2023-08-04 jrmu (define (make-leaf-set pairs)
56 665c255d 2023-08-04 jrmu (if (null? pairs)
58 665c255d 2023-08-04 jrmu (let ((pair (car pairs)))
59 665c255d 2023-08-04 jrmu (adjoin-set (make-leaf (car pair)
60 665c255d 2023-08-04 jrmu (cadr pair))
61 665c255d 2023-08-04 jrmu (make-leaf-set (cdr pairs))))))
63 665c255d 2023-08-04 jrmu ;; 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.
65 665c255d 2023-08-04 jrmu (define (encode message tree)
66 665c255d 2023-08-04 jrmu (if (null? message)
68 665c255d 2023-08-04 jrmu (append (encode-symbol (car message) tree)
69 665c255d 2023-08-04 jrmu (encode (cdr message) tree))))
71 665c255d 2023-08-04 jrmu (define (element-of-set x set)
72 665c255d 2023-08-04 jrmu (and (not (null? set))
73 665c255d 2023-08-04 jrmu (or (equal? x (car set))
74 665c255d 2023-08-04 jrmu (element-of-set x (cdr set)))))
76 665c255d 2023-08-04 jrmu ;; (test-case (element-of-set 'A '()) #f)
77 665c255d 2023-08-04 jrmu ;; (test-case (element-of-set 'A '(1 B C D)) #f)
78 665c255d 2023-08-04 jrmu ;; (test-case (element-of-set 'A '(1 A B C)) #t)
80 665c255d 2023-08-04 jrmu (define (encode-symbol sym tree)
81 665c255d 2023-08-04 jrmu (cond ((null? tree) (error "empty tree"))
82 665c255d 2023-08-04 jrmu ((not (element-of-set sym (symbols tree)))
83 665c255d 2023-08-04 jrmu (error "symbol not in tree"))
84 665c255d 2023-08-04 jrmu ((leaf? tree) '())
85 665c255d 2023-08-04 jrmu ((element-of-set sym (symbols (left-branch tree)))
86 665c255d 2023-08-04 jrmu (cons 0 (encode-symbol sym (left-branch tree))))
87 665c255d 2023-08-04 jrmu ((element-of-set sym (symbols (right-branch tree)))
88 665c255d 2023-08-04 jrmu (cons 1 (encode-symbol sym (right-branch tree))))))
90 665c255d 2023-08-04 jrmu ;; (define (encode-symbol sym tree)
91 665c255d 2023-08-04 jrmu ;; (cond ((null? tree) (error "empty tree"))
92 665c255d 2023-08-04 jrmu ;; ((leaf? tree) '())
93 665c255d 2023-08-04 jrmu ;; ((element-of-set sym (symbols (left-branch tree)))
94 665c255d 2023-08-04 jrmu ;; (cons 0 (encode-symbol sym (left-branch tree))))
95 665c255d 2023-08-04 jrmu ;; ((element-of-set sym (symbols (right-branch tree)))
96 665c255d 2023-08-04 jrmu ;; (cons 1 (encode-symbol sym (right-branch tree))))
97 665c255d 2023-08-04 jrmu ;; (else (error "symbol not in tree")))))
99 665c255d 2023-08-04 jrmu ;; 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.
101 665c255d 2023-08-04 jrmu (define sample-tree
102 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'A 4)
103 665c255d 2023-08-04 jrmu (make-code-tree
104 665c255d 2023-08-04 jrmu (make-leaf 'B 2)
105 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'D 1)
106 665c255d 2023-08-04 jrmu (make-leaf 'C 1)))))
107 665c255d 2023-08-04 jrmu (define sample-tree-2
108 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'A 4)
109 665c255d 2023-08-04 jrmu (make-code-tree
110 665c255d 2023-08-04 jrmu (make-leaf 'B 2)
111 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'E 1)
112 665c255d 2023-08-04 jrmu (make-leaf 'C 1)))))
114 665c255d 2023-08-04 jrmu (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
115 665c255d 2023-08-04 jrmu (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 665c255d 2023-08-04 jrmu (define sample-symbols '(A D A B B C A))
117 665c255d 2023-08-04 jrmu (define sample-symbols-2 '(E C B A B E E A B B A A C A))
118 665c255d 2023-08-04 jrmu (test-case (decode sample-message sample-tree) sample-symbols)
120 665c255d 2023-08-04 jrmu (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
121 665c255d 2023-08-04 jrmu ;; (test-case (encode sample-symbols '()) "error: empty tree")
122 665c255d 2023-08-04 jrmu ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
123 665c255d 2023-08-04 jrmu (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
124 665c255d 2023-08-04 jrmu (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
126 665c255d 2023-08-04 jrmu ;; 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.
128 665c255d 2023-08-04 jrmu (define (generate-huffman-tree pairs)
129 665c255d 2023-08-04 jrmu (successive-merge (make-leaf-set pairs)))
131 665c255d 2023-08-04 jrmu ;; 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.)
