[Perl]解数独题

523066680

题库来源：免费的在线数独

抓题脚本：[threads]多线程批量下载数独题库

打包：
http://523066680.ys168.com/
Perl/数独/数独题库200801-201709_含答案.zip

资料：
rosettacode 网站上有各种语言的解数独程序，其中的perl示例特别精简，但是有很大优化空间。
http://rosettacode.org/wiki/Sudoku#Perl

523066680

初始方案，先提取所有空缺单元坐标，在递归层中挨个填入并在下一层填入时根据更新的矩阵缩小可选数字范围。
跑完 sudoku_nd0.txt 三千多道题 6 秒，但是跑 nd1-nd4 就很慢了。

有时间继续尝试 Dancing Links 算法

1. =info
   
2.     解数独 初版
   
3.     523066680 2017-09
   
4. =cut
   
5. 
   
6. use warnings;
   
7. use IO::Handle;
   
8. use File::Slurp;
   
9. use Time::HiRes qw/time/;
   
10. STDOUT->autoflush(1);
    
11. 
    
12. my @games;
    
13. my $gamedata = eval read_file("sudoku_nd0.txt");
    
14. grep { push @games, $gamedata->{$_} } sort keys %$gamedata;
    
15. 
    
16. #题目挑选
    
17. #@games = @games[108, 2040, 3234, 820, 659, 1569, 1307, 2987, 3235, 2742];
    
18. 
    
19. our @unsolve;
    
20. our $block = [];  #区块引用
    
21. my $mat = [[]];
    
22. my $index = 0;
    
23. my $time_a;
    
24. 
    
25. #创建区块引用
    
26. make_block_refs( $block, $mat );
    
27. 
    
