Perl 的能力体现 -- Tk 版

[netken]

Perl不只会做CGI
真的，不信来这里看看
在看这些东西之前，你需要
Linux: Perl 5.6.0 or greater,Tk 800 or greater
Win32: ActivePerl 5.6.0 or greater,ppm Tk 800 or greater
好了，安装完这些东西，那就尝试一下下面的代码吧
看看 Perl 都做了什么

[ExitWindows]

up

[netken]

Perl写的saolei,only 4,908字节

#!/usr/bin/perl
# writen by NetKen.
use Tk;

$max = 15;#line number
$bomb = 20;#Bomb! number

$win = MainWindow->new( "-title"=>"Perl/Tk 扫雷!" );

startbutton();
label();

MainLoop();

sub startbutton {
$start_room = $win->Frame()->pack( '-side'=>'top' );
$start_button = $start_room->Button ( "-text"=>"START" , "-width"=>$max , "-height"=>1 , "-font"=>"-adobe-helvetica-bold-b-narrow--18-180-80-80-p-80-iso8859" , "-foreground"=>"red" , "-command"=>\&start )->pack ( "-side"=>"top" );
};

sub start {
$start_button->destroy();
format_array();
level();
};

sub restart {
for (my $i=0;$i<$max ;$i++)
{
my $n_i = "$i";$n_i = "0$i" if $i<10;
my $button_room_name = "button_room"."$i";
${$button_room_name}->destroy();
for (my $j=0;$j<$max ;$j++) {
my $n_j = "$j";$n_j = "0$j" if $j<10;
my $button_name = "button".$n_i.$n_j;
undef ${$button_name};
}
}

$start_button->configure ( "-text"=>"START" , "-command"=> \&start );
};

sub label {
$label = $win->Label ( "-text"=>"Kick Bomb! - START!" , "-width"=>($max-1)*2 , "-height"=>2 , "-font"=>"-adobe-verdana-bold-r-narrow--18-180-80-80-p-80-iso8859")->pack( "-side"=>"top" );
};

sub format_array {
undef @array;
for (my $k=0;$k<$bomb+1 ;$k++) {
srand(rand($max*100));
my $number = rand($max*100);
$number=int($number);
$number+=$max if $number<$max;
my $i = $number % $max;
my $j = int(( $number - $j ) / $max);
$array[$i][$j] = "0";
}
for (my $i=0;$i<$max ;$i++ ) {
for (my $j=0;$j<$max ;$j++ ) {
if ($array[$i][$j] eq "0") {
$array[$i-1][$j]++ if $i>0 and $array[$i-1][$j] ne "0";
$array[$i+1][$j]++ if $i<$max-1 and $array[$i+1][$j] ne "0";
$array[$i][$j-1]++ if $j>0 and $array[$i][$j-1] ne "0";
$array[$i][$j+1]++ if $j<$max-1 and $array[$i][$j+1] ne "0";
$array[$i-1][$j-1]++ if $i>0 and $j>0 and $array[$i-1][$j-1] ne "0";
$array[$i+1][$j+1]++ if $i<$max-1 and $j<$max-1 and $array[$i+1][$j+1] ne "0";
$array[$i-1][$j+1]++ if $i>0 and $j<$max-1 and $array[$i-1][$j+1] ne "0";
$array[$i+1][$j-1]++ if $i<$max-1 and $j>0 and $array[$i+1][$j-1] ne "0";
}
}
}
};

sub level {
for (my $i=0;$i<$max ;$i++)
{
my $n_i = "$i";$n_i = "0$i" if $i<10;
my $button_room_name = "button_room"."$i";
$eval .= '$'."$button_room_name".'=$win->Frame()->pack("-side"=>"top");';
for (my $j=0;$j<$max ;$j++) {
my $n_j = "$j";$n_j = "0$j" if $j<10;
my $button_name = "button".$n_i.$n_j;
$eval .= '$'."$button_name".'=$'."$button_room_name".'->Button("-text"=>"?","-width"=>1,"-height"=>1,"-command"=>[\&change_button,'."$i,$j".'])->pack("-side"=>"left");';
}
}
eval $eval;
undef $eval;
};

# 如果为 null ,则 flat ,如果有数字 则 ridge
sub change_button {
my $i = shift;
my $j = shift;
my $n_i = "$i";$n_i = "0$i" if $i<10;
my $n_j = "$j";$n_j = "0$j" if $j<10;
if ($array[$i][$j] eq "0") {
gameover();
} else {
unless ($array[$i][$j]) {
disp_blank($i,$j);
} else {
${"button".$n_i.$n_j}->configure ( "-text"=>"$array[$i][$j]" , "-relief"=>"ridge" );
}
}
};

