お気楽 Perl プログラミング超入門

はじめに

今回は簡単な例題として、「連結リスト (linked list)」という基本的なデータ構造を作ってみましょう。

●連結リストとは？

連結リストはデータを一方向につなげたデータ構造です。リストを操作するプログラミング言語では Lisp が有名ですが、Lisp で扱うリストが連結リストです。下図に連結リストの構造を示します。

(1)変数
  ┌─┐    ┌─┬─┐  ┌─┬─┐  ┌─┬─┐  
  │・┼─→│10│・┼→│20│・┼→│30│／│ ／：終端
  └─┘    └─┴─┘  └─┴─┘  └─┴─┘  

(2)ヘッダセル
  ┌─┬─┐    ┌─┬─┐  ┌─┬─┐  ┌─┬─┐  
  │  │・┼─→│10│・┼→│20│・┼→│30│／│ ／：終端
  └─┴─┘    └─┴─┘  └─┴─┘  └─┴─┘  

                図 : 連結リスト

連結リストはセル (cell) というデータをつなげて作ります。セルにはデータを格納する場所と、次のセルを指し示す場所から構成されます。上図でいうと、箱がひとつのセルを表していて、左側にデータを格納し、右側に次のセルへの参照を格納します。Lisp では、左側の部分を CAR といい、右側の部分を CDR といいます。連結リストの終わりを示すため、最後のセルの右側には特別な値を格納します。Lisp では終端を nil というデータで表します。

そして、図 (1) のように先頭セルへの参照を変数に格納しておけば、この変数を使って連結リストにアクセスすることができます。また、図 (2) のようにヘッダセルを用意する方法もあります。今回は図 (2) の方法でプログラムを作ることにします。

連結リストの長所は、データの挿入や削除が簡単にできることです。配列でデータの削除や挿入を行う場合、要素を移動しなければいけませんが、連結リストはセルを付け替えるだけで実現できます。逆に、配列はどの要素にも一定の時間でアクセスすることができますが、連結リストはセルを順番にたどっていくため、後ろのデータほどアクセスに時間がかかります。これが連結リストの短所です。

●セルの定義

それではプログラムを作りましょう。最初にセルを表すクラス Cell を定義します。次のリストを見てください。

リスト : セルの定義

package Cell;

# 終端
our $nil = {};
bless $nil, 'Cell';

# 終端のチェック
sub null {
    my $cp = shift;
    ref $cp eq 'Cell' && $cp == $nil;
}
# セルの生成
sub new {
    my ($type, $item, $link) = @_;
    my $cp = {item => $item, link => $link};
    bless $cp, $type;
    $cp;
}

大域変数 $nil に空のハッシュをセットします。$nil は連結リストの終端として使います。$nil にも bless でクラス Cell の印を付けておきます。メソッド null は連結リストの終端をチェックします。ref で引数が Cell のインスタンスであることを確認してから、演算子 == で $nil と比較します。セルを生成するコンストラクタ new は簡単です。ハッシュを生成してキー item に要素 $item を、キー link に次のセルへのリファレンス $link を格納して返します。

次はセルのアクセスメソッドを定義します。

リスト : セルのアクセスメソッド

# 先頭要素を取り出す
sub car {
    my $cp = shift;
    $cp->{'item'};
}

# 先頭要素を取り除いたリストを返す
sub cdr {
    my $cp = shift;
    $cp->{'link'};
}

# item を書き換える
sub set_car {
    my ($cp, $x) = @_;
    $cp->{'item'} = $x;
}

# link を書き換える
sub set_cdr {
    my ($cp, $x) = @_;
    $cp->{'link'} = $x;
}

car, set_car はキー item のアクセスメソッド、cdr, set_cdr は link のアクセスメソッドです。メソッド名は Lisp / Scheme から拝借しました。プログラムは簡単なので、説明は不要でしょう。

●作業用メソッド nth_cell

次は、作業用のメソッドとして n 番目のセルを求める処理を作ります。メソッド名は nth_cell としました。次のリストを見てください。

リスト : n 番目のセルを求める

sub nth_cell {
    my ($cp, $n) = @_;
    my $i = -1;
    while (!$cp->null()) {
        last if $i == $n;
        $cp = $cp->cdr();
        $i++;
    }
    $cp;
}

