[Perl]解数独题
本帖最后由 523066680 于 2017-09-16 18:27 编辑题库来源：免费的在线数独
抓题脚本：多线程批量下载数独题库
打包：
http://523066680.ys168.com/
Perl/数独/数独题库200801-201709_含答案.zip
资料：
rosettacode 网站上有各种语言的解数独程序，其中的perl示例特别精简，但是有很大优化空间。
http://rosettacode.org/wiki/Sudoku#Perl 本帖最后由 523066680 于 2017-09-16 18:56 编辑
初始方案，先提取所有空缺单元坐标，在递归层中挨个填入并在下一层填入时根据更新的矩阵缩小可选数字范围。
跑完 sudoku_nd0.txt 三千多道题 6 秒，但是跑 nd1-nd4 就很慢了。
有时间继续尝试 Dancing Links 算法
=info
解数独 初版
523066680 2017-09
=cut
use warnings;
use IO::Handle;
use File::Slurp;
use Time::HiRes qw/time/;
STDOUT->autoflush(1);
my @games;
my $gamedata = eval read_file("sudoku_nd0.txt");
grep { push @games, $gamedata->{$_} } sort keys %$gamedata;
#题目挑选
#@games = @games;
our @unsolve;
our $block = [];#区块引用
my $mat = [[]];
my $index = 0;
my $time_a;
#创建区块引用
make_block_refs( $block, $mat );
while ( $index <= $#games )
{
#字符串转矩阵
str_to_mat( $games[$index] , $mat );
$time_a = time();
#设置 @unsolve 数组，存储空缺元素的坐标
set_unsolve_array($mat);
solve($mat, 0, 0);
print_mat($mat);
printf "Game index: %d, time used: %.3fs\n\n", $index, time() - $time_a;
$index++;
}
sub solve
{
my ($mat, $prev, $lv) = @_;
my @possible;
my ($row, $col);
my $current;
for my $i ( $prev .. $#unsolve )
{
($row, $col) = @{$unsolve[$i]};
if ( $mat->[$row][$col] == 0 )
{
$current = $i;
@possible = get_possible_num( $mat, $row, $col );
last;
}
}
if ( not defined $current ) { return 1 }
else
{
return 0 if ( $#possible < 0 )
}
my $res = 0;
for my $p ( @possible )
{
$mat->[ $row ][ $col ] = $p;
$res = solve($mat, $current+1, $lv+1);
last if ($res == 1);
}
#使对应单元恢复为0 否则影响递归判断
$mat->[$row][$col] = 0 if ($res == 0) ;
return $res;
}
sub get_possible_num
{
our $block;
my ($mat, $row, $col) = @_;
my @possible = (0,1,2,3,4,5,6,7,8,9);
#区块坐标
my $blockrow = int($row/3);
my $blockcol = int($col/3);
#排除元素
for my $n ( 0 .. 8 )
{
$possible[ $mat->[$n][$col] ] = 0;
$possible[ $mat->[$row][$n] ] = 0;
$possible[ ${$block->[$blockrow][$blockcol][$n]} ] = 0;
}
return grep { $_ } @possible;
}
sub set_unsolve_array
{
our ( @unsolve );
my ($mat) = @_;
@unsolve = ();
for my $row ( 0..8 )
{
for my $col ( 0..8 )
{
if ( $mat->[$row][$col] == 0 )
{
push @unsolve, [ $row, $col, ];
}
}
}
#根据可选数字的数量由少到多排序
@unsolve = sort { $#{$a->} <=> $#{$b->} } @unsolve;
}
sub make_block_refs
{
my ($block, $mat) = @_;
#将数独的九个宫对应的引用分组保存
for my $r ( 0..2 )
{
for my $c ( 0..2 )
{
for my $rr ( $r*3 .. $r*3+2 )
{
for my $cc ( $c*3 .. $c*3+2 )
{
push @{ $block->[$r][$c] }, \$mat->[$rr][$cc];
}
}
}
}
}
sub str_to_mat
{
my ( $str, $mat ) = @_;
my $idx = 0;
for my $row ( 0 .. 8 )
{
for my $col ( 0 .. 8 )
{
$mat->[$row][$col] = substr( $str, $idx++, 1 );
}
}
}
sub print_mat
{
my ($mat) = @_;
grep { print join(",", @{$mat->[$_]} ),"\n" } ( 0..8 );
}
for test: SLOW!! :mrgreen:
my $sudo3 = [
[ 8, 0, 0, 0, 0, 0, 0, 0, 0 ],
[ 0, 0, 3, 6, 0, 0, 0, 0, 0 ],
[ 0, 7, 0, 0, 9, 0, 2, 0, 0 ],
[ 0, 5, 0, 0, 0, 7, 0, 0, 0 ],
[ 0, 0, 0, 0, 4, 5, 7, 0, 0 ],
[ 0, 0, 0, 1, 0, 0, 0, 3, 0 ],
[ 0, 0, 1, 0, 0, 0, 0, 6, 8 ],
[ 0, 0, 8, 5, 0, 0, 0, 1, 0 ],
[ 0, 9, 0, 0, 0, 0, 4, 0, 0 ],
];
my $sudo4 = [
[ 0, 0, 5, 3, 0, 0, 0, 0, 0 ],
[ 8, 0, 0, 0, 0, 0, 0, 2, 0 ],
[ 0, 7, 0, 0, 1, 0, 5, 0, 0 ],
[ 4, 0, 0, 0, 0, 5, 3, 0, 0 ],
[ 0, 1, 0, 0, 7, 0, 0, 0, 6 ],
[ 0, 0, 3, 2, 0, 0, 0, 8, 0 ],
[ 0, 6, 0, 5, 0, 0, 0, 0, 9 ],
[ 0, 0, 4, 0, 0, 0, 0, 3, 0 ],
[ 0, 0, 0, 0, 0, 9, 7, 0, 0 ],
];
my $sudo5 = [
[ 9, 8, 0, 7, 0, 0, 6, 0, 0 ],
[ 7, 0, 0, 0, 0, 0, 0, 8, 0 ],
[ 0, 0, 6, 0, 5, 0, 0, 0, 0 ],
[ 4, 0, 0, 0, 0, 3, 0, 0, 0 ],
[ 0, 0, 8, 9, 0, 0, 0, 7, 0 ],
[ 0, 0, 0, 0, 2, 0, 3, 0, 0 ],
[ 0, 1, 0, 0, 0, 0, 2, 0, 0 ],
[ 0, 0, 7, 5, 0, 0, 0, 6, 0 ],
[ 0, 0, 0, 0, 0, 1, 0, 5, 4 ],
];
my $sudo6 = [
[ 9, 8, 0, 7, 0, 0, 6, 0, 0 ],
[ 5, 0, 0, 0, 9, 0, 0, 7, 0 ],
[ 0, 0, 7, 0, 0, 4, 0, 0, 0 ],
[ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
[ 0, 0, 8, 5, 0, 0, 0, 6, 0 ],
[ 0, 0, 0, 0, 0, 0, 3, 0, 2 ],
[ 0, 1, 0, 0, 0, 0, 0, 0, 0 ],
[ 0, 0, 5, 4, 0, 0, 0, 8, 0 ],
[ 0, 0, 0, 0, 2, 1, 9, 0, 0 ],
];
my $sudo7 = [
[ 0, 0, 7, 0, 9, 0, 0, 0, 2 ],
[ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
[ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
[ 0, 0, 5, 7, 0, 0, 0, 0, 0 ],
[ 0, 0, 0, 5, 4, 0, 0, 0, 7 ],
[ 0, 0, 0, 0, 0, 1, 3, 0, 0 ],
[ 0, 0, 9, 0, 0, 0, 0, 0, 4 ],
[ 8, 0, 0, 0, 0, 5, 1, 0, 0 ],
[ 1, 0, 0, 0, 0, 0, 6, 8, 0 ],
];
my $sudo8 = [
[ 0, 9, 0, 0, 0, 0, 0, 0, 4 ],
[ 1, 0, 0, 0, 0, 0, 8, 6, 0 ],
[ 8, 0, 0, 0, 0, 5, 0, 1, 0 ],
[ 0, 0, 0, 0, 0, 1, 0, 3, 0 ],
[ 0, 0, 0, 5, 4, 0, 0, 0, 7 ],
[ 0, 5, 0, 7, 0, 0, 0, 0, 0 ],
[ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
[ 0, 7, 0, 0, 9, 0, 0, 0, 2 ],
[ 0, 0, 8, 0, 0, 0, 0, 0, 0 ],
];
my $sudo9 = [
[ 0, 0, 0, 0, 0, 0, 8, 0, 0 ],
[ 0, 0, 2, 0, 7, 0, 0, 4, 0 ],
[ 0, 0, 0, 3, 0, 0, 6, 0, 1 ],
[ 6, 0, 0, 1, 0, 0, 0, 0, 5 ],
[ 0, 0, 9, 0, 4, 0, 0, 0, 0 ],
[ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
[ 0, 0, 7, 0, 0, 5, 0, 9, 0 ],
[ 3, 0, 0, 0, 0, 0, 1, 0, 8 ],
[ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
];
my $sudo10 = [
[ 0, 1, 6, 3, 0, 0, 0, 0, 0 ],
[ 0, 0, 8, 0, 0, 0, 0, 0, 0 ],
[ 4, 0, 0, 0, 7, 0, 2, 0, 0 ],
[ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
[ 0, 0, 0, 0, 4, 0, 9, 0, 0 ],
[ 0, 5, 0, 1, 0, 0, 0, 6, 0 ],
[ 0, 8, 1, 0, 0, 0, 0, 3, 0 ],
[ 0, 0, 0, 0, 0, 0, 0, 0, 8 ],
[ 9, 0, 0, 0, 0, 5, 7, 0, 0 ],
];
my $sudo11 = [
[ 8, 0, 0, 5, 0, 0, 1, 0, 0 ],
[ 0, 0, 9, 0, 0, 0, 0, 0, 4 ],
[ 1, 0, 0, 0, 0, 0, 6, 8, 0 ],
[ 0, 0, 5, 0, 0, 7, 0, 0, 0 ],
[ 0, 0, 0, 0, 4, 5, 0, 0, 7 ],
[ 0, 0, 0, 1, 0, 0, 3, 0, 0 ],
[ 0, 0, 7, 0, 9, 0, 0, 0, 2 ],
[ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
[ 3, 0, 0, 6, 0, 0, 0, 0, 0 ],
];
本帖最后由 rubyish 于 2017-09-18 23:39 编辑
play $sudo9:
v1: time 0m0.585s
5 9 34 1 68 2 7
1 6 25 7 83 4 9
7 4 83 2 96 5 1
6 7 41 8 29 3 5
8 5 96 4 37 1 2
2 3 19 5 74 8 6
4 1 78 6 52 9 3
3 2 57 9 41 6 8
9 8 62 3 15 7 4
real 0m0.585s
v2:
sudo9: time 0m0.538s
5 9 34 1 68 2 7
1 6 25 7 83 4 9
7 4 83 2 96 5 1
6 7 41 8 29 3 5
8 5 96 4 37 1 2
2 3 19 5 74 8 6
4 1 78 6 52 9 3
3 2 57 9 41 6 8
9 8 62 3 15 7 4
real 0m0.538s
user 0m0.528s
sys 0m0.007s
#!/usr/bin/perl
# version 26, subversion 0 (v5.26.0)
use 5.010;
sub ERROR(){ 0b1111111110 }
sub FINISH() { 0 }
sub BEST() { 1 }
sub MIN() { 10 }
my ( @VERTI, @HORIS, @BLOKE, @MAYBE, @HOVER );
my ( @GIMME, $DIT, $DAT, $LOST );
my $sudo1 = [ # 0.030s
[ 0, 0, 0, 0, 0, 0, 0, 9, 0 ],
[ 1, 9, 0, 4, 7, 0, 6, 0, 8 ],
[ 0, 5, 2, 8, 1, 9, 4, 0, 7 ],
[ 2, 0, 0, 0, 4, 8, 0, 0, 0 ],
[ 0, 0, 9, 0, 0, 0, 5, 0, 0 ],
[ 0, 0, 0, 7, 5, 0, 0, 0, 9 ],
[ 9, 0, 7, 3, 6, 4, 1, 8, 0 ],
[ 5, 0, 6, 0, 8, 1, 0, 7, 4 ],
[ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
];
my $sudo3 = [ # 0.620s
[ 8, 0, 0, 0, 0, 0, 0, 0, 0 ],
[ 0, 0, 3, 6, 0, 0, 0, 0, 0 ],
[ 0, 7, 0, 0, 9, 0, 2, 0, 0 ],
[ 0, 5, 0, 0, 0, 7, 0, 0, 0 ],
[ 0, 0, 0, 0, 4, 5, 7, 0, 0 ],
[ 0, 0, 0, 1, 0, 0, 0, 3, 0 ],
[ 0, 0, 1, 0, 0, 0, 0, 6, 8 ],
[ 0, 0, 8, 5, 0, 0, 0, 1, 0 ],
[ 0, 9, 0, 0, 0, 0, 4, 0, 0 ],
];
my $sudo9 = [ # 0.536s
[ 0, 0, 0, 0, 0, 0, 8, 0, 0 ],
[ 0, 0, 2, 0, 7, 0, 0, 4, 0 ],
[ 0, 0, 0, 3, 0, 0, 6, 0, 1 ],
[ 6, 0, 0, 1, 0, 0, 0, 0, 5 ],
[ 0, 0, 9, 0, 4, 0, 0, 0, 0 ],
[ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
[ 0, 0, 7, 0, 0, 5, 0, 9, 0 ],
[ 3, 0, 0, 0, 0, 0, 1, 0, 8 ],
[ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
];
init();
play($sudo9); # for 1 .. 10;
# play($sudo3);
# ____________________SUB____________________
sub init {
for my $i ( 0 .. 8 ) {
my $i3 = 3 * int( $i / 3 );
for my $j ( 0 .. 8 ) {
$HOVER[$i][$j] = int( $j / 3 ) + $i3;
}
}
for ( my $n = 0 ; $n < ERROR ; $n += 2 ) {
for my $i ( 1 .. 9 ) {
next if $n & 1 << $i;
push @{ $MAYBE[$n] }, $i;
}
}
}
sub play {
my $sudo = shift;
@VERTI = @HORIS = @BLOKE = (0) x 9;
@GIMME = ();
$DIT = 0;
for my $i ( 0 .. 8 ) {
for my $j ( 0 .. 8 ) {
my $k = $HOVER[$i][$j];
if ( !$sudo->[$i][$j] ) {
push @GIMME, [ $i, $j, $k ];
next;
}
$VERTI[$j] |= 1 << $sudo->[$i][$j];
$HORIS[$i] |= 1 << $sudo->[$i][$j];
$BLOKE[$k] |= 1 << $sudo->[$i][$j];
}
}
$LOST = @GIMME + 1;
$DAT= $#GIMME;
explore($sudo);
}
sub best {
my ( $min, $best, $posi ) = ( MIN, FINISH, $DAT );
for my $that ( $DIT .. $DAT ) {
my ( $i, $j, $k ) = @{ $GIMME[$that] };
my $this = $HORIS[$i] | $VERTI[$j] | $BLOKE[$k];
return ERROR if $this == ERROR;
my $maybe = @{ $MAYBE[$this] };
if ( $min > $maybe ) {
$posi = $that;
$best = $this;
last if $maybe == BEST;
$min = $maybe;
}
}
@GIMME[ $DIT, $posi ] = @GIMME[ $posi, $DIT ];
$DIT++;
return $best;
}
sub explore {
my $sudo = shift;
return if $DIT == $LOST;
my $this = best();
return if $this == ERROR;
echo($sudo) if $this == FINISH;
my ( $i, $j, $k ) = @{ $GIMME[ $DIT - 1 ] };
for my $n ( @{ $MAYBE[$this] } ) {
my $that = 1 << $n;
$sudo->[$i][$j] = $n;
$HORIS[$i] |= $that;
$VERTI[$j] |= $that;
$BLOKE[$k] |= $that;
explore($sudo);
$HORIS[$i] ^= $that;
$VERTI[$j] ^= $that;
$BLOKE[$k] ^= $that;
}
$sudo->[$i][$j] = 0;
$DIT--;
}
sub echo {
my ( $sudo, $i ) = @_;
for my $A (@$sudo) {
say '' if !( $i++ % 3 );
say " @$A@$A@$A";
}
}
__DATA__
$_
回复 1# 523066680
看了网站上精简解法...
看看过程(在楼下)......
http://rosettacode.org/wiki/Sudoku#Perl
#!/usr/bin/perl
use integer;
use strict;
my @A = qw(
5 3 00 2 47 0 0
0 0 20 0 08 0 0
1 0 07 0 39 0 2
0 0 80 7 20 4 9
0 2 09 8 00 7 0
7 9 00 0 00 8 0
0 0 00 3 05 0 6
9 6 00 1 03 0 0
0 5 06 9 00 1 0
);
sub solve {
my $i;
foreach $i ( 0 .. 80 ) {
next if $A[$i];
my %t = map {
$_ / 9 == $i / 9 ||
$_ % 9 == $i % 9 ||
$_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
? $A[$_] : 0,
1;
} 0 .. 80;
solve( $A[$i] = $_ ) for grep !$t{$_}, 1 .. 9;
return $A[$i] = 0;
}
$i = 0;
foreach (@A) {
print "-----+-----+-----\n" if !($i%27) && $i;
print !($i%9) ? '': $i%3 ? ' ' : '|', $_;
print "\n" unless ++$i%9;
}
}
solve(); 重点在这....
my %t = map {
$_ / 9 == $i / 9 ||
$_ % 9 == $i % 9 ||
$_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
? $A[$_] : 0,
1;
} 0 .. 80;
一开始,理解不出来...
后来直接打印 %t
找到 数独解 过程...
数组
...
5 3 00 2 47 0 0
0 0 20 0 08 0 0
1 0 07 0 39 0 2
0 0 80 7 20 4 9
0 2 09 8 00 7 0
7 9 00 0 00 8 0
0 0 00 3 05 0 6
9 6 00 1 03 0 0
0 5 06 9 00 1 0
------------------------------------------------------
解题过程...
1.在数组中(@A)找出为0（非1〜9数字）
2.依 所在点 收集已经填入数字(%t)
3. 把可填入数字依序填入
1.在数组中(@A)找出为0（非1〜9数字）
foreach $i ( 0 .. 80 ) {
next if $A[$i];
上例: $i 为2
2.依 所在点 收集已经填入数字(%t)
my %t = map {
$_ / 9 == $i / 9 ||
$_ % 9 == $i % 9 ||
$_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
? $A[$_] : 0,
1;
} 0 .. 80;
上例结果:0,1,2,3,4,5,7,8
3. 把可填入数字依序填入(上例结果:6,9)solve( $A[$i] = $_ ) for grep !$t{$_}, 1 .. 9;
提高 %t 收集 方法...
$ cat sdk_net.pl
#!/usr/bin/perl
use integer;
use strict;
my @A = qw(
5 3 00 2 47 0 0
0 0 20 0 08 0 0
1 0 07 0 39 0 2
0 0 80 7 20 4 9
0 2 09 8 00 7 0
7 9 00 0 00 8 0
0 0 00 3 05 0 6
9 6 00 1 03 0 0
0 5 06 9 00 1 0
);
my $sCnt = 0;
sub solve {
my $n;
foreach $n ( 0 .. 80 ) {
next if $A[$n];
my %t = map {
$_ / 9 == $n / 9 ||
$_ % 9 == $n % 9 ||
$_ / 27 == $n / 27 && $_ % 9 / 3 == $n % 9 / 3
? $A[$_] : 0,
1;
} 0 .. 80;
++$sCnt;
solve( $A[$n] = $_ ) for grep !$t{$_}, 1 .. 9;
return $A[$n] = 0;
}
print_sudoku(@A);
}
sub print_sudoku{
my (@A) = @_;
my $n = 0;
foreach (@A) {
print "-----+-----+-----\n" if !($n%27) && $n;
print !($n%9) ? '': $n%3 ? ' ' : '|', $_;
print "\n" unless ++$n%9;
}
print "-----+-----+-----\n";
}
solve();
print STDERR "Total count: $sCnt\n";
$ diff sdk.pl sdk_net.pl
20,32d19
< my(@aRow, @aCol, @aSqu);
<
< foreach my $n ( 0 .. 80 ) {
< my $sRow = $n/9;
< my $sCol = $n%9;
< my $sSqu = ($n/27)*3+($n/3)%3;
<
< push @{$aRow[$sRow]}, $n;
< push @{$aCol[$sCol]}, $n;
< push @{$aSqu[$sSqu]}, $n;
< }
<
<
37,41c24,30
< my $sRow = $n/9;
< my $sCol = $n%9;
< my $sSqu = ($n/27)*3+($n/3)%3;
< my %t = map{ $A[$_]=>1 } grep{ $A[$_] }
< @{$aRow[$sRow]}, @{$aCol[$sCol]}, @{$aSqu[$sSqu]};
---
> my %t = map {
> $_ / 9 == $n / 9 ||
> $_ % 9 == $n % 9 ||
> $_ / 27 == $n / 27 && $_ % 9 / 3 == $n % 9 / 3
> ? $A[$_] : 0,
> 1;
> } 0 .. 80;
本帖最后由 523066680 于 2017-09-18 12:46 编辑
回复 6# jason680
这个程序仔细看过，遇到数独网站难度1到难度4的某些题目，解题效率会非常慢。
一点优化：
搜索空缺单元每次都是从下标0开始的，虽然用了 next if $A[$i] 跳过不必处理的单元。
可以改为在调用函数时传入位置信息。进一步地，可以在一开始就把所有空缺单元的索引存储到列表中
use integer;
use strict;
my @A = qw(
1 4 0 9 6 8 0 0 0
0 0 0 0 0 0 9 0 0
6 0 0 0 5 7 3 0 0
0 0 0 0 0 0 0 0 7
3 0 0 0 0 0 8 4 0
0 0 0 1 9 6 5 0 0
0 7 0 0 0 0 4 0 5
4 0 6 0 1 0 0 3 0
0 0 0 0 0 0 0 0 0
);
our @unsolve = grep { ! $A[$_] } ( 0 .. $#A );
solve(0);
sub solve
{
my ( $prev ) = @_;
my $i;
for my $index ( $prev .. $#unsolve )
{
$i = $unsolve[$index];
my %t =
map {
($_ / 9 == $i / 9 ||
$_ % 9 == $i % 9 ||
$_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
? $A[$_] : 0 ), 1;
}
0 .. 80;
for (grep !$t{$_}, 1 .. 9)
{
$A[$i] = $_;
solve( $prev+1 );
}
return $A[$i] = 0;
}
$i = 0;
for ( @A )
{
print "-----+-----+-----\n" if !( $i % 27 ) && $i;
print !($i%9) ? '': $i%3 ? ' ' : '|', $_;
print "\n" unless ++$i%9;
}
print "\n";
}
在我的电脑上跑这道题 140968000000000900600057300000000007300000840000196500070000405406010030000000000
会有零点几秒的差异。
我在2楼的代码方案与此类似，不过各个过程都用函数独立出来了，以及 unsolve 数组的顺序是根据可选数字的量进行排序，从选项更少的单元开始。
在某些情况下会快很多。
sub set_unsolve_array
{
our ( @unsolve );
my ($mat) = @_;
@unsolve = ();
for my $row ( 0..8 ) {
for my $col ( 0..8 ) {
if ( $mat->[$row][$col] == 0 )
{
push @unsolve, [ $row, $col, ];
}
}
}
#根据可选数字的量由少到多排序
@unsolve = sort { $#{$a->} <=> $#{$b->} } @unsolve;
}
Rubyish 的代码则快得多，跑完 sudoku_nd0.txt 只要零点几秒，跑完 nd2/nd3/nd4 需要一百多秒（已经完爆RosettaCode的Perl代码以及我二楼的代码）。
本帖最后由 523066680 于 2017-09-18 14:37 编辑
最近换了个方案，遇到难度高的题目时比原来的方案快得多（还是没有Rubyish的代码快啊~）。
给定一个题目，判断 1-9 每个数字的全局分布情况（可能性）。
比如1可能分布的情况有6种，测试每一种，把9个1全部填入数独，然后继续测试其他数字的分布。
题目
140968000000000900600057300000000007300000840000196500070000405406010030000000000
数字1的可能分布情况
140968000000001900600057310010000007300000841000196500071000405406010030000000100
140968000000001900600057310000000107310000840000196500071000405406010030000000001
140968000000001900600057301000000107310000840000196500071000405406010030000000010
140968000000001900600057301000000107310000840000196500070000415406010030001000000
140968000000001900600057301000000107301000840000196500070000415406010030010000000
140968000000001900600057301000000017310000840000196500071000405406010030000000100
完整代码：
=info
523066680 2017-09
=cut
use File::Slurp;
use IO::Handle;
STDOUT->autoflush(1);
# my $gamedata = eval read_file("../sudoku_nd1.txt");
# grep { push @games, $gamedata->{$_} } sort keys %$gamedata;
@games = ("140968000000000900600057300000000007300000840000196500070000405406010030000000000");
our @order;
our $answer_mat = [[]];
my $mat;
my $res;
my $allcase;
my $answer_str;
#坐标对应区块位置的表
our @blk = map { int($_ / 3) } ( 0..8 );
while ( $index <= $#games )
{
$mat = [[]];
$time_a = time();
str_to_mat( $games[$index] , $mat );
$allcase = [ map { [] } (0..9) ];
grep { possible_mat($mat, $_, $allcase->[$_], 0) } (1..9);
@order = sort { $#{$allcase->[$a]} <=> $#{$allcase->[$b]} } ( 0 .. 9 );
$res = recursive( $mat, 1 ); #起点为1，下标 0占位
if ($res == 1)
{
print_mat( $answer_mat );
}
else { die "false\n" }
printf "Game index: %d, time used: %.3fs\n\n", $index, time() - $time_a;
$index++;
}
sub recursive
{
our (@order, $answer_mat);
my ( $mat, $lv ) = @_;
my @case;
if ( $lv > 9 )
{
$answer_mat = $mat;
return 1;
}
$target = $order[$lv];
possible_mat($mat, $target, \@case, 0);
my $t_mat = [[]];
my $res = 0;
for my $s ( @case )
{
str_to_mat( $s, $t_mat );
$res = recursive( $t_mat, $lv+1 );
last if ($res == 1);
}
return $res;
}
sub possible_mat
{
my ( $mat, $target, $aref, $lv ) = @_;
# level means row
my $str;
if ($lv == 9)
{
$count++;
push @$aref, mat_to_str($mat);
return 1;
}
my @cols = get_possible_column( $mat, $lv, $target );
my $res = 0;
my $ever;
for my $c ( @cols )
{
$ever = $mat->[$lv][$c];
$mat->[$lv][$c] = $target;
$res = possible_mat( $mat, $target, $aref, $lv+1 );
$mat->[$lv][$c] = $ever;
}
return $res;
}
sub get_possible_column
{
our @blk;
my ( $mat, $row, $target ) = @_;
my @cols = ( 0..8 );
for my $c ( 0..8 )
{
#如果当前行已经存在这个数字，则直接返回这个数字的位置。
if ( $mat->[$row][$c] == $target )
{
return ( $c );
}
elsif ( $mat->[$row][$c] != 0 )
{
$cols[$c] = -1;
}
for my $r ( 0..8 )
{
if ( $mat->[$r][$c] == $target )
{
$cols[$c] = -1;
if ( $blk[$r] == $blk[$row] )
{
$cols[ $blk[$c] * 3 + 0] = -1;
$cols[ $blk[$c] * 3 + 1] = -1;
$cols[ $blk[$c] * 3 + 2] = -1;
}
}
}
}
return grep { $_ != -1 } @cols;
}
sub str_to_mat
{
my ( $str, $mat ) = @_;
my $idx = 0;
for my $row ( 0 .. 8 )
{
for my $col ( 0 .. 8 )
{
$mat->[$row][$col] = substr( $str, $idx++, 1 );
}
}
}
sub mat_to_str
{
my ( $mat ) = @_;
return join("", map { join("", @{$mat->[$_]} ) } (0..8));
}
sub print_mat
{
my ($mat) = @_;
grep { print join(",", @{$mat->[$_]} ),"\n" } ( 0..8 );
}
跑完 sudoku_nd0.txt 三千多道题需要十多秒，跑完 sudoku_nd4.txt 大约六百秒
guanyu OPT, Wode kanfa?
1: dont repeat
biru:
$_ / 9 == $n / 9 ||
2: if array is ok, dont use hash
biru:
my %t = map {...
3: remove useless loop
biru:
foreach $n ( 0 .. 80 ) {...
my %t = map {...} 0 .. 80;
solve( $A[$n] = $_ ) for grep !$t{$_}, 1 .. 9;