sub disp_blank {
my $i = shift;
my $j = shift;

my $m_i = "$i";$m_i = "0$i" if $i<10;
my $m_j = "$j";$m_j = "0$j" if $j<10;

${"button".$m_i.$m_j}->configure ( "-text"=>"$array[$i][$j]" , "-relief"=>"flat" );

if ($i>0 and $array[$i-1][$j] eq "" ) {
my $num_i = $i-1;
my $n_i = "$num_i";$n_i = "0$num_i" if $num_i<10;
my $n_j = "$j";$n_j = "0$j" if $j<10;
my $state = ${"button".$n_i.$n_j}->cget ( "-relief" );
disp_blank($i-1,$j) unless $state eq "flat";
}
if ( $j>0 and $array[$i][$j-1] eq "" ) {
my $num_j = $j-1;
my $n_i = "$i";$n_i = "0$i" if $i<10;
my $n_j = "$num_j";$n_j = "0$num_j" if $num_j<10;
my $state = ${"button".$n_i.$n_j}->cget ( "-relief" );
disp_blank($i,$j-1) unless $state eq "flat";
}
if ( $i<$max-1 and $array[$i+1][$j] eq "" ) {
my $num_i = $i+1;
my $n_i = "$num_i";$n_i = "0$num_i" if $num_i<10;
my $n_j = "$j";$n_j = "0$j" if $j<10;
my $state = ${"button".$n_i.$n_j}->cget ( "-relief" );
disp_blank($i+1,$j) unless $state eq "flat";
}
if ( $j<$max-1 and $array[$i][$j+1] eq "" ) {
my $num_j = $j+1;
my $n_i = "$i";$n_i = "0$i" if $i<10;
my $n_j = "$num_j";$n_j = "0$num_j" if $num_j<10;
my $state = ${"button".$n_i.$n_j}->cget ( "-relief" );
disp_blank($i,$j+1) unless $state eq "flat";
}


};

sub gameover {
for (my $i=0;$i<$max ;$i++ ) {
for (my $j=0;$j<$max ;$j++ ) {
my $n_i = "$i";$n_i = "0$i" if $i<10;
my $n_j = "$j";$n_j = "0$j" if $j<10;
${"button".$n_i.$n_j}->configure ( "-text"=>"X" , "-foreground"=>"red" , "-background"=>"black" ) if $array[$i][$j] eq "0";
}
}
$start_button = $start_room->Button ( "-text"=>"RESTART" , "-width"=>$max , "-height"=>1 , "-font"=>"-adobe-helvetica-bold-b-narrow--18-180-80-80-p-80-iso8859" , "-foreground"=>"red" , "-command"=>\&restart )->pack ( "-side"=>"top" );
$label->configure ( "-text"=>"Bomb... Oh~ u r FAILED!" );
};

[netken]

sigh.看来大家对tk不敢兴趣？
上面那个扫雷写的很烂，
我再来贴一个吧，是贪吃蛇 , 一共 3,482 个字节
总想不通，tk那么好的东西，为什么不用呢？
配合上perl,无敌啊....;)
#!/usr/bin/perl
# writen by NetKen.
use Tk;
use strict;

my $max_width = 32;
my $max_height = 24;
my $snake_size=15;
my $speed = 200;

my($new_snake_x,$new_snake_y);

my @snake_pos = ( [$snake_size,$snake_size] , [$snake_size,$snake_size*2] , [$snake_size,$snake_size*3] , [$snake_size,$snake_size*4] );
my $last="d";
my $dir="d";

my $win = MainWindow->new( '-title'=>'Perl/Tk Snake!' );

my $canvas = $win->Canvas( '-width'=>$max_width*$snake_size,'-height'=>$max_height*$snake_size,'-relief'=>'ridge','-border'=>1)->pack();

$canvas->create('text',$max_width*$snake_size/2,$max_height*$snake_size/2,'-anchor'=>'center','-text'=>'Double Press Mouse Button 1 --> START or RESTART','-fill'=>'white');

foreach my $tmp (@snake_pos) {
my $box = $canvas->create('rectangle',$$tmp[0],$$tmp[1],$$tmp[0]+$snake_size-2,$$tmp[1]+$snake_size-2,'-fill'=>'black','-tag'=>'box');
}

$win->bind('<Left>',sub {$dir="l"} );
$win->bind('<Right>',sub {$dir="r"} );
$win->bind('<Up>',sub {$dir="u"} );
$win->bind('<Down>',sub {$dir="d"} );

$win->bind('<Double-1>',sub {
@snake_pos = ( [$snake_size,$snake_size] , [$snake_size,$snake_size*2] , [$snake_size,$snake_size*3] , [$snake_size,$snake_size*4] );
$last="d";
$dir="d";
$canvas->delete('gameover');
$canvas->delete('new_snake');

#->
rand_new_snake();
new_snake($new_snake_x,$new_snake_y);
#-<

snake();
});

MainLoop();