nth_cell の引数 $cp はヘッダセルになります。ヘッダセルから数えるので、変数 $i は -1 に初期化します。次に、while 文でセルを順番にたどり、$i が $n と等しくなったならば、そのセル $cp を返します。

セルのたどり方は実に簡単です。下図を見てください。

 cp1         cp2         cp3
┌─┬─┐  ┌─┬─┐  ┌─┬─┐
│10│・┼→│20│・┼→│30│・┼→
└─┴─┘  └─┴─┘  └─┴─┘
↑          ↑
(1)         (2)

(1) $cp = $cp->cdr() => cp2
(2) $cp = $cp->cdr() => cp3

    図 : セルのたどり方

セル cp1 の link にはセル cp2 への参照が格納されています。変数 $cp が cp1 の場合、$cp = $cp->cdr() とすれば、$cp の値はセル cp2 になります (図 (1))。さらに $cp = $cp->cdr() とすれば、$cp の値は cp3 になります (図 (2))。

nth_cell の場合、while 文でセルをたどっていきますが、途中でセルがなくなった場合、cp の値は $nil になるので繰り返しを終了して $nil を返すことになります。

●連結リストの定義

次は連結リストを表すクラス LinkList を定義します。次のリストを見てください。

リスト : 連結リストの定義

package LinkList;

sub new {
    my $type = shift;
    my $obj = {top => Cell->new(0, $Cell::nil)};
    bless $obj, $type;
    $obj;
}

# アクセスメソッド
sub top {
    my $xs = shift;
    $xs->{'top'};
}

LinkList のコンストラクタ new は、セルを保持するキー top を用意して、そこにヘッダセルをセットします。ヘッダセルの item はダミーで、このプログラムでは 0 をセットします。link には終端 $nil をセットします。これで連結リストは空リストになります。メソッド top はキー top の値を返すだけです。

あとは、連結リストを操作するメソッドを定義します。連結リストを操作する基本的なメソッドを下表に示します。

●データの参照

それでは、n 番目の要素を求めるメソッド nth から作りましょう。次のリストを見てください。

リスト : n 番目の要素を求める

sub nth {
    my ($xs, $n) = @_;
    my $cp = $xs->top()->nth_cell($n);
    $cp->null() ? $cp : $cp->car();
}

メソッド nth_cell を呼び出して n 番目のセルを求めます。$cp が終端でなければ、格納されているデータ $cp->car() を返します。$cp が終端の場合は、$cp をそのまま返します。

●データの更新

次は要素を書き換えるメソッド update_nth を作ります。

リスト : n 番目の要素を更新

sub update_nth {
    my ($xs, $n, $x) = @_;
    my $cp = $xs->top()->nth_cell($n);
    if (!$cp->null()) {
        $cp->set_car($x);
        return $x;
    }
    $cp;
}

nth_cell で n 番目のセルを求めます。$cp が終端ならば、n 番目のセルはないので、$cp をそのまま返します。セルが見つかった場合は、set_car で item の値を $x に書き換えます。そして return で $x の値を返します。

●データの挿入

次は、データの挿入を行うメソッド insert_nth を作りましょう。データの挿入はセルの link を書き換えることで実現できます。下図を見てください。セル (1) とセル (2) の間にセル (3) を挿入します。

 top         (1)                (2)
┌─┐      ┌─┬─┐         ┌─┬─┐  ┌─┬─┐
│  ┼──→│10│・┼─ X ─→│20│・┼→│30│／│
└─┘      └─┴┼┘         └─┴─┘  └─┴─┘
                  │   (3)      ↑
                  │  ┌─┬─┐│
                  └→│40│・┼┘
                      └─┴─┘

セル(1)とセル(2)の間にセル(3)を挿入する場合

            図 : データの挿入

セル (1) の後ろにセル (3) を挿入する場合、セル (1) の link にはセル (2) への参照がセットされているので、この値をセル (3) の link にセットします。これで、セル (3) とセル (2) がリンクされます。次に、セル (1) の link にセル (3) への参照をセットします。これで、セル (1) とセル (2) の間に、セル (3) を挿入することができます。

プログラムは次のようになります。

リスト : データの挿入

