オンラインSICP読書女子会 #30 (2.3.4)

練習問題 2.67 - 2.69

2.3.4. 例: ハフマン符号化木

まずは普通にハフマン符号.
ハフマン符号は二分木で表現できてそれがハフマン符号化木の模様.

2.3.4 (a) ハフマン木の生成

頻度の少ないノード2つを接合して新しいノードにするのを繰り返すことで, 頻度が少ないほど長い枝の先っぽになる.
つまりその文字を表現するのに必要なビット列が長くなる.

2.3.4 (b) ハフマン木の表現

葉と節に対するコンストラクタとセレクタ.

symbols と weight, tree の場合も symbols-tree と weight-tree つくって, それを使って

(define (symbols object)
	(if
		(leaf? object)
		(symbol-leaf object)
		(symbols-tree object)))

とかのほうがすっきりなきがほんのり.
一緒になってると caddr の数が埋もれてもにゅん＝ω＝；

2.3.4 (b) 実装

; [sec-2.3.4-b.scm]
;
(define (sec-2.3.4-b)
	(print "leaf = (make-leaf 'A 8)")
	(let
		(
			(leaf (make-leaf 'A 8))
		)
		(print ";==> " leaf)
		(print "(leaf? leaf)")
		(print ";==> "(leaf? leaf))
		(print "(symbol-leaf leaf)")
		(print ";==> " (symbol-leaf leaf))
		(print "(weight-leaf leaf)")
		(print ";==> " (weight-leaf leaf))
	)

	(newline)
	(print "(make-code-tree (make-leaf 'B 8) (make-leaf 'C 1))")
	(let
		(
			(tree (make-code-tree (make-leaf 'B 8) (make-leaf 'C 1)))
		)
		(print ";==> " tree)
		(print "(leaf? tree)")
		(print ";==> " (leaf? tree))
		(print "(left-branch tree)")
		(print ";==> " (left-branch tree))
		(print "(right-branch tree)")
		(print ";==> " (right-branch tree))
		(print "(symbols tree)")
		(print ";==> " (symbols tree))
		(print "(weight tree)")
		(print ";==> " (weight tree))
	)
	#t)


(define (make-leaf symbol weight)
	(list 'leaf symbol weight))

(define (leaf? object)
	(eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr  x))
(define (weight-leaf x) (caddr x))


(define (make-code-tree left right)
	(list
		left
		right
		(append (symbols left) (symbols right))
		(+ (weight left) (weight right))))

(define (left-branch  tree) (car  tree))
(define (right-branch tree) (cadr tree))

(define (symbols tree)
	(if
		(leaf? tree)
		(list (symbol-leaf tree))
		(caddr tree)))

(define (weight tree)
	(if
		(leaf? tree)
		(weight-leaf tree)
		(cadddr tree)))

2.3.4 (b) 実行結果

gosh> (sec-2.3.4-b)
leaf = (make-leaf 'A 8)
;==> (leaf A 8)
(leaf? leaf)
;==> #t
(symbol-leaf leaf)
;==> A
(weight-leaf leaf)
;==> 8

(make-code-tree (make-leaf 'B 8) (make-leaf 'C 1))
;==> ((leaf B 8) (leaf C 1) (B C) 9)
(leaf? tree)
;==> #f
(left-branch tree)
;==> (leaf B 8)
(right-branch tree)
;==> (leaf C 1)
(symbols tree)
;==> (B C)
(weight tree)
;==> 9
#t

2.3.4 (c) 復号化手続き

(print "TEST" 1) は TEST1 になるのに (error "TEST" 1) は TEST 1 になるのね微妙な違い＝ヮ＝；

枝選ぶ bit で 0/1 以外はエラーってしてるけれど, 入力の bits が中途半端で途切れてる場合はエラーでないのね…
とはいってもエラーにするには (tree-eq? current-branch tree) が真ってするか, 今ちょうど区切りのいいところかの判定用に引数を追加するかが必要ぽそう.
というわけで判定の手軽な後者を実装してみたっ・ω・*

2.3.4 (c) 実装

; [sec-2.3.4-c.scm]
;
(define (sec-2.3.4-c)
	(let
		(
			(tree (make-code-tree (make-leaf 'A 8) (make-code-tree (make-leaf 'B 3) (make-leaf 'C 1))))
		)
		(print "tree = " tree)
		(print "(decode (list 0) tree)")
		(print ";==> " (decode (list 0) tree))
		(print "(decode (list 1 0) tree)")
		(print ";==> " (decode (list 1 0) tree))
		(print "(decode (list 0 1 0 1 1 0) tree)")
		(print ";==> " (decode (list 0 1 0 1 1 0) tree))
		(print "(decode (list 1) tree) ; raise error")
		(print ";==> " (decode (list 1) tree))
	)
	#t)


(load "./sec-2.3.4-b")


(define (decode bits tree)
	(define (decode-1 bits current-branch completed)
		(if
			(null? bits)
			(if
				completed
				'()
				(error "unexpected end of bits"))
			(let
				(
					(next-branch (choose-branch (car bits) current-branch))
				)
				(if
					(leaf? next-branch)
					(cons
						(symbol-leaf next-branch)
						(decode-1 (cdr bits) tree #t))
					(decode-1 (cdr bits) next-branch #f)))))

	(decode-1 bits tree #t))


(define (choose-branch bit branch)
	(cond
		((= bit 0) (left-branch branch))
		((= bit 1) (right-branch branch))
		(else (error "bad bit: CHOOSE-BRANCH" bit))))

2.3.4 (c) 実行結果

gosh> (sec-2.3.4-c)
tree = ((leaf A 8) ((leaf B 3) (leaf C 1) (B C) 4) (A B C) 12)
(decode (list 0) tree)
;==> (A)
(decode (list 1 0) tree)
;==> (B)
(decode (list 0 1 0 1 1 0) tree)
;==> (A B C A)
(decode (list 1) tree) ; raise error
*** ERROR: unexpected end of bits

2.3.4 (d) 重み付き要素の集合

小さい方から葉を選びとるために順序付きリストとしての adjoin-set を leaf に対して再度実装する.

2.3.4 (d) 実装

; [sec-2.3.4-d.scm]
;
(define (sec-2.3.4-d)
	(print "(make-leaf-set '((A 4) (B 2) (C 1) (D 1)))")
	(print ";==> " (make-leaf-set '((A 4) (B 2) (C 1) (D 1))))
	#t)


(load "./sec-2.3.4-c")


(define (adjoin-set x set)
	(cond
		; 初回及び一番軽い場合.
		((null? set) (list x))
		; 途中に挿入.
		((< (weight x) (weight (car set))) (cons x set))
		; 次を探索.
		(else
			(cons
				(car set)
				(adjoin-set x (cdr set))))))


(define (make-leaf-set pairs)
	(if
		(null? pairs)
		'()
		(let
			(
				(pair (car pairs))
			)
			(adjoin-set
				(make-leaf
					(car  pair)   ; symbol.
					(cadr pair))  ; frequency.
				(make-leaf-set (cdr pairs))))))

2.3.4 (d) 実行結果

gosh> (sec-2.3.4-d)
(make-leaf-set '((A 4) (B 2) (C 1) (D 1)))
;==> ((leaf D 1) (leaf C 1) (leaf B 2) (leaf A 4))
#t

ex-2.67. 提示された木とメッセージの decode

そのまんま・ω・*

ex-2.67. 実装

; [ex-2.67.scm]
;
(define (ex-2.67)
	(print "sample-tree")
	(print ";==> " sample-tree)
	(print "sample-message")
	(print ";==> " sample-message)
	(print "(decode sample-message sample-tree)")
	(print ";==> " (decode sample-message sample-tree))
	#t)


(load "./sec-2.3.4-d")


(define sample-tree
	(make-code-tree
		(make-leaf 'A 4)
		(make-code-tree
			(make-leaf 'B 2)
			(make-code-tree
				(make-leaf 'D 1)
				(make-leaf 'C 1)))))


(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))

ex-2.67. 実行結果

gosh> (ex-2.67)
sample-tree
;==> ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)
sample-message
;==> (0 1 1 0 0 1 0 1 0 1 1 1 0)
(decode sample-message sample-tree)
;==> (A D A B B C A)
#t

ex-2.68. encode-symbol の実装

1文字分を符号化する encode-symbol の実装.
繰り返して平文全体を符号化する encode は設問文にて提示されている.

リストの中に指定の要素が含まれるかの判定する関数の名前すっぱりわすれててめっちゃぐぐってしまった＝ヮ＝；

eq? を使うと、memq という便利な手続きを実装できます。
(p.155, 2.3.1 クォートより)

普通にしばらく前につくってた＞ヮ＜；

節はその左右から辿れる文字の一覧を持ってるのでその中に含まれるかをみて, 含まれている方にたどるように.
でもこれ最悪ケースで, 左の $n-1$ 件になかった, 左の $n-2$ 件になかった, …っていう感じで $\Theta(n^2)$ になっちゃう？＝ω＝；

ex-2.68. 実装

; [ex-2.68.scm]
;
(define (ex-2.68)
	(print "sample-tree")
	(print ";==> " sample-tree)
	(print "sample-text")
	(print ";==> " sample-text)
	(print "(encode sample-text sample-tree)")
	(print ";==> " (encode sample-text sample-tree))
	(print "(decode (encode sample-text sample-tree) sample-tree)")
	(print ";==> " (decode (encode sample-text sample-tree) sample-tree))

	(newline)
	(print "sample-message")
	(print ";==> " sample-message)
	(print "(decode sample-message sample-tree)")
	(print ";==> " (decode sample-message sample-tree))
	(print "(encode (decode sample-message sample-tree) sample-tree)")
	(print ";==> " (encode (decode sample-message sample-tree) sample-tree))
	#t)


(load "./ex-2.67")


(define sample-text '(A D A B B C A))


(define (encode message tree)
	(if
		(null? message)
		'()
		(append
			(encode-symbol (car message) tree)
			(encode (cdr message) tree))))


(define (encode-symbol char tree)
	(define (iter current-tree)
		(cond
			((leaf? current-tree)
				'())
			((memq char (symbols (left-branch current-tree)))
				(cons 0 (iter (left-branch current-tree))))
			((memq char (symbols (right-branch current-tree)))
				(cons 1 (iter (right-branch current-tree))))
			(else
				(error "NEVER REACH HERE"))))

	(if
		(memq char (symbols tree))
		(iter tree)
		(error "bad char:" char "not in tree" tree)))

ex-2.68. 実行結果

gosh> (ex-2.68)
sample-tree
;==> ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)
sample-text
;==> (A D A B B C A)
(encode sample-text sample-tree)
;==> (0 1 1 0 0 1 0 1 0 1 1 1 0)
(decode (encode sample-text sample-tree) sample-tree)
;==> (A D A B B C A)

sample-message
;==> (0 1 1 0 0 1 0 1 0 1 1 1 0)
(decode sample-message sample-tree)
;==> (A D A B B C A)
(encode (decode sample-message sample-tree) sample-tree)
;==> (0 1 1 0 0 1 0 1 0 1 1 1 0)
#t

ex-2.69. ハフマン木の生成

さいしょにてゃっと作ってみたらそっちは複雑っぽくなって,

もし手続きの設計が複雑になったとしたら、ほぼ確実に何かを間違えている。
(設問文より)

めっちゃこれ＝ヮ＝；

というわけでそっちはそっちで書き上げてはみたのでそれは後ほど。

何も考えずに別の方法で書いてみたらなるほどシンプルになりましたっ＞ヮ＜；

小さい方から2つとって, 新しく作った節を3つめ以降に adjoin-set でソート挿入して, ソートした結果からまた2つとって…, ってこれも最悪ケースで $\Theta(n^2)$ ？＝ω＝；

ex-2.69. 実装

; [ex-2.69.scm]
;
(define (ex-2.69)
	(print "sample-pairs")
	(print ";==> " sample-pairs)
	(print "(generate-huffman-tree sample-pairs)")
	(print ";==> " (generate-huffman-tree sample-pairs))

	(newline)
	(let
		(
			(built-tree (generate-huffman-tree sample-pairs))
		)
		(print "built-tree ;= (generate-huffman-tree sample-pairs)")
		(print ";==> " built-tree)

		(print "sample-text")
		(print ";==> " sample-text)
		(print "(encode sample-text built-tree)")
		(print ";==> " (encode sample-text built-tree))
		(print "(decode (encode sample-text built-tree) built-tree)")
		(print ";==> " (decode (encode sample-text built-tree) built-tree))
	)

	#t)


(load "./ex-2.68")


(define sample-pairs
	'((A 4) (B 2) (C 1) (D 1)))


(define (generate-huffman-tree pairs)
	(successive-merge (make-leaf-set pairs)))


(define (successive-merge leaves)
	(cond
		; 要素数 == 0:
		((null? leaves)
			(error "leaves must have at least one element"))
		; 要素数 == 1:
		((null? (cdr leaves))
			(car leaves))
		; 要素数 >= 2:
		(else
			(successive-merge
				(adjoin-set
					(make-code-tree
						(car leaves)
						(cadr leaves))
					(cddr leaves))))))

ex-2.69. 実行結果

gosh> (ex-2.69)
sample-pairs
;==> ((A 4) (B 2) (C 1) (D 1))
(generate-huffman-tree sample-pairs)
;==> ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)

built-tree ;= (generate-huffman-tree sample-pairs)
;==> ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)
sample-text
;==> (A D A B B C A)
(encode sample-text built-tree)
;==> (0 1 1 0 0 1 0 1 0 1 1 1 0)
(decode (encode sample-text built-tree) built-tree)
;==> (A D A B B C A)
#t

ex-2.69. (b) ハフマン木の生成 (失敗編)

さいしょにてゃっと作ってみた版.
うん. 複雑になってる＝ヮ＝；

ただこっちは処理中に作成済み部分を混ぜ込んではないのでステップ数的には有利になる？

ex-2.69. (b) 実装

; [ex-2.69.scm]
;
(define (ex-2.69)
	(print "sample-pairs")
	(print ";==> " sample-pairs)
	(print "(generate-huffman-tree sample-pairs)")
	(print ";==> " (generate-huffman-tree sample-pairs))

	(newline)
	(let
		(
			(built-tree (generate-huffman-tree sample-pairs))
		)
		(print "built-tree ;= (generate-huffman-tree sample-pairs)")
		(print ";==> " built-tree)

		(print "sample-text")
		(print ";==> " sample-text)
		(print "(encode sample-text built-tree)")
		(print ";==> " (encode sample-text built-tree))
		(print "(decode (encode sample-text built-tree) built-tree)")
		(print ";==> " (decode (encode sample-text built-tree) built-tree))
	)

	#t)


(load "./ex-2.68")


(define sample-pairs
	'((A 4) (B 2) (C 1) (D 1)))


(define (generate-huffman-tree pairs)
	(successive-merge (make-leaf-set pairs)))

(define (successive-merge leaves)
	(define (iter last-node rest-leaves)
		(if
			(null? rest-leaves)
			last-node
			(let
				(
					(next (take-next (weight last-node) rest-leaves))
				)
				(let
					(
						(next-node (car next))
						(new-rest  (cdr next))
					)
					(iter (make-code-tree last-node next-node) new-rest)))))

	(define (take-next last-weight leaves)
		(define (take-next-iter last-node leaves)
			(cond
				((null? leaves)
					(cons last-node '()))
				((> (+ (weight last-node) (weight (car leaves))) last-weight)
					(cons last-node leaves))
				(else
					(take-next-iter
						(make-code-tree
							last-node
							(car leaves))
						(cdr leaves)))))

		(take-next-iter (car leaves) (cdr leaves)))

	(if
		(pair? leaves)
		(iter (car leaves) (cdr leaves))
		(error "leaves must have at least one element")))

ex-2.69. (b) 実行結果

gosh> (ex-2.69)
sample-pairs
;==> ((A 4) (B 2) (C 1) (D 1))
(generate-huffman-tree sample-pairs)
;==> ((((leaf D 1) (leaf C 1) (D C) 2) (leaf B 2) (D C B) 4) (leaf A 4) (D C B A) 8)

built-tree ;= (generate-huffman-tree sample-pairs)
;==> ((((leaf D 1) (leaf C 1) (D C) 2) (leaf B 2) (D C B) 4) (leaf A 4) (D C B A) 8)
sample-text
;==> (A D A B B C A)
(encode sample-text built-tree)
;==> (1 0 0 0 1 0 1 0 1 0 0 1 1)
(decode (encode sample-text built-tree) built-tree)
;==> (A D A B B C A)
#t