2つの配列から重複を弾く（Perlで）

いきなり例題から。

以下のような2つの配列があるとき、

my @fruits1 = qw/orange banana apple lemon/;
my @fruits2 = qw/orange banana/;

@fruits1のうち@fruits2とカブるものをカットして、重複しないappleとlemonだけ@fruits1に残したいとする。

こういうとき、今までぼくはこう書いていたのだけど、

#!/usr/bin/env perl
#
# cut_overlap.pl

use strict;
use warnings;
use feature 'say';

# 以後、配列名は短縮
my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

for my $f2 (@f2) {
    for my $f1 (@f1) {
        if ($f1 eq $f2) {
            say "match:\t$f1!";
            @f1 = grep {$f1 ne $_} @f1;
        }
    }
}

say '===';
say "\@f1の残りは……";
say for @f1;
say "です！";

まあ、これでも目的は達成できる。実行結果は以下。

match: orange!
match: banana!
===
@f1の残りは……
apple
lemon
です！

最初にorange、その後にbananaがマッチして、あとにはappleとlemonが残っている。

コードでやってることとしては、まず2つの配列をループさせて、要素同士がマッチしたらその要素を元の配列からgrepで削除する。

削除というか、実際には「対象の要素以外を元の配列に入れ直す」という感じか。

で、ここでは重複を弾きたい（数を減らしたい）@f1の方を内側のループにして、grepでもその配列を対象としてカットしている。

というのも、この内と外を逆にすると、

# 以後、シバンやプラグマは省略
#
# cut_overlap2.pl

my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

for my $f1 (@f1) { #<= 外側にもってくる
    for my $f2 (@f2) { #<= 内側に入れる
        if ($f1 eq $f2) {
            say "match:\t$f1!";
            @f1 = grep {$f1 ne $_} @f1;
        }
    }
}

say '===';
say "\@f1の残りは……";
say for @f1;
say "です！";

結果。

match: orange!
===
@f1の残りは……
banana
apple
lemon
です！

こんなふうに、意図に反して最初のorangeだけマッチして、本来消えてほしいbananaが残ってしまう。

中身はどういうことになってるのか、必殺のprintデバッグ。

# cut_overlap3_debug.pl

my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

for my $f1 (@f1) {
    for my $f2 (@f2) {
        say "f1:$f1 & f2:$f2"; #<= 中身を出力してみる
        if ($f1 eq $f2) {
            say "match:\t$f1!";
            @f1 = grep {$f1 ne $_} @f1;
        }
    }
}

say '===';
say "\@f1の残りは……";
say for @f1;
say "です！";

結果。

f1:orange & f2:orange
match: orange!
f1:orange & f2:banana
f1:apple & f2:orange
f1:apple & f2:banana
f1:lemon & f2:orange
f1:lemon & f2:banana
===
@f1の残りは……
banana
apple
lemon
です！

ということで、どうやら最初にorangeにマッチした後、@f1が2周めでbananaを飛ばしてappleの周回に入ってしまっている。（実行結果の4行目）

ちなみに、さっきの上手くいった場合だと、内部はどうなっているのかというと、

f1:orange & f2:orange
match: orange!
f1:apple & f2:orange
f1:lemon & f2:orange
f1:banana & f2:banana
match: banana!
f1:lemon & f2:banana
===
@f1の残りは……
apple
lemon
です！

という感じで、このときは目的上の影響がなくて気づかなかったけど、じつはここでもorangeがマッチした後、@f1のbananaがスッ飛ばされている。（実行結果の3行目）

ということで、実利的には最初の方法であれば目的は果たせるものの、裏で起こっていることはどちらも意図と違うというか、ちょっと気持ち悪い感じがあって、そこでいつもお世話になっていますPerl入学式のサポーター陣とのチャットでいろいろ相談してみた。

で、さっそく @xtetsuji さんからいただいた解答例がこちら。