sub insert_nth {
    my ($xs, $n, $x) = @_;
    my $cp = $xs->top()->nth_cell($n - 1);
    if (!$cp->null()) {
        $cp->set_cdr(Cell->new($x, $cp->cdr()));
        return $x;
    }
    $cp;
}

連結リストにデータを挿入する場合、挿入する位置のひとつ手前のセルが必要になります。nth_cell で $n - 1 番目のセルを求めます。セル $cp が見つかれば、$cp の後ろに $x を挿入します。$n が 0 の場合、nth_cell はヘッダセルを返すので、リストの先頭にデータが挿入されることになります。

Cell->new($x, cp->cdr()) で $x を格納する新しいセルを生成します。第 2 引数に cp->cdr() を指定することで、新しいセルの後ろに、$cp の次のセルを接続することができます。そして、$cp->set_cdr で link の値を新しいセルに書き換えます。これで $cp の後ろに新しいセルを挿入することができます。最後に挿入した $x を返します。

●データの削除

次は、n 番目の要素を削除するメソッド delete_nth を作りましょう。

 (1)           (2)         (3)
┌─┬─┐    ┌─┬─┐  ┌─┬─┐  
│10│・┼×→│20│・┼→│30│・┼→
└─┴┼┘    └─┴─┘  └─┴─┘  
      │                  ↑
      └─────────┘

図 : データの削除:セル(2) を削除する場合

データを削除する場合も、セルを付け替えるだけで済ますことができます。上図を見てください。セル (1) の後ろにあるセル (2) を削除する場合、セル (1) の link をセル (3) への参照に書き換えればいいのです。セル (3) はセル (2) の link から求めることができます。つまり、セル (1) を保持する変数を $cp とすると、セル (3) は $cp->cdr()->cdr() で求めることができるのです。

プログラムは次のようになります。

リスト : データの削除

sub delete_nth {
    my ($xs, $n) = @_;
    my $cp = $xs->top()->nth_cell($n - 1);
    if (!$cp->null() && !$cp->cdr()->null()) {
        my $x = $cp->cdr()->car();
        $cp->set_cdr($cp->cdr()->cdr());
        return $x;
    }
    $Cell::nil;
}

データを削除する場合も、削除する位置のひとつ手前のセルが必要になります。nth_cell で $n - 1 番目のセルを求めます。セル $cp が見つかれば、$cp の後ろのセルを削除します。

次に、削除するセルがあるか $cp->cdr() の値をチェックします。値が終端でなければ、そのセルを削除します。まず、削除するセルに格納されているデータを $x に取り出します。それから set_cdr で $cp の link の値を $cp->cdr()->cdr() に書き換えます。最後に $x を返します。

ところで、連結リストからはずされたセルやデータは、変数 top からアクセスすることができなくなります。Perl の場合、どの変数からも参照されなくなったオブジェクトはゴミになり、「ゴミ集め (GC)」^[*1] によって回収されます。

GC がないプログラミング言語では、不要になったオブジェクトは自動的に回収されません。それを行うようにプログラムする必要があるのです。Perl のように GC があるプログラミング言語では、ゴミになったオブジェクトは自動的に回収されるので、プログラマの負担はそれだけ少なくなります。

●高階関数 each

次は高階関数 each を作ります。each は連結リストの要素に関数 $f を適用します。次のリストを見てください。

リスト : 高階関数 each

sub each {
    my ($xs, $f) = @_;
    my $cp = $xs->top()->cdr();
    while (!$cp->null()) {
        $f->($cp->car());
        $cp = $cp->cdr();
    }
}

ヘッダセルに連結しているセルを取り出して変数 $cp にセットします。あとは、while 文でセルを順番にたどり、$f->($cp->car()) を呼び出すだけです。とても簡単ですね、

●連結リストの表示

次は連結リストを表示するメソッド print_list を作ります。連結リストはカッコでくくって、要素をカンマで区切ることにします。次のリストを見てください。

リスト ; 連結リストの表示

sub print_list {
    my $xs = shift;
    my $cp = $xs->top()->cdr();
    print "(";
    while (!$cp->null()) {
        print $cp->car();
        last if $cp->cdr()->null();
        print ", ";
        $cp = $cp->cdr();
    }
    print ")\n";
}

ヘッダセルの後ろのセルを求めて変数 $cp にセットします。最初に print で "(" を表示してから、while 文でセルを順番にたどります。$cp が終端の場合は while 文を終了して print で ")" を表示します。連結リストが空リストの場合は () と表示されます。

