Common Lisp 入門の番外編です。今回はレンジコーダを使って実際にファイルを圧縮してみましょう。レンジコーダの基本的な説明は拙作のページ Lisp でレンジコーダ または Algorithms with Python レンジコーダ をお読みください。
なお、このドキュメントは Algorithms with Python レンジコーダ のプログラムを Common Lisp で書き直したものです。内容は重複しますが、あしからずご了承ください。
それではプログラムを作りましょう。最初に、レンジコーダを生成する関数を定義します。
プログラムは次のようになります。
リスト : レンジコーダの生成
; 構造体の定義
(defstruct range-coder
direction file range low buff cnt)
; 定数
(defconstant max-range #x100000000)
(defconstant min-range #x1000000)
(defconstant mask #xffffffff)
(defconstant ff-check #xff000000)
(defconstant code-size 256)
; 符号化用レンジコーダ
(defun call-with-range-encoder (out proc)
(let ((rc (make-range-coder :direction :encode
:file out
:range max-range
:low 0
:buff 0
:cnt 0)))
; proc の呼び出し
(funcall proc rc)
; 終了処理
(finish rc out)))
; 復号用レンジコーダ
(defun call-with-range-decoder (in proc)
(let ((rc (make-range-coder :direction :decode
:file in
:range max-range
:buff 0
:cnt 0)))
; buff の初期値 (0) を読み捨てる
(read-byte in)
; 4 byte read
(setf (range-coder-low rc)
(+ (ash (read-byte in) 24)
(ash (read-byte in) 16)
(ash (read-byte in) 8)
(read-byte in)))
; proc の呼び出し
(funcall proc rc)))
最初にレンジコーダを表す構造体 range-coder を定義します。符号化のときは direction にキーワード :encode を、復号のときは :decdoe をセットします。file にはバイナリモードでオープンしたバイトストリームをセットします。range は幅、buff と cnt が桁上がり用のバッファ、low は符号化のときは下限値で復号のときは符号語を表します。
Common Lisp は多倍長整数をサポートしているので、range は max-range (#x100000000) で初期化します。符号化の場合、low は 0 で初期化します。復号の場合、low の範囲は 32 ビットなので、ファイルから 4 バイト分読み込んで初期化します。符号化のとき、最初に出力される 1 バイトは buff の初期値 0 なので、復号のときは 1 バイト読み捨てることに注意してください。
なお、符号化の処理で一番最初に符号語を出力するとき、buff の値を出力しないようにすれば、復号の初期化で 1 バイト読み捨てる処理は不要になります。また、圧縮後のファイルサイズも 1 バイト少なくなります。興味のある方はプログラムを改造してみてください。
次は出現頻度表と累積度数表を作成する関数 make-frequency と make-cumul を作ります。プログラムは次のようになります。
リスト : 出現頻度表の作成
(defun make-frequency (filename)
(call-with-byte-input-file
filename
#'(lambda (in)
(let ((table (make-array code-size :initial-element 0))
(cnt 0))
(do ((c (read-byte in nil) (read-byte in nil)))
((null c))
(incf cnt)
(incf (aref table c)))
(let ((n 0))
(do ((m (apply #'max (coerce table 'list)) (ash m -1)))
((<= m #xffff))
(incf n))
(when (plusp n)
(map-into table
#'(lambda (x)
(if (zerop x)
x
(logior (ash x (- n)) 1)))
table))
(values cnt table (make-cumul table)))))))
レンジコーダでファイルを圧縮する場合、ハフマン符号と同様に出現頻度表をファイルに付加する必要があります。記号の出現頻度を 1 バイトで表すと、ファイルに付加するデータは 256 バイトですみますが、これではレンジコーダの力を十分に発揮させることはできません。そこで、今回は記号の出現頻度を 2 バイト (0 - #xffff) で表すことにします。
make-frequency の引数 filename がファイル名を表します。call-with-byte-input-stream でファイルをオープンして、最初の do ループで各記号の出現頻度を求めてベクタ table にセットします。次に、出現頻度を 2 バイトに丸めます。table の最大値を求めて変数 m にセットします。そして、m が #xffff 以下になるまで m を右へシフトしていき、その回数を変数 n にセットします。あとは table の各要素を n ビット右へシフトするだけです。このとき、出現頻度が 0 にならないように最下位ビットを 1 にしています。
リスト : 累積度数表の作成
(defun make-cumul (table)
(do ((cumul (make-array (1+ code-size) :initial-element 0))
(x 0 (1+ x)))
((>= x code-size) cumul)
(setf (aref cumul (1+ x))
(+ (aref cumul x) (aref table x)))))
累積度数表は関数 make-cumul で作ります。累積度数表の大きさは code-size + 1 とし、code-size 番目の要素が table の要素の合計値になります。したがって、記号 c の出現確率は table[c] / cumul[code-size] で求めることができます。
次は記号を符号化する関数 encode を作ります。
リスト : 符号化
(defun encode (rc table cumul c)
(let ((temp (floor (range-coder-range rc)
(aref cumul code-size))))
(incf (range-coder-low rc)
(* (aref cumul c) temp))
(setf (range-coder-range rc)
(* (aref table c) temp))
(encode-normalize rc)))
encode の引数 rc は range-coder のオブジェクト、table が出現頻度表、cumul が累積度数表、c が符号化する記号です。区間の幅 range を狭めて下限値 low の値を計算します。range は記号の出現確率で縮小すればいいので、range * table[c] / cumul[size] となります。low の増分は区間の下限値なので、range * cumul[c] / cumul[code-size] となります。プログラムでは、あらかじめ range / cumul[code-size] を計算して変数 temp にセットし、その値を使って range と low の値を計算しています。
なお、cumul[code-size] の値が range より大きくなると、temp が 0 になってしまうので、レンジコーダは正常に動作しません。cumul[code-size] が min-range 以上にならないように注意してください。今回のプログラムは記号の出現頻度が #xffff 以下になるように丸められているので、code-size が 256 以下であれば cumul[code-size] が min-range をオーバーすることありません。code-size を 256 より大きくする場合は注意してください。
次は range と low の値を正規化する関数 encode-normalize を作ります。
リスト : 符号化のときの正規化
(defun encode-normalize (rc)
(when (>= (range-coder-low rc) max-range)
; 桁上がり
(incf (range-coder-buff rc))
(setf (range-coder-low rc)
(logand (range-coder-low rc) mask))
(when (plusp (range-coder-cnt rc))
(flush-buff rc 0 (1- (range-coder-cnt rc)))
(setf (range-coder-buff rc) 0
(range-coder-cnt rc) 0)))
(do ()
((>= (range-coder-range rc) min-range))
(cond ((< (range-coder-low rc) ff-check)
(flush-buff rc #xff (range-coder-cnt rc))
(setf (range-coder-buff rc)
(logand (ash (range-coder-low rc) -24) #xff)
(range-coder-cnt rc)
0))
(t (incf (range-coder-cnt rc))))
(setf (range-coder-low rc)
(logand (ash (range-coder-low rc) 8) mask)
(range-coder-range rc)
(ash (range-coder-range rc) 8))))
基本的な処理は簡単で、range の値が min-range 未満の場合は、range と low の値を 256 倍して符号語をファイルへ出力します。このときポイントになるのが桁上がりの処理です。
low を 256 倍するとき、最上位の 8 ビットを符号語としてすぐにファイルへ出力すると、桁上がりに対応することができません。そこで、最上位 8 ビットを変数 buff に格納することにします。low を 256 倍するときは、先に buff の値を符号語として出力し、low の最上位 8 ビットを buff に格納します。そして、low の値は MAX_RANGE 未満 (32 ビット) で保持します。桁上がりが発生したら、buff の値を +1 すればいいわけです。
ここで問題点が一つあります。それは buff の値が 255 (#xff) のとき、桁上がりが発生すると buff が #x100 になることです。この場合、buff の値は 0 になり、先に出力した符号語を +1 しないといけません。そこで、low の最上位 8 ビットが #xff の場合は buff を出力しないで、#xff の個数を変数 cnt でカウントすることにします。次の図を見てください。
buff, cnt low
------------------------------
12, 0 <= [ff, 34, 56, 78]
------------------------------
12, 1 <= [34, 56, 78, 00]
図 : バッファの動作
たとえば、buff が #x12 で low の最上位 8 ビットが #xff の場合、buff を出力しないで cnt の値を +1 します。そして、low を 8 ビット左へシフト (256 倍) します。つまり、buff と cnt で [12, ff] を表していることになります。また、最上位 8 ビットの値が #xff で続く場合もありえます。この場合は、cnt の値を +1 していきます。たとえば cnt が 3 であれば、buff と cnt で [12, ff, ff, ff] を表します。
桁上がりが発生したときは buff を +1 します。このとき、cnt が 0 よりも大きい場合はバッファを出力します。たとえば、buff が #x12 で cnt が 3 の場合、バッファは [12, ff, ff, ff] を表しています。これに 1 を加えると、[13, 00, 00, 00] になります。つまり、buff に 1 を加えてから出力し、そのあと 0 を出力すればいいわけです。このとき、最後の 0 を buff にセットするので、出力する 0 の個数は cnt - 1 になります。
プログラムの説明に戻ります。encode-normalize の前半部分が桁上がりの処理です。low が max-range 以上の場合は桁上がりが発生しています。buff の値を +1 して、low の値を 32 ビットの範囲に収めます。バッファを出力する場合は、buff を出力したあとで cnt - 1 個の 0 を出力します。この処理を関数 flush-buff で行います。そのあと、buff と cnt に 0 をセットします。
次の do ループで、low と range の値を 256 倍していきます。このとき、low の上位 8 ビットの値をチェックします。low が ff-check (#xff000000) 未満の場合、low の上位 8 ビットは #xff ではありません。この場合、buff を出力したあと、#xff を cnt 個出力するだけです。そのあとで、low の上位 8 ビットを buff にセットし、cnt を 0 にします。low の上位 8 ビットが #xff の場合は cnt を +1 するだけです。最後に、low と range を 256 倍 (左へ 8 ビットシフト) します。
次はレンジコーダの符号化を終了するメソッド finish を作ります。
リスト : 符号化の終了
; buff と記号 c を n 個書き出す
(defun flush-buff (rc c n)
(write-byte (range-coder-buff rc) (range-coder-file rc))
(dotimes (x n)
(write-byte c (range-coder-file rc))))
; 符号化の終了処理
(defun finish (rc out)
(if (< (range-coder-low rc) max-range)
(flush-buff rc #xff (range-coder-cnt rc))
; 桁上がり
(progn
(incf (range-coder-buff rc))
(flush-buff rc 0 (range-coder-cnt rc))))
;
(write-byte (logand (ash (range-coder-low rc) -24) #xff) out)
(write-byte (logand (ash (range-coder-low rc) -16) #xff) out)
(write-byte (logand (ash (range-coder-low rc) -8) #xff) out)
(write-byte (logand (range-coder-low rc) #xff) out))
最初に桁上がりをチェックします。桁上がりがなければ、buff を出力したあと #xff を cnt 個出力します。桁上がりがある場合は、buff を +1 して出力したあと、0 を cnt 個出力します。最後に low の値 (4 バイト) を出力します。
最後に、符号化を行う関数 encode-file を作ります。
リスト : レンジコーダによる符号化
(defun encode-file (in-file out-file)
(call-with-byte-output-file
out-file
#'(lambda (out)
(multiple-value-bind
(size table cumul)
(make-frequency in-file)
(write-file-size out size)
(when (plusp size)
(write-freq-table out table)
(call-with-byte-input-file
in-file
#'(lambda (in)
(call-with-range-encoder
out
#'(lambda (rc)
(dotimes (x size)
(encode rc table cumul (read-byte in))))))))))))
引数 in-file が入力ファイル名、out-file が出力ファイル名です。最初に、call-with-byte-output-file で出力ファイルをオープンします。次に make-frequency を呼び出して、ファイルサイズ、出現頻度表、累積度数表を求めて変数 size, table, cumul にセットします。そして、ファイルサイズを関数 write-file-size で書き込みます。
size が 0 でなければ、レンジコーダで符号化を行います。関数 write-freq-table で出現頻度表を書き込みます。次に、call-with-byte-input-file で入力ファイルをオープンし、call-with-range-encoder で符号化用のレンジコーダを生成します。あとは、read-byte で記号を読み込み、encode で符号化するだけです。
次は復号を行う関数 decode を作ります。
リスト : 復号
; 記号の探索
(defun search-code (cumul value)
(do ((i 0)
(j (1- code-size)))
((>= i j) i)
(let ((k (floor (+ i j) 2)))
(if (<= (aref cumul (1+ k)) value)
(setf i (1+ k))
(setf j k)))))
; 復号
(defun decode (rc table cumul)
(let* ((temp (floor (range-coder-range rc)
(aref cumul code-size)))
(c (search-code cumul (floor (range-coder-low rc) temp))))
(decf (range-coder-low rc)
(* (aref cumul c) temp))
(setf (range-coder-range rc)
(* (aref table c) temp))
(decode-normalize rc)
c))
レンジコーダで記号を復号する場合、累積度数表 cumul から次式の条件を満たす記号 c を探します。
cumul[c]/cumul[code-size] <= low/range < cumul[c + 1]/count_sum[code-size]
レンジコーダは整数で計算するので、割り算の結果が 0 にならないよう計算の順番に注意してください。プログラムでは、range / cumul[code-size] の値を temp にセットし、low / temp を関数 search-code で二分探索しています。
記号 c を求めたあと、low と range の値を更新します。range は記号の出現確率で縮小すればいいので、値は temp * table[c] となります。復号の場合は low から temp * cumul[c] を引き算します。最後に、関数 decode-normalize を呼び出して、求めた記号 c を返します。
次は low と range の値を更新 (正規化) する関数 decode-normalize を作ります。
リスト : 復号の正規化
; 復号の正規化
(defun decode-normalize (rc)
(do ()
((>= (range-coder-range rc) min-range))
(setf (range-coder-range rc)
(ash (range-coder-range rc) 8)
(range-coder-low rc)
(logand (+ (ash (range-coder-low rc) 8)
(read-byte (range-coder-file rc)))
mask))))
符号化と違って復号の正規化はとても簡単です。range が min-range よりも小さい場合は range と low を 256 倍し、ファイルから 1 記号読み込んで low に加算するだけです。
最後に復号を行う関数 decode を作ります。
リスト : レンジコーダによる復号
; ファイルの復号
(defun decode-file (in-file out-file)
(call-with-byte-input-file
in-file
#'(lambda (in)
(let* ((size (read-file-size in))
(table (if (plusp size) (read-freq-table in)))
(cumul (if (plusp size) (make-cumul table))))
(call-with-byte-output-file
out-file
#'(lambda (out)
(when (plusp size)
(call-with-range-decoder
in
#'(lambda (rc)
(dotimes (x size)
(write-byte (decode rc table cumul) out)))))))))))
引数 in-file が入力ファイル名、out-file が出力ファイル名です。最初に入力ファイルをオープンして、関数 read-file-size でファイルサイズを、read-freq-table で出現頻度表を読み込みます。そして、make-cumul で累積度数表を作成します。次に出力ファイルをオープンして、ファイルサイズが 0 でなければ、復号用レンジコーダを生成します。あとは、decode で記号を復号して write-byte で出力するだけです。
あとのプログラムは簡単なので、説明は割愛いたします。詳細は プログラムリスト１ をお読みください。
それでは、実際に Canterbury Corpus で配布されているテストデータ The Canterbury Corpus を圧縮してみましょう。結果は次のようになりました。
表 : レンジコーダの結果
() はファイルサイズと出現頻度表を引いた値
ファイル名 サイズ RangeCoder 下限値
--------------------------------------------------------
alice29.txt 152,089 87,380 ( 86,864) 86,837
asyoulik.txt 125,179 75,770 ( 75,254) 75,235
cp.html 24,603 16,603 ( 16,087) 16,082
fields.c 11,150 7,500 ( 6,984) 6,980
grammar.lsp 3,721 2,675 ( 2,159) 2,155
kennedy.xls 1,029,744 460,622 (460,106) 459,970
lcet10.txt 426,754 249,679 (249,163) 249,071
plrabn12.txt 481,861 273,569 (273,053) 272,936
ptt5 513,216 78,226 ( 77,710) 77,636
sum 38,240 25,994 ( 25,478) 25,473
xargs.1 4,227 3,109 ( 2,593) 2,589
--------------------------------------------------------
合計 2,810,784 1,281,127 (1,275,451) 1,274,964
レンジコーダの圧縮率は圧縮の限界に近い値となりました。出現頻度表が 512 バイト付加されているので、小さなファイルの圧縮率はハフマン符号よりも悪くなる場合がありますが、大きなファイルではハフマン符号よりも高い圧縮率になりました。とくに ptt5 の圧縮率は、レンジコーダの方がとても高くなります。記号に 1 ビット未満の符号語を割り当てることができるレンジコーダ (算術符号) の特徴が結果に出ていると思います。
;
; rcs.l : 静的なレンジコーダ
;
; Copyright (C) 2010 Makoto Hiroi
;
; バイト入力用ファイルオープン
(defun call-with-byte-input-file (filename proc)
(with-open-file (in filename
:direction :input
:element-type 'unsigned-byte)
(funcall proc in)))
; バイト出力用ファイルオープン
(defun call-with-byte-output-file (filename proc)
(with-open-file (out filename
:direction :output
:if-exists :rename-and-delete
:element-type 'unsigned-byte)
(funcall proc out)))
; 定数
(defconstant max-range #x100000000)
(defconstant min-range #x1000000)
(defconstant mask #xffffffff)
(defconstant ff-check #xff000000)
(defconstant code-size 256)
; 構造体の定義
(defstruct range-coder
direction file range low buff cnt)
; buff と記号 c を n 個書き出す
(defun flush-buff (rc c n)
(write-byte (range-coder-buff rc) (range-coder-file rc))
(dotimes (x n)
(write-byte c (range-coder-file rc))))
; 符号化の終了処理
(defun finish (rc out)
(if (< (range-coder-low rc) max-range)
(flush-buff rc #xff (range-coder-cnt rc))
; 桁上がり
(progn
(incf (range-coder-buff rc))
(flush-buff rc 0 (range-coder-cnt rc))))
;
(write-byte (logand (ash (range-coder-low rc) -24) #xff) out)
(write-byte (logand (ash (range-coder-low rc) -16) #xff) out)
(write-byte (logand (ash (range-coder-low rc) -8) #xff) out)
(write-byte (logand (range-coder-low rc) #xff) out))
; 符号化用レンジコーダ
(defun call-with-range-encoder (out proc)
(let ((rc (make-range-coder :direction :encode
:file out
:range max-range
:low 0
:buff 0
:cnt 0)))
(funcall proc rc)
; 終了処理
(finish rc out)))
; 復号用レンジコーダ
(defun call-with-range-decoder (in proc)
(let ((rc (make-range-coder :direction :decode
:file in
:range max-range
:buff 0
:cnt 0)))
; buff の初期値 (0) を読み捨てる
(read-byte in)
; 4 byte read
(setf (range-coder-low rc)
(+ (ash (read-byte in) 24)
(ash (read-byte in) 16)
(ash (read-byte in) 8)
(read-byte in)))
;
(funcall proc rc)))
; 符号化の正規化
(defun encode-normalize (rc)
(when (>= (range-coder-low rc) max-range)
; 桁上がり
(incf (range-coder-buff rc))
(setf (range-coder-low rc)
(logand (range-coder-low rc) mask))
(when (plusp (range-coder-cnt rc))
(flush-buff rc 0 (1- (range-coder-cnt rc)))
(setf (range-coder-buff rc) 0
(range-coder-cnt rc) 0)))
(do ()
((>= (range-coder-range rc) min-range))
(cond ((< (range-coder-low rc) ff-check)
(flush-buff rc #xff (range-coder-cnt rc))
(setf (range-coder-buff rc)
(logand (ash (range-coder-low rc) -24) #xff)
(range-coder-cnt rc)
0))
(t (incf (range-coder-cnt rc))))
(setf (range-coder-low rc)
(logand (ash (range-coder-low rc) 8) mask)
(range-coder-range rc)
(ash (range-coder-range rc) 8))))
; 復号の正規化
(defun decode-normalize (rc)
(do ()
((>= (range-coder-range rc) min-range))
(setf (range-coder-range rc)
(ash (range-coder-range rc) 8)
(range-coder-low rc)
(logand (+ (ash (range-coder-low rc) 8)
(read-byte (range-coder-file rc)))
mask))))
; ファイルサイズの書き込み
(defun write-file-size (out size)
(write-byte (logand (ash size -24) #xff) out)
(write-byte (logand (ash size -16) #xff) out)
(write-byte (logand (ash size -8) #xff) out)
(write-byte (logand size #xff) out))
; ファイルサイズの読み込み
(defun read-file-size (in)
(+ (ash (read-byte in) 24)
(ash (read-byte in) 16)
(ash (read-byte in) 8)
(read-byte in)))
; 出現頻度表の書き込み
(defun write-freq-table (out table)
(map nil
#'(lambda (x)
(write-byte (ash x -8) out)
(write-byte (logand x #xff) out))
table))
; 出現頻度表の読み込み
(defun read-freq-table (in)
(let ((table (make-array code-size)))
(dotimes (x code-size table)
(setf (aref table x)
(+ (ash (read-byte in) 8) (read-byte in))))))
; 累積度数表の作成
(defun make-cumul (table)
(do ((cumul (make-array (1+ code-size) :initial-element 0))
(x 0 (1+ x)))
((>= x code-size) cumul)
(setf (aref cumul (1+ x))
(+ (aref cumul x) (aref table x)))))
; 出現頻度表
(defun make-frequency (filename)
(call-with-byte-input-file
filename
#'(lambda (in)
(let ((table (make-array code-size :initial-element 0))
(cnt 0))
(do ((c (read-byte in nil) (read-byte in nil)))
((null c))
(incf cnt)
(incf (aref table c)))
(let ((n 0))
(do ((m (apply #'max (coerce table 'list)) (ash m -1)))
((<= m #xffff))
(incf n))
(when (plusp n)
(map-into table
#'(lambda (x)
(if (zerop x)
x
(logior (ash x (- n)) 1)))
table))
(values cnt table (make-cumul table)))))))
; 符号化
(defun encode (rc table cumul c)
(let ((temp (floor (range-coder-range rc)
(aref cumul code-size))))
(incf (range-coder-low rc)
(* (aref cumul c) temp))
(setf (range-coder-range rc)
(* (aref table c) temp))
(encode-normalize rc)))
; 記号の探索
(defun search-code (cumul value)
(do ((i 0)
(j (1- code-size)))
((>= i j) i)
(let ((k (floor (+ i j) 2)))
(if (<= (aref cumul (1+ k)) value)
(setf i (1+ k))
(setf j k)))))
; 復号
(defun decode (rc table cumul)
(let* ((temp (floor (range-coder-range rc)
(aref cumul code-size)))
(c (search-code cumul (floor (range-coder-low rc) temp))))
(decf (range-coder-low rc)
(* (aref cumul c) temp))
(setf (range-coder-range rc)
(* (aref table c) temp))
(decode-normalize rc)
c))
; ファイルの符号化
(defun encode-file (in-file out-file)
(call-with-byte-output-file
out-file
#'(lambda (out)
(multiple-value-bind
(size table cumul)
(make-frequency in-file)
(write-file-size out size)
(when (plusp size)
(write-freq-table out table)
(call-with-byte-input-file
in-file
#'(lambda (in)
(call-with-range-encoder
out
#'(lambda (rc)
(dotimes (x size)
(encode rc table cumul (read-byte in))))))))))))
; ファイルの復号
(defun decode-file (in-file out-file)
(call-with-byte-input-file
in-file
#'(lambda (in)
(let* ((size (read-file-size in))
(table (if (plusp size) (read-freq-table in)))
(cumul (if (plusp size) (make-cumul table))))
(call-with-byte-output-file
out-file
#'(lambda (out)
(when (plusp size)
(call-with-range-decoder
in
#'(lambda (rc)
(dotimes (x size)
(write-byte (decode rc table cumul) out)))))))))))