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 (define (encode message tree)
64 665c255d 2023-08-04 jrmu (if (null? message)
66 665c255d 2023-08-04 jrmu (append (encode-symbol (car message) tree)
67 665c255d 2023-08-04 jrmu (encode (cdr message) tree))))
69 665c255d 2023-08-04 jrmu (define (element-of-set x set)
70 665c255d 2023-08-04 jrmu (and (not (null? set))
71 665c255d 2023-08-04 jrmu (or (equal? x (car set))
72 665c255d 2023-08-04 jrmu (element-of-set x (cdr set)))))
74 665c255d 2023-08-04 jrmu (define (encode-symbol sym tree)
75 665c255d 2023-08-04 jrmu (cond ((null? tree) (error "empty tree"))
76 665c255d 2023-08-04 jrmu ((not (element-of-set sym (symbols tree)))
77 665c255d 2023-08-04 jrmu (error "symbol not in tree"))
78 665c255d 2023-08-04 jrmu ((leaf? tree) '())
79 665c255d 2023-08-04 jrmu ((element-of-set sym (symbols (left-branch tree)))
80 665c255d 2023-08-04 jrmu (cons 0 (encode-symbol sym (left-branch tree))))
81 665c255d 2023-08-04 jrmu ((element-of-set sym (symbols (right-branch tree)))
82 665c255d 2023-08-04 jrmu (cons 1 (encode-symbol sym (right-branch tree))))))
84 665c255d 2023-08-04 jrmu (define sample-tree
85 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'A 4)
86 665c255d 2023-08-04 jrmu (make-code-tree
87 665c255d 2023-08-04 jrmu (make-leaf 'B 2)
88 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'D 1)
89 665c255d 2023-08-04 jrmu (make-leaf 'C 1)))))
90 665c255d 2023-08-04 jrmu (define sample-tree-2
91 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'A 4)
92 665c255d 2023-08-04 jrmu (make-code-tree
93 665c255d 2023-08-04 jrmu (make-leaf 'B 2)
94 665c255d 2023-08-04 jrmu (make-code-tree (make-leaf 'E 1)
95 665c255d 2023-08-04 jrmu (make-leaf 'C 1)))))
97 665c255d 2023-08-04 jrmu (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
98 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))
99 665c255d 2023-08-04 jrmu (define sample-symbols '(A D A B B C A))
100 665c255d 2023-08-04 jrmu (define sample-symbols-2 '(E C B A B E E A B B A A C A))
102 665c255d 2023-08-04 jrmu ;; (test-case (decode sample-message sample-tree) sample-symbols)
103 665c255d 2023-08-04 jrmu ;; (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
104 665c255d 2023-08-04 jrmu ;; ;; (test-case (encode sample-symbols '()) "error: empty tree")
105 665c255d 2023-08-04 jrmu ;; ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
106 665c255d 2023-08-04 jrmu ;; (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
107 665c255d 2023-08-04 jrmu ;; (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
109 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.
111 665c255d 2023-08-04 jrmu (define (generate-huffman-tree pairs)
112 665c255d 2023-08-04 jrmu (successive-merge (make-leaf-set pairs)))
114 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.)
116 665c255d 2023-08-04 jrmu (define (successive-merge leaf-set)
117 665c255d 2023-08-04 jrmu (cond ((null? leaf-set) (error "no leaves in leaf-set"))
118 665c255d 2023-08-04 jrmu ((null? (cdr leaf-set)) (car leaf-set))
119 665c255d 2023-08-04 jrmu (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
120 665c255d 2023-08-04 jrmu (car leaf-set))
121 665c255d 2023-08-04 jrmu (cddr leaf-set))))))
124 665c255d 2023-08-04 jrmu ;; (test-case (generate-huffman-tree '()) "no leaves in leaf-set")
125 665c255d 2023-08-04 jrmu (test-case (generate-huffman-tree '((A 8))) '(leaf A 8))
126 665c255d 2023-08-04 jrmu (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 665c255d 2023-08-04 jrmu (test-case (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1)))
128 665c255d 2023-08-04 jrmu '((((leaf B 3)
129 665c255d 2023-08-04 jrmu ((leaf C 1) (leaf D 1) (C D) 2)
132 665c255d 2023-08-04 jrmu (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
133 665c255d 2023-08-04 jrmu (B C D E F G H)
136 665c255d 2023-08-04 jrmu (B C D E F G H A)
139 665c255d 2023-08-04 jrmu ;; ((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 665c255d 2023-08-04 jrmu ;; ((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 665c255d 2023-08-04 jrmu ;; ((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 665c255d 2023-08-04 jrmu ;; (((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 665c255d 2023-08-04 jrmu ;; (((leaf C 1) (leaf D 1) (C D) 2)
144 665c255d 2023-08-04 jrmu ;; (leaf B 3)
145 665c255d 2023-08-04 jrmu ;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
146 665c255d 2023-08-04 jrmu ;; (leaf A 8))
147 665c255d 2023-08-04 jrmu ;; ((((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
148 665c255d 2023-08-04 jrmu ;; ((leaf B 3)
149 665c255d 2023-08-04 jrmu ;; ((leaf C 1) (leaf D 1) (C D) 2)
152 665c255d 2023-08-04 jrmu ;; (leaf A 8))
153 665c255d 2023-08-04 jrmu ;; ((leaf A 8)
154 665c255d 2023-08-04 jrmu ;; (((leaf B 3)
155 665c255d 2023-08-04 jrmu ;; ((leaf C 1) (leaf D 1) (C D) 2)
158 665c255d 2023-08-04 jrmu ;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
159 665c255d 2023-08-04 jrmu ;; (B C D E F G H)
161 665c255d 2023-08-04 jrmu ;; (((((leaf B 3)
162 665c255d 2023-08-04 jrmu ;; ((leaf C 1) (leaf D 1) (C D) 2)
165 665c255d 2023-08-04 jrmu ;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
166 665c255d 2023-08-04 jrmu ;; (B C D E F G H)
168 665c255d 2023-08-04 jrmu ;; (leaf A 8)
169 665c255d 2023-08-04 jrmu ;; (B C D E F G H A)
171 665c255d 2023-08-04 jrmu ;; ((((leaf B 3)
172 665c255d 2023-08-04 jrmu ;; ((leaf C 1) (leaf D 1) (C D) 2)
175 665c255d 2023-08-04 jrmu ;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
176 665c255d 2023-08-04 jrmu ;; (B C D E F G H)
178 665c255d 2023-08-04 jrmu ;; (leaf A 8)
179 665c255d 2023-08-04 jrmu ;; (B C D E F G H A)