while 文の中では、$cp の要素を print で出力します。次のセルが終端であれば、last で繰り返しを脱出します。そうでなければ print で ", " を出力してから、$cp の値を $cp->cdr() に書き換えます。これで連結リストを表示することができます。

あとのプログラムは簡単なので、説明は割愛します。詳細はプログラムリストをお読みください。

●簡単なテスト

それでは実行してみましょう。次に示す簡単なテストを行ってみました。

リスト : 簡単なテスト (testlist.pl)

use strict;
use warnings;
use LinkList;

my $xs = LinkList->new();
$xs->print_list();
print $xs->is_empty(), "\n";

foreach my $i (1..8) {
    $xs->insert_nth(0, $i);
    $xs->print_list();
}
print $xs->is_empty(), "\n";

$xs->insert_nth(8, 9);
$xs->print_list();

$xs->insert_nth(8, 10);
$xs->print_list();

foreach my $i (0..9) {
    print $xs->nth($i), " ";
}
print "\n";

foreach my $i (0..9) {
    $xs->update_nth($i, $xs->nth($i) * 2);
    $xs->print_list();
}
print "\n";

$xs->delete_nth(9);
$xs->print_list();
$xs->delete_nth(4);
$xs->print_list();
$xs->delete_nth(0);
$xs->print_list();

$ perl -I. testlist.pl
()
1
(1)
(2, 1)
(3, 2, 1)
(4, 3, 2, 1)
(5, 4, 3, 2, 1)
(6, 5, 4, 3, 2, 1)
(7, 6, 5, 4, 3, 2, 1)
(8, 7, 6, 5, 4, 3, 2, 1)

(8, 7, 6, 5, 4, 3, 2, 1, 9)
(8, 7, 6, 5, 4, 3, 2, 1, 10, 9)
8 7 6 5 4 3 2 1 10 9 
(16, 7, 6, 5, 4, 3, 2, 1, 10, 9)
(16, 14, 6, 5, 4, 3, 2, 1, 10, 9)
(16, 14, 12, 5, 4, 3, 2, 1, 10, 9)
(16, 14, 12, 10, 4, 3, 2, 1, 10, 9)
(16, 14, 12, 10, 8, 3, 2, 1, 10, 9)
(16, 14, 12, 10, 8, 6, 2, 1, 10, 9)
(16, 14, 12, 10, 8, 6, 4, 1, 10, 9)
(16, 14, 12, 10, 8, 6, 4, 2, 10, 9)
(16, 14, 12, 10, 8, 6, 4, 2, 20, 9)
(16, 14, 12, 10, 8, 6, 4, 2, 20, 18)

(16, 14, 12, 10, 8, 6, 4, 2, 20)
(16, 14, 12, 10, 6, 4, 2, 20)
(14, 12, 10, 6, 4, 2, 20)

正常に動作していますね。興味のある方はいろいろ試してみてください。

●プログラムリスト

#
# LinkList.pm : 連結リスト
#
#               Copyright (C) 2015-2023 Makoto Hiroi
#
use strict;
use warnings;

package Cell;

# 終端
our $nil = {};
bless $nil, 'Cell';

# 終端のチェック
sub null {
    my $cp = shift;
    ref $cp eq 'Cell' && $cp == $nil;
}

# セルの生成
sub new {
    my ($type, $item, $link) = @_;
    my $cp = {item => $item, link => $link};
    bless $cp, $type;
    $cp;
}

# アクセスメソッド
sub car {
    my $cp = shift;
    $cp->{'item'};
}

sub cdr {
    my $cp = shift;
    $cp->{'link'};
}

sub set_car {
    my ($cp, $x) = @_;
    $cp->{'item'} = $x;
}

sub set_cdr {
    my ($cp, $x) = @_;
    $cp->{'link'} = $x;
}

# 作業用メソッド
sub nth_cell {
    my ($cp, $n) = @_;
    my $i = -1;
    while (!$cp->null()) {
        last if $i == $n;
        $cp = $cp->cdr();
        $i++;
    }
    $cp;
}

package LinkList;

sub new {
    my $type = shift;
    my $obj = {top => Cell->new(0, $Cell::nil)};
    bless $obj, $type;
    $obj;
}