# xtetsuji_1.pl
# 
# 出力部分は省略

my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

array_minus1(\@f1, \@f2);

sub array_minus1 {
    my $f1 = shift;
    my $f2 = shift;
    @$f1 = map {
        my $f1_value = $_;
        ( grep { $f1_value eq $_ } @$f2 ) ? () : $f1_value;
    } @$f1;
}

さらに、もう1案いただいた。

# xtetsuji_2.pl

my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

array_minus2(\@f1, \@f2);

sub array_minus2 {
    my $f1 = shift;
    my $f2 = shift;
    my %f2_value_is = map { $_ => 1 } @$f2;
    @$f1 = map { $f2_value_is{$_} ? () : $_ } @$f1;
}

結果はいずれも、以下。

@f1の残りは……
apple
lemon
です！

前者はgrep, 後者はmapを使っているけど、どちらも「マッチしたら空リストに入れる＝元の配列から外す」という処理になっている。

そしてそれとは別に、@skjmさんからAcme::Toolsのminusもあるよ、と教えて頂いて。
Acme::Tools - search.cpan.org

これを使うと、こんな感じ。

# acme_minus.pl

use Acme::Tools 'minus';

my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

my @result = minus(\@f1, \@f2);

say "\@f1の残りは……";
say for @result;
say "です！";

結果は同じなので省略。

このAcme::Tools::minusの中身はこんな感じ。

sub minus {
  my %seen;
  my %notme=map{($_=>1)}@{$_[1]};
  grep !$notme{$_}&&!$seen{$_}++, @{$_[0]};
}

http://cpansearch.perl.org/src/KJETIL/Acme-Tools-0.21/Tools.pm

ちょっと略記が多いのでわかりづらいのだけど、自分が見慣れた書式に噛み砕くと……

sub minus {
    my $f1 = shift;
    my $f2 = shift;

    my %notme = map { ($_ => 1) } @{$f2};

    my %seen;
    my @result = grep { !$notme{$_} && !$seen{$_}++ } @{$f1};

    return @result;
}

といった感じか。

ちなみに、これの途中にある以下のインクリメント。

!$seen{$_}++

何度見てもこれのある意味がわからず、実際、これを取っても結果は同じなのだけど、じつは最初の配列@f1に対して、

my @f1 = qw/orange banana apple lemon/;
my @f2 = qw/orange banana/;

以下のように、同配列内の重複要素を入れてみると、結果も変わる。

my @f1 = qw/orange banana apple lemon apple/; #<= 末尾にappleを追加
my @f2 = qw/orange banana/;

先のインクリメントを入れた状態だと、これまで通りこうなるのだけど、

@f1の残りは……
apple
lemon
です！

そのインクリメントを外して以下のようにすると、

my @result = grep { !$notme{$_} } @{$f1};

結果はこうなる。

@f1の残りは……
apple
lemon
apple
です！

つまり、そのインクリメントは元になる配列（@f1）内の重複をカット（ユニーク化）してくれていた。

ということで、これについてはもう要件の問題というか、このツールを使う人がそもそもどういう結果を期待しているか？　によって要不要を判断するところだろう。

とりあえずぼくの当初の希望としては、「片方の配列からもう片方の配列と重複する要素を取り除く」ということだけを求めていて、「元の配列内に存在する重複も取り除く」ことは求めていないので、そのインクリメントなしバージョンの方が適切かもしれない。

結論としてのコード集

すでにけっこう長くなってしまったけど、もう少しコード例を挙げつつ、では結局のところ、ぼく自身は今後どういうときにどういうコードで対応していくか、というまとめ。

remove

まずはこれまで話題にしたとおり、「片方の配列からもう片方の配列と重複する要素を取り除く」ということをしたい場合には、こんな関数を使う。

sub remove {
    my $whole = shift;
    my $part = shift;

    my %remove = map { $_ => 1 } @$part;

    my @result;
    for my $element (@$whole) {
        if (! $remove{$element}) {
            push @result, $element;
        }
    }
    return @result;
}

