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.68.  The encode procedure takes as arguments a message and a tree and produces the list of bits that gives the encoded message.
 64 665c255d 2023-08-04 jrmu 
 65 665c255d 2023-08-04 jrmu (define (encode message tree)
 66 665c255d 2023-08-04 jrmu   (if (null? message)
 67 665c255d 2023-08-04 jrmu       '()
 68 665c255d 2023-08-04 jrmu       (append (encode-symbol (car message) tree)
 69 665c255d 2023-08-04 jrmu 	      (encode (cdr message) tree))))
 70 665c255d 2023-08-04 jrmu 
 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)))))
 75 665c255d 2023-08-04 jrmu 
 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)
 79 665c255d 2023-08-04 jrmu 
 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))))))
 89 665c255d 2023-08-04 jrmu 
 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")))))
 98 665c255d 2023-08-04 jrmu   
 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. 
100 665c255d 2023-08-04 jrmu 
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)))))
113 665c255d 2023-08-04 jrmu 
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)
119 665c255d 2023-08-04 jrmu 
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)