# アクセスメソッド
sub top {
    my $xs = shift;
    $xs->{'top'};
}

# n 番目のセルを求める
sub nth {
    my ($xs, $n) = @_;
    my $cp = $xs->top()->nth_cell($n);
    $cp->null() ? $cp : $cp->car();
}

# n 番目のデータを更新
sub update_nth {
    my ($xs, $n, $x) = @_;
    my $cp = $xs->top()->nth_cell($n);
    if (!$cp->null()) {
        $cp->set_car($x);
        return $x;
    }
    $cp;
}

# n 番目にデータを挿入
sub insert_nth {
    my ($xs, $n, $x) = @_;
    my $cp = $xs->top()->nth_cell($n - 1);
    if (!$cp->null()) {
        $cp->set_cdr(Cell->new($x, $cp->cdr()));
        return $x;
    }
    $cp;
}

# n 番目のデータを削除
sub delete_nth {
    my ($xs, $n) = @_;
    my $cp = $xs->top()->nth_cell($n - 1);
    if (!$cp->null() && !$cp->cdr()->null()) {
        my $x = $cp->cdr()->car();
        $cp->set_cdr($cp->cdr()->cdr());
        return $x;
    }
    $Cell::nil;
}

# 巡回
sub each {
    my ($xs, $f) = @_;
    my $cp = $xs->top()->cdr();
    while (!$cp->null()) {
        $f->($cp->car());
        $cp = $cp->cdr();
    }
}

# 空リストか
sub is_empty {
    my $xs = shift;
    $xs->top->cdr()->null();
}

# 表示
sub print_list {
    my $xs = shift;
    my $cp = $xs->top()->cdr();
    print "(";
    while (!$cp->null()) {
        print $cp->car();
        last if $cp->cdr()->null();
        print ", ";
        $cp = $cp->cdr();
    }
    print ")\n";
}

1;

順列と組み合わせ

今回は簡単な例題として「順列 (permutation)」と「組み合わせ (combination)」を取り上げます。Perl には順列や組み合わせを求めるライブラリ Math::Combinatorics がありますが、今回は Perl のお勉強ということで、実際にプログラムを作ってみましょう。

●順列の生成

順列の生成は拙作のページ「再帰定義」で取り上げました。今回は 1 から n までの数字から m 個を選ぶ順列を生成することにします。関数名は permutations としました。

permutations($f, $n, $m);

permutations は高階関数で、生成した順列を関数 $f に渡して呼び出します。プログラムは次のようになります。

リスト : 順列の生成 (1)

# 配列 $xs に $n と等しい要素があるか
sub member {
    my ($n, $xs) = @_;
    foreach my $x (@$xs) {
        return 1 if $x == $n;
    }
    0;
}

# 1 .. n の数字から m 個を選ぶ順列を生成
sub perm_sub {
    my ($f, $n, $m, $xs) = @_;
    if (@$xs == $m) {
        $f->([@$xs]);
    } else {
        for (my $i = 1; $i <= $n; $i++) {
            if (!member($i, $xs)) {
                push @$xs, $i;
                perm_sub($f, $n, $m, $xs);
                pop @$xs;
            }
        }
    }
}

sub permutations {
    my ($f, $n, $m) = @_;
    perm_sub($f, $n, $m, []);
}

実際の処理は関数 perm_sub で行います。引数 $f が関数、$n が数字の上限値、$m が選ぶ数字の個数、引数 $xs が選んだ数字を格納する配列です。@$xs の大きさが $m と等しい場合、順列が一つ完成しました。[@$xs] で配列をコピーして関数 $f に渡します。そうでなければ、1 から $n までの数字から一つ選んで、配列 @$xs に追加します。このとき、関数 member で $xs に同じ数字がないことをチェックします。あとは、perm_sub を再帰呼び出しして、戻ってきたら pop で配列 $xs から末尾の要素を削除します。これで順列を生成することができます。

それでは、実際に試してみましょう。

リスト : 簡単なテスト

permutations(sub {my $xs = shift; print "@$xs\n"; }, 4, 4);