sub snake {
my($x,$y,$nodir);
if ($dir eq "l") {
$x = -$snake_size;
$y = 0;
$nodir = "r";
} elsif ($dir eq "r") {
$x = $snake_size;
$y = 0;
$nodir = "l";
} elsif ($dir eq "u") {
$x = 0;
$y = -$snake_size;
$nodir = "d";
} elsif ($dir eq "d") {
$x = 0;
$y = $snake_size;
$nodir = "u";
}

my $new_x = $snake_pos[@snake_pos-1][0]+$x;
my $new_y = $snake_pos[@snake_pos-1][1]+$y;

if ($new_x < 1 or $new_x > $max_width*$snake_size-1 or $new_y < 1 or $new_y > $max_height*$snake_size-1) {gameover();return;}


foreach my $tmp (@snake_pos) {
if ($new_x == $$tmp[0] and $new_y == $$tmp[1]) {gameover();return;}
}

return if $last eq $nodir;

$last = $dir;

push(@snake_pos,[$new_x,$new_y]);

#->
if ( $new_x == $new_snake_x and $new_y == $new_snake_y ) {
unshift(@snake_pos,[$snake_pos[0][0],$snake_pos[0][1]]);
$canvas->delete('new_snake');

rand_new_snake();

new_snake($new_snake_x,$new_snake_y);
}
#-<

$canvas->delete('box');

foreach my $tmp (@snake_pos) {
my $box = $canvas->create('rectangle',$$tmp[0],$$tmp[1],$$tmp[0]+$snake_size-2,$$tmp[1]+$snake_size-2,'-fill'=>'black','-tag'=>'box');
}

shift(@snake_pos);

$win->after($speed,\&snake );

};

sub gameover {
$canvas->create('text',$max_width*$snake_size/2,$max_height*$snake_size/2,'-anchor'=>'center','-text'=>'GAME OVER!','-fill'=>'red','-font'=>'-adobe-verdana-bold-r-narrow--36-360-90-90-90-p-90-iso8859','-tag'=>'gameover');
};

sub new_snake {
my($x,$y)=@_;

$canvas->create('rectangle',$x,$y,$x+$snake_size-2,$y+$snake_size-2,'-fill'=>'black','-tag'=>'new_snake');
$speed-=5 if $speed > 10;

};

sub rand_new_snake {
$new_snake_x=int rand($max_width-2);
$new_snake_y=int rand($max_height-2);
$new_snake_x++;$new_snake_y++;
$new_snake_x*=$snake_size;$new_snake_y*=$snake_size;
};

sub game_win {
$canvas->create('text',$max_width*$snake_size/2,$max_height*$snake_size/2,'-anchor'=>'center','-text'=>'YOU ARE VICTOROR!','-fill'=>'red','-font'=>'-adobe-verdana-bold-r-narrow--24-360-90-90-90-p-90-iso8859','-tag'=>'gameover');
};

[商海连横]

看来你学 perl 很久了？

[netken]

1年不到,perl的功能还很多呢，我这算是皮毛了...
想想吧，人家只用了2行，700个字节就写出了dvd解码程序，my god,那才叫厉害
....

[nan1nan1]

呵呵
netken在这里又碰上你了，那个Man.Editor咋样了？

BTW:Tk可是好东东啊。

[netken]

ha
hehe,manEditor已经处理好了ms-win和x-windows下的问题
都能正常显示了
后面的时间就开始编写个个功能函数
相信不久就可以正式推出了
good luck!

[Sunsalangane]

我主要是不知道TK是个什么东东，tk800,是不是需要我下载一个用ppm install安装？

[netken]

如果你用的是 active perl
那么直接
ppm
install Tk
等安装完成就可以了

[bjwan]

有没有 Perl/Tk的中文学习资料下载？

[netken]

很少，建议还是看英文的吧，中文的即使有，写的也很乱
英文的不是太难，差不多都可以看懂的
写的很好
直接看 pod 或者 man 就可以
windows下有 html 格式的文件，自然看着就更舒服了;)

[netken]

re oasis_me: 我只用c做过嵌入，不知道delphi可以不可以，不过有个方法，可能有点笨，但却很简单，就是系统调用某个perl,把函数作成参数型的，然后用管道把perl和其他程序连起来就可以了。我起初为方便就那么做的。
re jinandsun:注释我会尽快写的，因为最近在写一个论坛和文档管理发布系统，有点类似 csdn 的系统，所以时间上有点拉不开，现在都是早晨 7 点才睡觉，晚上写东西写累了，就来写写自己对 Perl 的感受，hoho
估计过两天就差不多了，现在论坛部分已经凑合可以用了

[oasis_me]

如果我不用perl/tk,而用delphi做一个界面，然后把perl嵌进去会很难吗

[jinandsun]

hehe ~大家把代码放上解释最好了~我好拷贝看啊~这样我看的很麻烦~有写地方看不明白或则说很多地方~谢谢~