NDO::Weblog

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

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

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

• http://github.com/naoya/perl-algorithm-mtf/tree/master

に置いています。

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 は実装していません。

自作ライブラリで圧縮

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

• Algorithm::DivSufSort (id:naoya:20081016:1224173077) で Suffix Array を作り、BWT に変換


• 変換したテキストに Algorithm::MTF で先頭移動法を適用


• Algorithm::RangeCoder (id:naoya:20080927:1222512024) でエントロピー符号化

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

% 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";

参考文献

• Move To Front - Wikipedia
  
  
  
  • 先頭移動法のアルゴリズムの概要
  
  
  
  


• Algorithms with Python / ブロックソート
  
  
  
  • Python による先頭移動法の実装あり。MTF-1、MTF-2 についても解説あり
  
  
  
  


• 図解入門 よくわかる最新データ圧縮技術の基本と仕組み―情報圧縮技術とアルゴリズムの基礎講座 (How‐nual Visual Guide Book)
  
  
  
  • 主要な圧縮アルゴリズムの概要が平易に解説されている書籍。(絶版)