$ perl perm.pl
1 2 3 4
1 2 4 3
1 3 2 4
1 3 4 2
1 4 2 3
1 4 3 2
2 1 3 4
2 1 4 3
2 3 1 4
2 3 4 1
2 4 1 3
2 4 3 1
3 1 2 4
3 1 4 2
3 2 1 4
3 2 4 1
3 4 1 2
3 4 2 1
4 1 2 3
4 1 3 2
4 2 1 3
4 2 3 1
4 3 1 2
4 3 2 1

正常に動作していますね。

●順列を配列に格納する

生成した順列を配列に格納して返すことも簡単にできます。次のリストを見てください。

リスト : 順列の生成

sub permutations_list {
    my ($n, $m) = @_;
    my $a = [];
    permutations(sub {push @$a, shift}, $n, $m);
    $a;
}

関数 permutations_list は、無名の配列 $a を用意して permutations を呼び出します。あとは、無名の関数の中で受け取った順列を配列 @$a に push で追加していくだけです。

それでは実際に試してみましょう。

リスト : 簡単なテスト (2)

my $b = permutations_list(4, 4);
foreach my $xs (@$b) {
    print "@$xs\n";
}

結果は permutations と同じです。

●配列から m 個の要素を選ぶ順列

次は、配列に格納された要素から m 個を選ぶ順列を生成するプログラムを作ってみましょう。この場合、配列の要素を交換することで、簡単に順列を生成することができます。たとえば、i 番目の要素を選ぶ場合、0 から i - 1 番目までの要素は選択済みとすると、i から末尾までの要素から選べばよいことになります。選択する要素が j 番目の場合、i 番目の要素と j 番目の要素を交換して、次は i + 1 番目の要素を i + 1 から末尾までの中から選べばよいわけです。

プログラムは次のようになります。

リスト : 順列の生成 (3)

sub perm1_sub {
    my ($f, $i, $n, $xs) = @_;
    if ($n == $i) {
        $f->([@$xs[0 .. $n - 1]]);
    } else {
        my $temp = $xs->[$i];
        for (my $j = $i; $j < @$xs; $j++) {
            $xs->[$i] = $xs->[$j];
            $xs->[$j] = $temp;
            perm1_sub($f, $i + 1, $n, $xs);
            $xs->[$j] = $xs->[$i];
            $xs->[$i] = $temp;
        }
    }
}

sub permutations1 {
    my ($f, $n, $xs) = @_;
    perm1_sub($f, 0, $n, $xs);
}

実際の処理は関数 perm1_sub で行います。引数 $i が選択する位置、$n が選択する要素の個数、$xs が配列です。$n と $i が等しい場合、$n 個の要素を選択したので、$xs の 0 番目から $n - 1 番目までをコピーして関数 $f に渡します。そうでなければ、配列の要素を交換します。for 文の変数 $j が選択する要素の位置を表します。$j の範囲は $i から @$xs - 1 までになります。あとは要素を交換して perm1_sub を再帰呼び出しして、戻ってきたら交換した要素を元に戻すだけです。

それでは実際に試してみましょう。

リスト : 簡単なテスト (3)

permutations1(sub {my $xs = shift; print "@$xs\n"; }, 4, [1,2,3,4]);

$ perl perm.pl
1 2 3 4
1 2 4 3
1 3 2 4
1 3 4 2
1 4 3 2
1 4 2 3
2 1 3 4
2 1 4 3
2 3 1 4
2 3 4 1
2 4 3 1
2 4 1 3
3 2 1 4
3 2 4 1
3 1 2 4
3 1 4 2
3 4 1 2
3 4 2 1
4 2 3 1
4 2 1 3
4 3 2 1
4 3 1 2
4 1 3 2
4 1 2 3

24 通りの順列が生成されました。ただし、生成される順列の順番は permutations とは異なることに注意してください。

●組み合わせの生成

次は「組み合わせ (combination)」を生成するプログラムを作ってみましょう。たとえば、配列 [1, 2, 3, 4, 5] の中から 3 個を選ぶ組み合わせは次のようになります。

1 2 3, 1 2 4, 1 2 5, 1 3 4, 1 3 5, 1 4 5
2 3 4, 2 3 5, 2 4 5, 3 4 5

最初に 1 を選択した場合、次は [2, 3, 4, 5] の中から 2 個を選べばいいですね。2 番目に 2 を選択したら、次は [3, 4, 5] の中から 1 個を選べばいいわけです。これで、[1, 2, 3], [1, 2, 4], [1, 2, 5] が生成されます。

