免费注册 查看新帖 |

Chinaunix

  平台 论坛 博客 文库
1234下一页
最近访问板块 发新帖
查看: 11148 | 回复: 30

[Perl]解数独题 [复制链接]

论坛徽章:
12
子鼠
日期:2014-10-11 16:46:482016科比退役纪念章
日期:2018-03-16 10:24:0515-16赛季CBA联赛之山东
日期:2017-11-10 14:32:142016科比退役纪念章
日期:2017-09-02 15:42:4715-16赛季CBA联赛之佛山
日期:2017-08-28 17:11:5515-16赛季CBA联赛之浙江
日期:2017-08-24 16:55:1715-16赛季CBA联赛之青岛
日期:2017-08-17 19:55:2415-16赛季CBA联赛之天津
日期:2017-06-29 10:34:4315-16赛季CBA联赛之四川
日期:2017-05-16 16:38:55黑曼巴
日期:2016-07-19 15:03:112015亚冠之萨济拖拉机
日期:2015-05-22 11:38:5315-16赛季CBA联赛之北京
日期:2019-08-13 17:30:53
发表于 2017-09-16 18:19 |显示全部楼层
本帖最后由 523066680 于 2017-09-16 18:27 编辑

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

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

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

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

论坛徽章:
12
子鼠
日期:2014-10-11 16:46:482016科比退役纪念章
日期:2018-03-16 10:24:0515-16赛季CBA联赛之山东
日期:2017-11-10 14:32:142016科比退役纪念章
日期:2017-09-02 15:42:4715-16赛季CBA联赛之佛山
日期:2017-08-28 17:11:5515-16赛季CBA联赛之浙江
日期:2017-08-24 16:55:1715-16赛季CBA联赛之青岛
日期:2017-08-17 19:55:2415-16赛季CBA联赛之天津
日期:2017-06-29 10:34:4315-16赛季CBA联赛之四川
日期:2017-05-16 16:38:55黑曼巴
日期:2016-07-19 15:03:112015亚冠之萨济拖拉机
日期:2015-05-22 11:38:5315-16赛季CBA联赛之北京
日期:2019-08-13 17:30:53
发表于 2017-09-16 18:25 |显示全部楼层
本帖最后由 523066680 于 2017-09-16 18:56 编辑

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

