最初はDartsのXSを作ろうとしたのだけど、どうもtemplateばりばりのC++コードとXSは相性が悪い。でもTrieを作るだけなら、Perlでもそこそこ出来るし、実際Regexp::OptimizerやRegexp::Assembleのようなモジュールもある。ただこれらはTrie以外のOptimizeもしてしまうので、ちょっと重たいというわけで、mk_trie_regexp.plというScriptをサクっと書いてみました。

使い方は簡単。/usr/share/dict/wordsのような、一行一語のファイルを引数に指定すると、それに対応した正規表現を吐いてくれます。あとはそれを

my $re = do "keyword.list.rx";

とかして読み込めばOK。

しかし、はてなのキーワードリストはすでにRegexpとして書かれちゃっているので、これを戻す為にhatena2list.plというscriptも書いときました。

そしてベンチマークを取った結果が以下です。

            (warning: too few iterations for a reliable count)
          s/iter  comp_raw comp_trie
comp_raw    4.61        --      -87%
comp_trie  0.592      679%        --
           Rate  pm_raw pm_trie
pm_raw    156/s      --   -100%
pm_trie 70337/s  44874%      --
            (warning: too few iterations for a reliable count)
          s/iter  nm_raw nm_trie
nm_raw      23.6      --   -100%
nm_trie 1.57e-02 150763%      --

            (warning: too few iterations for a reliable count)
          s/iter  comp_raw comp_trie
comp_raw    4.45        --      -90%
comp_trie  0.465      855%        --
           Rate  pm_raw pm_trie
pm_raw    532/s      --    -99%
pm_trie 92027/s  17197%      --
            (warning: too few iterations for a reliable count)
          s/iter  nm_raw nm_trie
nm_raw      6.91      --   -100%
nm_trie 1.22e-02  56417%      --

Darts版ほどとは行きませんが、なかなかPracticalなのではないでしょうか。なんといってもPerlから直接使える--正規表現そのものはRubyでも互換?--のはぐ〜でしょう。

Dan the Just Another (Perl|Trie) Hacker

mk_trie_regexp.pl

#!/usr/bin/env perl
#
# $Id: mk_trie_regexp.pl,v 0.1 2005/09/10 20:19:44 dankogai Exp dankogai $
#
use strict;
use warnings;

package Regexp::Trie;

sub new{ bless {} => shift }
sub add{
    my $self = shift;
    my $str  = shift;
    my $ref  = $self;
    for my $char (split //, $str){
        $ref->{$char} ||= {};
        $ref = $ref->{$char};
    }
    $ref->{''} = 1; # { '' => 1 } as terminator
    $self;
}
sub _regexp{
    my $self = shift;
    return if $self->{''} and scalar keys %$self == 1; # terminator
    my (@alt, @cc);
    my $q = 0;
    for my $char (sort keys %$self){
        my $qchar = quotemeta $char;
        if (ref $self->{$char}){
            if (defined (my $recurse = _regexp($self->{$char}))){
                push @alt, $qchar . $recurse;
            }else{
                push @cc, $qchar;
            }
        }else{
            $q = 1;
        }
    }
    my $cconly = !@alt;
    @cc and push @alt, @cc == 1 ? $cc[0] : '['. join('', @cc). ']';
    my $result = @alt == 1 ? $alt[0] : '(?:' . join('|', @alt) . ')';
    $q and $result = $cconly ? "$result?" : "(?:$result)?";
    return $result;
}
sub as_regexp{ my $str = shift->_regexp; qr/$str/ }

package main;

my $src = shift || die "$0 src [dst]";
my $dst = shift || "$src.rx";
my $trie = Regexp::Trie->new;

my $count;
$|=1;
open my $in, "<:raw", $src or die "$src : $!";
while(<$in>){
    chomp;
    $trie->add($_);
    ++$count % 1000 == 0 and print "$count\r";
}
close $in;
print "$count\n";
system ("ps v$$");
my $qr = $trie->as_regexp;
open my $out, ">:raw", $dst or die "$dst : $!";
print $out 'qr{'.$qr.'}';
close $out;
system ("ps v$$");

__END__

hatena2list.pl

#!/usr/bin/env perl
use strict;
use warnings;
use LWP::Simple;
my $url = shift || "http://d.hatena.ne.jp/images/keyword/keywordlist";
sub fetch{
    my $url = shift;
    $url =~ m{^http://} and return get($url);
    open my $in, "<:raw", $url or die "$url : $!";
    my $retval = join '', <$in>;
    close $in;
    return $retval;
}
my %ent =    (amp => '&', gt => '>', lt => '>', quot => q('));
my $re_ent = join '|', keys %ent;
my $str = fetch($url);
my @words;
for (split m/(?!\\)\|/, $str){
    s/\\s/ /g;
    s/\\//g;
    s/&($re_ent);/$ent{$1}/g;
    s/^\s+//; s/^\s+\z//;
    /^$/ and next;
    push @words, $_;
}
print "$_\n" for (sort @words);
__END__

bench.pl

#!/usr/bin/env perl
use strict;
use warnings;
use LWP::Simple;
my $url = shift || "http://d.hatena.ne.jp/images/keyword/keywordlist";
sub fetch{
    my $url = shift;
    $url =~ m{^http://} and return get($url);
    open my $in, "<:raw", $url or die "$url : $!";
    my $retval = join '', <$in>;
    close $in;
    return $retval;
}
my %ent =    (amp => '&', gt => '>', lt => '>', quot => q('));
my $re_ent = join '|', keys %ent;
my $str = fetch($url);
my @words;
for (split m/(?!\\)\|/, $str){
    s/\\s/ /g;
    s/\\//g;
    s/&($re_ent);/$ent{$1}/g;
    s/^\s+//; s/^\s+\z//;
    /^$/ and next;
    push @words, $_;
}
print "$_\n" for (sort @words);
__END__