[2, 3, 4, 5] の中から 2 個選ぶとき、2 を選ばない場合があります。この場合は [3, 4, 5] の中から 2 個を選べばいいわけです。ここで 3 を選ぶと [1, 3, 4], [1, 3, 5] が生成できます。同様に、3 を除いた [4, 5] の中から 2 個をえらぶと [1, 4, 5] を生成することができます。

これで 1 を含む組み合わせを生成したので、次は 1 を含まない組み合わせ、つまり [2, 3, 4, 5] から 3 個を選ぶ組み合わせを生成すればいいわけです。けっきょく、この処理の考え方は次に示す組み合わせの公式と同じです。

これをプログラムすると次のようになります。

リスト : 組み合わせの生成

sub comb_sub {
    my ($f, $i, $n, $r, $xs) = @_;
    if ($r == 0) {
        $f->([@$xs]);
    } elsif ($n - $i + 1 == $r) {
        $f->([@$xs, $i .. $n]);
    } else {
        push @$xs, $i;
        comb_sub($f, $i + 1, $n, $r - 1, $xs);
        pop @$xs;
        comb_sub($f, $i + 1, $n, $r, $xs);
    }
}

sub combinations {
    my ($f, $n, $r) = @_;
    comb_sub($f, 1, $n, $r, []);
}

関数 combinations は高階関数で、1 から $n までの数字から $r 個の数字を選ぶ組み合わせを生成します。実際の処理は関数 comb_sub で行います。引数 $i が選ぶ数字、$xs が選んだ数字を格納する配列です。$r が 0 の場合、[@$xs] で配列をコピーして関数 $f に渡して呼び出します。残った数字 ($i から $n まで) の個数が $r と等しい場合は、その数字をすべて選び、関数 $f に渡します。

それ以外の場合、最初に数字 $i を選択します。push で $i を $xs に追加して、comb_sub を再帰呼び出しします。このとき、$i を +1 して、$r を -1 します。戻ってきたら、$xs から末尾の要素を pop で削除して、comb_sub を再帰呼び出しします。このときは、$i を選択しない場合です。$i は +1 しますが、$r は -1 しません。これで、すべての組み合わせを生成することができます。

実際に試してみましょう。

リスト : 簡単なテスト

combinations(sub {my $xs = shift; print "@$xs\n";}, 5, 3);

$ perl perm.pl
1 2 3
1 2 4
1 2 5
1 3 4
1 3 5
1 4 5
2 3 4
2 3 5
2 4 5
3 4 5

正常に動作していますね。

●組み合わせを配列に格納する

生成した組み合わせを配列に格納して返す場合も簡単です。プログラムは次のようになります。

リスト : 組み合わせの生成 (2)

sub combinations_list {
    my ($n, $r) = @_;
    my $a = [];
    combinations(sub {push @$a, shift;}, $n, $r);
    $a;
}

関数 combinations_list は、無名の配列 $a を用意して、combinations を呼び出します。あとは、無名の関数の中で受け取った組み合わせを配列 @$a に push で追加していくだけです。

それでは実際に試してみましょう。

リスト : 簡単なテスト (2)

$b = combinations_list(5, 3);
foreach my $xs (@$b) {
    print "@$xs\n";
}

結果は combinations と同じです。

●配列から n 個の要素を選ぶ組み合わせ

次は配列から n 個の要素を選ぶ組み合わせを生成するプログラムを作ります。次のリストを見てください。

リスト ; 組み合わせの生成 (3)

