perlで虫食い算を解く

http://quiz-tairiku.com/nan/q1.html

perl初心者です。
perl修行の一環として、上記URLに掲載されている虫食い算を解くperlのコードに挑戦しています。
10の変数と10のforループを使えば何とかなりそうなのですが、
これだと負荷が非常に高いコードになるため、これ以外の方法を模索しています。

何か良い案はないものでしょうか？
よろしくお願い致します。

No.8 ベストアンサー 回答者： kumoz 回答日時： 2008/05/19 13:58

前回は枝刈りを省略したコードでしたので、枝刈りを組み込んだものを紹介しておきます。

組み込んである枝刈りは、次のとおりです。
1) 0 は R または T
2) N は 9 ではない
3) N + C は 9 以下
4) M は N + C または N + C + 1 のどちらか
5) １の位の和の末尾は N
6) 桁上がりを含む 10 の位の和の末尾は O

use strict;
my ($add_alp, $ans_alp) = split /\+-+\+/, join '+', map { /([-\w]+)/; $1 } <DATA>;
my %alp_idx = (N => 0, C => 1, M => 2, A => 3, O => 4, R => 5, S => 6, T => 7, I => 8, D => 9);
my (@work, $up);
perm(0 .. 9);

sub perm {
my @list = @_;
foreach my $n (@list) {
next if !$n and (@work <= 4 or @work == 6 or @work >= 8);
next if !@work and $n == 9;
last if @work == 1 and $work[0] + $n > 9;
next if @work == 2 and !($work[0] + $work[1] == $n or $work[0] + $work[1] == $n - 1);
if (@work == 7) {
my $total = $work[4] * 2 + $work[0] * 5 + $n * 2 + $work[3] + $work[1] + $work[6] + $work[5];
next if substr($total, -1, 1) != $work[0];
$up = substr $total, 0, length($total) - 1;
}
if (@work == 8) {
my $total = $work[7] * 2 + $work[4] * 5 + $work[1] * 2 + $n * 2 + $work[3] + $work[6] + $up;
next if substr($total, -1, 1) != $work[4];
}
push @work, $n;
if (@work == 10) {
my $add_num = join('', map { /[A-T]/ ? $work[$alp_idx{$_}] : $_ } split(//, $add_alp));
my $ans_num = join('', map { $work[$alp_idx{$_}] } split(//, $ans_alp));
if ($ans_num == eval($add_num)) {
print join(' ', sort keys %alp_idx), "\n";
print "$work[$alp_idx{$_}] " foreach sort keys %alp_idx;
print "\n\n";
}
} else {
perm(grep !/$n/, @list);
}
pop @work;
}
}

__DATA__
INTO
ONTO
CANON
INTACT
AMMONIA
OMISSION
DIACRITIC
STATISTICS
ASSOCIATION
ANTIMACASSAR
CONTORTIONIST
NONDISCRIMINATION
+ CONTRADISTINCTION
-------------------
MISADMINISTRATION


kabaokaba さんへ
いつどこで見たかは思い出せないのですが、Higher-Order に関して興味深いコードがあります。
0000000000 から 9876543210 までの特殊なインクリメントを、for ループで生成するものです。
参考にしていただけましたら、幸いです。

use strict;
my @alpha = 'a' .. 'j';
my @order = (0) x @alpha; $order[-2] = -1;
my $quit = join '', reverse @alpha;
my @perm;

while (join('', @alpha) ne $quit) {
for (my $limit = 1, my $i = $#order - 1; $i >= 0; $limit++, $i--) {
if ($order[$i] < $limit) {
$order[$i]++;
@alpha[$i .. $#alpha] = sort @alpha[$i .. $#alpha];
push @alpha, splice(@alpha, $i + $_, 1) foreach @order[$i .. $#order];
push @perm, join('', @alpha);
last;
} else {
$order[$i] = 0;
}
}
}

No.7 回答者： kabaokaba 回答日時： 2008/05/16 21:37

> while (@list=$perm->()){

何をしてるんだろうか＞自分
当然ながら
while (my @list=$perm->()){
です．

粘着してますが，
whileループだけ
no strrict 'refs', 'vars';
をして，シンボリックリンクをわざと使って
ハッシュを排除すると
私の環境で半分くらいの時間(55秒ちょっと)になりました．
{
no strict 'refs', 'vars';
while (($A,$C,$D,$I,$M,$N,$O,$R,$S,$T)=$perm->()){

next if $R * $T != 0;
next if $N + $C > 10;
next if ( $O*2 + $N*4 + $T*2
+ $A + $C + $S
+ $R ) % 10 != 0;

my @numbers= map {my $num;
for my $i (split(//,$_)){
$num.=$$i;
}
$num;
} @DATA;

my $sum;
for my $i (0..$#numbers-1){
$sum+=$numbers[$i];
}

printf "A=%d, C=%d, D=%d, I=%d, M=%d, N=%d, O=%d, R=%d, S=%d, T=%d\n",
$A, $C, $D, $I, $M, $N, $O, $R, $S, $T if ($sum == $numbers[-1]);
}
}

更に，RかTの一方が0になるということで
1から9の順列を作って，それにR=0またはT=0を追加すれば
実測では半分くらい（約20秒ちょっと）くらいまでになってます．

参考程度まで．

No.6 回答者： kabaokaba 回答日時： 2008/05/15 23:41

とりあえず修正．

Rを見逃してました(苦笑)
RT=0であって，T=0とは限りませんね．

まだ無駄があると思いますが，あんまりやって
わけの分からないものになっても意味がないので
とりあえずコードを晒しておきます．
明らかな無駄は，枝刈はせずに
何はともあれ全部の順列を構成することですが，
こうしておけば汎用性の確保と
場合によっては分散もできるかなということで．
順列の生成はHighr-Order Perlのコードを使ってます．

私の環境ではこのコードで
126.03125秒で10!通りの全件チェック完了でした．
No.5さんの2秒ってのはすごいですね．

>この方法だと大変多くの時間とリソースを要すると思うのです。
時間は食いますが，
実はそれほどリソースは食いません．
再帰をしてないのでスタックは食いませんし，
変数1個と要素10個の配列一個を裏側にいれてるだけです．
あとは表にでてる計算用のもろもろ．

use strict;
use warnings;

use Time::HiRes qw( gettimeofday tv_interval );

sub permfactory{## Hiher-Order Perl by Mark Jason Dominus
my @item=@_;
my $n=0;
return sub{
$n++, return @item if $n==0;
my $i;
my $p = $n;
for ($i=1; $i<=@item && $p%$i==0; $i++){
$p = $p/$i;
}
my $d=$p%$i;
my $j = @item - $i;
return if $j<0;
@item[$j+1..$#item] = reverse @item[$j+1..$#item];
@item[$j,$j+$d] =@item[$j+$d,$j];
$n++;
return @item;
}
}

my $perm=permfactory(0..9);

my @DATA = map {chomp; $_;} <DATA>;

my $start=[gettimeofday()];

while (@list=$perm->()){
my %DIGIT
= (N => $list[0], C => $list[1], M => $list[2],
A => $list[3], O => $list[4], R => $list[5],
S => $list[6], T => $list[7], I => $list[8],
D => $list[9],
);

next if $DIGIT{'R'} * $DIGIT{'T'} != 0;
next if $DIGIT{'N'} + $DIGIT{'C'} > 10;
next if ( $DIGIT{'O'}*2 + $DIGIT{'N'}*4 + $DIGIT{'T'}*2
+ $DIGIT{'A'} + $DIGIT{'C'} + $DIGIT{'S'}
+ $DIGIT{'R'} ) % 10 != 0;


my @numbers= map {my $num;
for my $i (split(//,$_)){
$num.=$DIGIT{$i};
}
$num;
} @DATA;

my $sum;
for my $i (0..$#numbers-1){
$sum+=$numbers[$i];
}

printf "A=%d, C=%d, D=%d, I=%d, M=%d, N=%d, O=%d, R=%d, S=%d, T=%d\n",
$DIGIT{'A'}, $DIGIT{'C'}, $DIGIT{'D'},
$DIGIT{'I'}, $DIGIT{'M'}, $DIGIT{'N'}, $DIGIT{'O'},
$DIGIT{'R'}, $DIGIT{'S'}, $DIGIT{'T'} if ($sum == $numbers[-1]);

}
my $end=[gettimeofday()];
print tv_interval ($start,$end);

__DATA__
INTO
ONTO
CANON
INTACT
AMMONIA
OMISSION
DIACRITIC
STATISTICS
ASSOCIATION
ANTIMACASSAR
CONTORTIONIST
NONDISCRIMINATION
CONTRADISTINCTION
MISADMINISTRATION

No.5 回答者： kumoz 回答日時： 2008/05/12 19:11

まずは、汎用的な順列生成プログラムを作るのがよいと思います。

次のプログラムは、再帰呼び出しを使った簡単な順列生成プログラムです。
0 から 3 までの４文字の順列を生成します。コメントに記してあるところ
２個所を直すと 10 文字の順列を生成するようになります。

use strict;
my @work;
perm(0 .. 3); # 3 --> 9

sub perm {
my @list = @_;
foreach my $n (@list) {
push @work, $n;
if (@work == 4) { # 4 --> 10
print @work, "\n";
# print 文に代えて、ここでチェックをする
} else {
perm(grep !/$n/, @list);
}
pop @work;
}
}

次のプログラムは、上のコードに今回のパズルの問題を組み込んだものです。
なお、%alp_idx は各アルファベットが @work の何番目に割り当てられている
かを表すハッシュです。

use strict;
my ($add_alp, $ans_alp) = split /\+-+\+/, join '+', map { /([-\w]+)/; $1 } <DATA>;
my %alp_idx = (N => 0, C => 1, M => 2, A => 3, O => 4, R => 5, S => 6, T => 7, I => 8, D => 9);
my @work;
perm(0 .. 9);

sub perm {
my @list = @_;
foreach my $n (@list) {
# ここに、枝刈りを組み込む
push @work, $n;
if (@work == 10) {
my $add_num = join('', map { /[A-T]/ ? $work[$alp_idx{$_}] : $_ } split(//, $add_alp));
my $ans_num = join('', map { $work[$alp_idx{$_}] } split(//, $ans_alp));
if ($add_num !~ /\+0/ and $ans_num == eval($add_num)) {
print join(' ', sort keys %alp_idx), "\n";
print "$work[$alp_idx{$_}] " foreach sort keys %alp_idx;
print "\n\n";
}
} else {
perm(grep !/$n/, @list);
}
pop @work;
}
}

__DATA__
INTO
ONTO
CANON
INTACT
AMMONIA
OMISSION
DIACRITIC
STATISTICS
ASSOCIATION
ANTIMACASSAR
CONTORTIONIST
NONDISCRIMINATION
+ CONTRADISTINCTION
-------------------
MISADMINISTRATION

上のプログラムは生成された順列 3,628,800 を総当たりでチェックしているので、
私のパソコンで 993 秒かかりました。適切な枝刈りを組み入れることで、2 秒位で
実行が完了するようになります。枝刈りを組み込む場合、@work の要素数が判断材
料になります。

この回答へのお礼

kumozさん

ご回答どうもありがとうございました。
上記コードだと大変負荷が高くなりそうですが、
perlの勉強という意味では大変有意義なコードです。
所々見たことのない関数/関数の使い方があるため、勉強になります。
今からgoogleを左に、上記コードを右のディスプレイに収めながら格闘してみます。

お礼日時：2008/05/13 06:26

No.4 回答者： kabaokaba 回答日時： 2008/05/08 12:18

コンピュータのアルゴリズムとしては

問題に過度に依存させずに
総当りで計算させるのが筋だと思う．
まずは何でもいいから汎用的なものを書いて答えを知って，
それから最適化とか負荷軽減かな

私がやるなら
(1) 呼び出すたびに0..9までの並び替えを順番に出す関数を作る
（全部出しきったら undef を返す）
=> perm とでもする
並び替えはリストのレファレンスでかえす
(2) whileで回す
while ($list=perm){
足し算のチェック
正解が出たら記録する
}

計算回数を減らしたければ、この問題は
T=0となることは最高位の数字に注目すれば自明だから
これで1/10になりますね

この回答へのお礼

kabaokabaさん

ご回答どうもありがとうございました。
kabaokabaさんの仰る方法が正攻法かと思うのですが、
この方法だと大変多くの時間とリソースを要すると思うのです。
その問題に対する最適化、負荷軽減技術を教えていただきたいと思っておりました。

お礼日時：2008/05/13 06:23

No.3 回答者： mtaka2 回答日時： 2008/05/08 11:09

虫食い算は下の桁から順番に計算するのが基本ですね。

1)最下位の桁だけに注目し、まず
「O+O+N+T+A+N+C+S+N+R+T+N+N = 下一桁がN」になる
O,N,T,A,C,S,Rを求めます。

式変形(両辺からNを引く)と「O+O+N+T+A+N+C+S+N+R+T+Nが10の倍数かどうか」になるので、O,N,T,A,C,Sを割り当てれば、Rは自動的に求まります。
6変数のループで7変数が出ます。

このチェックは、虫食いを割り当てた数値文字列を求めなくても、
単なる足し算だけでチェックできるので、負荷は軽いと思います。

2)下二桁について見て、
「TO+TO+ON+CT+IA+ON+IC+CS+ON+A+R+ST+ON+ON=下二桁がON」になる
かどうかチェック
これは、1)での結果を踏まえると、10の位だけを見ればよくて、
「T+T+O+C+I+O+I+C+O+A+S+O+(step1の足し算結果を10で割った値)が
10の倍数かどうか」
になります。
ここで新たに増える文字はありません。

3)下三桁について見て、
「NTO+NTO+NON+ACT+…+ION=ION」になるか
新たに文字「I」が増えますが、1)・2)と同様の式変形により、
それ以外の7文字からIが自動的に求まります。
Iについてのループは要りません。

4)下4桁について見て、以下略

とやっていけばいいんじゃないでしょうか。
3)以降は、残りは「IMD」3文字しかありませんし、3文字分で全数式が合うかどうかでループさせた方が速いかもしれません。

あとは、最上位桁に使われている「IOCADSNM」は0ではありえません。となると、残りの「RT」はどちらかが0なので、1)のループ時点で枝狩りできます。

この回答へのお礼

mtaka2さん

ご回答ありがとうございました。
mtaka2さんの方法ならば8桁+7桁+6桁…の足し算よりも遥かに効率良く計算できそうです。
この方法で上手く行ったならば報告致します。

お礼日時：2008/05/13 06:06

No.2 回答者： noname#58606 回答日時： 2008/05/08 00:40

めんどちー、ですねー。

プログラムは素人ながら、作るけど、数学には、疎いので、確実な回答法が分からなかったので。
こういうのって、回答は一つなのかな？
問題を作るのって、簡単なのかな？と思ったので。

例えば、
　ＡＣ
＋ＦＣ
------
　ＣＤ

は、
Ａ＝３、Ｃ＝５、Ｄ＝０、Ｆ＝１でも、
Ａ＝２、Ｃ＝３、Ｄ＝６、Ｆ＝３でも、いけるかな？

a～ｚまで回答してもらって、アルファベットの配列で、うんにゃらまんにゃらで、できないかな。
その回答のアルファベットで、問題と解答を変換して、イコールなら、正解。
問題に出てこないアルファベットは、非表示にしたりして。

分かるかな？
問題を作成して回答をだしてから、ランダムで、その数値に、アルファベットを割り当て、出力。
そして、入力回答したアルファベットから、再度問題と解答を、計算する。
足し算の合計と、回答を照らし合わせるのではない。
回答したアルファベットから、再度、割り当てて、計算するのが、ポイント。

なぜ、こんな事を考えたかというと・・・。

利点としては、
◆問題作成が、誰でも作成でき、楽ちん。
普通に数値を配列とかをつかって、変換すれば、問題と解答が簡単にできる。
簡単にできるって事は、毎回、問題を変えることが出来る。
回答の秒数とか、保存出来れば、コンテンツにもなるし。

◆予想外の回答にも対応出来る。
問題と答えを作ってから、文字に変換するので、少なくとも、一つ回答がある。
また、上のような数を変えても、成立する場合に、強い。

◆配列を使うので、ちと早いかも。
あとはそれぞれの数値のデータの持たせ方だと、思うが・・・、うまく頭が働いてないなー。（苦笑

まぁ、思いっきり例題とは、違うので、お礼とかポイントとかは、いらないです。

この回答へのお礼

noname#58606さん

ご回答どうもありがとうございました。
ご指摘いただいた逆算出の方法も試してみたのですが、
上手いこといきませんでした。
配列の基本操作から勉強しなおして再度チャレンジしてみようと思います。

お礼日時：2008/05/10 22:56

No.1 回答者： moon_piyo 回答日時： 2008/05/07 23:52

10個のforですけど

どうでしょう...

chomp($exp = join("", <DATA>));
$exp =~ s/\n/+/g;

@data = (0..9);
@used[@data] = (0)x@data;
foreach $n (grep $used[$_]==0 && $_, @data) {
local($used[$n])=1;
foreach $c (grep $used[$_]==0 && $_, @data) {
local($used[$c])=1;
foreach $m (grep $used[$_]==0 && $_, @data) {
next unless ($m == $n + $c || $m == $n + $c + 1);
local($used[$m])=1;
foreach $a (grep $used[$_]==0 && $_, @data) {
local($used[$a])=1;
foreach $d (grep $used[$_]==0 && $_, @data) {
local($used[$d])=1;
foreach $i (grep $used[$_]==0 && $_, @data) {
local($used[$i])=1;
foreach $o (grep $used[$_]==0 && $_, @data) {
local($used[$o])=1;
foreach $r (grep $used[$_]==0, @data) {
local($used[$r])=1;
foreach $s (grep $used[$_]==0 && $_, @data) {
local($used[$s])=1;
foreach $t (grep $used[$_]==0, @data) {
eval "(\$e=\$exp) =~ tr/ACDIMNORST/".join("", $a, $c, $d, $i, $m, $n, $o, $r, $s, $t)."/";
next if (eval $e);
print "A:$a C:$c D:$d I:$i M:$m N:$n O:$o R:$r S:$s T:$t\n";
}}}}}}}}}}
<STDIN>;
__DATA__
INTO
ONTO
CANON
INTACT
AMMONIA
OMISSION
DIACRITIC
STATISTICS
ASSOCIATION
ANTIMACASSAR
CONTORTIONIST
NONDISCRIMINATION
CONTRADISTINCTION
- MISADMINISTRATION

この回答へのお礼

moon_piyoさん

ご回答ありがとうございました。
上記のコードをそのまま実行したところ見事に正しい答えが表示されました。
コードの中の知らないコマンド、書式を調べました。
　→大変勉強になりました。

どうもありがとうございました。
今後もどうぞよろしくお願い致します。

お礼日時：2008/05/10 22:53