28. while ( $index <= $#games )
    
29. {
    
30.     #字符串转矩阵
    
31.     str_to_mat( $games[$index] , $mat );
    
32.     $time_a = time();
    
33. 
    
34.     #设置 @unsolve 数组，存储空缺元素的坐标
    
35.     set_unsolve_array($mat);
    
36.     solve($mat, 0, 0);
    
37.    
    
38.     print_mat($mat);
    
39.     printf "Game index: %d, time used: %.3fs\n\n", $index, time() - $time_a;
    
40.     $index++;
    
41. }
    
42. 
    
43. sub solve
    
44. {
    
45.     my ($mat, $prev, $lv) = @_;
    
46.     my @possible;
    
47.     my ($row, $col);
    
48.     my $current;
    
49. 
    
50.     for my $i ( $prev .. $#unsolve )
    
51.     {
    
52.         ($row, $col) = @{$unsolve[$i]};
    
53.         if ( $mat->[$row][$col] == 0 )
    
54.         {
    
55.             $current = $i;
    
56.             @possible = get_possible_num( $mat, $row, $col );
    
57.             last;
    
58.         }
    
59.     }
    
60. 
    
61.     if ( not defined $current ) { return 1 }
    
62.     else
    
63.     {   
    
64.         return 0 if ( $#possible < 0 )
    
65.     }
    
66. 
    
67.     my $res = 0;
    
68.     for my $p ( @possible )
    
69.     {
    
70.         $mat->[ $row ][ $col ] = $p;
    
71.         $res = solve($mat, $current+1, $lv+1);
    
72.         last if ($res == 1);
    
73.     }
    
74. 
    
75.     #使对应单元恢复为0 否则影响递归判断
    
76.     $mat->[$row][$col] = 0 if ($res == 0) ;
    
77.     return $res;
    
78. }
    
79. 
    
80. sub get_possible_num
    
81. {
    
82.     our $block;
    
83.     my ($mat, $row, $col) = @_;
    
84.     my @possible = (0,1,2,3,4,5,6,7,8,9);
    
85. 
    
86.     #区块坐标
    
87.     my $blockrow = int($row/3);
    
88.     my $blockcol = int($col/3);
    
89. 
    
90.     #排除元素
    
91.     for my $n ( 0 .. 8 )
    
92.     {
    
93.         $possible[ $mat->[$n][$col] ] = 0;
    
94.         $possible[ $mat->[$row][$n] ] = 0;
    
95.         $possible[ ${$block->[$blockrow][$blockcol][$n]} ] = 0;
    
96.     }
    
97. 
    
98.     return grep { $_ } @possible;
    
99. }
    
100. 
     
101. sub set_unsolve_array
     
102. {
     
103.     our ( @unsolve );
     
104.     my ($mat) = @_;
     
105. 
     
106.     @unsolve = ();
     
107.     for my $row ( 0..8 )
     
108.     {
     
109.         for my $col ( 0..8 )
     
110.         {
     
111.             if ( $mat->[$row][$col] == 0 )
     
112.             {
     
113.                 push @unsolve, [ $row, $col, [get_possible_num( $mat, $row, $col )] ];
     
114.             }
     
115.         }
     
116.     }
     
117. 
     
118.     #根据可选数字的数量由少到多排序
     
119.     @unsolve = sort { $#{$a->[2]} <=> $#{$b->[2]} } @unsolve;
     
120. }
     
121. 
     
122. sub make_block_refs
     
123. {
     
124.     my ($block, $mat) = @_;
     
125. 
     
126.     #将数独的九个宫对应的引用分组保存
     
127.     for my $r ( 0..2 )
     
128.     {
     
129.         for my $c ( 0..2 )
     
130.         {
     
131.             for my $rr ( $r*3 .. $r*3+2 )
     
132.             {
     
133.                 for my $cc ( $c*3 .. $c*3+2 )
     
134.                 {
     
135.                     push @{ $block->[$r][$c] }, \$mat->[$rr][$cc];
     
136.                 }
     
137.             }
     
138.         }
     
139.     }
     
140. }
     
141. 
     
142. sub str_to_mat
     
143. {
     
144.     my ( $str, $mat ) = @_;
     
145.     my $idx = 0;
     
146. 
     
147.     for my $row ( 0 .. 8 )
     
148.     {
     
149.         for my $col ( 0 .. 8 )
     
150.         {
     
151.             $mat->[$row][$col] = substr( $str, $idx++, 1 );
     
152.         }
     
153.     }
     
154. }
     
155. 
     
156. sub print_mat
     
157. {
     
158.     my ($mat) = @_;
     
159.     grep { print join(",", @{$mat->[$_]} ),"\n" } ( 0..8 );
     
160. }
     

复制代码

rubyish

for test: SLOW!!

1. my $sudo3 = [
   
2.     [ 8, 0, 0, 0, 0, 0, 0, 0, 0 ],
   
3.     [ 0, 0, 3, 6, 0, 0, 0, 0, 0 ],
   
4.     [ 0, 7, 0, 0, 9, 0, 2, 0, 0 ],
   
5.     [ 0, 5, 0, 0, 0, 7, 0, 0, 0 ],
   
6.     [ 0, 0, 0, 0, 4, 5, 7, 0, 0 ],
   
7.     [ 0, 0, 0, 1, 0, 0, 0, 3, 0 ],
   
8.     [ 0, 0, 1, 0, 0, 0, 0, 6, 8 ],
   
9.     [ 0, 0, 8, 5, 0, 0, 0, 1, 0 ],
   
10.     [ 0, 9, 0, 0, 0, 0, 4, 0, 0 ],
    
11. ];
    
12. 
    
13. 
    
14. my $sudo4 = [
    
15.     [ 0, 0, 5, 3, 0, 0, 0, 0, 0 ],
    
16.     [ 8, 0, 0, 0, 0, 0, 0, 2, 0 ],
    
17.     [ 0, 7, 0, 0, 1, 0, 5, 0, 0 ],
    
18.     [ 4, 0, 0, 0, 0, 5, 3, 0, 0 ],
    
19.     [ 0, 1, 0, 0, 7, 0, 0, 0, 6 ],
    
20.     [ 0, 0, 3, 2, 0, 0, 0, 8, 0 ],
    
21.     [ 0, 6, 0, 5, 0, 0, 0, 0, 9 ],
    
22.     [ 0, 0, 4, 0, 0, 0, 0, 3, 0 ],
    
23.     [ 0, 0, 0, 0, 0, 9, 7, 0, 0 ],
    
24. ];
    
25. 
    
26. my $sudo5 = [
    
27.     [ 9, 8, 0, 7, 0, 0, 6, 0, 0 ],
    
28.     [ 7, 0, 0, 0, 0, 0, 0, 8, 0 ],
    
29.     [ 0, 0, 6, 0, 5, 0, 0, 0, 0 ],
    
30.     [ 4, 0, 0, 0, 0, 3, 0, 0, 0 ],
    
31.     [ 0, 0, 8, 9, 0, 0, 0, 7, 0 ],
    
32.     [ 0, 0, 0, 0, 2, 0, 3, 0, 0 ],
    
33.     [ 0, 1, 0, 0, 0, 0, 2, 0, 0 ],
    
34.     [ 0, 0, 7, 5, 0, 0, 0, 6, 0 ],
    
35.     [ 0, 0, 0, 0, 0, 1, 0, 5, 4 ],
    
36. ];
    
37. 
    
38. my $sudo6 = [
    
39.     [ 9, 8, 0, 7, 0, 0, 6, 0, 0 ],
    
40.     [ 5, 0, 0, 0, 9, 0, 0, 7, 0 ],
    
41.     [ 0, 0, 7, 0, 0, 4, 0, 0, 0 ],
    
42.     [ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
    
43.     [ 0, 0, 8, 5, 0, 0, 0, 6, 0 ],
    
44.     [ 0, 0, 0, 0, 0, 0, 3, 0, 2 ],
    
45.     [ 0, 1, 0, 0, 0, 0, 0, 0, 0 ],
    
46.     [ 0, 0, 5, 4, 0, 0, 0, 8, 0 ],
    
47.     [ 0, 0, 0, 0, 2, 1, 9, 0, 0 ],
    
48. ];
    
49. 
    
50. my $sudo7 = [
    
51.     [ 0, 0, 7, 0, 9, 0, 0, 0, 2 ],
    
52.     [ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
    
53.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
    
54.     [ 0, 0, 5, 7, 0, 0, 0, 0, 0 ],
    
55.     [ 0, 0, 0, 5, 4, 0, 0, 0, 7 ],
    
56.     [ 0, 0, 0, 0, 0, 1, 3, 0, 0 ],
    
57.     [ 0, 0, 9, 0, 0, 0, 0, 0, 4 ],
    
58.     [ 8, 0, 0, 0, 0, 5, 1, 0, 0 ],
    
59.     [ 1, 0, 0, 0, 0, 0, 6, 8, 0 ],
    
60. ];
    
61. 
    
62. my $sudo8 = [
    
63.     [ 0, 9, 0, 0, 0, 0, 0, 0, 4 ],
    
64.     [ 1, 0, 0, 0, 0, 0, 8, 6, 0 ],
    
65.     [ 8, 0, 0, 0, 0, 5, 0, 1, 0 ],
    
66.     [ 0, 0, 0, 0, 0, 1, 0, 3, 0 ],
    
67.     [ 0, 0, 0, 5, 4, 0, 0, 0, 7 ],
    
68.     [ 0, 5, 0, 7, 0, 0, 0, 0, 0 ],
    
69.     [ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
    
70.     [ 0, 7, 0, 0, 9, 0, 0, 0, 2 ],
    
71.     [ 0, 0, 8, 0, 0, 0, 0, 0, 0 ],
    
72. ];
    
73. 
    
74. my $sudo9 = [
    
75.     [ 0, 0, 0, 0, 0, 0, 8, 0, 0 ],
    
76.     [ 0, 0, 2, 0, 7, 0, 0, 4, 0 ],
    
77.     [ 0, 0, 0, 3, 0, 0, 6, 0, 1 ],
    
78.     [ 6, 0, 0, 1, 0, 0, 0, 0, 5 ],
    
79.     [ 0, 0, 9, 0, 4, 0, 0, 0, 0 ],
    
80.     [ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
    
81.     [ 0, 0, 7, 0, 0, 5, 0, 9, 0 ],
    
82.     [ 3, 0, 0, 0, 0, 0, 1, 0, 8 ],
    
83.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
    
84. ];
    
85. 
    
86. my $sudo10 = [
    
87.     [ 0, 1, 6, 3, 0, 0, 0, 0, 0 ],
    
88.     [ 0, 0, 8, 0, 0, 0, 0, 0, 0 ],
    
89.     [ 4, 0, 0, 0, 7, 0, 2, 0, 0 ],
    
90.     [ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
    
91.     [ 0, 0, 0, 0, 4, 0, 9, 0, 0 ],
    
92.     [ 0, 5, 0, 1, 0, 0, 0, 6, 0 ],
    
93.     [ 0, 8, 1, 0, 0, 0, 0, 3, 0 ],
    
94.     [ 0, 0, 0, 0, 0, 0, 0, 0, 8 ],
    
95.     [ 9, 0, 0, 0, 0, 5, 7, 0, 0 ],
    
96. ];
    
97. 
    
98. my $sudo11 = [
    
99.     [ 8, 0, 0, 5, 0, 0, 1, 0, 0 ],
    
100.     [ 0, 0, 9, 0, 0, 0, 0, 0, 4 ],
     
101.     [ 1, 0, 0, 0, 0, 0, 6, 8, 0 ],
     
102.     [ 0, 0, 5, 0, 0, 7, 0, 0, 0 ],
     
103.     [ 0, 0, 0, 0, 4, 5, 0, 0, 7 ],
     
104.     [ 0, 0, 0, 1, 0, 0, 3, 0, 0 ],
     
105.     [ 0, 0, 7, 0, 9, 0, 0, 0, 2 ],
     
106.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
     
107.     [ 3, 0, 0, 6, 0, 0, 0, 0, 0 ],
     
108. ];
     

复制代码

rubyish

play $sudo9:

v1: time 0m0.585s

1. 
   
2. 5 9 3  4 1 6  8 2 7
   
3. 1 6 2  5 7 8  3 4 9
   
4. 7 4 8  3 2 9  6 5 1
   
5. 
   
6. 6 7 4  1 8 2  9 3 5
   
7. 8 5 9  6 4 3  7 1 2
   
8. 2 3 1  9 5 7  4 8 6
   
9. 
   
10. 4 1 7  8 6 5  2 9 3
    
11. 3 2 5  7 9 4  1 6 8
    
12. 9 8 6  2 3 1  5 7 4
    
13. 
    
14. real        0m0.585s
    

复制代码

v2:
sudo9: time 0m0.538s

1. 5 9 3  4 1 6  8 2 7
   
2. 1 6 2  5 7 8  3 4 9
   
3. 7 4 8  3 2 9  6 5 1
   
4. 
   
5. 6 7 4  1 8 2  9 3 5
   
6. 8 5 9  6 4 3  7 1 2
   
7. 2 3 1  9 5 7  4 8 6
   
8. 
   
9. 4 1 7  8 6 5  2 9 3
   
10. 3 2 5  7 9 4  1 6 8
    
11. 9 8 6  2 3 1  5 7 4
    
12. 
    
13. real    0m0.538s
    
14. user    0m0.528s
    
15. sys    0m0.007s

复制代码

1. #!/usr/bin/perl
   
2. # version 26, subversion 0 (v5.26.0)
   
3. 
   
4. use 5.010;
   
5. sub ERROR()  { 0b1111111110 }
   
6. sub FINISH() { 0 }
   
7. sub BEST()   { 1 }
   
8. sub MIN()    { 10 }
   
9. my ( @VERTI, @HORIS, @BLOKE, @MAYBE, @HOVER );
   
10. my ( @GIMME, $DIT, $DAT, $LOST );
    
11. 
    
12. my $sudo1 = [    # 0.030s
    
13.     [ 0, 0, 0, 0, 0, 0, 0, 9, 0 ],
    
14.     [ 1, 9, 0, 4, 7, 0, 6, 0, 8 ],
    
15.     [ 0, 5, 2, 8, 1, 9, 4, 0, 7 ],
    
16.     [ 2, 0, 0, 0, 4, 8, 0, 0, 0 ],
    
17.     [ 0, 0, 9, 0, 0, 0, 5, 0, 0 ],
    
18.     [ 0, 0, 0, 7, 5, 0, 0, 0, 9 ],
    
19.     [ 9, 0, 7, 3, 6, 4, 1, 8, 0 ],
    
20.     [ 5, 0, 6, 0, 8, 1, 0, 7, 4 ],
    
21.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
    
22. ];
    
23. 
    
24. my $sudo3 = [    # 0.620s
    
25.     [ 8, 0, 0, 0, 0, 0, 0, 0, 0 ],
    
26.     [ 0, 0, 3, 6, 0, 0, 0, 0, 0 ],
    
27.     [ 0, 7, 0, 0, 9, 0, 2, 0, 0 ],
    
28.     [ 0, 5, 0, 0, 0, 7, 0, 0, 0 ],
    
29.     [ 0, 0, 0, 0, 4, 5, 7, 0, 0 ],
    
30.     [ 0, 0, 0, 1, 0, 0, 0, 3, 0 ],
    
31.     [ 0, 0, 1, 0, 0, 0, 0, 6, 8 ],
    
32.     [ 0, 0, 8, 5, 0, 0, 0, 1, 0 ],
    
33.     [ 0, 9, 0, 0, 0, 0, 4, 0, 0 ],
    
34. ];
    
35. 
    
36. my $sudo9 = [    # 0.536s
    
37.     [ 0, 0, 0, 0, 0, 0, 8, 0, 0 ],
    
38.     [ 0, 0, 2, 0, 7, 0, 0, 4, 0 ],
    
39.     [ 0, 0, 0, 3, 0, 0, 6, 0, 1 ],
    
40.     [ 6, 0, 0, 1, 0, 0, 0, 0, 5 ],
    
41.     [ 0, 0, 9, 0, 4, 0, 0, 0, 0 ],
    
42.     [ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
    
43.     [ 0, 0, 7, 0, 0, 5, 0, 9, 0 ],
    
44.     [ 3, 0, 0, 0, 0, 0, 1, 0, 8 ],
    
45.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
    
46. ];
    
47. 
    
48. init();
    
49. 
    
50. play($sudo9);   # for 1 .. 10;
    
51. 
    
52. # play($sudo3);
    
53. 
    
54. # ____________________SUB____________________
    
55. sub init {
    
56.     for my $i ( 0 .. 8 ) {
    
57.         my $i3 = 3 * int( $i / 3 );
    
58. 
    
59.         for my $j ( 0 .. 8 ) {
    
60.             $HOVER[$i][$j] = int( $j / 3 ) + $i3;
    
61.         }
    
62.     }
    
63. 
    
64.     for ( my $n = 0 ; $n < ERROR ; $n += 2 ) {
    
65.         for my $i ( 1 .. 9 ) {
    
66.             next if $n & 1 << $i;
    
67.             push @{ $MAYBE[$n] }, $i;
    
68.         }
    
69.     }
    
70. }
    
71. 
    
72. sub play {
    
73.     my $sudo = shift;
    
74.     @VERTI = @HORIS = @BLOKE = (0) x 9;
    
75.     @GIMME = ();
    
76.     $DIT   = 0;
    
77. 
    
78.     for my $i ( 0 .. 8 ) {
    
79.         for my $j ( 0 .. 8 ) {
    
80.             my $k = $HOVER[$i][$j];
    
81. 
    
82.             if ( !$sudo->[$i][$j] ) {
    
83.                 push @GIMME, [ $i, $j, $k ];
    
84.                 next;
    
85.             }
    
86. 
    
87.             $VERTI[$j] |= 1 << $sudo->[$i][$j];
    
88.             $HORIS[$i] |= 1 << $sudo->[$i][$j];
    
89.             $BLOKE[$k] |= 1 << $sudo->[$i][$j];
    
90.         }
    
91.     }
    
92. 
    
93.     $LOST = @GIMME + 1;
    
94.     $DAT  = $#GIMME;
    
95.     explore($sudo);
    
96. }
    
97. 
    
98. sub best {
    
99.     my ( $min, $best, $posi ) = ( MIN, FINISH, $DAT );
    
100. 
     
101.     for my $that ( $DIT .. $DAT ) {
     
102.         my ( $i, $j, $k ) = @{ $GIMME[$that] };
     
103.         my $this = $HORIS[$i] | $VERTI[$j] | $BLOKE[$k];
     
104. 
     
105.         return ERROR if $this == ERROR;
     
106. 
     
107.         my $maybe = @{ $MAYBE[$this] };
     
108. 
     
109.         if ( $min > $maybe ) {
     
110.             $posi = $that;
     
111.             $best = $this;
     
112.             last if $maybe == BEST;
     
113.             $min = $maybe;
     
114.         }
     
115.     }
     
116. 
     
117.     @GIMME[ $DIT, $posi ] = @GIMME[ $posi, $DIT ];
     
118.     $DIT++;
     
119.     return $best;
     
120. }
     
121. 
     
122. sub explore {
     
123.     my $sudo = shift;
     
124.     return if $DIT == $LOST;
     
125. 
     
126.     my $this = best();
     
127.     return if $this == ERROR;
     
128.     echo($sudo) if $this == FINISH;
     
129. 
     
130.     my ( $i, $j, $k ) = @{ $GIMME[ $DIT - 1 ] };
     
131.     for my $n ( @{ $MAYBE[$this] } ) {
     
132.         my $that = 1 << $n;
     
133.         $sudo->[$i][$j] = $n;
     
134.         $HORIS[$i] |= $that;
     
135.         $VERTI[$j] |= $that;
     
136.         $BLOKE[$k] |= $that;
     
137.         explore($sudo);
     
138.         $HORIS[$i] ^= $that;
     
139.         $VERTI[$j] ^= $that;
     
140.         $BLOKE[$k] ^= $that;
     
141.     }
     
142.     $sudo->[$i][$j] = 0;
     
143.     $DIT--;
     
144. }
     
145. 
     
146. sub echo {
     
147.     my ( $sudo, $i ) = @_;
     
148.     for my $A (@$sudo) {
     
149.         say '' if !( $i++ % 3 );
     
150.         say " @$A[0..2]  @$A[3..5]  @$A[6..8]";
     
151.     }
     
152. }
     
153. 
     
154. __DATA__
     
155. $_
     
156. 
     

复制代码

jason680

回复 1# 523066680

看了网站上精简解法...
看看过程(在楼下)......

http://rosettacode.org/wiki/Sudoku#Perl

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

my @A = qw(
    5 3 0  0 2 4  7 0 0
    0 0 2  0 0 0  8 0 0
    1 0 0  7 0 3  9 0 2

    0 0 8  0 7 2  0 4 9
    0 2 0  9 8 0  0 7 0
    7 9 0  0 0 0  0 8 0

    0 0 0  0 3 0  5 0 6
    9 6 0  0 1 0  3 0 0
    0 5 0  6 9 0  0 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();

jason680

重点在这....
        my %t = map {
                $_ / 9 == $i / 9 ||
                $_ % 9 == $i % 9 ||
                $_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
                ? $A[$_] : 0,
                1;
            } 0 .. 80;

一开始,理解不出来...
后来直接打印 %t
找到 数独解 过程...

数组
[0]   [1]  [2]   [3]   [4]   [5]   [6]   [7]   [8]
[9] [10] [11] [12] [13] [14] [15] [16] [17]
...
[72] [73] [74] [75] [76] [77] [78] [79] [80]

    5 3 0  0 2 4  7 0 0
    0 0 2  0 0 0  8 0 0
    1 0 0  7 0 3  9 0 2

    0 0 8  0 7 2  0 4 9
    0 2 0  9 8 0  0 7 0
    7 9 0  0 0 0  0 8 0

    0 0 0  0 3 0  5 0 6
    9 6 0  0 1 0  3 0 0
    0 5 0  6 9 0  0 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;

jason680

提高 %t 收集 方法...

$ cat sdk_net.pl
#!/usr/bin/perl
use integer;
use strict;

my @A = qw(
    5 3 0  0 2 4  7 0 0
    0 0 2  0 0 0  8 0 0
    1 0 0  7 0 3  9 0 2

    0 0 8  0 7 2  0 4 9
    0 2 0  9 8 0  0 7 0
    7 9 0  0 0 0  0 8 0

    0 0 0  0 3 0  5 0 6
    9 6 0  0 1 0  3 0 0
    0 5 0  6 9 0  0 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

回复 6# jason680

这个程序仔细看过，遇到数独网站难度1到难度4的某些题目，解题效率会非常慢。

一点优化：
搜索空缺单元每次都是从下标0开始的，虽然用了 next if $A[$i] 跳过不必处理的单元。
可以改为在调用函数时传入位置信息。进一步地，可以在一开始就把所有空缺单元的索引存储到列表中

1. use integer;
   
2. use strict;
   
3. 
   
4. my @A = qw(
   
5. 1 4 0 9 6 8 0 0 0
   
6. 0 0 0 0 0 0 9 0 0
   
7. 6 0 0 0 5 7 3 0 0
   
8. 0 0 0 0 0 0 0 0 7
   
9. 3 0 0 0 0 0 8 4 0
   
10. 0 0 0 1 9 6 5 0 0
    
11. 0 7 0 0 0 0 4 0 5
    
12. 4 0 6 0 1 0 0 3 0
    
13. 0 0 0 0 0 0 0 0 0
    
14. );
    
15. 
    
16. our @unsolve = grep { ! $A[$_] } ( 0 .. $#A );
    
17. 
    
18. solve(0);
    
19. 
    
20. sub solve
    
21. {
    
22.     my ( $prev ) = @_;
    
23. 
    
24.     my $i;
    
25.     for my $index ( $prev .. $#unsolve )
    
26.     {
    
27.         $i = $unsolve[$index];   
    
28.         my %t =
    
29.             map {
    
30.                ($_ / 9 == $i / 9 ||
    
31.                 $_ % 9 == $i % 9 ||
    
32.                 $_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
    
33.                 ? $A[$_] : 0 ), 1;
    
34.             }
    
35.             0 .. 80;
    
36.         
    
37.         for (grep !$t{$_}, 1 .. 9)
    
38.         {
    
39.             $A[$i] = $_;
    
40.             solve( $prev+1 );
    
41.         }
    
42.         return $A[$i] = 0;
    
43.     }
    
44. 
    
45.     $i = 0;
    
46.     for ( @A )
    
47.     {
    
48.         print "-----+-----+-----\n" if !( $i % 27 ) && $i;
    
49.         print !($i%9) ? '': $i%3 ? ' ' : '|', $_;
    
50.         print "\n" unless ++$i%9;
    
51.     }
    
52.     print "\n";
    
53. }
    

复制代码

在我的电脑上  跑这道题 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, [get_possible_num( $mat, $row, $col )] ];
            }
        }
    }

    #根据可选数字的量由少到多排序
    @unsolve = sort { $#{$a->[2]} <=> $#{$b->[2]} } @unsolve;
}

Rubyish 的代码则快得多，跑完 sudoku_nd0.txt 只要零点几秒，跑完 nd2/nd3/nd4 需要一百多秒（已经完爆RosettaCode的Perl代码以及我二楼的代码）。

523066680

最近换了个方案，遇到难度高的题目时比原来的方案快得多（还是没有Rubyish的代码快啊~）。

给定一个题目，判断 1-9 每个数字的全局分布情况（可能性）。
比如1可能分布的情况有6种，测试每一种，把9个1全部填入数独，然后继续测试其他数字的分布。

题目

140968000000000900600057300000000007300000840000196500070000405406010030000000000

数字1的可能分布情况

140968000000001900600057310010000007300000841000196500071000405406010030000000100
140968000000001900600057310000000107310000840000196500071000405406010030000000001
140968000000001900600057301000000107310000840000196500071000405406010030000000010
140968000000001900600057301000000107310000840000196500070000415406010030001000000
140968000000001900600057301000000107301000840000196500070000415406010030010000000
140968000000001900600057301000000017310000840000196500071000405406010030000000100

完整代码：

1. =info
   
2.     523066680 2017-09
   
3. =cut
   
4. 
   
5. use File::Slurp;
   
6. use IO::Handle;
   
7. STDOUT->autoflush(1);
   
8. 
   
9. # my $gamedata = eval read_file("../sudoku_nd1.txt");
   
10. # grep { push @games, $gamedata->{$_} } sort keys %$gamedata;
    
11. 
    
12. @games = ("140968000000000900600057300000000007300000840000196500070000405406010030000000000");
    
13. 
    
14. our @order;
    
15. our $answer_mat = [[]];
    
16. my $mat;
    
17. my $res;
    
18. my $allcase;
    
19. my $answer_str;
    
20. 
    
21. #坐标对应区块位置的表
    
22. our @blk = map { int($_ / 3) } ( 0..8 );
    
23. 
    
24. while ( $index <= $#games )
    
25. {
    
26.     $mat = [[]];
    
27.     $time_a = time();
    
28.     str_to_mat( $games[$index] , $mat );
    
29. 
    
30.     $allcase = [ map { [] } (0..9) ];
    
31.     grep { possible_mat($mat, $_, $allcase->[$_], 0) } (1..9);
    
32.     @order = sort { $#{$allcase->[$a]} <=> $#{$allcase->[$b]} } ( 0 .. 9 );
    
33. 
    
34.     $res = recursive( $mat, 1 ); #起点为1，下标 0占位
    
35. 
    
36.     if ($res == 1)
    
37.     {
    
38.         print_mat( $answer_mat );
    
39.     }
    
40.     else { die "false\n" }
    
41. 
    
42.     printf "Game index: %d, time used: %.3fs\n\n", $index, time() - $time_a;
    
43.     $index++;
    
44. }
    
45. 
    
46. sub recursive
    
47. {
    
48.     our (@order, $answer_mat);
    
49.    
    
50.     my ( $mat, $lv ) = @_;
    
51.     my @case;
    
52. 
    
53.     if ( $lv > 9 )
    
54.     {
    
55.         $answer_mat = $mat;
    
56.         return 1;
    
57.     }
    
58. 
    
59.     $target = $order[$lv];
    
60.     possible_mat($mat, $target, \@case, 0);
    
61. 
    
62.     my $t_mat = [[]];
    
63.     my $res = 0;
    
64. 
    
65.     for my $s ( @case )
    
66.     {
    
67.         str_to_mat( $s, $t_mat );
    
68.         $res = recursive( $t_mat, $lv+1 );
    
69.         last if ($res == 1);
    
70.     }
    
71. 
    
72.     return $res;
    
73. }
    
74. 
    
75. sub possible_mat
    
76. {
    
77.     my ( $mat, $target, $aref, $lv ) = @_;
    
78.     # level means row
    
79. 
    
80.     my $str;
    
81.     if ($lv == 9)
    
82.     {
    
83.         $count++;
    
84.         push @$aref, mat_to_str($mat);
    
85.         return 1;
    
86.     }
    
87. 
    
88.     my @cols = get_possible_column( $mat, $lv, $target );
    
89. 
    
90.     my $res = 0;
    
91.     my $ever;
    
92.     for my $c ( @cols )
    
93.     {
    
94.         $ever = $mat->[$lv][$c];
    
95.         $mat->[$lv][$c] = $target;
    
96.         $res = possible_mat( $mat, $target, $aref, $lv+1 );
    
97.         $mat->[$lv][$c] = $ever;
    
98.     }
    
99. 
    
100.     return $res;
     
101. }
     
102. 
     
103. sub get_possible_column
     
104. {
     
105.     our @blk;
     
106.     my ( $mat, $row, $target ) = @_;
     
107.     my @cols = ( 0..8 );
     
108. 
     
109.     for my $c ( 0..8 )
     
110.     {
     
111.         #如果当前行已经存在这个数字，则直接返回这个数字的位置。
     
112.         if ( $mat->[$row][$c] == $target )
     
113.         {
     
114.             return ( $c );
     
115.         }
     
116.         elsif ( $mat->[$row][$c] != 0 )
     
117.         {
     
118.             $cols[$c] = -1;
     
119.         }
     
120. 
     
121.         for my $r ( 0..8 )
     
122.         {
     
123.             if ( $mat->[$r][$c] == $target )
     
124.             {
     
125.                 $cols[$c] = -1;
     
126.                 if ( $blk[$r] == $blk[$row] )
     
127.                 {
     
128.                     $cols[ $blk[$c] * 3 + 0] = -1;
     
129.                     $cols[ $blk[$c] * 3 + 1] = -1;
     
130.                     $cols[ $blk[$c] * 3 + 2] = -1;
     
131.                 }
     
132.             }
     
133.         }
     
134.     }
     
135. 
     
136.     return grep { $_ != -1 } @cols;
     
137. }
     
138. 
     
139. sub str_to_mat
     
140. {
     
141.     my ( $str, $mat ) = @_;
     
142.     my $idx = 0;
     
143. 
     
144.     for my $row ( 0 .. 8 )
     
145.     {
     
146.         for my $col ( 0 .. 8 )
     
147.         {
     
148.             $mat->[$row][$col] = substr( $str, $idx++, 1 );
     
149.         }
     
150.     }
     
151. }
     
152. 
     
153. sub mat_to_str
     
154. {
     
155.     my ( $mat ) = @_;
     
156.     return join("", map { join("", @{$mat->[$_]} ) } (0..8));
     
157. }
     
158. 
     
159. sub print_mat
     
160. {
     
161.     my ($mat) = @_;
     
162.     grep { print join(",", @{$mat->[$_]} ),"\n" } ( 0..8 );
     
163. }
     

复制代码

跑完 sudoku_nd0.txt 三千多道题需要十多秒，跑完 sudoku_nd4.txt 大约六百秒

rubyish

guanyu OPT, Wode kanfa?

1: dont repeat
biru:

1. $_ / 9 == $n / 9 ||

复制代码

2: if array is ok, dont use hash
biru:

1. my %t = map {...

复制代码

3: remove useless loop
biru:

1. foreach $n ( 0 .. 80 ) {...

复制代码

1. my %t = map {...} 0 .. 80;

复制代码

1. solve( $A[$n] = $_ ) for grep !$t{$_}, 1 .. 9;

复制代码