[puzzle]华容道 15-Puzzle

头像
523066680
Administrator
Administrator
帖子: 453
注册时间: 2016年07月19日 12:14
拥有现金: 锁定
储蓄: 锁定
Has thanked: 46 times
Been thanked: 77 times
联系:

[puzzle]华容道 15-Puzzle

帖子 #1 523066680 » 2019年03月25日 10:20

wikipedia 关键词:
Klotski
Rush Hour (puzzle)
15 Puzzle Game

4x4的华容道

代码: 全选

 1  2  3  4
 5  6  7  8
 9 10 11 12
13 14 15  0


其中0是空位,随机打乱,通过平移得到有序的排列。

头像
523066680
Administrator
Administrator
帖子: 453
注册时间: 2016年07月19日 12:14
拥有现金: 锁定
储蓄: 锁定
Has thanked: 46 times
Been thanked: 77 times
联系:

Re: [Puzzle]华容道

帖子 #2 523066680 » 2019年03月25日 19:30

Rosettacode 网站上摘取的,Perl TK 做的同款游戏。

perltk_15puzzle.png


Code: [全选] [展开/折叠] [Download] (15-Puzzle.pl)
  1. # http://rosettacode.org/wiki/15_Puzzle_Game#Perl
  2.  
  3. use strict;
  4. use warnings;
  5.  
  6. use Getopt::Long;
  7. use List::Util 1.29 qw(shuffle pairmap first all);
  8. use Tk;
  9.     # 5 options                                 1 label text
  10. my ($verbose,@fixed,$nocolor,$charsize,$extreme,$solvability);
  11.  
  12. unless (GetOptions (
  13.                      'verbose!' => \$verbose,
  14.                      'tiles|positions=i{16}' => \@fixed,
  15.                      'nocolor' => \$nocolor,
  16.                      'charsize|size|c|s=i' => \$charsize,
  17.                      'extreme|x|perl' => \$extreme,
  18.                     )
  19.         ) { die "invalid arguments!";}
  20.  
  21. @fixed = &check_req_pos(@fixed) if @fixed;
  22.  
  23. my $mw = Tk::MainWindow->new(-bg=>'black',-title=>'Giuoco del 15');
  24.  
  25. if ($nocolor){ $mw->optionAdd( '*Button.background',   'ivory' );}
  26.  
  27. $mw->optionAdd('*Button.font', 'Courier '.($charsize or 16).' bold' );
  28. $mw->bind('<Control-s>', sub{#&init_board;
  29.                              &shuffle_board});
  30.  
  31. my $top_frame = $mw->Frame( -borderwidth => 2, -relief => 'groove',
  32.                            )->pack(-expand => 1, -fill => 'both');
  33.  
  34. $top_frame->Label( -textvariable=>\$solvability,
  35.                   )->pack(-expand => 1, -fill => 'both');
  36.  
  37. my $game_frame = $mw->Frame(  -background=>'saddlebrown',
  38.                               -borderwidth => 10, -relief => 'groove',
  39.                             )->pack(-expand => 1, -fill => 'both');
  40.  
  41. # set victory conditions in pairs of coordinates
  42. my @vic_cond =  pairmap {
  43.        [$a,$b]
  44.     } qw(0 0 0 1 0 2 0 3
  45.          1 0 1 1 1 2 1 3
  46.          2 0 2 1 2 2 2 3
  47.          3 0 3 1 3 2 3 3);
  48.  
  49. my $board = [];
  50.  
  51. my $victorious = 0;
  52.  
  53. &init_board;
  54.  
  55. if ( $extreme ){ &extreme_perl}
  56.  
  57. &shuffle_board;
  58.  
  59. MainLoop;
  60.  
  61. ################################################################################
  62. sub init_board{
  63.   # tiles from 1 to 15
  64.   for (0..14){
  65.      $$board[$_]={
  66.           btn=>$game_frame->Button(
  67.                             -text => $_+1,
  68.                             -relief => 'raised',
  69.                             -borderwidth => 3,
  70.                             -height => 2,
  71.                             -width =>  4,
  72.                                   -background=>$nocolor?'ivory':'gold1',
  73.                                   -activebackground => $nocolor?'ivory':'gold1',
  74.                                   -foreground=> $nocolor?'black':'DarkRed',
  75.                                   -activeforeground=>$nocolor?'black':'DarkRed'
  76.           ),
  77.           name => $_+1,     # x and y set by shuffle_board
  78.      };
  79.      if (($_+1) =~ /^(2|4|5|7|10|12|13|15)$/ and !$nocolor){
  80.          $$board[$_]{btn}->configure(
  81.                                   -background=>'DarkRed',
  82.                                   -activebackground => 'DarkRed',
  83.                                   -foreground=> 'gold1',
  84.                                   -activeforeground=>'gold1'
  85.          );
  86.      }
  87.    }
  88.    # empty tile
  89.    $$board[15]={
  90.           btn=>$game_frame->Button(
  91.                             -relief => 'sunken',
  92.                             -borderwidth => 3,
  93.                             -background => 'lavender',
  94.                             -height => 2,
  95.                             -width =>  4,
  96.           ),
  97.           name => 16,      # x and y set by shuffle_board
  98.      };
  99. }
  100. ################################################################################
  101. sub shuffle_board{
  102.     if ($victorious){
  103.         $victorious=0;
  104.         &init_board;
  105.     }
  106.     if (@fixed){
  107.           my $index = 0;
  108.  
  109.           foreach my $tile(@$board[@fixed]){
  110.                   my $xy = $vic_cond[$index];
  111.                   ($$tile{x},$$tile{y}) = @$xy;
  112.                   $$tile{btn}->grid(-row=>$$xy[0], -column=> $$xy[1]);
  113.                   $$tile{btn}->configure(-command =>[\&move,$$xy[0],$$xy[1]]);
  114.                   $index++;
  115.           }
  116.           undef @fixed;
  117.     }
  118.     else{
  119.         my @valid = shuffle (0..15);
  120.         foreach my $tile ( @$board ){
  121.             my $xy = $vic_cond[shift @valid];
  122.             ($$tile{x},$$tile{y}) = @$xy;
  123.             $$tile{btn}->grid(-row=>$$xy[0], -column=> $$xy[1]);
  124.             $$tile{btn}->configure(-command => [ \&move, $$xy[0], $$xy[1] ]);
  125.         }
  126.     }
  127.     my @appear =  map {$_->{name}==16?'X':$_->{name}}
  128.                   sort{$$a{x}<=>$$b{x}||$$a{y}<=>$$b{y}}@$board;
  129.     print "\n".('-' x 57)."\n".
  130.           "Appearence of the board:\n[@appear]\n".
  131.           ('-' x 57)."\n".
  132.           "current\tfollowers\t               less than current\n".
  133.           ('-' x 57)."\n" if $verbose;
  134.     # remove the, from now on inutile, 'X' for the empty space
  135.     @appear = grep{$_ ne 'X'} @appear;
  136.     my $permutation;
  137.     foreach my $num (0..$#appear){
  138.         last if $num == $#appear;
  139.          my $perm;
  140.           $perm += grep {$_ < $appear[$num]} @appear[$num+1..$#appear];
  141.           if ($verbose){
  142.             print "[$appear[$num]]\t@appear[$num+1..$#appear]".
  143.             (" " x (37 - length "@appear[$num+1..$#appear]")).
  144.             "\t   $perm ".($num == $#appear  - 1 ? '=' : '+')."\n";
  145.           }
  146.           $permutation+=$perm;
  147.     }
  148.     print +(' ' x 50)."----\n" if $verbose;
  149.     if ($permutation % 2){
  150.         print "Impossible game with odd permutations!".(' ' x 13).
  151.               "$permutation\n"if $verbose;
  152.         $solvability = "Impossible game with odd permutations [$permutation]\n".
  153.                         "(ctrl-s to shuffle)".
  154.                         (($verbose or $extreme) ? '' :
  155.                            " run with --verbose to see more info");
  156.         return;
  157.     }
  158.     # 105 is the max permutation
  159.     my $diff =  $permutation == 0 ? 'SOLVED' :
  160.                 $permutation < 35 ? 'EASY  ' :
  161.                 $permutation < 70 ? 'MEDIUM' : 'HARD  ';
  162.     print "$diff game with even permutations".(' ' x 17).
  163.           "$permutation\n" if $verbose;
  164.     $solvability = "$diff game with permutation parity of [$permutation]\n".
  165.                     "(ctrl-s to shuffle)";
  166. }
  167. ################################################################################
  168. sub move{
  169.     # original x and y
  170.     my ($ox, $oy) = @_;
  171.     my $self = first{$_->{x} == $ox and $_->{y} == $oy} @$board;
  172.     return if $$self{name}==16;
  173.     # check if one in n,s,e,o is the empty one
  174.     my $empty = first {$_->{name} == 16 and
  175.                           ( ($_->{x}==$ox-1 and $_->{y}==$oy) or
  176.                             ($_->{x}==$ox+1 and $_->{y}==$oy) or
  177.                             ($_->{x}==$ox and $_->{y}==$oy-1) or
  178.                             ($_->{x}==$ox and $_->{y}==$oy+1)
  179.                            )
  180.                       } @$board;
  181.     return unless $empty;
  182.     # empty x and y
  183.     my ($ex,$ey) = ($$empty{x},$$empty{y});
  184.     # reconfigure emtpy tile
  185.     $$empty{btn}->grid(-row => $ox, -column => $oy);
  186.     $$empty{x}=$ox;    $$empty{y}=$oy;
  187.     # reconfigure pressed tile
  188.     $$self{btn}->grid(-row => $ex, -column => $ey);
  189.     $$self{btn}->configure(-command => [ \&move, $ex, $ey ]);
  190.     $$self{x}=$ex;    $$self{y}=$ey;
  191.     # check for victory if the empty one is at the bottom rigth tile (3,3)
  192.     &check_win if $$empty{x} == 3 and $$empty{y} == 3;
  193. }
  194. ################################################################################
  195. sub check_win{
  196.      foreach my $pos (0..$#$board){
  197.         return unless ( $$board[$pos]->{'x'} == $vic_cond[$pos]->[0] and
  198.                         $$board[$pos]->{'y'} == $vic_cond[$pos]->[1]);
  199.      }
  200.      # victory!
  201.      $victorious = 1;
  202.      my @text =  ('Dis','ci','pu','lus','15th','','','at',
  203.                   'P','e','r','l','M','o','n','ks*');
  204.      foreach my $tile(@$board){
  205.             $$tile{btn}->configure( -text=> shift @text,
  206.                                     -command=>sub{return});
  207.             $mw->update;
  208.             sleep 1;
  209.      }
  210. }
  211. ################################################################################
  212. sub check_req_pos{
  213.     my @wanted = @_;
  214.     # fix @wanted: seems GetOptions does not die if more elements are passed
  215.     @wanted = @wanted[0..15];
  216.     my @check = (1..16);
  217.     unless ( all {$_ == shift @check} sort {$a<=>$b} @wanted ){
  218.         die "tiles must be from 1 to 16 (empty tile)\nyou passed [@wanted]\n";
  219.     }
  220.     return map {$_-1} @wanted;
  221. }
  222. ################################################################################
  223. sub extreme_perl {
  224.   $verbose = 0;
  225.   $mw->optionAdd('*font', 'Courier 20 bold');
  226.   my @extreme = (
  227.     'if $0',                               #1
  228.     "\$_=\n()=\n\"foo\"=~/o/g",            #2
  229.     "use warnings;\n\$^W ?\nint((length\n'Discipulus')/3)\n:'15'",   #3
  230.     "length \$1\nif \$^X=~\n\/(?:\\W)(\\w*)\n(?:\\.exe)\$\/", #4
  231.     "use Config;\n\$Config{baserev}",                   #5.
  232.     "(split '',\nvec('JAPH'\n,1,8))[0]",       #6
  233.     "scalar map\n{ord(\$_)=~/1/g}\nqw(p e r l)", #7
  234.     "\$_ = () =\n'J A P H'\n=~\/\\b\/g",   # 8
  235.     "eval join '+',\nsplit '',\n(substr\n'12345',3,2)",  #9
  236.     'printf \'%b\',2',                     #10
  237.    "int(((1+sqrt(5))\n/ 2)** 7 /\nsqrt(5)+0.5)-2",    #11
  238.    "split '',\nunpack('V',\n01234567))\n[6,4]",  # 12
  239.    'J','A','P','H'                               # 13..16
  240.  );
  241.  foreach (0..15){
  242.      $$board[$_]{btn}->configure(-text=> $extreme[$_],
  243.                                 -height => 8,
  244.                                  -width =>  16, ) if $extreme[$_];
  245.  
  246.  }
  247.  @fixed = qw(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15);
  248.  $mw->after(5000,\&shuffle_board);#
  249. }
您没有权限查看这个主题的附件。


回到 “算法和编码”

在线用户

用户浏览此论坛: 没有注册用户 和 0 访客