Perlの順列生成ワンライナーを考える

例題：

同じ数字が２回以上現れない、４桁の数字を羅列する（最上位桁が0でもOK）

…というのを考える。
その個数は、順列
${}_nP_m=n\cdot(n-1)\cdot(n-2)\cdots(n-m+1)=\frac{n!}{(n-m)!}$
から求められるので、この場合は10×9×8×7=5040個の数字列が現れることになる。

順列を生成するスクリプト

では実際に5040個の数字列を出力するには。
素直に(？)書くと以下のようなスクリプトになると思う。

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

# 使用する要素の集合
my @elements = (0..9);
# 選び出す要素の個数
my $m = 4;

# すべての順列を書き出す
my @results = &permutation($m, @elements);
print join('', @$_), "\n" for (@results);


# 渡された配列から $m 個を選ぶ順列を返すサブルーチン
sub permutation {
    my $m = shift;
    return ([]) if ($m == 0);

    my @results = ();
    for (0..$#_) {
        my $elem = $_[$_];
        # 渡された要素から１つを選び出し、残った配列を @array とする
        my @array = @_;
        splice(@array, $_, 1);
        # 選び出した１つの要素と、残りの配列から生成される順列をそれぞれ繋げる(再帰処理)
        for my $perm (&permutation($m - 1, @array)) {
            my $result = [$elem, @$perm];
            push(@results, $result);
        }
    }

    return @results;
}

ちょっとリファレンスとデリファレンスを繰り返してゴチャゴチャするけど、まぁ簡潔なんじゃないかと。
全部メモリに格納することになるのでかなりメモリは食うかも…。
ともあれ、これで順列をすべて求めることはできる。

$ perl permutation.pl
0123
0124
0125
...
9874
9875
9876
$ perl permutation.pl | wc
    5040    5040   25200

もうちょっと短いスクリプトにしてみる

引数から配列と選ぶ個数をとってみるようにする。

< # 使用する要素の集合
< my @elements = (0..9);
< # 選び出す要素の個数
< my $m = 4;
< # すべての順列を書き出す
< my @results = &permutation($m, @elements);
< print join('', @$_), "\n" for (@results);
< 
< 
---
> my $m = shift;
> my @elements = @ARGV;
> print join('', @$_), "\n" for (&permutation($m, @elements));

こんなカンジで。

$ perl permutation.pl 4 0 1 2 3 4 5 6 7 8 9

で同じ結果になる。(bashやzshのブレース展開を使用すれば 4 {0..9} と書いても同じ)

for文のネストをなくしてみる

簡単に思いつくのは

<             my $result = [$elem, @$perm];
<             push(@results, $result);
---
>             push(@results, [$elem, @$perm]);

という変更だけど、for文の中身がこの程度の操作をするだけならmap関数使えばいいか、と。

<         # 選び出した１つの要素と、残りの配列から生成される順列をそれぞれ繋げる(再帰処理)
<         for my $perm (&permutation($m - 1, @array)) {
<             my $result = [$elem, @$perm];
<             push(@results, $result);
<         }
---
>         push(@results, map { [$elem, @$_] } &permutation($m - 1, @array));

もう少しfor文の中身を簡潔に

いちいち@arrayにコピーしてからspliceするのは面倒。
そもそも対象とする集合に重複要素はないという前提で、grepフィルタリングで@arrayを作ってみる。

