1 665c255d 2023-08-04 jrmu (define (test-case actual expected)
 2 665c255d 2023-08-04 jrmu   (newline)
 3 665c255d 2023-08-04 jrmu   (display "Actual:   ")
 4 665c255d 2023-08-04 jrmu   (display actual)
 5 665c255d 2023-08-04 jrmu   (newline)
 6 665c255d 2023-08-04 jrmu   (display "Expected: ")
 7 665c255d 2023-08-04 jrmu   (display expected)
 8 665c255d 2023-08-04 jrmu   (newline))
 9 665c255d 2023-08-04 jrmu 
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))
16 665c255d 2023-08-04 jrmu 
17 665c255d 2023-08-04 jrmu (define (make-code-tree left right)
18 665c255d 2023-08-04 jrmu   (list left
19 665c255d 2023-08-04 jrmu 	right
20 665c255d 2023-08-04 jrmu 	(append (symbols left) (symbols right))
21 665c255d 2023-08-04 jrmu 	(+ (weight left) (weight right))))
22 665c255d 2023-08-04 jrmu 
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)))
33 665c255d 2023-08-04 jrmu 
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)
37 665c255d 2023-08-04 jrmu 	'()
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))))
49 665c255d 2023-08-04 jrmu 
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)
57 665c255d 2023-08-04 jrmu       '()
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))))))
62 665c255d 2023-08-04 jrmu 
63 665c255d 2023-08-04 jrmu ;; Exercise 2.67.  Define an encoding tree and a sample message:
64 665c255d 2023-08-04 jrmu 
65 665c255d 2023-08-04 jrmu (define sample-tree
66 665c255d 2023-08-04 jrmu   (make-code-tree (make-leaf 'A 4)
67 665c255d 2023-08-04 jrmu                   (make-code-tree
68 665c255d 2023-08-04 jrmu                    (make-leaf 'B 2)
69 665c255d 2023-08-04 jrmu                    (make-code-tree (make-leaf 'D 1)
70 665c255d 2023-08-04 jrmu                                    (make-leaf 'C 1)))))
71 665c255d 2023-08-04 jrmu 
72 665c255d 2023-08-04 jrmu (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
73 665c255d 2023-08-04 jrmu (test-case (decode sample-message sample-tree) '(A D A B B C A))