sub comb1_sub {
    my ($f, $i, $r, $xs, $ys) = @_;
    if ($r == 0) {
        $f->([@$ys]);
    } elsif (@$xs - $i == $r) {
        $f->([@$ys, @$xs[$i .. $#$xs]]);
    } else {
        push @$ys, $xs->[$i];
        comb1_sub($f, $i + 1, $r - 1, $xs, $ys);
        pop @$ys;
        comb1_sub($f, $i + 1, $r, $xs, $ys);
    }
}

sub combinations1 {
    my ($f, $r, $xs) = @_;
    comb1_sub($f, 0, $r, $xs, []);
}

実際の処理は関数 comb1_sub で行います。$xs が配列で、$ys が選んだ要素を格納する配列です。基本的には comb_sub と同じで、変数 $i が $xs の添字になるだけです。つまり、選択する要素は $xs->[$i] になります。

それでは実行してみましょう。

リスト : 簡単なテスト

combinations1(sub {my $xs = shift; print "@$xs\n"; }, 3, [1,2,3,4,5]);

$ perl perm.pl
1 2 3
1 2 4
1 2 5
1 3 4
1 3 5
1 4 5
2 3 4
2 3 5
2 4 5
3 4 5

正常に動作していますね。

●プログラムリスト

#
# perm.pl : 順列と組み合わせの生成
#
#           Copyright (C) 2015-2023 Makoto Hiroi
#
use strict;
use warnings;

sub member {
    my ($n, $xs) = @_;
    foreach my $x (@$xs) {
        return 1 if $x == $n;
    }
    0;
}

# 1 .. n の数字から m 個を選ぶ順列を生成
sub perm_sub {
    my ($f, $n, $m, $xs) = @_;
    if (@$xs == $m) {
        $f->([@$xs]);
    } else {
        for (my $i = 1; $i <= $n; $i++) {
            if (!member($i, $xs)) {
                push @$xs, $i;
                perm_sub($f, $n, $m, $xs);
                pop @$xs;
            }
        }
    }
}

sub permutations {
    my ($f, $n, $m) = @_;
    perm_sub($f, $n, $m, []);
}

sub permutations_list {
    my ($n, $m) = @_;
    my $a = [];
    permutations(sub {push @$a, shift}, $n, $m);
    $a;
}

# 配列から n 個選ぶ順列
sub perm1_sub {
    my ($f, $i, $n, $xs) = @_;
    if ($n == $i) {
        $f->([@$xs[0 .. $n - 1]]);
    } else {
        my $temp = $xs->[$i];
        for (my $j = $i; $j < @$xs; $j++) {
            $xs->[$i] = $xs->[$j];
            $xs->[$j] = $temp;
            perm1_sub($f, $i + 1, $n, $xs);
            $xs->[$j] = $xs->[$i];
            $xs->[$i] = $temp;
        }
    }
}

sub permutations1 {
    my ($f, $n, $xs) = @_;
    perm1_sub($f, 0, $n, $xs);
}

# 組み合わせ
sub comb_sub {
    my ($f, $i, $n, $r, $xs) = @_;
    if ($r == 0) {
        $f->([@$xs]);
    } elsif ($n - $i + 1 == $r) {
        $f->([@$xs, $i .. $n]);
    } else {
        push @$xs, $i;
        comb_sub($f, $i + 1, $n, $r - 1, $xs);
        pop @$xs;
        comb_sub($f, $i + 1, $n, $r, $xs);
    }
}

sub combinations {
    my ($f, $n, $r) = @_;
    comb_sub($f, 1, $n, $r, []);
}

sub combinations_list {
    my ($n, $r) = @_;
    my $a = [];
    combinations(sub {push @$a, shift;}, $n, $r);
    $a;
}

# 配列から要素を選ぶ
sub comb1_sub {
    my ($f, $i, $r, $xs, $ys) = @_;
    if ($r == 0) {
        $f->([@$ys]);
    } elsif (@$xs - $i == $r) {
        $f->([@$ys, @$xs[$i .. $#$xs]]);
    } else {
        push @$ys, $xs->[$i];
        comb1_sub($f, $i + 1, $r - 1, $xs, $ys);
        pop @$ys;
        comb1_sub($f, $i + 1, $r, $xs, $ys);
    }
}

sub combinations1 {
    my ($f, $r, $xs) = @_;
    comb1_sub($f, 0, $r, $xs, []);
}

# テスト
permutations(sub {my $xs = shift; print "@$xs\n"; }, 4, 4);

my $b = permutations_list(4, 4);
foreach my $xs (@$b) {
    print "@$xs\n";
}

permutations1(sub {my $xs = shift; print "@$xs\n"; }, 4, [1,2,3,4]);

combinations(sub {my $xs = shift; print "@$xs\n";}, 5, 3);

$b = combinations_list(5, 3);
foreach my $xs (@$b) {
    print "@$xs\n";
}

combinations1(sub {my $xs = shift; print "@$xs\n"; }, 3, [1,2,3,4,5]);