<     for (0..$#_) {
<         my $elem = $_[$_];
<         my @array = @_;
<         splice(@array, $_, 1);
---
>     for my $elem (@_) {
>         my @array = grep { ! /^$elem$/ } @_;

とりあえずここまででこんなカンジに。

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

my $m = shift;
my @elements = @ARGV;
print join('', @$_), "\n" for (&permutation($m, @elements));

sub permutation {
    my $m = shift;
    return ([]) if ($m == 0);

    my @results = ();
    for my $elem (@_) {
        my @array = grep { ! /^$elem$/ } @_;
        push(@results, map { [$elem, @$_] } &permutation($m - 1, @array));
    }

    return @results;
}

だいぶスッキリしてきた。

ワンライナーを作る

上記スクリプトを元に、ワンライナーを作ってみよう。

「削っても動作が変わらないところ」を省く

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

代入はせずにダイレクトに

< my $m = shift;
< my @elements = @ARGV;
< print join('', @$_), "\n" for (&permutation($m, @elements));
---
> print join('', @$_), "\n" for (&permutation(shift, @ARGV));

サブルーチン内も簡潔に

<     my $m = shift;
<     return ([]) if ($m == 0);
---
>     return ([]) if ((my $m = shift) == 0);

@arrayへの代入は必要ないのでダイレクトに

<         my @array = grep { ! /^$elem$/ } @_;
<         push(@results, map { [$elem, @$_] } &permutation($m - 1, @array));
---
>         push(@results, map { [$elem, @$_] } &permutation($m - 1, grep { ! /^$elem$/ } @_));

そこまでできればfor文は１行にまとめたい

<     my @results = ();
<     for my $elem (@_) {
<         push(@results, map { [$elem, @$_] } &permutation($m - 1, grep { ! /^$elem$/ } @_));
<     }
---
>     my (@results, $elem);
>     $elem = $_, push(@results, map { [$elem, @$_] } &permutation($m - 1, grep { ! /^$elem$/ } @_)) for @_;

ここらで変数名やサブルーチン名を短くしてみる

< print join('', @$_), "\n" for (&permutation(shift, @ARGV));
---
> print join('', @$_), "\n" for (&p(shift, @ARGV));

< sub permutation {
---
> sub p {

<     my (@results, $elem);
<     $elem = $_, push(@results, map { [$elem, @$_] } &permutation($m - 1, grep { ! /^$elem$/ } @_)) for @_;
---
>     my (@r, $e);
>     $e = $_, push(@r, map { [$e, @$_] } &p($m - 1, grep { ! /^$e$/ } @_)) for @_;

<     return @results;
---
>     return @r;

ここまででこんな状態。

print join('', @$_), "\n" for (&p(shift, @ARGV));

sub p {
    return ([]) if ((my $m = shift) == 0);

    my (@r, $e);
    $e = $_, push(@r, map { [$e, @$_] } &p($m - 1, grep { ! /^$e$/ } @_)) for @_;

    return @r;
}

うーん、まぁ一行に繋げてしまえそうだけど、もうひといき。

my宣言をまとめてみたり、条件分岐を変えてみたり、最後のreturn文を省いてみたり

<     return ([]) if ((my $m = shift) == 0);
< 
<     my (@r, $e);
---
>     my ($m, $e, @r);
>     $m = shift || return [];

< 
<     return @r;
---
>     @r;

print join('', @$_), "\n" for (&p(shift, @ARGV));

sub p {
    my ($m, $e, @r);
    $m = shift || return [];
    $e = $_, push(@r, map { [$e, @$_] } &p($m - 1, grep { ! /^$e$/ } @_)) for @_;
    @r;
}

ここまでくれば全部つなげてワンライナーにできる！

$ perl -e 'sub p { my ($m, $e, @r); $m = shift || return []; $e = $_, push(@r, map { [$e, @$_] } &p($m - 1, grep { ! /^$e$/ } @_)) for @_; @r } print join("", @$_), "\n" for (&p(shift, @ARGV))' 4 0 1 2 3 4 5 6 7 8 9
0123
0124
0125
...
9874
9875
9876

改行コードはコマンドラインスイッチで

perl -le 'sub p { my ($m, $e, @r); $m = shift || return []; $e = $_, push(@r, map { [$e, @$_] } &p($m - 1, grep { ! /^$e$/ } @_)) for @_; @r } print join("", @$_) for (&p(shift, @ARGV))'

詰められるスペースを詰める

perl -le'sub p{my($m,$e,@r);$m=shift||return[];$e=$_,push@r,map[$e,@$_],p($m-1,grep!/^$e$/,@_)for@_;@r}print join"",@$_ for p(shift,@ARGV)'

とりあえずこれで完成、ということで。

例題の要件を満たすだけなら

わざわざ丁寧に配列のリファレンスで返すこともなく、文字列でつなげてしまうだけでも良い。

perl -le'sub p{my($m,$e,@r);$m=shift||return"";$e=$_,push@r,map$e.$_,p($m-1,grep!/^$e$/,@_)for@_;@r}print for p(shift,@ARGV)' 4 0 1 2 3 4 5 6 7 8 9

とはいえ、こんな馬鹿正直に作っていてはここらが限界なのかも知れない。
まったく別のアプローチを考えてみる。

サブルーチンと似たような操作をするmapを使って４桁の数字列を生成する

perl -le '@$a = map {$a = $_; map { $a.$_ } grep { /[^$a]/} @b } @{$a ||= [@b = 0..9]} for 1..3; print for @$a'

詰めてしまえば

perl -le'@$a=map{$a=$_;map$a.$_,grep/[^$a]/,@b}@{$a||=[@b=0..9]}for 1..3;print for@$a'

for文の繰り返し回数だけ、「@bのうちまだ使っていないもの」をそれぞれ繋げて新しい文字列を作っていく、というもの。わかりにくい。

とにかく４桁の数値を作ってフィルタリングする

perl -le 'print for grep { my %a; $a{$_}++ for split//; keys %a > 3 } "0000".."9999"'

詰めてしまえば

perl -le'print for grep{my%a;$a{$_}++for split//;keys%a>3}"0000".."9999"'

マジカルインクリメントを使ってとりあえず10000個の数字を生成してしまってから、ハッシュを利用して使われている数字の個数を調べて重複しているものを取り除く、という方法。

とはいえいちいち中でsplitして調べるのも…と思ったんだけど正規表現とかでフィルタリングする方法がまともに思いつかなかった orz

perl -le 'print for grep { /^(.)/ && /^(.[^$1])/ && /^(..[^$1])/ && /^...[^$1]/ } "0123".."9876"'
perl -le 'print for grep/^(.)/&&/^(.[^$1])/&&/^(..[^$1])/&&/^...[^$1]/,"0123".."9876"'

これはひどいよなぁ…

CPANを使うと

Math::Combinatorics

nPkを出すことはできないようなので、combineをpermuteで繋げる形になるみたい。

perl -MMath::Combinatorics -le 'print @$_ for map permute(@$_), combine(4, 0..9)'

ただしこれだと出力の順番は小さい順にはならない。順番を気にする場合は

perl -MMath::Combinatorics -le 'print @$_ for sort { join("",@$a) <=> join("",@$b) } map permute(@$_), combine(4, 0..9)'

とか。

Algorithm::Permute

perl -MAlgorithm::Permute -le '$p=Algorithm::Permute->new([0..9], 4); print @a while (@a = $p->next)'

これまた順番めちゃめちゃ。

perl -MAlgorithm::Permute -le '$p=Algorithm::Permute->new([0..9], 4); push @b,join"",@a while (@a = $p->next); print for sort @b'

結論

出力したい順列の条件に応じて色々使い分けが必要かも？