有限文脈モデルの続きです。今回は、多値レンジコーダを用いた有限文脈モデルにおいて、圧縮率を向上させる有効な方法を紹介しましょう。
高い圧縮率を実現しているデータ圧縮アルゴリズムに "PPM (Prediction by Partial Matching)" があります。PPM は 1984 年に J. G. Cleary 氏と I. H. Witten 氏によって提案されたアルゴリズムで、文脈から作られる統計的モデルによって次の文字の出現確率を予測する方法です。
簡単にいえば「高次の有限文脈モデル」になりますが、PPM はまだ現れていない記号（未出現記号）をエスケープ (escape) 記号とし、このエスケープ記号を使って符号化するところが特徴です。
もう少し具体的に説明しましょう。PPM の基本的な考え方はそれほど難しくありません。たとえば、有限文脈モデルの次数を 5 次 (order-5) としましょう。記号 a を符号化する場合、まず order-5 の出現頻度表を調べます。ここで、order-5 に記号 a が存在すれば、それを算術符号 (またはレンジコーダ) で符号化します。もし、記号 a が存在しない場合は、エスケープ記号を符号化して order-4 の出現頻度表を調べます。つまり、次数を下げながら記号 a が出現している文脈モデルを探すわけです。
PPM は高次の有限文脈モデルを操作するため、実際のプログラムはかなり複雑になります。いきなり PPM をプログラムするのは大変ですが、エスケープ記号というアイデアは PPM 以外の圧縮アルゴリズムにも用いることができそうです。そこで、有限文脈モデル (order-2) のプログラムにエスケープ記号を適用して、どのくらい効果があるか試してみましょう。
プログラムは簡単です。order-2 の出現頻度表で記号が見つからない場合は、その出現頻度表でエスケープ記号を符号化します。それから、order-0 の出現頻度表で記号を符号化します。つまり、有限文脈モデルは order-2 -> order-0 という 2 段階になります。今回は簡単なテストということで、order-2 -> order-1 -> order-0 という 3 段階のモデルにはしません。ご了承くださいませ。
PPM の場合、エスケープ記号に与える出現確率をエスケープ確率と呼びます。そして、エスケープ確率の計算方法を Method と呼びます。Method にはいくつかの方式が提案されていますが、PPM では Method C や Method D が経験的に良い性能を持つと言われています。
Method C : u / (n + u) Method D : (u / 2) / n n : そのモデルで出現した記号の総数 u : そのモデルで出現したエスケープ記号の総数
適応型レンジコーダで符号化する場合、Method C はとても簡単に実現できます。まず、記号の出現頻度表は、エスケープ記号を 1 とし他の記号は 0 に初期化します。たとえば、記号 a を符号化する場合、表に記号 a がない（個数 0) 場合はエスケープ記号を符号化し、出現頻度表を更新します。このとき、記号 a とエスケープ記号の個数を増やせば、通常のレンジコーダで Method C を実現することができます。
つまり、記号 a を符号化したときは出現頻度表の a の個数を +1 して、エスケープ記号を符号化したときは記号 a とエスケープ記号の個数を +1 するのです。これでエスケープ記号の出現確率は u / (n + u) になるので、あとは通常のレンジコーダで符号化すればいいわけです。とても簡単ですね。
Method D は Method C の改良版です。Method C でエスケープ記号を符号化したとき、記号 a とエスケープ記号の個数を +1 ずつしましたが、これを 0.5 ずつにして合わせて +1 とするのが Method D です。Method C では、エスケープ記号の個数を +1 しているため、記号の出現確率よりもエスケープ確率の割合が増大する場合がありますが、Method D ではこれを補正することができます。
Method D を簡単に実現するには、記号 a を符号化するときに記号の個数を +2 すればいいでしょう。これでエスケープ記号の割合が増大するのを補正することができます。あとは通常の適応型レンジコーダで符号化すれば、Method D に相当する出現確率で符号化することができます。
それではプログラムを作りましょう。エスケープ記号を含む出現頻度表は bitree を使って簡単に作成することができます。
リスト : 出現頻度表の初期化
;;; order-0 用出現頻度表
(defun initialize-bitree ()
(let ((bt (make-bitree code-size)))
(dotimes (x code-size bt)
(bitree-update bt x 1))))
;;; order-2 用出現頻度表
(defun initialize-bitree-with-esc ()
(let ((bt (make-bitree (1+ code-size))))
(bitree-update bt esc 1)
bt))
order-2 用の出現頻度表は関数 initialize-bitree-with-esc で初期化します。エスケープ記号の値 (256) は変数 esc にセットします。esc を付け加えるので記号の種類は code-size + 1 になります。make-bitree で出現頻度表 bt を生成するとき、各記号の出現頻度は 0 に初期化されているので、bitree-update で esc の値を +1 します。最後に bt を返します。
次は出現頻度表を更新する関数 update を修正します。
リスト : 出現頻度表の更新
(defun update (bt c inc &optional c1)
(bitree-update bt c inc)
(when c1
(bitree-update bt c1 inc))
(when (<= *max-sum* (bitree-sum bt))
(dotimes (x (bitree::bitree-size bt))
(let ((n (ash (bitree-frequency bt x) -1)))
(when (plusp n)
(bitree-update bt x (- n)))))))
エスケープ記号を符号化したあと、記号とエスケープ記号の出現頻度を更新します。エスケープ記号だけ更新すると、いつまでたっても他の記号を符号化することはできません。記号を符号化した場合は、引数 c と c1 には同じ記号を渡します。これで Method D に相当する出現確率になります。出現頻度の合計値が *max-sum* 以上になったら、出現している記号の個数を半分にします。このとき、エスケープ記号の値も半分にする必要があるので、出現頻度表の大きさを関数 bitree-size で取得します。
なお、記号の増分値 inc に大きな値を設定すると、圧縮率が向上する場合があります。これはあとで試してみましょう。
次は記号を符号化する関数 encode-with-esc を作ります。
リスト : 記号の符号化
(defun encode-with-esc (rc c bt2 bt0)
(cond ((zerop (bitree-frequency bt2 c))
(encode rc bt2 esc)
(encode rc bt0 c)
(update bt2 c *inc2* esc)
(update bt0 c inc0))
(t
(encode rc bt2 c)
(update bt2 c *inc2* c))))
引数 rc はレンジコーダのオブジェクト、bt2 は order-2 の出現頻度表、bt0 は order-0 の出現頻度表、c は符号化する記号です。bitree-frequency で記号 c の出現頻度を求めます。それが 0 の場合、記号 c は出現していないので関数 encode でエスケープ記号を bt2 で符号化し、それから bt0 で c を符号化します。そうでなければ bt2 で c を符号化します。
次に、update で出現頻度表 bt0 と bt2 を更新します。inc0 と *inc2* は記号の増分値です。inc0 は order-0 用で値は 4 に、*inc2* は order-2 用で 4 以上の値に設定します。ここで、出現頻度表 bt2 と bt0 の更新に注目してください。order-2 で記号 c を符号化したあと、order-0 の出現頻度表 bt0 の更新は行っていませんね。このように、低次の出現頻度表を更新しない方法を update exclusion といいます。
exclusion には「除外」という意味があり、低次のモデルを更新から除外することで、圧縮率を向上させることができます。実際に試してみると高次のモデルだけ更新した方が圧縮率は高くなります。また、低次のモデルを更新する必要がないので、実行速度の点でも有利になります。
次は記号を復号する関数 decode-with-esc を作ります。
リスト : 記号の復号
(defun decode-with-esc (rc bt2 bt0)
(let ((c (decode rc bt2)))
(cond ((= c esc)
(setq c (decode rc bt0))
(update bt0 c inc0)
(update bt2 c *inc2* esc))
(t (update bt2 c *inc2* c)))
c))
order-2 の出現頻度表 bt2 を使って記号を復号します。復号した記号 c がエスケープ記号であれば、order-0 の出現頻度表 bt0 で記号を復号して変数 c にセットします。それから、update で bt2 と bt0 を更新します。bt2 で復号した記号がエスケープ記号でなければ bt2 を更新するだけです。最後に記号 c を返します。
最後に符号化と復号を行う関数 encode と decode を作ります。
リスト : エスケープ記号付き有限文脈モデル
(defun encode-order-2 (rc in size)
(let ((bt0 (initialize-bitree))
(bt2-table (make-bitree-order-2))
(c0 0)
(c1 0))
(dotimes (x size)
(let ((c2 (read-byte in)))
(encode-with-esc rc
c2
(get-bitree-order-2 bt2-table c0 c1)
bt0)
(setq c0 c1
c1 c2)))))
(defun decode-order-2 (rc out size)
(let ((bt0 (initialize-bitree))
(bt2-table (make-bitree-order-2))
(c0 0)
(c1 0))
(dotimes (x size)
(let ((c2 (decode-with-esc rc
(get-bitree-order-2 bt2-table c0 c1)
bt0)))
(write-byte c2 out)
(setq c0 c1
c1 c2)))))
有限文脈モデル (order-2) のプログラムとの違いは、order-0 と order-2 の出現頻度表を用意することです。encode-with-esc と decode-with-esc を呼び出すとき、order-2 用の出現頻度表を get-bitree-order-2 で求めます。order-0 用の出現頻度表 bt0 はそのまま渡します。なお、累積度数の上限値 *max-sum* は #x4000 としました。
それでは、実際に Canterbury Corpus で配布されているテストデータ The Canterbury Corpus を圧縮してみましょう。*inc2* の値を +16, +32, +64 に変更して試してみたところ、結果は次にようになりました。
表 : 有限文脈モデル + ESC 記号の結果
ファイル名 サイズ LHA(lh5) +16 +32 +64
----------------------------------------------------------------
alice29.txt 152,089 59,117 52,024 51,989 52,128
asyoulik.txt 125,179 52,341 44,347 44,327 44,453
cp.html 24,603 8,384 8,597 8,585 8,574
fields.c 11,150 3,170 3,445 3,441 3,428
grammar.lsp 3,721 1,271 1,282 1,281 1,279
kennedy.xls 1,029,744 198,342 177,737 166,218 155,516
lcet10.txt 426,754 159,558 147,007 146,859 147,301
plrabn12.txt 481,861 210,045 170,076 170,524 171,968
ptt5 513,216 52,305 53,374 53,746 54,612
sum 38,240 13,993 15,163 15,125 15,056
xargs.1 4,227 1,778 1,763 1,763 1,763
----------------------------------------------------------------
合計 2,810,784 760,304 674,815 663,858 656,078
エスケープ記号の効果はとても大きいですね。*inc2* は +32 程度でよさそうです。order-2 にエスケープ記号を適用しただけで、LHA を上回る圧縮率になるとは大変驚きました。PPM の圧縮率がなぜ高いのか、その理由が少しだけわかったような気がしました。
PPM にはもうひとつ重要な方法があります。高次のモデルでエスケープ記号を符号化したあと、低次のモデルで記号を符号化するとき、高次のモデルで出現している記号を低次のモデルの出現頻度表から除外することができます。これを exclusion といいます。
実は、低次のモデルで符号化するとき、高次のモデルで出現した記号は必要ありません。復号処理から見た場合、エスケープ記号が復号されるということは、復号される記号はそのモデルに出現していない記号であることがわかります。これらの記号は復号処理に必要ありませんね。
したがって、低次のモデルで高次モデルの出現記号を取り除いて符号化しても、復号処理で同じように高次モデルの出現記号を除外すれば、記号をきちんと復号することができるのです。そして exclusion を行うことにより、符号化する記号に割り当てられる出現確率を増やすことができます。これが exclusion の真の目的です。PPM ではこの効果が絶大で、圧縮率を大幅に向上させることができます。
簡単な例を示しましょう。記号 c を符号化することを考えてみます。
記号 c を符号化 exclusion 無 有
5 次 => {a (1), escape (1)} escape : 1/2 1/2
4 次 => {a (1), b (1), escape (2)} escape : 2/4 2/3 (a を除外)
3 次 => {a (1), b (1), c (1), escape (3)} c : 1/6 1/4 (a, b を除外)
確率 : 1/24 1/12
情報量 : 4.58 bit 3.58 bit
5 次と 4 次のモデルに記号 c はないので、エスケープ記号が符号化されます。3 次のモデルには記号 c があるので、このモデルで c が符号化されます。exclusion がない場合、確率は 1/2 * 2/4 * 1/6 = 1/24 になります。
exclusion がある場合、5 次のモデルではエスケープ記号の確率は同じですが、4 次のモデルでは記号 a を除外できるので、エスケープ記号の確率は 2/3 となります。同様に 3 次のモデルで記号 c を符号化するとき、5 次と 4 次で出現している記号 a と b を除外できるので、確率は 1/4 になります。したがって、記号 c の確率は全体で 1/2 * 2/3 * 1/4 = 1/12 になります。
情報量 (-log2確率) を計算すると、exclusion がない場合が 4.58 bit になり、exclusion がある場合が 3.58 bit になります。exclusion を行った方が 1 bit 少なくなりますね。それだけ短い符号語で記号を符号化することができるわけです。これが exclusion の効果です。
この exclusion と update exclusion は効果がとても高く、PPM では常套手段といえる方法です。
それでは exclusion のプログラムを作りましょう。最初に exclusion 用の操作関数を定義します。次のリストを見てください。
リスト : exclusion 用操作関数
;;; ESC 以外の出現している記号をすべて求める
(defun get-symbol (bt)
(do ((a nil)
(x 0 (1+ x)))
((= x code-size) a)
(if (plusp (bitree-frequency bt x))
(push x a))))
;;; 記号を除外する
(defun exclusion (bt ls)
(mapcar (lambda (x)
(let ((n (bitree-frequency bt x)))
(bitree-update bt x (- n))
(cons x n)))
ls))
;;; 元に戻す
(defun restore-exclusion (bt ls)
(dolist (x ls)
(bitree-update bt (car x) (cdr x))))
関数 get-symbol は出現している記号をリストに格納して返します。0 から 255 までの記号の出現頻度を関数 bitree-frequency で求め、その値が 0 でなければ記号 x を変数 a のリストに追加します。
関数 exclusion は出現頻度表 bt からリスト ls に格納されている記号を除外します。まず、bitree-frequency で記号 x の出現頻度を求めて変数 n にセットし、次に bitee-update で (- n) を加算します。これで記号の出現頻度を 0 にすることができます。なお、元の値に復元するため、記号と出現頻度をリストに格納して返します。関数 restore-exclusion は exclusion で除外した記号の出現頻度を元に戻します。
次は、符号化と復号のプログラムを修正します。
リスト : 符号化と復号 (exclusion)
(defun encode-with-esc (rc c bt2 bt0)
(cond ((zerop (bitree-frequency bt2 c))
(encode rc bt2 esc)
(let ((ls (exclusion bt0 (get-symbol bt2))))
(encode rc bt0 c)
(restore-exclusion bt0 ls))
(update bt2 c *inc2* esc)
(update bt0 c inc0))
(t
(encode rc bt2 c)
(update bt2 c *inc2* c))))
(defun decode-with-esc (rc bt2 bt0)
(let ((c (decode rc bt2)))
(cond ((= c esc)
(let ((ls (exclusion bt0 (get-symbol bt2))))
(setq c (decode rc bt0))
(restore-exclusion bt0 ls))
(update bt0 c inc0)
(update bt2 c *inc2* esc))
(t (update bt2 c *inc2* c)))
c))
符号化の場合、bt0 で記号を符号化するときに exclusion を適用します。get-symbol で bt2 の記号を求め、exclusion で bt0 から除外します。そのあと、encode で記号を符号化して restore-exclusion で元に戻します。
復号も同様です。bt0 で記号を復号するとき、get-symbol で bt2 の記号を求め、exclusion で bt0 から除外します。そのあと、decode で記号を復号して restore-exclusion で元に戻します。
それでは、実際に Canterbury Corpus で配布されているテストデータ The Canterbury Corpus を圧縮してみましょう。*inc2* の値を +16, +32, +64 に変更して試してみたところ、結果は次にようになりました。
表 : 有限文脈モデル + ESC 記号 + exclusion の結果
exclusion exclusion
有 無
ファイル名 サイズ LHA(lh5) +16 +32 +64 +64
---------------------------------------------------------------------------
alice29.txt 152,089 59,117 51,729 51,694 51,833 52,128
asyoulik.txt 125,179 52,341 44,057 44,037 44,162 44,453
cp.html 24,603 8,384 8,481 8,469 8,458 8,574
fields.c 11,150 3,170 3,417 3,412 3,400 3,428
grammar.lsp 3,721 1,271 1,271 1,271 1,269 1,279
kennedy.xls 1,029,744 198,342 163,025 151,506 140,804 155,516
lcet10.txt 426,754 159,558 146,523 146,375 146,817 147,301
plrabn12.txt 481,861 210,045 169,518 169,967 171,410 171,968
ptt5 513,216 52,305 52,590 52,961 53,827 54,612
sum 38,240 13,993 14,907 14,869 14,800 15,056
xargs.1 4,227 1,778 1,744 1,744 1,744 1,763
----------------------------------------------------------------------------
合計 2,810,784 760,304 657,262 646,305 638,524 656,078
*inc2* が +64 の場合、exclusion によりすべてのファイルで圧縮率が向上しています。exclusion の効果はとても高いですね。ただし、exclusion を行うことで符号化・復号ともに時間がかかるようになります。
ところで、最高次数を増やすと圧縮率はさらに向上します。ご参考までに、order-3 の結果を示します。なお、このプログラムは order-3 から order-2, order-1, order-0 と次数を減らして記号が出現しているか調べています。基本的には最高次数が 3 の PPM とほぼ同じ処理になります。
表 : 有限文脈モデル (order-3) + ESC 記号 + exclusion の結果 ファイル名 サイズ order-3 LHA bzip2 -------------------------------------------------- alice29.txt 152,089 43,168 59,117 43,202 asyoulik.txt 125,179 38,922 52,341 39,569 cp.html 24,603 7,146 8,384 7,624 fields.c 11,150 2,932 3,170 3,039 grammar.lsp 3,721 1,124 1,271 1,283 kennedy.xls 1,029,744 130,976 198,342 130,280 lcet10.txt 426,754 115,182 159,558 107,706 plrabn12.txt 481,861 145,647 210,045 145,577 ptt5 513,216 52,702 52,305 49,759 sum 38,240 12,961 13,993 12,909 xargs.1 4,227 1,563 1,778 1,762 -------------------------------------------------- 合計 2,810,784 552,323 760,304 542,710
order-3 で bzip2 に迫る圧縮率になりました。PPM は大変優れた圧縮アルゴリズムであることがわかります。ただし、最高次数を増やすとメモリの使用量は大幅に増加し、符号化と復号ともに時間がとてもかかるようになります。今回の order-3 のプログラムでも、大きなファイルを圧縮するとメモリが足りなくなるかもしれません。実用的に使うには処理の高速化と、限られたメモリを有効に使う工夫が必要なります。
PPM に興味のある方は拙作のページ Algorithms with Python Prediction by Partial Matching (PPM) をお読みくださいませ。
;;;
;;; rce2.lsp : 適応型レンジコーダ (order-2 with ESC)
;;;
;;; Copyright (C) 2010-2023 Makoto Hiroi
;;;
(require :rangecoder "rangecoder.lsp")
(use-package :rangecoder)
(require :bitree "bitree.lsp")
(use-package :bitree)
;;; 定数
(defconstant esc code-size)
(defconstant inc0 4)
;;; グローバル変数
(defvar *max-sum* #x4000)
(defvar *inc2* 64)
;;; ファイルサイズの書き込み
(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 update (bt c inc &optional c1)
(bitree-update bt c inc)
(when c1
(bitree-update bt c1 inc))
(when (<= *max-sum* (bitree-sum bt))
(dotimes (x (bitree::bitree-size bt))
(let ((n (ash (bitree-frequency bt x) -1)))
(when (plusp n)
(bitree-update bt x (- n)))))))
;;; 初期化
(defun initialize-bitree ()
(let ((bt (make-bitree code-size)))
(dotimes (x code-size bt)
(bitree-update bt x 1))))
(defun initialize-bitree-with-esc ()
(let ((bt (make-bitree (1+ code-size))))
(bitree-update bt esc 1)
bt))
;;;
;;; 記号の符号化と復号
;;;
;;; 符号化
(defun encode (rc bt c)
(let ((temp (floor (range-coder-range rc)
(bitree-sum bt))))
(incf (range-coder-low rc)
(* (bitree-cumul bt c) temp))
(setf (range-coder-range rc)
(* (bitree-frequency bt c) temp))
(encode-normalize rc)))
;;; 復号
(defun decode (rc bt)
(let ((temp (floor (range-coder-range rc)
(bitree-sum bt))))
(multiple-value-bind
(c cumul)
(bitree-find bt (floor (range-coder-low rc) temp))
(decf (range-coder-low rc)
(* cumul temp))
(setf (range-coder-range rc)
(* (bitree-frequency bt c) temp))
(decode-normalize rc)
c)))
;;;
;;; 出現頻度表の生成
;;;
;;; order-2 用出現頻度表の作成
(defun make-bitree-order-2 ()
(make-array (list code-size code-size) :initial-element nil))
;;; order-2 の出現頻度表を取得
(defun get-bitree-order-2 (table c0 c1)
(let ((bt (aref table c0 c1)))
(if bt
bt
(setf (aref table c0 c1) (initialize-bitree-with-esc)))))
;;;
;;; exclusion 用操作関数
;;;
;;; ESC 以外の出現している記号をすべて求める
(defun get-symbol (bt)
(do ((a nil)
(x 0 (1+ x)))
((= x code-size) a)
(if (plusp (bitree-frequency bt x))
(push x a))))
;;; 記号を除外する
(defun exclusion (bt ls)
(mapcar (lambda (x)
(let ((n (bitree-frequency bt x)))
(bitree-update bt x (- n))
(cons x n)))
ls))
;;; 元に戻す
(defun restore-exclusion (bt ls)
(dolist (x ls)
(bitree-update bt (car x) (cdr x))))
;;;
;;; エスケープ記号付き有限文脈モデル
;;;
;;; 符号化
(defun encode-with-esc (rc c bt2 bt0)
(cond ((zerop (bitree-frequency bt2 c))
(encode rc bt2 esc)
(let ((ls (exclusion bt0 (get-symbol bt2))))
(encode rc bt0 c)
(restore-exclusion bt0 ls))
(update bt2 c *inc2* esc)
(update bt0 c inc0))
(t
(encode rc bt2 c)
(update bt2 c *inc2* c))))
(defun encode-order-2 (rc in size)
(let ((bt0 (initialize-bitree))
(bt2-table (make-bitree-order-2))
(c0 0)
(c1 0))
(dotimes (x size)
(let ((c2 (read-byte in)))
(encode-with-esc rc
c2
(get-bitree-order-2 bt2-table c0 c1)
bt0)
(setq c0 c1
c1 c2)))))
;;; 復号
(defun decode-with-esc (rc bt2 bt0)
(let ((c (decode rc bt2)))
(cond ((= c esc)
(let ((ls (exclusion bt0 (get-symbol bt2))))
(setq c (decode rc bt0))
(restore-exclusion bt0 ls))
(update bt0 c inc0)
(update bt2 c *inc2* esc))
(t (update bt2 c *inc2* c)))
c))
(defun decode-order-2 (rc out size)
(let ((bt0 (initialize-bitree))
(bt2-table (make-bitree-order-2))
(c0 0)
(c1 0))
(dotimes (x size)
(let ((c2 (decode-with-esc rc
(get-bitree-order-2 bt2-table c0 c1)
bt0)))
(write-byte c2 out)
(setq c0 c1
c1 c2)))))
;;; ファイルの符号化
(defun encode-file (in-file out-file)
(call-with-byte-output-file
out-file
(lambda (out)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (file-length in)))
(write-file-size out size)
(when (plusp size)
(call-with-range-encoder
out
(lambda (rc)
(encode-order-2 rc in size))))))))))
;;; ファイルの復号
(defun decode-file (in-file out-file)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (read-file-size in)))
(call-with-byte-output-file
out-file
(lambda (out)
(when (plusp size)
(call-with-range-decoder
in
(lambda (rc)
(decode-order-2 rc out size))))))))))
;;; 簡単なテスト
(defun test ()
(let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
"kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
(format t "----- encode -----~%")
(time
(dolist (file files)
(encode-file (format nil "./canterbury/~a" file)
(format nil "~a.en" file))))
;;
(format t "----- decode -----~%")
(time
(dolist (file files)
(decode-file (format nil "~a.en" file)
(format nil "~a.de" file))))))
;;;
;;; rce3.l : 適応型レンジコーダ (order-3 with ESC)
;;;
;;; Copyright (C) 2010-2023 Makoto Hiroi
;;;
(require :rangecoder "rangecoder.lsp")
(use-package :rangecoder)
(require :bitree "bitree.lsp")
(use-package :bitree)
;;; 定数
(defconstant esc code-size)
(defvar *max-sum* #x4000)
(defvar *inc2* 64)
;;; ファイルサイズの書き込み
(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 update (bt c inc &optional c1)
(bitree-update bt c inc)
(when c1
(bitree-update bt c1 inc))
(when (<= *max-sum* (bitree-sum bt))
(dotimes (x (bitree::bitree-size bt))
(let ((n (ash (bitree-frequency bt x) -1)))
(when (plusp n)
(bitree-update bt x (- n)))))))
;;; 初期化
(defun initialize-bitree ()
(let ((bt (make-bitree code-size)))
(dotimes (x code-size bt)
(bitree-update bt x 1))))
(defun initialize-bitree-with-esc ()
(let ((bt (make-bitree (1+ code-size))))
(bitree-update bt esc 1)
bt))
;;; 記号の符号化
(defun encode (rc bt c)
(let ((temp (floor (range-coder-range rc)
(bitree-sum bt))))
(incf (range-coder-low rc)
(* (bitree-cumul bt c) temp))
(setf (range-coder-range rc)
(* (bitree-frequency bt c) temp))
(encode-normalize rc)))
;;; 記号の復号
(defun decode (rc bt)
(let ((temp (floor (range-coder-range rc)
(bitree-sum bt))))
(multiple-value-bind
(c cumul)
(bitree-find bt (floor (range-coder-low rc) temp))
(decf (range-coder-low rc)
(* cumul temp))
(setf (range-coder-range rc)
(* (bitree-frequency bt c) temp))
(decode-normalize rc)
c)))
;;;
;;; 出現頻度表を格納するハッシュ表
;;;
(defun make-bitree-table ()
(make-hash-table :test 'equal))
(defun get-bitree (table &rest keys)
(let ((bt (gethash keys table nil)))
(if bt
bt
(setf (gethash keys table) (initialize-bitree-with-esc)))))
;;;
;;; exclusion 用操作関数
;;;
;;; ESC 以外の出現している記号をすべて求める
(defun get-symbol (bt)
(do ((a nil)
(x 0 (1+ x)))
((= x code-size) a)
(if (plusp (bitree-frequency bt x))
(push x a))))
;;; 記号を除外する
(defun exclusion (bt ls)
(mapcar (lambda (x)
(let ((n (bitree-frequency bt x)))
(bitree-update bt x (- n))
(cons x n)))
ls))
;;; 元に戻す
(defun restore-exclusion (bt ls)
(dolist (x ls)
(bitree-update bt (car x) (cdr x))))
;;;
;;; エスケープ記号付き有限文脈モデル
;;;
;;; 符号化
(defun encode-with-exclusion (rc bt c xs)
(let ((ys (exclusion bt xs)))
(encode rc bt c)
(restore-exclusion bt ys)))
(defun encode-with-esc (rc c &rest ls)
(labels ((encode-sub (ls inc xs)
(let ((bt (car ls)))
(cond ((plusp (bitree-frequency bt c))
(encode-with-exclusion rc bt c xs)
(update bt c inc c))
(t
(encode-with-exclusion rc bt esc xs)
(let ((zs (union xs (get-symbol bt))))
(update bt c inc esc)
(encode-sub (cdr ls) (/ inc 2) zs)))))))
(encode-sub ls *inc2* nil)))
(defun encode-order-3 (rc in size)
(let ((bt0 (initialize-bitree))
(bt-table (make-bitree-table))
(c0 0)
(c1 0)
(c2 0))
(dotimes (x size)
(let ((c (read-byte in)))
(encode-with-esc rc
c
(get-bitree bt-table c0 c1 c2)
(get-bitree bt-table c1 c2)
(get-bitree bt-table c2)
bt0)
(setq c0 c1
c1 c2
c2 c)))))
;;; 復号
(defun decode-with-exclusion (rc bt xs)
(let ((ys (exclusion bt xs)))
(prog1
(decode rc bt)
(restore-exclusion bt ys))))
(defun decode-with-esc (rc &rest ls)
(labels ((decode-sub (ls inc xs)
(let ((c (decode-with-exclusion rc (car ls) xs)))
(cond ((/= c esc)
(update (car ls) c inc c))
(t
(setq c (decode-sub (cdr ls)
(/ inc 2)
(union xs (get-symbol (car ls)))))
(update (car ls) c inc esc)))
c)))
(decode-sub ls *inc2* nil)))
(defun decode-order-3 (rc out size)
(let ((bt0 (initialize-bitree))
(bt-table (make-bitree-table))
(c0 0)
(c1 0)
(c2 0))
(dotimes (x size)
(let ((c (decode-with-esc rc
(get-bitree bt-table c0 c1 c2)
(get-bitree bt-table c1 c2)
(get-bitree bt-table c2)
bt0)))
(write-byte c out)
(setq c0 c1
c1 c2
c2 c)))))
;;; ファイルの符号化
(defun encode-file (in-file out-file)
(call-with-byte-output-file
out-file
(lambda (out)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (file-length in)))
(write-file-size out size)
(when (plusp size)
(call-with-range-encoder
out
(lambda (rc)
(encode-order-3 rc in size))))))))))
;;; ファイルの復号
(defun decode-file (in-file out-file)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (read-file-size in)))
(call-with-byte-output-file
out-file
(lambda (out)
(when (plusp size)
(call-with-range-decoder
in
(lambda (rc)
(decode-order-3 rc out size))))))))))
;;; 簡単なテスト
(defun test ()
(let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
"kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
(format t "----- encode -----~%")
(time
(dolist (file files)
(encode-file (format nil "./canterbury/~a" file)
(format nil "~a.en" file))))
;;
(format t "----- decode -----~%")
(time
(dolist (file files)
(decode-file (format nil "~a.en" file)
(format nil "~a.de" file))))))