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 (generate-huffman-tree pairs)
85 665c255d 2023-08-04 jrmu (successive-merge (make-leaf-set pairs)))
87 665c255d 2023-08-04 jrmu (define (successive-merge leaf-set)
88 665c255d 2023-08-04 jrmu (cond ((null? leaf-set) (error "no leaves in leaf-set"))
89 665c255d 2023-08-04 jrmu ((null? (cdr leaf-set)) (car leaf-set))
90 665c255d 2023-08-04 jrmu (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
91 665c255d 2023-08-04 jrmu (car leaf-set))
92 665c255d 2023-08-04 jrmu (cddr leaf-set))))))
94 665c255d 2023-08-04 jrmu ;; 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.)
96 665c255d 2023-08-04 jrmu ;; A 2 NA 16
97 665c255d 2023-08-04 jrmu ;; BOOM 1 SHA 3
98 665c255d 2023-08-04 jrmu ;; GET 2 YIP 9
99 665c255d 2023-08-04 jrmu ;; JOB 2 WAH 1
100 665c255d 2023-08-04 jrmu ;; Use generate-huffman-tree (exercise 2.69) to generate a corresponding Huffman tree, and use encode (exercise 2.68) to encode the following message:
102 665c255d 2023-08-04 jrmu (test-case (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))
103 665c255d 2023-08-04 jrmu '((((((leaf get 2) (leaf job 2) (get job) 4)
104 665c255d 2023-08-04 jrmu (leaf sha 3)
105 665c255d 2023-08-04 jrmu (get job sha)
107 665c255d 2023-08-04 jrmu (((leaf boom 1) (leaf wah 1) (boom wah) 2)
109 665c255d 2023-08-04 jrmu (boom wah a)
111 665c255d 2023-08-04 jrmu (get job sha boom wah a)
113 665c255d 2023-08-04 jrmu (leaf yip 9)
114 665c255d 2023-08-04 jrmu (get job sha boom wah a yip)
116 665c255d 2023-08-04 jrmu (leaf na 16)
117 665c255d 2023-08-04 jrmu (get job sha boom wah a yip na)
119 665c255d 2023-08-04 jrmu (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 665c255d 2023-08-04 jrmu (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))))
121 665c255d 2023-08-04 jrmu '(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))
123 665c255d 2023-08-04 jrmu ;; GET 00000
124 665c255d 2023-08-04 jrmu ;; JOB 00001
125 665c255d 2023-08-04 jrmu ;; SHA 0001
126 665c255d 2023-08-04 jrmu ;; BOOM 00100
127 665c255d 2023-08-04 jrmu ;; WAH 00101
132 665c255d 2023-08-04 jrmu ;; Get a job
134 665c255d 2023-08-04 jrmu ;; Sha na na na na na na na na
136 665c255d 2023-08-04 jrmu ;; Get a job
138 665c255d 2023-08-04 jrmu ;; Sha na na na na na na na na
140 665c255d 2023-08-04 jrmu ;; Wah yip yip yip yip yip yip yip yip yip
142 665c255d 2023-08-04 jrmu ;; Sha boom
144 665c255d 2023-08-04 jrmu ;; 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?
146 665c255d 2023-08-04 jrmu ;; 5 bits are required at most for encoding a symbol, which is actually 2 bits more than fixed-length code
148 665c255d 2023-08-04 jrmu ;; Overall, though, only 84 bits are required using Huffman encoding vs. 108 bits for fixed-length code
