Algorithm::MTF / BWT → MTF → Range Coder によるデータ圧縮

先日言及した Burrows Wheeler Transform (id:naoya:20081016:1224173077) による変換後のテキストは圧縮に使えたり、全文索引に利用できたりと応用範囲は広いです。

BWT により変換したテキストを圧縮するには、そのまま圧縮するのではなく先頭移動法 (Move-To-Front http://ja.wikipedia.org/wiki/Move_To_Front) を適用することでより情報に偏りを持たせてから圧縮するのがセオリーです。

今日は先頭移動法の Perl 実装を作ってみました。Algoritm::MTF です。

に置いています。

use Algorithm::MTF;

my $encoder = Algorithm::MTF::Encoder->new;
my $code = $mtf->encode("aaabac");         # [ 97, 0, 0, 98, 1, 99 ]

my $decoder = Algorithm::MTF::Decoder->new;
say $mtf->decode([ 97, 0, 0, 98, 1, 99 ]); # "aaabac"

のように使います。

試しに /etc/httpd/conf/mime.types を BWT にかけると

# MIME type                     Extensions
application/activemessage
application/andrew-inset        ez
application/applefile
application/atom+xml            atom
application/atomicmail
application/batch-smtp
application/beep+xml
application/cals-1840
application/cnrp+xml
application/commonground
application/cpl+xml
application/cybercash
...

というファイルが

...
.-..ssv.        agaooooooeoooaogabgacioaoiaeiozeoooooppraoououioiiouoooooiiiooo
ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
oooooooooooooooooooooooooooooooooooooooooooooooooooooooiidaaaaaagrrre/ooirgg...
...

となって、これれに MTF を施すと

...
1 0 0 1 1 0 0 0 1 1 1 5 0 0 13 0 0 0 2 0 0 0 0 0 0 0 0 0 2 1 0 0 0 0 0 13 1 13
1 0 0 0 0 0 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 3 1 0 0 0 0 0 0 0 0 0 0 0 6 1 2
1 6 1 0 1 1 0 0 8 1 26 0 8 2 0 0 0 0 0 0 0 5 27 2 0 0 27 0 0 0 0 14 2 0 0 7 1 
16 1 15 1 0 0 0 0 7 14 0 0 1 2 1 13 2 0 0 0 0 0 0 2 14 2 0 0 0 9 1 1 1 43 15 0 
2 1 10 11 3 8 1 0 4
...

という数字の羅列且つ 0 や 1 などの小さな数字がたくさん登場するより偏った状態に変換できました。このぐらい出現頻度に偏りがあると、エントロピー符号化に有利です。

Algorithm::MTF は内部では一方向連結リストで実装しています。配列の実装も作ってベンチマークを取りましたが、想定通りリストの方が高速という結果になりました。いまのところ MTF-1 や MTF-2 は実装していません。

自作ライブラリで圧縮

さて、ここ最近作ったライブラリを集めて一通りの圧縮アルゴリズムを適用した圧縮プログラムを作る事ができるようになりました。

です。実装して実行してみました。

% perl compressor.pl /etc/httpd/conf/mime.types
[1] Block sorting ... Building SA ... Split text ... Covert SA to BWT ... done
[2] Move-to-front ... done
[3] Packing integers ... done
[4] Range coder ... done

15020 bytes => 5042 bytes (66.4%)

1 trial of SA (30.001ms total)
1 trial of split (30ms total)
1 trial of BWT (30.001ms total)
1 trial of MTF (800.012ms total)
1 trial of pack (0s total)
1 trial of RC (1.490s total)

decompress ... done ... OK

と、mime.types ファイルを圧縮率 66.4 % で圧縮することができました。(Range Coder 用の頻度表は含めていません。また、これは実装が甘い箇所が色々とあって下限からはまだ遠いです。)

速度の方は、褒められたものではないですね。MTF と Range Coder が支配的です。Suffix Array の構築は divsufsort() 任せなので高速 ... ということで結局、自分がスクラッチから実装した箇所がボトルネックという結果になってしまいました。とほほ。MTF はポインタ操作、Range Coder は整数演算が相当回数発生するので、実用を考えるならこの辺は C/C++ で実装すべきなのでしょう。圧縮は特に空間コスト/計算量コストがシビアな世界で、実装の詰めや処理系の選択などアルゴリズムの理解から実用までのギャップは大きいです。

ベンチ用のコードがごちゃ混ぜになって見苦しいコードですが、以下に記載しておきます。

#!/usr/bin/env perl
use strict;
use warnings;

use Perl6::Say;
use FindBin::libs;
use Path::Class qw/file/;

use Algorithm::DivSufSort;
use Algorithm::MTF;
use Algorithm::RangeCoder;

use Benchmark::Timer;

use constant EOF => "\0";

my $timer = Benchmark::Timer->new;

sub bs_encode ($) {
    my $text = shift;

    $timer->start('SA');
    printf STDERR "Building SA ... ";
    my $sa = divsufsort $text;
    $timer->stop('SA');

    $timer->start('split');
    printf STDERR "Split text ... ";
    my @text = unpack('C*', $text);
    $timer->stop('split');

    $timer->start('BWT');
    printf STDERR "Covert SA to BWT ... ";
    my $bwt = join '', map { chr $text[$_ - 1] } @$sa;
    $timer->stop('BWT');

    return $bwt;
}

sub bs_decode ($) {
    my $data = shift;

    my $pos = - 1;
    my @data = split //, $data;
    my $len  = length $data;
    my @count;

    for (my $i = 0; $i < 0x100; $i++) {
        $count[$i] = 0;
    }

    for (my $i = 0; $i < $len; $i++) {
        if ($data[$i] eq EOF) {
            $pos = $i;
        }
        $count[ ord $data[$i] ]++;
    }

    for (my $i = 0; $i < 0x100; $i++) {
        $count[$i] += $count[$i - 1];
    }

    my @LFmapping;
    for (my $i = $len - 1; $i >= 0; $i--) {
        $LFmapping[ --$count[ ord $data[$i] ] ] = $i;
    }

    my @buff;
    for (0..$len - 1) {
        $pos = $LFmapping[ $pos ];
        push @buff, $data[ $pos ];
    }

    return join '', @buff;
}

my (@freq, @cum);

sub range_encode ($) {
    my $text = shift;

    my @char = unpack('C*', $text);
    for (my $i = 0; $i < 0x100; $i++) {
        $freq[$i] = 0;
    }

    for my $c (@char) {
        $freq[$c]++;
    }

    @cum = (0);
    for (my $i = 0; $i < 0x100; $i++) {
        $cum[$i + 1] = $cum[$i] + $freq[$i];
    }

    my $rc = Algorithm::RangeCoder->new;
    $rc->freq    = \@freq;
    $rc->cumfreq = \@cum;

    return $rc->encode($text);
}

sub range_decode ($) {
    my $bin = shift;

    my $rc = Algorithm::RangeCoder->new;
    $rc->freq    = \@freq;
    $rc->cumfreq = \@cum;

    return $rc->decode($bin);
}

sub compress ($) {
    my $text = shift;

    print STDERR "[1] Block sorting ... ";
    my $bwt = bs_encode $text;
    print STDERR "done\n";

    $timer->start('MTF');
    printf STDERR "[2] Move-to-front ... ";
    my $mtf  = Algorithm::MTF::Encoder->new;
    my $code = $mtf->encode($bwt);
    print STDERR "done\n";
    $timer->stop('MTF');

    $timer->start('pack');
    printf STDERR "[3] Packing integers ... ";
    my $packed = pack('C*', @$code);
    print STDERR "done\n";
    $timer->stop('pack');

    $timer->start('RC');
    printf STDERR "[4] Range coder ... ";
    my $bin = range_encode $packed;
    print STDERR "done\n";
    $timer->stop('RC');

    $bin;
}

sub decompress ($) {
    my $bin = shift;
    my $packed = range_decode $bin;
    my @code   = unpack('C*', $packed);
    my $mtf    = Algorithm::MTF::Decoder->new;
    my $bwt    = $mtf->decode(\@code);
    bs_decode $bwt;
}

my $file = shift or die "usage: $0 <file>";
my $text = file($file)->slurp;

my $bin = compress $text . EOF;

my $rate = 1 - length($bin) / length($text);

warn sprintf "\n%d bytes => %d bytes (%.1f%%)\n\n", length $text, length $bin, $rate * 100;
warn scalar $timer->reports, "\n";

printf STDERR "decompress ... ";
my $de = decompress $bin;
printf STDERR "done ... ";

## remove EOF
substr($de , -1, 1) = '';

printf STDERR $text eq $de ? "OK\n" : "NG";

参考文献