ハフマン符号化法のプログラムは「計算機プログラムの構造と解釈」（SICP）を参考にするとよい。完全な形では載っていないので、演習問題をいくつか解く必要はあるが。
概要
任意の文字列をハフマン符号化法によって符号化したり復号化したりしたい。これに必要になる関数は、大雑把に挙げると次の4つ。
- ハフマン木を作る関数（文字と頻度の組の集合を入力 ⇒ ハフマン木を出力）
- 符号化する関数（符号化したい文字列とハフマン木を入力 ⇒ 符号を出力）
- 復号化する関数（符号とハフマン木を入力 ⇒ 元の文字列を出力）
- 文字列内の文字の出現頻度を求める関数
以下、それぞれのコードをEmacs lispで書いていく。
ハフマン木を作る関数
データ構造はSICPに書かれているとおりで、木と葉の二種類を組み合わせてハフマン木を構成する。
木のほうは、
…の合計4要素。葉のほうは、
- 葉であることを表すシンボル
leaf
- 文字
- 文字の頻度
…の合計3要素から成るリスト。
木は関数 make-code-tree で、葉は関数 make-leaf で生成する。そのほかに、木／葉に含まれる文字の集合を集める関数 symbols や頻度の合計を求める関数 weight 等を書いたのが以下のコード。
(defun make-leaf (symbol weight)
(list 'leaf symbol weight))
(defun leafp (object)
(eq (car object) 'leaf))
(defun symbol-leaf (x)
(cadr x))
(defun weight-leaf (x)
(caddr x))
(defun symbols (tree)
(if (leafp tree)
(list (symbol-leaf tree))
(caddr tree)))
(defun weight (tree)
(if (leafp tree)
(weight-leaf tree)
(cadddr tree)))
(defun make-code-tree (left right)
(list left
right
(append (symbols left) (symbols right))
(+ (weight left) (weight right))))
;; ちょっと確認
(make-code-tree (make-leaf 'b 1) (make-leaf 'c 2))
=> ((leaf b 1) (leaf c 2) (b c) 3)
続いて、 ((c 3) (b 2) (a 1)) のような形で文字と出現頻度の組が与えられると、それをハフマン木に変換する関数 generate-huffman-tree を書く。ここで、make-leaf-set が ((c 3) (b 2) (a 1)) の各要素を葉に変換しつつ adjoin-set を利用して頻度の昇順に並べかえ、successive-merge は昇順のリストから先頭の葉／木を2つ取り出して、つまり貪欲法的に選択して、木を構成していく関数。
(defun generate-huffman-tree (pairs)
(successive-merge (make-leaf-set pairs)))
(defun adjoin-set (x set)
(cond ((null set) (list x))
((< (weight x) (weight (car set))) (cons x set))
(t (cons (car set)
(adjoin-set x (cdr set))))))
;; ちょっと確認
(adjoin-set (make-leaf 'a 4)
(list (make-code-tree (make-leaf 'b 2) (make-leaf 'c 1))))
=> (((leaf b 2) (leaf c 1) (b c) 3)
(leaf a 4))
(defun 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))))))
;; ちょっと確認
(make-leaf-set '((c 3) (b 2) (a 1)))
=> ((leaf a 1)
(leaf b 2)
(leaf c 3))
(defun successive-merge (set)
(cond ((null set) '())
((= (length set) 1) (car set))
(t (successive-merge
(adjoin-set (make-code-tree (car set) (cadr set))
(cddr set))))))
;; ハフマン木を生成して確認
(generate-huffman-tree
'((e 5) (d 4) (c 3) (b 2) (a 1)))
=> (((leaf c 3)
((leaf a 1)
(leaf b 2)
(a b)
3)
(c a b)
6)
((leaf d 4)
(leaf e 5)
(d e)
9)
(c a b d e)
15)
;; 木を図にしてみると、問題なさそう
15
6 9
3 3 4 5
1 2
符号化する関数（符号化したい文字列とハフマン木を入力 ⇒ 符号を出力）
encode という関数を作る。符号化したい文字列は、(A D A B B C A) のようなリストの形で与え、一文字を符号化する関数 encode-symbol を補助関数として使用する。そうすると、コードは次のようになる。
(defun encode (message tree)
(if (null message)
'()
(append (encode-symbol (car message) tree)
(encode (cdr message) tree))))
(defun encode-symbol (symbol tree)
(if (member symbol (symbols tree))
(cond ((leafp tree) nil)
((member symbol (symbols (left-branch tree)))
(cons 0 (encode-symbol symbol (left-branch tree))))
(t (cons 1 (encode-symbol symbol (right-branch tree)))))
(error "the symbol %S doesn't exist in the tree -- ENCODE-SYMBOL" symbol)))
;; ハフマン木を仮に定義して確認
(setq *my-test-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) ))))
=> ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)
(encode-symbol 'A *my-test-tree*)
=> (0)
(encode-symbol 'D *my-test-tree*)
=> (1 1 0)
(encode-symbol 'E *my-test-tree*)
=> error
(encode '(A D A B C) *my-test-tree*)
=> (0 1 1 0 0 1 0 1 1 1)
復号化する関数（符号とハフマン木を入力 ⇒ 元の文字列を出力）
decode 関数を作る。符号は、(0 1 1 0 0 1 0 1 1 1) のようなゼロと1のリストで、出力も(A D A B C)のようなリスト。メインの decode は、flet で定義した補助関数 decode-1 を呼び出す形。ビットを先頭から取りだして木を探索し、葉に到達したらその葉が持つ文字を自然なる再帰にcons する。そのほかに、left-branch, right-branch, choose-branch も定義。
(defun decode (bits tree)
(flet ((decode-1
(bits current-branch)
(if (null bits)
'()
(let ((next-branch (choose-branch
(car bits)
current-branch)))
(if (leafp next-branch)
(cons (symbol-leaf next-branch)
(decode-1 (cdr bits) tree))
(decode-1 (cdr bits) next-branch))))))
(decode-1 bits tree)))
(defun left-branch (tree) (car tree))
(defun right-branch (tree) (cadr tree))
(defun choose-branch (bit branch)
(cond ((= bit 0) (left-branch branch))
((= bit 1) (right-branch branch))
(t (error "bad bit %S -- CHOOSE-BRANCH" bit))))
;; 既出の例で確認
(decode '(0 1 1 0 0 1 0 1 1 1) *my-test-tree*)
=> (A D A B C)
文字列内の文字の出現頻度を求める関数
最後に、文字列を調査して文字と頻度のリストを生成する関数count-occurences を作る。これの出力を上述のgenerate-huffman-tree に渡すことになる。
概要としては、loopマクロで文字と頻度から成る連想リスト（association list）を作っておき、mapcarによってドット対をリストに変換する、という流れになっている。
(defun count-occurences (str)
(let ((n (length str)) tbl)
(loop for i from 0 to (1- n) do
(if (assoc (elt str i) tbl)
(incf (cdr (assoc (elt str i) tbl)))
(setf tbl (cons (cons (elt str i) 1) tbl))))
(mapcar (lambda (x)
(list (car x) (cdr x))) tbl)))
;; 確認（文字コード 97 が a に対応）
(count-occurences "aaa bb c")
=> ((99 1) (98 2) (32 2) (97 3))
統合
最終確認。
;; 文字列
(setq *my-message* "BACADAEAFABBAAAGAH")
=> "BACADAEAFABBAAAGAH"
;; 文字列からHuffman木を作る
(setq *my-h-tree* (generate-huffman-tree
(count-occurences *my-message*)))
=> ((leaf 65 9) (((... ... ... 2) (... ... ... 2) (67 68 69 70) 4) ((... ... ... 2) (leaf 66 3) (71 72 66) 5) (67 68 69 70 71 72 66) 9) (65 67 68 69 70 71 72 66) 18)
;; 符号化（string-to-list で文字列を文字のリストに変換している）
(setq *my-encoded-message*
(encode (string-to-list *my-message*) *my-h-tree*))
=> (1 1 1 0 1 0 0 0 0 1 0 0 ...)
;; ビット長さ
(length *my-encoded-message*)
=> 42
;; 復号化（string をapply して文字のリストを文字列に変換）
(apply 'string (decode *my-encoded-message* *my-h-tree*))
=> "BACADAEAFABBAAAGAH"
以上、貪欲法の例としてのハフマン符号化。とても素朴な実装と思われる（性能等を考えると改善の余地がたくさんある）。