有时间继续尝试 Dancing Links 算法

  1. =info
  2.     解数独 初版
  3.     523066680 2017-09
  4. =cut

  5. use warnings;
  6. use IO::Handle;
  7. use File::Slurp;
  8. use Time::HiRes qw/time/;
  9. STDOUT->autoflush(1);

  10. my @games;
  11. my $gamedata = eval read_file("sudoku_nd0.txt");
  12. grep { push @games, $gamedata->{$_} } sort keys %$gamedata;

  13. #题目挑选
  14. #@games = @games[108, 2040, 3234, 820, 659, 1569, 1307, 2987, 3235, 2742];

  15. our @unsolve;
  16. our $block = [];  #区块引用
  17. my $mat = [[]];
  18. my $index = 0;
  19. my $time_a;

  20. #创建区块引用
  21. make_block_refs( $block, $mat );

  22. while ( $index <= $#games )
  23. {
  24.     #字符串转矩阵
  25.     str_to_mat( $games[$index] , $mat );
  26.     $time_a = time();

  27.     #设置 @unsolve 数组,存储空缺元素的坐标
  28.     set_unsolve_array($mat);
  29.     solve($mat, 0, 0);
  30.    
  31.     print_mat($mat);
  32.     printf "Game index: %d, time used: %.3fs\n\n", $index, time() - $time_a;
  33.     $index++;
  34. }

  35. sub solve
  36. {
  37.     my ($mat, $prev, $lv) = @_;
  38.     my @possible;
  39.     my ($row, $col);
  40.     my $current;

  41.     for my $i ( $prev .. $#unsolve )
  42.     {
  43.         ($row, $col) = @{$unsolve[$i]};
  44.         if ( $mat->[$row][$col] == 0 )
  45.         {
  46.             $current = $i;
  47.             @possible = get_possible_num( $mat, $row, $col );
  48.             last;
  49.         }
  50.     }

  51.     if ( not defined $current ) { return 1 }
  52.     else
  53.     {   
  54.         return 0 if ( $#possible < 0 )
  55.     }

  56.     my $res = 0;
  57.     for my $p ( @possible )
  58.     {
  59.         $mat->[ $row ][ $col ] = $p;
  60.         $res = solve($mat, $current+1, $lv+1);
  61.         last if ($res == 1);
  62.     }

  63.     #使对应单元恢复为0 否则影响递归判断
  64.     $mat->[$row][$col] = 0 if ($res == 0) ;
  65.     return $res;
  66. }

  67. sub get_possible_num
  68. {
  69.     our $block;
  70.     my ($mat, $row, $col) = @_;
  71.     my @possible = (0,1,2,3,4,5,6,7,8,9);

  72.     #区块坐标
  73.     my $blockrow = int($row/3);
  74.     my $blockcol = int($col/3);

  75.     #排除元素
  76.     for my $n ( 0 .. 8 )
  77.     {
  78.         $possible[ $mat->[$n][$col] ] = 0;
  79.         $possible[ $mat->[$row][$n] ] = 0;
  80.         $possible[ ${$block->[$blockrow][$blockcol][$n]} ] = 0;
  81.     }

  82.     return grep { $_ } @possible;
  83. }

  84. sub set_unsolve_array
  85. {
  86.     our ( @unsolve );
  87.     my ($mat) = @_;

  88.     @unsolve = ();
  89.     for my $row ( 0..8 )
  90.     {
  91.         for my $col ( 0..8 )
  92.         {
  93.             if ( $mat->[$row][$col] == 0 )
  94.             {
  95.                 push @unsolve, [ $row, $col, [get_possible_num( $mat, $row, $col )] ];
  96.             }
  97.         }
  98.     }

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

  102. sub make_block_refs
  103. {
  104.     my ($block, $mat) = @_;

  105.     #将数独的九个宫对应的引用分组保存
  106.     for my $r ( 0..2 )
  107.     {
  108.         for my $c ( 0..2 )
  109.         {
  110.             for my $rr ( $r*3 .. $r*3+2 )
  111.             {
  112.                 for my $cc ( $c*3 .. $c*3+2 )
  113.                 {
  114.                     push @{ $block->[$r][$c] }, \$mat->[$rr][$cc];
  115.                 }
  116.             }
  117.         }
  118.     }
  119. }

  120. sub str_to_mat
  121. {
  122.     my ( $str, $mat ) = @_;
  123.     my $idx = 0;

  124.     for my $row ( 0 .. 8 )
  125.     {
  126.         for my $col ( 0 .. 8 )
  127.         {
  128.             $mat->[$row][$col] = substr( $str, $idx++, 1 );
  129.         }
  130.     }
  131. }

  132. sub print_mat
  133. {
  134.     my ($mat) = @_;
  135.     grep { print join(",", @{$mat->[$_]} ),"\n" } ( 0..8 );
  136. }
复制代码

论坛徽章:
7
戌狗
日期:2013-12-15 20:43:38技术图书徽章
日期:2014-03-05 01:33:12技术图书徽章
日期:2014-03-15 20:31:17未羊
日期:2014-03-25 23:48:20丑牛
日期:2014-04-07 22:37:44巳蛇
日期:2014-04-11 21:58:0915-16赛季CBA联赛之青岛
日期:2016-03-17 20:36:13
发表于 2017-09-17 02:38 |显示全部楼层
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. my $sudo4 = [
  13.     [ 0, 0, 5, 3, 0, 0, 0, 0, 0 ],
  14.     [ 8, 0, 0, 0, 0, 0, 0, 2, 0 ],
  15.     [ 0, 7, 0, 0, 1, 0, 5, 0, 0 ],
  16.     [ 4, 0, 0, 0, 0, 5, 3, 0, 0 ],
  17.     [ 0, 1, 0, 0, 7, 0, 0, 0, 6 ],
  18.     [ 0, 0, 3, 2, 0, 0, 0, 8, 0 ],
  19.     [ 0, 6, 0, 5, 0, 0, 0, 0, 9 ],
  20.     [ 0, 0, 4, 0, 0, 0, 0, 3, 0 ],
  21.     [ 0, 0, 0, 0, 0, 9, 7, 0, 0 ],
  22. ];

  23. my $sudo5 = [
  24.     [ 9, 8, 0, 7, 0, 0, 6, 0, 0 ],
  25.     [ 7, 0, 0, 0, 0, 0, 0, 8, 0 ],
  26.     [ 0, 0, 6, 0, 5, 0, 0, 0, 0 ],
  27.     [ 4, 0, 0, 0, 0, 3, 0, 0, 0 ],
  28.     [ 0, 0, 8, 9, 0, 0, 0, 7, 0 ],
  29.     [ 0, 0, 0, 0, 2, 0, 3, 0, 0 ],
  30.     [ 0, 1, 0, 0, 0, 0, 2, 0, 0 ],
  31.     [ 0, 0, 7, 5, 0, 0, 0, 6, 0 ],
  32.     [ 0, 0, 0, 0, 0, 1, 0, 5, 4 ],
  33. ];

  34. my $sudo6 = [
  35.     [ 9, 8, 0, 7, 0, 0, 6, 0, 0 ],
  36.     [ 5, 0, 0, 0, 9, 0, 0, 7, 0 ],
  37.     [ 0, 0, 7, 0, 0, 4, 0, 0, 0 ],
  38.     [ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
  39.     [ 0, 0, 8, 5, 0, 0, 0, 6, 0 ],
  40.     [ 0, 0, 0, 0, 0, 0, 3, 0, 2 ],
  41.     [ 0, 1, 0, 0, 0, 0, 0, 0, 0 ],
  42.     [ 0, 0, 5, 4, 0, 0, 0, 8, 0 ],
  43.     [ 0, 0, 0, 0, 2, 1, 9, 0, 0 ],
  44. ];

  45. my $sudo7 = [
  46.     [ 0, 0, 7, 0, 9, 0, 0, 0, 2 ],
  47.     [ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
  48.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
  49.     [ 0, 0, 5, 7, 0, 0, 0, 0, 0 ],
  50.     [ 0, 0, 0, 5, 4, 0, 0, 0, 7 ],
  51.     [ 0, 0, 0, 0, 0, 1, 3, 0, 0 ],
  52.     [ 0, 0, 9, 0, 0, 0, 0, 0, 4 ],
  53.     [ 8, 0, 0, 0, 0, 5, 1, 0, 0 ],
  54.     [ 1, 0, 0, 0, 0, 0, 6, 8, 0 ],
  55. ];

  56. my $sudo8 = [
  57.     [ 0, 9, 0, 0, 0, 0, 0, 0, 4 ],
  58.     [ 1, 0, 0, 0, 0, 0, 8, 6, 0 ],
  59.     [ 8, 0, 0, 0, 0, 5, 0, 1, 0 ],
  60.     [ 0, 0, 0, 0, 0, 1, 0, 3, 0 ],
  61.     [ 0, 0, 0, 5, 4, 0, 0, 0, 7 ],
  62.     [ 0, 5, 0, 7, 0, 0, 0, 0, 0 ],
  63.     [ 3, 0, 0, 0, 0, 6, 0, 0, 0 ],
  64.     [ 0, 7, 0, 0, 9, 0, 0, 0, 2 ],
  65.     [ 0, 0, 8, 0, 0, 0, 0, 0, 0 ],
  66. ];

  67. my $sudo9 = [
  68.     [ 0, 0, 0, 0, 0, 0, 8, 0, 0 ],
  69.     [ 0, 0, 2, 0, 7, 0, 0, 4, 0 ],
  70.     [ 0, 0, 0, 3, 0, 0, 6, 0, 1 ],
  71.     [ 6, 0, 0, 1, 0, 0, 0, 0, 5 ],
  72.     [ 0, 0, 9, 0, 4, 0, 0, 0, 0 ],
  73.     [ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
  74.     [ 0, 0, 7, 0, 0, 5, 0, 9, 0 ],
  75.     [ 3, 0, 0, 0, 0, 0, 1, 0, 8 ],
  76.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
  77. ];

  78. my $sudo10 = [
  79.     [ 0, 1, 6, 3, 0, 0, 0, 0, 0 ],
  80.     [ 0, 0, 8, 0, 0, 0, 0, 0, 0 ],
  81.     [ 4, 0, 0, 0, 7, 0, 2, 0, 0 ],
  82.     [ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
  83.     [ 0, 0, 0, 0, 4, 0, 9, 0, 0 ],
  84.     [ 0, 5, 0, 1, 0, 0, 0, 6, 0 ],
  85.     [ 0, 8, 1, 0, 0, 0, 0, 3, 0 ],
  86.     [ 0, 0, 0, 0, 0, 0, 0, 0, 8 ],
  87.     [ 9, 0, 0, 0, 0, 5, 7, 0, 0 ],
  88. ];

  89. my $sudo11 = [
  90.     [ 8, 0, 0, 5, 0, 0, 1, 0, 0 ],
  91.     [ 0, 0, 9, 0, 0, 0, 0, 0, 4 ],
  92.     [ 1, 0, 0, 0, 0, 0, 6, 8, 0 ],
  93.     [ 0, 0, 5, 0, 0, 7, 0, 0, 0 ],
  94.     [ 0, 0, 0, 0, 4, 5, 0, 0, 7 ],
  95.     [ 0, 0, 0, 1, 0, 0, 3, 0, 0 ],
  96.     [ 0, 0, 7, 0, 9, 0, 0, 0, 2 ],
  97.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
  98.     [ 3, 0, 0, 6, 0, 0, 0, 0, 0 ],
  99. ];
复制代码

论坛徽章:
7
戌狗
日期:2013-12-15 20:43:38技术图书徽章
日期:2014-03-05 01:33:12技术图书徽章
日期:2014-03-15 20:31:17未羊
日期:2014-03-25 23:48:20丑牛
日期:2014-04-07 22:37:44巳蛇
日期:2014-04-11 21:58:0915-16赛季CBA联赛之青岛
日期:2016-03-17 20:36:13
发表于 2017-09-17 02:41 |显示全部楼层
本帖最后由 rubyish 于 2017-09-18 23:39 编辑

play $sudo9:

v1: time 0m0.585s

  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. 6 7 4  1 8 2  9 3 5
  5. 8 5 9  6 4 3  7 1 2
  6. 2 3 1  9 5 7  4 8 6

  7. 4 1 7  8 6 5  2 9 3
  8. 3 2 5  7 9 4  1 6 8
  9. 9 8 6  2 3 1  5 7 4

  10. 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. 6 7 4  1 8 2  9 3 5
  5. 8 5 9  6 4 3  7 1 2
  6. 2 3 1  9 5 7  4 8 6

  7. 4 1 7  8 6 5  2 9 3
  8. 3 2 5  7 9 4  1 6 8
  9. 9 8 6  2 3 1  5 7 4

  10. real    0m0.538s
  11. user    0m0.528s
  12. sys    0m0.007s
复制代码

  1. #!/usr/bin/perl
  2. # version 26, subversion 0 (v5.26.0)

  3. use 5.010;
  4. sub ERROR()  { 0b1111111110 }
  5. sub FINISH() { 0 }
  6. sub BEST()   { 1 }
  7. sub MIN()    { 10 }
  8. my ( @VERTI, @HORIS, @BLOKE, @MAYBE, @HOVER );
  9. my ( @GIMME, $DIT, $DAT, $LOST );

  10. my $sudo1 = [    # 0.030s
  11.     [ 0, 0, 0, 0, 0, 0, 0, 9, 0 ],
  12.     [ 1, 9, 0, 4, 7, 0, 6, 0, 8 ],
  13.     [ 0, 5, 2, 8, 1, 9, 4, 0, 7 ],
  14.     [ 2, 0, 0, 0, 4, 8, 0, 0, 0 ],
  15.     [ 0, 0, 9, 0, 0, 0, 5, 0, 0 ],
  16.     [ 0, 0, 0, 7, 5, 0, 0, 0, 9 ],
  17.     [ 9, 0, 7, 3, 6, 4, 1, 8, 0 ],
  18.     [ 5, 0, 6, 0, 8, 1, 0, 7, 4 ],
  19.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
  20. ];

  21. my $sudo3 = [    # 0.620s
  22.     [ 8, 0, 0, 0, 0, 0, 0, 0, 0 ],
  23.     [ 0, 0, 3, 6, 0, 0, 0, 0, 0 ],
  24.     [ 0, 7, 0, 0, 9, 0, 2, 0, 0 ],
  25.     [ 0, 5, 0, 0, 0, 7, 0, 0, 0 ],
  26.     [ 0, 0, 0, 0, 4, 5, 7, 0, 0 ],
  27.     [ 0, 0, 0, 1, 0, 0, 0, 3, 0 ],
  28.     [ 0, 0, 1, 0, 0, 0, 0, 6, 8 ],
  29.     [ 0, 0, 8, 5, 0, 0, 0, 1, 0 ],
  30.     [ 0, 9, 0, 0, 0, 0, 4, 0, 0 ],
  31. ];

  32. my $sudo9 = [    # 0.536s
  33.     [ 0, 0, 0, 0, 0, 0, 8, 0, 0 ],
  34.     [ 0, 0, 2, 0, 7, 0, 0, 4, 0 ],
  35.     [ 0, 0, 0, 3, 0, 0, 6, 0, 1 ],
  36.     [ 6, 0, 0, 1, 0, 0, 0, 0, 5 ],
  37.     [ 0, 0, 9, 0, 4, 0, 0, 0, 0 ],
  38.     [ 0, 0, 0, 0, 5, 7, 0, 0, 0 ],
  39.     [ 0, 0, 7, 0, 0, 5, 0, 9, 0 ],
  40.     [ 3, 0, 0, 0, 0, 0, 1, 0, 8 ],
  41.     [ 0, 8, 0, 0, 0, 0, 0, 0, 0 ],
  42. ];

  43. init();

  44. play($sudo9);   # for 1 .. 10;

  45. # play($sudo3);

  46. # ____________________SUB____________________
  47. sub init {
  48.     for my $i ( 0 .. 8 ) {
  49.         my $i3 = 3 * int( $i / 3 );

  50.         for my $j ( 0 .. 8 ) {
  51.             $HOVER[$i][$j] = int( $j / 3 ) + $i3;
  52.         }
  53.     }

  54.     for ( my $n = 0 ; $n < ERROR ; $n += 2 ) {
  55.         for my $i ( 1 .. 9 ) {
  56.             next if $n & 1 << $i;
  57.             push @{ $MAYBE[$n] }, $i;
  58.         }
  59.     }
  60. }

  61. sub play {
  62.     my $sudo = shift;
  63.     @VERTI = @HORIS = @BLOKE = (0) x 9;
  64.     @GIMME = ();
  65.     $DIT   = 0;

  66.     for my $i ( 0 .. 8 ) {
  67.         for my $j ( 0 .. 8 ) {
  68.             my $k = $HOVER[$i][$j];

  69.             if ( !$sudo->[$i][$j] ) {
  70.                 push @GIMME, [ $i, $j, $k ];
  71.                 next;
  72.             }

  73.             $VERTI[$j] |= 1 << $sudo->[$i][$j];
  74.             $HORIS[$i] |= 1 << $sudo->[$i][$j];
  75.             $BLOKE[$k] |= 1 << $sudo->[$i][$j];
  76.         }
  77.     }

  78.     $LOST = @GIMME + 1;
  79.     $DAT  = $#GIMME;
  80.     explore($sudo);
  81. }

  82. sub best {
  83.     my ( $min, $best, $posi ) = ( MIN, FINISH, $DAT );

  84.     for my $that ( $DIT .. $DAT ) {
  85.         my ( $i, $j, $k ) = @{ $GIMME[$that] };
  86.         my $this = $HORIS[$i] | $VERTI[$j] | $BLOKE[$k];

  87.         return ERROR if $this == ERROR;

  88.         my $maybe = @{ $MAYBE[$this] };

  89.         if ( $min > $maybe ) {
  90.             $posi = $that;
  91.             $best = $this;
  92.             last if $maybe == BEST;
  93.             $min = $maybe;
  94.         }
  95.     }

  96.     @GIMME[ $DIT, $posi ] = @GIMME[ $posi, $DIT ];
  97.     $DIT++;
  98.     return $best;
  99. }

  100. sub explore {
  101.     my $sudo = shift;
  102.     return if $DIT == $LOST;

  103.     my $this = best();
  104.     return if $this == ERROR;
  105.     echo($sudo) if $this == FINISH;

  106.     my ( $i, $j, $k ) = @{ $GIMME[ $DIT - 1 ] };
  107.     for my $n ( @{ $MAYBE[$this] } ) {
  108.         my $that = 1 << $n;
  109.         $sudo->[$i][$j] = $n;
  110.         $HORIS[$i] |= $that;
  111.         $VERTI[$j] |= $that;
  112.         $BLOKE[$k] |= $that;
  113.         explore($sudo);
  114.         $HORIS[$i] ^= $that;
  115.         $VERTI[$j] ^= $that;
  116.         $BLOKE[$k] ^= $that;
  117.     }
  118.     $sudo->[$i][$j] = 0;
  119.     $DIT--;
  120. }

  121. sub echo {
  122.     my ( $sudo, $i ) = @_;
  123.     for my $A (@$sudo) {
  124.         say '' if !( $i++ % 3 );
  125.         say " @$A[0..2]  @$A[3..5]  @$A[6..8]";
  126.     }
  127. }

  128. __DATA__
  129. $_

复制代码

评分

参与人数 1信誉积分 +6 收起 理由
523066680 + 6 速度飞快!

查看全部评分

论坛徽章:
145
技术图书徽章
日期:2013-10-01 15:32:13戌狗
日期:2013-10-25 13:31:35金牛座
日期:2013-11-04 16:22:07子鼠
日期:2013-11-18 18:48:57白羊座
日期:2013-11-29 10:09:11狮子座
日期:2013-12-12 09:57:42白羊座
日期:2013-12-24 16:24:46辰龙
日期:2014-01-08 15:26:12技术图书徽章
日期:2014-01-17 13:24:40巳蛇
日期:2014-02-18 14:32:59未羊
日期:2014-02-20 14:12:13白羊座
日期:2014-02-26 12:06:59
发表于 2017-09-18 09:44 |显示全部楼层
回复 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();

论坛徽章:
145
技术图书徽章
日期:2013-10-01 15:32:13戌狗
日期:2013-10-25 13:31:35金牛座
日期:2013-11-04 16:22:07子鼠
日期:2013-11-18 18:48:57白羊座
日期:2013-11-29 10:09:11狮子座
日期:2013-12-12 09:57:42白羊座
日期:2013-12-24 16:24:46辰龙
日期:2014-01-08 15:26:12技术图书徽章
日期:2014-01-17 13:24:40巳蛇
日期:2014-02-18 14:32:59未羊
日期:2014-02-20 14:12:13白羊座
日期:2014-02-26 12:06:59
发表于 2017-09-18 10:14 |显示全部楼层
重点在这....
        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;


评分

参与人数 1信誉积分 +6 收起 理由
523066680 + 6 非常清晰

查看全部评分

论坛徽章:
145
技术图书徽章
日期:2013-10-01 15:32:13戌狗
日期:2013-10-25 13:31:35金牛座
日期:2013-11-04 16:22:07子鼠
日期:2013-11-18 18:48:57白羊座
日期:2013-11-29 10:09:11狮子座
日期:2013-12-12 09:57:42白羊座
日期:2013-12-24 16:24:46辰龙
日期:2014-01-08 15:26:12技术图书徽章
日期:2014-01-17 13:24:40巳蛇
日期:2014-02-18 14:32:59未羊
日期:2014-02-20 14:12:13白羊座
日期:2014-02-26 12:06:59
发表于 2017-09-18 10:41 |显示全部楼层
提高 %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;


论坛徽章:
12
子鼠
日期:2014-10-11 16:46:482016科比退役纪念章
日期:2018-03-16 10:24:0515-16赛季CBA联赛之山东
日期:2017-11-10 14:32:142016科比退役纪念章
日期:2017-09-02 15:42:4715-16赛季CBA联赛之佛山
日期:2017-08-28 17:11:5515-16赛季CBA联赛之浙江
日期:2017-08-24 16:55:1715-16赛季CBA联赛之青岛
日期:2017-08-17 19:55:2415-16赛季CBA联赛之天津
日期:2017-06-29 10:34:4315-16赛季CBA联赛之四川
日期:2017-05-16 16:38:55黑曼巴
日期:2016-07-19 15:03:112015亚冠之萨济拖拉机
日期:2015-05-22 11:38:5315-16赛季CBA联赛之北京
日期:2019-08-13 17:30:53
发表于 2017-09-18 11:23 |显示全部楼层
本帖最后由 523066680 于 2017-09-18 12:46 编辑

回复 6# jason680

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

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

  1. use integer;
  2. use strict;

  3. my @A = qw(
  4. 1 4 0 9 6 8 0 0 0
  5. 0 0 0 0 0 0 9 0 0
  6. 6 0 0 0 5 7 3 0 0
  7. 0 0 0 0 0 0 0 0 7
  8. 3 0 0 0 0 0 8 4 0
  9. 0 0 0 1 9 6 5 0 0
  10. 0 7 0 0 0 0 4 0 5
  11. 4 0 6 0 1 0 0 3 0
  12. 0 0 0 0 0 0 0 0 0
  13. );

  14. our @unsolve = grep { ! $A[$_] } ( 0 .. $#A );

  15. solve(0);

  16. sub solve
  17. {
  18.     my ( $prev ) = @_;

  19.     my $i;
  20.     for my $index ( $prev .. $#unsolve )
  21.     {
  22.         $i = $unsolve[$index];   
  23.         my %t =
  24.             map {
  25.                ($_ / 9 == $i / 9 ||
  26.                 $_ % 9 == $i % 9 ||
  27.                 $_ / 27 == $i / 27 && $_ % 9 / 3 == $i % 9 / 3
  28.                 ? $A[$_] : 0 ), 1;
  29.             }
  30.             0 .. 80;
  31.         
  32.         for (grep !$t{$_}, 1 .. 9)
  33.         {
  34.             $A[$i] = $_;
  35.             solve( $prev+1 );
  36.         }
  37.         return $A[$i] = 0;
  38.     }

  39.     $i = 0;
  40.     for ( @A )
  41.     {
  42.         print "-----+-----+-----\n" if !( $i % 27 ) && $i;
  43.         print !($i%9) ? '': $i%3 ? ' ' : '|', $_;
  44.         print "\n" unless ++$i%9;
  45.     }
  46.     print "\n";
  47. }
复制代码

在我的电脑上  跑这道题 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代码以及我二楼的代码)。



论坛徽章:
12
子鼠
日期:2014-10-11 16:46:482016科比退役纪念章
日期:2018-03-16 10:24:0515-16赛季CBA联赛之山东
日期:2017-11-10 14:32:142016科比退役纪念章
日期:2017-09-02 15:42:4715-16赛季CBA联赛之佛山
日期:2017-08-28 17:11:5515-16赛季CBA联赛之浙江
日期:2017-08-24 16:55:1715-16赛季CBA联赛之青岛
日期:2017-08-17 19:55:2415-16赛季CBA联赛之天津
日期:2017-06-29 10:34:4315-16赛季CBA联赛之四川
日期:2017-05-16 16:38:55黑曼巴
日期:2016-07-19 15:03:112015亚冠之萨济拖拉机
日期:2015-05-22 11:38:5315-16赛季CBA联赛之北京
日期:2019-08-13 17:30:53
发表于 2017-09-18 12:13 |显示全部楼层
本帖最后由 523066680 于 2017-09-18 14:37 编辑

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

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

题目
140968000000000900600057300000000007300000840000196500070000405406010030000000000

数字1的可能分布情况
140968000000001900600057310010000007300000841000196500071000405406010030000000100
140968000000001900600057310000000107310000840000196500071000405406010030000000001
140968000000001900600057301000000107310000840000196500071000405406010030000000010
140968000000001900600057301000000107310000840000196500070000415406010030001000000
140968000000001900600057301000000107301000840000196500070000415406010030010000000
140968000000001900600057301000000017310000840000196500071000405406010030000000100

完整代码:
  1. =info
  2.     523066680 2017-09
  3. =cut

  4. use File::Slurp;
  5. use IO::Handle;
  6. STDOUT->autoflush(1);

  7. # my $gamedata = eval read_file("../sudoku_nd1.txt");
  8. # grep { push @games, $gamedata->{$_} } sort keys %$gamedata;

  9. @games = ("140968000000000900600057300000000007300000840000196500070000405406010030000000000");

  10. our @order;
  11. our $answer_mat = [[]];
  12. my $mat;
  13. my $res;
  14. my $allcase;
  15. my $answer_str;

  16. #坐标对应区块位置的表
  17. our @blk = map { int($_ / 3) } ( 0..8 );

  18. while ( $index <= $#games )
  19. {
  20.     $mat = [[]];
  21.     $time_a = time();
  22.     str_to_mat( $games[$index] , $mat );

  23.     $allcase = [ map { [] } (0..9) ];
  24.     grep { possible_mat($mat, $_, $allcase->[$_], 0) } (1..9);
  25.     @order = sort { $#{$allcase->[$a]} <=> $#{$allcase->[$b]} } ( 0 .. 9 );

  26.     $res = recursive( $mat, 1 ); #起点为1,下标 0占位

  27.     if ($res == 1)
  28.     {
  29.         print_mat( $answer_mat );
  30.     }
  31.     else { die "false\n" }

  32.     printf "Game index: %d, time used: %.3fs\n\n", $index, time() - $time_a;
  33.     $index++;
  34. }

  35. sub recursive
  36. {
  37.     our (@order, $answer_mat);
  38.    
  39.     my ( $mat, $lv ) = @_;
  40.     my @case;

  41.     if ( $lv > 9 )
  42.     {
  43.         $answer_mat = $mat;
  44.         return 1;
  45.     }

  46.     $target = $order[$lv];
  47.     possible_mat($mat, $target, \@case, 0);

  48.     my $t_mat = [[]];
  49.     my $res = 0;

  50.     for my $s ( @case )
  51.     {
  52.         str_to_mat( $s, $t_mat );
  53.         $res = recursive( $t_mat, $lv+1 );
  54.         last if ($res == 1);
  55.     }

  56.     return $res;
  57. }

  58. sub possible_mat
  59. {
  60.     my ( $mat, $target, $aref, $lv ) = @_;
  61.     # level means row

  62.     my $str;
  63.     if ($lv == 9)
  64.     {
  65.         $count++;
  66.         push @$aref, mat_to_str($mat);
  67.         return 1;
  68.     }

  69.     my @cols = get_possible_column( $mat, $lv, $target );

  70.     my $res = 0;
  71.     my $ever;
  72.     for my $c ( @cols )
  73.     {
  74.         $ever = $mat->[$lv][$c];
  75.         $mat->[$lv][$c] = $target;
  76.         $res = possible_mat( $mat, $target, $aref, $lv+1 );
  77.         $mat->[$lv][$c] = $ever;
  78.     }

  79.     return $res;
  80. }

  81. sub get_possible_column
  82. {
  83.     our @blk;
  84.     my ( $mat, $row, $target ) = @_;
  85.     my @cols = ( 0..8 );

  86.     for my $c ( 0..8 )
  87.     {
  88.         #如果当前行已经存在这个数字,则直接返回这个数字的位置。
  89.         if ( $mat->[$row][$c] == $target )
  90.         {
  91.             return ( $c );
  92.         }
  93.         elsif ( $mat->[$row][$c] != 0 )
  94.         {
  95.             $cols[$c] = -1;
  96.         }

  97.         for my $r ( 0..8 )
  98.         {
  99.             if ( $mat->[$r][$c] == $target )
  100.             {
  101.                 $cols[$c] = -1;
  102.                 if ( $blk[$r] == $blk[$row] )
  103.                 {
  104.                     $cols[ $blk[$c] * 3 + 0] = -1;
  105.                     $cols[ $blk[$c] * 3 + 1] = -1;
  106.                     $cols[ $blk[$c] * 3 + 2] = -1;
  107.                 }
  108.             }
  109.         }
  110.     }

  111.     return grep { $_ != -1 } @cols;
  112. }

  113. sub str_to_mat
  114. {
  115.     my ( $str, $mat ) = @_;
  116.     my $idx = 0;

  117.     for my $row ( 0 .. 8 )
  118.     {
  119.         for my $col ( 0 .. 8 )
  120.         {
  121.             $mat->[$row][$col] = substr( $str, $idx++, 1 );
  122.         }
  123.     }
  124. }

  125. sub mat_to_str
  126. {
  127.     my ( $mat ) = @_;
  128.     return join("", map { join("", @{$mat->[$_]} ) } (0..8));
  129. }

  130. sub print_mat
  131. {
  132.     my ($mat) = @_;
  133.     grep { print join(",", @{$mat->[$_]} ),"\n" } ( 0..8 );
  134. }
复制代码

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

论坛徽章:
7
戌狗
日期:2013-12-15 20:43:38技术图书徽章
日期:2014-03-05 01:33:12技术图书徽章
日期:2014-03-15 20:31:17未羊
日期:2014-03-25 23:48:20丑牛
日期:2014-04-07 22:37:44巳蛇
日期:2014-04-11 21:58:0915-16赛季CBA联赛之青岛
日期:2016-03-17 20:36:13
发表于 2017-09-19 04:13 |显示全部楼层
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;
复制代码
您需要登录后才可以回帖 登录 | 注册

本版积分规则 发表回复

  

北京盛拓优讯信息技术有限公司. 版权所有 京ICP备16024965号-6 北京市公安局海淀分局网监中心备案编号:11010802020122 niuxiaotong@pcpop.com 17352615567
未成年举报专区
中国互联网协会会员  联系我们:huangweiwei@itpub.net
感谢所有关心和支持过ChinaUnix的朋友们 转载本站内容请注明原作者名及出处

清除 Cookies - ChinaUnix - Archiver - WAP - TOP