huffman-codes-stuff.scm (5658B)
1 (define-library (sicp solutions huffman-codes-stuff) 2 (import (scheme base)) 3 (import (scheme process-context)) 4 (import (scheme write)) 5 (import (scheme cxr)) 6 (import (only (sicp utils) accumulate)) 7 (import (only (sicp solutions chapter-2 exercise-40) remove)) 8 (export decode 9 encode 10 generate-huffman-tree 11 make-leaf 12 sample-message 13 sample-tree 14 weight 15 make-code-tree) 16 17 (begin 18 (define (make-leaf symbol weight) 19 (list 'leaf symbol weight)) 20 21 (define (leaf? object) 22 (eq? (car object) 'leaf)) 23 24 (define (symbol-leaf x) (cadr x)) 25 (define (weight-leaf x) (caddr x)) 26 27 (define (make-code-tree left right) 28 (list left 29 right 30 (append (symbols left) 31 (symbols right)) 32 (+ (weight left) 33 (weight right)))) 34 35 (define (left-branch tree) (car tree)) 36 (define (right-branch tree) (cadr tree)) 37 38 (define (symbols tree) 39 (if (leaf? tree) 40 (list (symbol-leaf tree)) 41 (caddr tree))) 42 43 (define (weight tree) 44 (if (leaf? tree) 45 (weight-leaf tree) 46 (cadddr tree))) 47 48 (define (decode bits tree) 49 (define (decode-1 bits current-branch) 50 (if (null? bits) 51 '() 52 (let ([next-branch 53 (choose-branch 54 (car bits) 55 current-branch)]) 56 (if (leaf? next-branch) 57 (cons 58 (symbol-leaf next-branch) 59 (decode-1 (cdr bits) tree)) 60 (decode-1 (cdr bits) 61 next-branch))))) 62 (decode-1 bits tree)) 63 (define (choose-branch bit branch) 64 (cond ((= bit 0) (left-branch branch)) 65 ((= bit 1) (right-branch branch)) 66 (else (error "Bad bit: 67 CHOOSE-BRANCH" bit)))) 68 69 (define (adjoin-set x set) 70 (cond 71 ((null? set) (list x)) 72 ((< (weight x) 73 (weight (car set))) 74 (cons x set)) 75 (else (cons (car set) 76 (adjoin-set x 77 (cdr set)))))) 78 79 (define (make-leaf-set pairs) 80 (if (null? pairs) 81 '() 82 (let ([pair (car pairs)]) 83 (adjoin-set 84 (make-leaf (car pair) 85 (cadr pair)) 86 (make-leaf-set (cdr pairs)))))) 87 88 ;; Exercise 2.67 89 90 (define sample-tree 91 (make-code-tree 92 (make-leaf 'A 4) 93 (make-code-tree 94 (make-leaf 'B 2) 95 (make-code-tree 96 (make-leaf 'D 1) 97 (make-leaf 'C 1))))) 98 99 (define sample-message 100 '(0 1 1 0 0 1 0 1 0 1 1 1 0)) 101 102 103 ;; Exercise 2.68 104 105 (define (element-of-set? x elements) 106 (cond 107 ((null? elements) #f) 108 ((eq? x (car elements)) #t) 109 (else (element-of-set? x (cdr elements))))) 110 111 (define (encode-symbol symbol tree) 112 (define (encode-symbol' bits current-tree) 113 (cond 114 ((leaf? current-tree) bits) 115 ((element-of-set? symbol 116 (symbols (left-branch current-tree))) 117 (encode-symbol' (cons 0 bits) 118 (left-branch current-tree))) 119 ((element-of-set? symbol 120 (symbols (right-branch current-tree))) 121 (encode-symbol' (cons 1 bits) 122 (right-branch current-tree))) 123 (else (error "Symbol is unknown: " symbol)))) 124 125 (reverse (encode-symbol' '() tree))) 126 127 (define (encode message tree) 128 (if (null? message) 129 '() 130 (append 131 (encode-symbol (car message) 132 tree) 133 (encode (cdr message) 134 tree)))) 135 136 '({(A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1)} 137 {(A 8) (B 3) ({C D} 2) (E 1) (F 1) (G 1) (H 1)} 138 {(A 8) (B 3) ({C D} 2) ({E F} 2) (G 1) (H 1)} 139 {(A 8) (B 3) ({C D} 2) ({E F} 2) ({G H} 2)} 140 {(A 8) (B 3) ({C D} 2) ({E F G H} 4)} 141 {(A 8) ({B C D} 5) ({E F G H} 4)} 142 {(A 8) ({B C D E F G H} 9)} 143 {({A B C D E F G H} 17)}) 144 145 (define (successive-merge leaf-set) 146 (define (inner-merge leaf-set) 147 (define minimal-weighted-leaf 148 (accumulate (lambda (x y) (if (< (weight x) 149 (weight y)) 150 x 151 y)) 152 (car leaf-set) 153 leaf-set)) 154 (define leaf-set-without-minimal-weighted-leaf 155 (remove minimal-weighted-leaf 156 leaf-set)) 157 (define next-to-minimal-weighted-leaf 158 (accumulate (lambda (x y) (if (< (weight x) 159 (weight y)) 160 x 161 y)) 162 (car leaf-set-without-minimal-weighted-leaf) 163 leaf-set-without-minimal-weighted-leaf)) 164 (define results 165 (cons (make-code-tree 166 next-to-minimal-weighted-leaf 167 minimal-weighted-leaf) 168 (remove next-to-minimal-weighted-leaf 169 leaf-set-without-minimal-weighted-leaf))) 170 171 results) 172 173 (define (successive-merge' leaf-set) 174 (cond 175 ((null? leaf-set) 176 (error "Empty set of weighted symbols:" leaf-set)) 177 ((null? (cdr leaf-set)) leaf-set) 178 (else (successive-merge' (inner-merge leaf-set))))) 179 180 (car (successive-merge' leaf-set))) 181 182 (define (generate-huffman-tree pairs) 183 (successive-merge 184 (make-leaf-set pairs)))))