インターネット上の yahoo! の「知恵袋」や「教えて xxx」や「どう書く？ org」では、興味の引かれる質問や問題が掲載されることがあります。回答を寄せるか否かは別にして、 自分なりのプログラムを作ったりして楽しんでいます。この節の問題は、「どう書く？ org」(http://ja.doukaku.org/295/) に出題されたものです。
sort 関数は、Perl のプログラムでは比較的よく使われる関数です。 今回は、文字列中に数字列が含まれた文字列を対象にソートを行います。数字混じり文字列のソートでは、 文字列中の数字列を数値でソートして、それ以外を文字列としてソートすることになります。 対象となる文字列は、次のようなものです。
ソート前: x12, x1A, x1B, xAB, x13, x12B, x1
各文字列は、数字列とそれ以外の文字列が一定の順序で並んでいる必要があります。 なお、数字列とそれ以外の文字列の項目数が一致していなくても構いません。上記の例では、x12 が 'x' と 12 の２つ、x1A が 'x' と 1 と 'A' の３つ、xAB が 'xAB' の１つが、それぞれの項目数になります。
ソートは、それぞれの項目を数字列では数値比較を、 それ以外の文字列は文字列比較を行って進めていきます。数字列を含まない文字列比較で 'x' と 'xAB' のように、短い文字列が長い文字列の先頭部分文字列の場合は短いほうの "x" が「小さい」と判断されます。また、x1 と x1A のように途中の項目までまったく同じで項目数が違う場合は、項目数の少ない x1 が「小さい」と判断します。 上記のリストをソートした結果は、次のようになります。
ソート後: x1, x1A, x1B, x1B, x12, x12B, xAB
次が、数字混じり文字列のソート用のプログラムです。 プログラムでは、ハッシュとソートサブルーチンを併用しています。ハッシュのキーに元の文字列を、 値の無名配列に元の文字列を数字列とそれ以外の文字列に分解したものを入れています。
use strict;
my %parse;
while (<DATA>) {
print 'ソート前: ', $_;
%parse = map { $_ => [grep { length } split /(\d+)/] } split /[\s,]+/;
print 'ソート後: ', join(', ', sort sortsub keys %parse), "\n\n";
}
sub sortsub {
my $common_idx = $#{$parse{$a}} <= $#{$parse{$b}} ? $#{$parse{$a}} : $#{$parse{$b}};
my $ret = 0;
foreach my $i (0 .. $common_idx) {
if ($parse{$a}->[$i] =~ /\d+/) { $ret = $parse{$a}->[$i] <=> $parse{$b}->[$i]; }
else { $ret = $parse{$a}->[$i] cmp $parse{$b}->[$i]; }
return $ret if $ret != 0;
}
return $#{$parse{$a}} > $#{$parse{$b}} ? 1 : $#{$parse{$a}} < $#{$parse{$b}} ? -1 : 0;
}
__DATA__
x12, x13, x1A, x1B, xAB, x12B, x1
chap1.txt, chap10.txt, chap100.txt, chap2.txt, chap20.txt
A10B1, A10B10, A10B2, A1B1, A1B10, A1B2, A2B1, A2B10, A2B2
このプログラムでは、テスト用のサンプルデータをプログラムの末尾の __DATA__ 以下に置いています。このようにすると、手軽にプログラムのテストをすることができます。__DATA__ 以下のサンプルデータは、他のファイルハンドルと同様に while (<DATA>) { ... } を使って行単位で読み込み処理することができます。<DATA> で読み込んだ行は、 次の文を使って一気にハッシュ %parse を構築します。
%parse = map { $_ => [grep { length } split /(\d+)/] } split /[\s,]+/;
短い文ですが、一見しただけではすぐに理解できないと部分があると思います。 この文では、関数の引数としてのデフォルト変数 $_ を３つ省略しています。$_ を省略せずに書くと、次の文となります。
%parse = map { $_ => [grep { length $_ } split /(\d+)/, $_] } split /[\s,]+/, $_;
(2) (3) (2) (1)
上の文には４つの $_ がありますが、番号の違うものは別の値が格納されます。 末尾の (1) の $_ には、while ループで読み込んだ行が順番に格納されていきます。最初に末尾の split /[\s,]+/, $_ を処理すると、末尾は行を分解した文字列のリストに置き換わります。なお、split の分割文字列を丸カッコで囲まなければ捨てられますが、丸カッコで囲む (無名配列の中の split) と分割文字列も他の部分文字列といっしょに返されます。また、\s には改行も含まれているため、事前に chomp しておく必要はありません。
%parse = map { $_ => [grep { length $_ } split /(\d+)/, $_] } ('x12', 'x13', 'x1A', 'x1B', 'xAB', 'x12B', 'x1');
(2) (3) (2)
map 関数のブロック内では、末尾の引数の文字列のリストを順次処理して、 ハッシュのキーと値を生成します。２つの (2) の $_ には、引数の文字列が順次格納されます。最初の $_ は、元の文字列のままでハッシュのキーとなります。ハッシュの値である無名配列には、２つ目の $_ を split で分割して、数字列とそれ以外の文字列にしたものを格納します。その際に、split で空文字列の要素が生成される可能性があるため、length の引数の (3) の $_ に格納しながら１つずつチェックします。この文のすべての処理が終わると、 次に示すハッシュと等価なものができあがります。
%parse = (x12 => ['x', 12], x13 => ['x', 13], x1A => ['x', 1, 'A'], x1B => ['x', 1, 'B'],
xAB => ['xAB'], x12B => ['x', 12, 'B'], x => ['x', 1]);
ここで、少し寄り道をして、split とソートサブルーチンについて説明しておきましょう。
上の文で length を使っているのは、なぜだろうと思った方もいるかもしれません。実は、上の例では必要ないのです。 length が必要となるのは、先頭が数字列の場合です。分割文字列として数字列を指定しているため、 先頭に空文字列の要素が返されてしまいます。分割文字列を数字２桁とした例を挙げてみます。
$str = '12abc3456xyz89';
@list1 = split /(\d\d)/, $str, -1;
print "(";
foreach (0 .. $#list1) {
print $list1[$_] ? $list1[$_] : q('');
print ', ' if $_ < $#list1;
}
print ")\n"; # ('', 12, 'abc', 34, '', 56, 'xyz', 89, '')
@list2 = split /(\d\d)/, $str;
print "(";
foreach (0 .. $#list2) {
print $list2[$_] ? $list2[$_] : q('');
print ', ' if $_ < $#list2;
}
print ")\n"; # ('', 12, 'abc', 34, '', 56, 'xyz', 89)
split の第３引数には、分割数を指定することができます。最初の例にあるように -1 のような負の数を指定すると、空文字要素も含めて生成したすべての部分文字列のリストを返します。 先頭と末尾に分割文字列がある場合や途中で分割文字列が連続している場合は、 それに対応した箇所に空文字要素が含まれることになります。
２番目の例のように、分割数を指定しない通常の split では、末尾の空文字要素のみ除外したリストを返します。これが、split のデフォルトの動作になります。 とちらにしても、先頭や途中の空文字要素が残ってしまうので、必要がなければ別途除外することになります。
@list = grep { length $_ } split /(\d\d)/, $str; # (12, 'abc', 34, 56, 'xyz', 89)
grep { length $_ } を加えると、空文字列要素は長さ 0 なので除外できます。{ length $_ } の代わりに { defined $_ } を使うと、空文字要素自体は定義されていると評価されるので除外できません。 また、{ $_ } のように要素自体を評価すると、0 の数値や "0" の文字列が偽と評価されて除外されるので、 場合によってはうまく行きません。
ソートサブルーチンは、通常のサブルーチンとは異なる点がいくつかあります。 まず、ソートサブルーチンは、引数を受け取ることができません。その代わりに sort の特殊変数 $a と $b は、ソートサブルーチンから見ることができます。ソートサブルーチン内では、$a と $b を使ってコードを実行し、戻り値として -1, 0, 1 のいずれかを返すようにします。 また、ソートサブルーチンは、sort 文の第１引数として名前だけを渡します。 その際に、ソートサブルーチン名の後ろには丸カッコとカンマを付けません。この書き方は、print (または printf) 文の出力ファイルハンドルの指定と同様です。
引数にサブルーチンを使った sort 文は、構文上の曖昧さが残る場合があります。 ソートサブルーチンを使う機会が多くないので、ついうっかりと次のように書いてしまうことがあります。 ソートの結果を見て、意図どおりにならないので驚くことになります。
%num2alpha = (1 => 'one', 2 => 'two', 3 => 'three', 4 => 'four', 5 => 'five');
sub subname { map { $num2alpha{$_} @_; }
@list = sort subname(5, 1, 3, 2, 4);
print "@list\n"; # "5 1 3 2 4" と表示
コードの意図は、通常のサブルーチンを呼び出して、戻り値の ('five', 'one', 'three', 'two', 'four') を文字列順にソートすることです。しかし、Perl は subname をソートサブルーチンと解釈し、丸カッコ内の (5, 1, 3, 2, 4) をソート対象のリストとして実行してしまいます。 構文上の曖昧さを回避して意図どおりに動かすには、ソートブロックを付け加える、明示的にサブルーチンを呼び出す、 などの方法があります。
@list = sort { $a cmp $b } subname(5, 1, 3, 2, 4);
@list = sort &subname(5, 1, 3, 2, 4);%parse ハッシュの構築が終わってソートの準備が整ったので、 次の文の太字の部分でソートサブルーチンを呼び出しながらソートを行います。なお、ソートの並べ換え対象リストを keys %parse としていますが、対象のリストに重複する ("x1A" が２つある等) 要素がある場合は、最初に @list などに保存しておいて sort sortsub @list にようにする必要があります。
print 'ソート後: ', join(', ', sort sortsub keys %parse), "\n\n";
sub sortsub {
my $common_idx = $#{$parse{$a}} <= $#{$parse{$b}} ? $#{$parse{$a}} : $#{$parse{$b}}; # 共通添字番号の最大値
my $ret = 0; # 戻り値を仮に 0 としておく
foreach my $i (0 .. $common_idx) {
if ($parse{$a}->[$i] =~ /\d+/) { $ret = $parse{$a}->[$i] <=> $parse{$b}->[$i]; } # 数字比較
else { $ret = $parse{$a}->[$i] cmp $parse{$b}->[$i]; } # 文字列比較
return $ret if $ret != 0; # 比較して同じでない場合
}
return $#{$parse{$a}} > $#{$parse{$b}} ? 1 : $#{$parse{$a}} < $#{$parse{$b}} ? -1 : 0; # 共通要素がすべて同じ場合
}
sort では、ソート対象の引数のうちの２つを $a と $b にセットして sortsub を呼び出します。$a と $b には %parse ハッシュのキーであり、ソートサブルーチン内から $a と $b を介して %parse の値にもアクセスできます。ソートサブルーチンでは、２つの無名配列内の要素である部分文字列を、 数字列は数値比較で、その他の文字列は文字列比較をしながら進めていきます。
配列にも添字 (インデックス) がありますが、ハッシュのキーほどは活用されていません。 しかし、配列の添字を活用すると、配列の他の要素にアクセスするのが容易になります。foreach (@array) では他の要素にアクセスするのに苦労しますが、foreach (0 .. $#array) では添字の計算をすることによって前後を始めとする他の要素にも簡単にアクセスできます。 この節では、配列の添字を活用した事例として、配列の要素に順位付けをする例を取り上げます。
@abc 配列: bac acb cab cba acb bca abc bac 順位付与後: 4:bac 2:acb 7:cab 8:cba 2:acb 6:bca 1:abc 4:bac
元の配列 @abc の要素が上の１行目であった場合には、次の行に示してあるように、 元の要素の前にコロンをはさんでソート順位を付け加えます。もし同じ要素がある場合は、同じ順位を付けます。 上の例では acb と bac がそれぞれ２つずつあるので、同じ順位が付与されることになります。
use strict;
my @abc = qw(bac acb cab cba acb bca abc bac);
my @order = sort { $abc[$a] cmp $abc[$b] } 0 .. $#abc;
foreach my $i (0 .. $#order) {
my $rank = $i + 1;
if ($i > 0) {
my @pre = split /:/, $abc[$order[$i - 1]];
$rank = $pre[0] if $abc[$order[$i]] eq $pre[1];
}
$abc[$order[$i]] = "$rank:$abc[$order[$i]]";
}
print "@abc\n";まず、ソートの対象を配列の添字 (0 .. $#abc) にして、並べ換えた結果を別の配列 @order に格納します。配列の添字を対象とした場合は、ソートブロックを { $abc[$a] cmp $abc[$b] } のように指定して要素同士の比較を行います。出来上がった @order 配列の要素には @abc の添字が辞書順に並び、@order 配列の添字が順位を示すことになります。
@order 配列: 6 1 4 0 7 5 2 3
$abc[$order[$_]] = ($_ + 1) . ":$abc[$order[$_]]" foreach 0 .. $#order;
@abc の添字を格納した @order を作成したことで、@abc 配列の個々の要素に $abc[$order[N]] のように間接的な形でアクセスができるようになります。@order の添字が順位を保持しているので、同じ要素がなければ上の１行で順位を付与することができます。
システムのログファイルなどでは、ファイルのサイズが非常に大きくなることがあります。 巨大ファイルを１度にソートしようとすると、メモリが不足してエラーとなって実行できないことがあります。 ファイルが巨大すぎて実行できない場合は、一時ファイルなどを使って２段階に分けてソートすることもできます。 そのためには、事前の調査とテストを行なうことがお薦めです。
巨大なファイルも小さなファイルに分割すれば個々のファイルはソートできるようになりますが、 単に分割するだけではダメで分割自体がソートの第１段階になっている必要があります。 複雑なソートを行うこともできますが、ここでは話を単純化するために、 行頭からの辞書順でのソートを例に取り上げます。
$count{substr($_,0,1)}++ while <IN>;
print "$_: $count{$_} " foreach sort keys %count;
print "\n";
# while (<IN>) { push @max, $_ if substr($_, 0, 1) eq 'a'; }
# print sort @max;
上記のコードは手始めに行頭の１文字別に行数を数えて、コンソールに表示します。 次に、コメントアウトにしてあるコードで、行数の１番多い文字列 (上記の例では 'a') の行をすべて配列に入れてソート試してみます。ソートが異常なく実行できれば、調査とテストが OK となります。ソートが失敗した場合は、文字数を増やして再び調査とテストを繰り返します。 なお、行数の片寄りがある場合は、行数が多い文字列のみ文字数を増やすことができます。
次のプログラムは基本モデルのようなもので、対象ファイルに合わせて修正をすることで、 多様なケースに対応できるようになります。プログラムの前半部ではファイルに書き出しながらすべての行を読み取り、 後半部では小分けにしたソートを行いながらソート済みファイルに書き出しています。 ここで重要な役割を果たしているのが %group ハッシュのキーで、一次ソートキーの役割と、 一時ファイルを管理 (主ファイル名として読み書きする等) する役割を担っています。
use strict;
open IN, "infile" or die "Can't open infile: $!";
my %group;
while (my $line = <IN>) {
my $key = substr($line, 0, 1);
push @{$group{$key}}, $line;
if (@{$group{$kye}} == 1000) { # 一定の行数になったら
open OUT, ">>$key.tmp" or die "Can't open $key.tmp: $!";
print OUT @{$group{$key}}; # 一時ファイルに書き出して
close OUT;
@{$group{$key}} = (); # 配列を空にする
}
}
close IN;
open OUT, ">outfile" or die "Can't open outfile: $!";
foreach my $key (sort keys %group) {
if (-e "$key.tmp") { # 保存してあるファイルがある場合は
open IN, "$key.tmp" or die "Can't open $key.tmp: $!";
push @{$group{$key}}, <IN>; # 配列に格納して
close IN;
unlink "$key.tmp" or die "Can't delete $key.tmp: $!"; # 一時ファイルを削除
}
print OUT sort @{$group{$key}}; # ソートしてファイルに書き出す
@{$group{$key}} = ();
}
close OUT;(2011/11/01)