これを以下のように呼び出すと、

my @f1 = qw/orange banana apple lemon apple/;
my @f2 = qw/orange banana/;

my @result = remove(\@f1, \@f2);
say for @result;

@f1から@f2の要素と重複する要素を取り除いたものが出てくる。

apple
lemon
apple

この際、@f1内の重複はカットしない。

crush

次に、じつはこれまでに出た要件とは別に、「とにかく重複するものは全部消してほしい」と思うこともあるので、その対策。

この場合、上記の修正前の Acme::Tools::minus でも微妙に適合していなくて、なぜなら上述のとおり、同配列の重複については最低でも1つ残してしまうから。

しかしここでの新たな要件は、たとえば以下の2つの配列があった場合、

my @f1 = qw/orange banana apple lemon apple/;
my @f2 = qw/orange banana/;

lemon以外はすべて重複しているので、

lemon

とだけ出てほしい。

で、そのためにこのような関数を作ってみた。

sub crush {
    my $x = shift;
    my $y = shift;

    my %crush;
    map { $crush{ $_ }++ } ( @$x, @$y );

    for (keys %crush) {
        if ($crush{$_} >= 2) {
            delete $crush{$_};
        }
    }

    my @result;
    for ( @$x, @$y ) {
        if ($crush{$_}) {
            push @result, $_;
        }
    }
    return @result;
}

これで以下のように実行すると、

# 以後、果物の種類を増やす

my @f1 = qw/orange banana apple grape lemon apple/;
my @f2 = qw/orange banana strawberry/;

my @result = crush(\@f1, \@f2);
say for @result;

以下のように、とにかく全体の中で重複したものは取り除いてくれる。

grape
lemon
strawberry

この際、関数内ではハッシュで処理しているので、途中で順番がめちゃくちゃになっているのだけど、用途としては関数に渡した順に返ってきたほうが便利な気もするので、最後のfor文で順番を元に戻している。

ちなみに、関数名の crush というのは、重複した果物どうしをぶつけてつぶしてしまうイメージより。ジュースになって、形が消えるというような。

uniq

ついでにもう一つ、途中で少し話題にしたけど、渡した配列全体の中から、重複した余分な分はカットしつつ、でも1つは残しておきたい場合。

これは List::MoreUtilsのuniq関数を使えば早い。

use List::MoreUtils 'uniq';

my @f1 = qw/orange banana apple grape lemon apple/;
my @f2 = qw/orange banana strawberry/;

my @result = uniq(@f1, @f2);
say for @result;

実行。

orange
banana
apple
grape
lemon
strawberry

登場した果物すべてが1つずつ残っている。

uniqはリファレンスではなく普通に配列を渡すだけなので、用途が合えば作業も手っ取り早くてよい。

まとめ・謝辞・宣伝

ということで、さすがにこれだけ対処法を作っておけば、この辺りの要望には応えやすくなるだろう。

冒頭に示した危なっかしい二重ループ＆grepの方法に比べると、コードの効率としても安心感としてもだいぶ改善したのではないか。

そして今回もまた、いつものようにPerl入学式のサポーターの皆さんには大変お世話になりました。
ぼくも一応サポーターなんですが、まだまだ教わってばかりです……。

ちなみに、Perl入学式は東京・大阪に加えて去年からスタートしたin沖縄、そして今年からはin北海道も増えて、ますます積極的に活動中です。
www.perl-entrance.org

近いところだと今週土曜にin東京の今年度前期の第2回が開催されます。
perl-entrance-tokyo.connpass.com

その翌週には大阪と沖縄、さらにその後に北海道もありますので、興味のある方はぜひご確認のほど。
perl-entrance-okinawa.connpass.com
perl-entrance-sapporo.connpass.com
perl-entrance-osaka.connpass.com

以上です。

（大阪の画像……）