I have patched the code to toggle the grid and added it to the menu. Most of the text is now in English as well. A couple of notes:
Here is the code (sorry to get it to fit within the space that PM allows I had to strip the comments out)
#!/usr/bin/perl
# p e n t r i s . p l © Christian Duehl
use strict;
use warnings;
use Tk;
use Tk::LabFrame;
use Tk::ErrorDialog;
package main;
my %C = (
rows => 20, #20, # 26 (FZEIL)
cols => 13, #10, # 16 (FSPALT)
rowpix => 31, # 22, # 16 (ZPIX)
colpix => 31, # 20, # 14 (SPIX)
withgrid => 1, # 1 or 0 for showing the grid or not
points => 0,
startspeed => 1000,
speed => 0,
gametype => 'Pentris',
);
my %Config = (
version => '0.0.2',
version_date => '2004-08-23',
Menuefont => '{Arial} 8 {normal}',
highscore_p => 'highscore.pentris',
highscore_t => 'highscore.tetris',
);
my %Stones;
{
my $Middle = int( $C{cols} / 2 );#-1;
%Stones = ('Tetris langer gerader Vierer' =>
{
weight => 6, # factor for random choice
color => 1, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [0, $Middle],
[0, $Middle-1],
[0, $Middle+1],
[0, $Middle+2],
],
},
'Tetris L mit Nase nach rechts' =>
{
weight => 6, # factor for random choice
color => 2, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [1, $Middle],
[0, $Middle+1],
[0, $Middle],
[2, $Middle],
],
},
'Tetris L mit Nase nach links' =>
{
weight => 6, # factor for random choice
color => 3, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [1, $Middle],
[0, $Middle-1],
[0, $Middle],
[2, $Middle],
],
},
'Tetris Winkel nach rechts' =>
{
weight => 6, # factor for random choice
color => 4, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [1, $Middle],
[0, $Middle],
[1, $Middle+1],
[2, $Middle+1],
],
},
'Tetris Winkel nach links' =>
{
weight => 6, # factor for random choice
color => 5, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [1, $Middle+1],
[0, $Middle+1],
[1, $Middle],
[2, $Middle],
],
},
'Tetris Quadrat' =>
{
weight => 6, # factor for random choice
color => 6, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [0, $Middle],
[0, $Middle+1],
[1, $Middle],
[1, $Middle+1],
],
},
'Tetris Mittelnase' =>
{
weight => 6, # factor for random choice
color => 7, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Tetris',
coords => [ [0, $Middle],
[0, $Middle-1],
[0, $Middle+1],
[1, $Middle],
],
},
'1er Quadrat' =>
{
weight => 3, # factor for random choice
color => 8, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Extra',
coords => [ [0, $Middle],
],
},
'2er gerade' => # wie auch sonst?
{
weight => 3, # factor for random choice
color => 9, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Extra',
coords => [ [0, $Middle],
[1, $Middle],
],
},
'3er gerade' => # wie auch sonst?
{
weight => 3, # factor for random choice
color => 10, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Extra',
coords => [ [0, $Middle],
[1, $Middle],
[2, $Middle],
],
},
'3er Winkel' => # wie auch sonst?
{
weight => 3, # factor for random choice
color => 11, # stone color (SF)
bonus => 0, # bonus points (SPB)
type => 'Extra',
coords => [ [0, $Middle+1],
[1, $Middle+1],
[0, $Middle],
],
},
'Pentomino I' =>
{
weight => 1, # factor for random choice
color => 12, # stone color (SF)
bonus => 10, # bonus points (SPB)
type => 'Pentris',
coords => [ [0, $Middle],
[0, $Middle-1],
[0, $Middle+1],
[0, $Middle+2],
[0, $Middle-2],
],
},
'Pentomino L Nase nach oben rechts' =>
{
weight => 1, # factor for random choice
color => 13, # stone color (SF)
bonus => 10, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[0, $Middle+1],
[2, $Middle],
[3, $Middle],
],
},
'Pentomino L Nase nach oben links' =>
{
weight => 1, # factor for random choice
color => 14, # stone color (SF)
bonus => 10, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle+1],
[0, $Middle+1],
[0, $Middle],
[2, $Middle+1],
[3, $Middle+1],
],
},
'Pentomino Y Nase nach oben rechts' =>
{
weight => 1, # factor for random choice
color => 15, # stone color (SF)
bonus => 20, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[2, $Middle],
[3, $Middle],
[1, $Middle+1],
],
},
'Pentomino Y Nase nach oben links' =>
{
weight => 1, # factor for random choice
color => 10, # stone color (SF)
bonus => 20, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle+1],
[0, $Middle+1],
[2, $Middle+1],
[3, $Middle+1],
[1, $Middle],
],
},
'Pentomino V' =>
{
weight => 1, # factor for random choice
color => 17, # stone color (SF)
bonus => 20, # bonus points (SPB)
type => 'Pentris',
coords => [ [0, $Middle-1],
[0, $Middle],
[0, $Middle+1],
[1, $Middle-1],
[2, $Middle-1],
],
},
'Pentomino T' =>
{
weight => 1, # factor for random choice
color => 18, # stone color (SF)
bonus => 15, # bonus points (SPB)
type => 'Pentris',
coords => [ [0, $Middle],
[0, $Middle+1],
[0, $Middle-1],
[1, $Middle],
[2, $Middle],
],
},
'Pentomino X' =>
{
weight => 1, # factor for random choice
color => 19, # stone color (SF)
bonus => 25, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[2, $Middle],
[1, $Middle+1],
[1, $Middle-1],
],
},
'Pentomino P Bauch nach rechts' =>
{
weight => 1, # factor for random choice
color => 20, # stone color (SF)
bonus => 15, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[2, $Middle],
[1, $Middle+1],
[0, $Middle+1],
],
},
'Pentomino P Bauch nach links' =>
{
weight => 1, # factor for random choice
color => 21, # stone color (SF)
bonus => 15, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle+1],
[0, $Middle+1],
[2, $Middle+1],
[1, $Middle],
[0, $Middle],
],
},
'Pentomino F richtigherum' =>
{
weight => 1, # factor for random choice
color => 22, # stone color (SF)
bonus => 30, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[2, $Middle],
[1, $Middle-1],
[0, $Middle+1],
],
},
'Pentomino F gespiegelt' =>
{
weight => 1, # factor for random choice
color => 23, # stone color (SF)
bonus => 30, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[2, $Middle],
[1, $Middle+1],
[0, $Middle-1],
],
},
'Pentomino U' =>
{
weight => 1, # factor for random choice
color => 24, # stone color (SF)
bonus => 20, # bonus points (SPB)
type => 'Pentris',
coords => [ [0, $Middle],
[0, $Middle-1],
[1, $Middle-1],
[1, $Middle+1],
[0, $Middle+1],
],
},
'Pentomino Z oben rechts' =>
{
weight => 1, # factor for random choice
color => 25, # stone color (SF)
bonus => 30, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[1, $Middle-1],
[1, $Middle+1],
[0, $Middle-1],
[2, $Middle+1],
],
},
'Pentomino Z oben links' =>
{
weight => 1, # factor for random choice
color => 26, # stone color (SF)
bonus => 30, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[1, $Middle-1],
[1, $Middle+1],
[2, $Middle-1],
[0, $Middle+1],
],
},
'Pentomino W' =>
{
weight => 1, # factor for random choice
color => 27, # stone color (SF)
bonus => 30, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[0, $Middle],
[0, $Middle-1],
[1, $Middle+1],
[2, $Middle+1],
],
},
'Pentomino N von links oben nach rechts unten' =>
{
weight => 1, # factor for random choice
color => 28, # stone color (SF)
bonus => 15, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle+1],
[1, $Middle],
[0, $Middle],
[2, $Middle+1],
[3, $Middle+1],
],
},
'Pentomino N von rechts oben nach links unten' =>
{
weight => 1, # factor for random choice
color => 29, # stone color (SF)
bonus => 15, # bonus points (SPB)
type => 'Pentris',
coords => [ [1, $Middle],
[1, $Middle+1],
[0, $Middle+1],
[2, $Middle],
[3, $Middle],
],
},
);
}
my @Color = ('#000000', # black = background, don't use this!
'#EE9900', # Tetris I 1
'#FF0033', # Tetris L r 2
'#2200FF', # Tetris L l 3
'#22CCCC', # Tetris N l-r 4
'#CC22CC', # Tetris N r-l 5
'#EEDD00', # Tetris square 6
'#00BB00', # Tetris T 7
'#883300', # 1er 8
'#AA5500', # 2er 9
'#CC7700', # 3er gerade 10
'#660066', # 3er Winkel 11
'#FFAA11', # Pentris I 12
'#1100CC', # Pentris L l 13
'#CC0011', # Pentris L r 14
'#00AA44', # Pentris Y r 15 x
'#AA5577', # Pentris Y l 16
'#990099', # Pentris V 17
'#009900', # Pentris T 18
'#006600', # Pentris X 19
'#1100AA', # Pentris P r 20
'#AA0011', # Pentris P l 21
'#CCCCFF', # Pentris F right 22
'#CCFFCC', # Pentris F wrong 23
'#88EEAA', # Pentris U 24 x
'#FF00FF', # Pentris Z r 25
'#00FF00', # Pentris Z l 26
'#110099', # Pentris W 27
'#11DDAA', # Pentris N l-r 28
'#DD88AA', # Pentris N r-l 29
);
runtk();
exit;
package Pentris::Base;
sub _property {
my ($self, $attr, $value) = @_;
die "no attribute given in _property" unless defined $attr;
return $self->{$attr} if @_ != 3;
my $old_value = $self->{$attr};
$self->{$attr} = $value;
return $old_value;
} # sub Pentris::Base::_property
package Pentris::Stone;
use base qw/Pentris::Base/;
sub new {
my ($ref, $type) = (@_, 'random');
my $class = (ref $ref) || $ref;
my $self = {};
bless $self, $class;
if ($type eq 'random') {
my @choice;
for my $stone (keys %Stones) {
if ($Stones{$stone}->{type} eq 'Tetris' or
$C{gametype} ne 'Tetris') {
push @choice, $stone for 0 .. $Stones{$stone}->{weight
+};
}
}
$type = $choice[ int rand scalar @choice ];
die "Undefined type" unless defined $type;
}
die "stone '$type' is not known" unless exists $Stones{$type};
$self->color ($Stones{$type}->{color});
$self->type ($type );
my @coords;
for my $square (@{ $Stones{$type}->{coords} }) {
my ($ri, $ci) = @$square;
push @coords, [ $ri, $ci ];
}
$self->coords([@coords]);
$self->bonus ($Stones{$type}->{bonus});
return $self;
} # sub RDW06::Field::new
sub color { return shift->_property('color', @_) }
sub type { return shift->_property('type', @_) }
sub coords { return shift->_property('coords', @_) }
sub bonus { return shift->_property('bonus', @_) }
package main;
sub runtk {
my $mw = new MainWindow;
$mw->title('Pentris');
my $gf = $mw->LabFrame(-label => 'Game Field',
-labelside => 'acrosstop',
)
->pack(-side => 'top',
-expand => 1,
-fill => 'both',
);
my $width = $C{colpix} * $C{cols} + 1;
my $height = $C{rowpix} * $C{rows} + 1;
my $fld = $gf->Canvas(-background => 'black',
-width => $width,
-height => $height,
)
->pack(-side => 'top',
-expand => 0,
-fill => 'none',
);
draw_grid($fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix});
{
my $fi = $mw->Frame()
->pack(-side => 'top',
-expand => 1,
-fill => 'both',
);
my $pf = $fi->LabFrame(-label => 'Game Type',
-labelside => 'acrosstop',
)
->pack(-side => 'left',
-expand => 1,
-fill => 'both',
);
$pf->Label(-textvariable => \$C{gametype})
->pack(-side => 'top',
-expand => 0,
-fill => 'none',
);
my $pp = $fi->LabFrame(-label => 'Points',
-labelside => 'acrosstop',
)
->pack(-side => 'left',
-expand => 1,
-fill => 'both',
);
$pp->Label(-textvariable => \$C{points})
->pack(-side => 'top',
-expand => 0,
-fill => 'none',
);
}
my $quit_b = $mw->Button(-text => 'End',
-command => [ \&my_exit, $mw ],
)
->pack(-side => 'top',
-padx => 10,
-pady => 2,
-expand => 1,
-fill => 'x',
);
my $menu = $mw->Menu(-type => 'menubar',
-font => $Config{Menuefont},
);
$mw->configure(-menu => $menu);
$menu->cascade(-label => 'Menu',
-underline => 0,
-font => $Config{Menuefont},
);
$menu->separator(); # the rest of the menues is at the right side
$menu->cascade(-label => 'Help',
-underline => 0,
-font => $Config{Menuefont},
);
my $game_menu = $menu
->Menu(-font => $Config{Menuefont},
-tearoff => 0,
-menuitems => [
[
'command' => 'New Game',
-command => [ \&start_game, 'dumm
+y',
$mw,
+ $fld,
$widt
+h, $height,
$C{ro
+ws}, $C{cols},
$C{ro
+wpix}, $C{colpix}
],
-accelerator => 'F2',
-font => $Config{Menuefont},
-underline => 0,
],
[
'command' => 'Toggle Grid',
-command => [ sub{ $C{withgrid} ^
+=1;
draw_grid($fld
+,$width,$height,$C{rows},$C{cols},$C{rowpix},$C{colpix});},
'dummy'
],
-accelerator => 'F3',
-font => $Config{Menuefont},
-underline => 0,
],
[
'command' => 'Show highscores',
-command => [ \&show_highscore, $
+mw ],
-font => $Config{Menuefont},
-underline => 0,
],
'-', # seperator
[
'command' => 'Exit',
-command => [ \&my_exit, $mw ],
-accelerator => 'ESC',
-font => $Config{Menuefont},
-underline => 0,
],
],
);
$menu->entryconfigure('Menu', -menu => $game_menu);
my $help_menu = $menu
->Menu(-font => $Config{Menuefont},
-tearoff => 0,
-menuitems => [
[
'command' => "Help",
-command => [ \&help, $mw ],
-accelerator => 'F1',
-font => $Config{Menuefont},
-underline => 0,
],
[
'command' => "History",
-command => [ \&history, $mw ],
-font => $Config{Menuefont},
-underline => 1,
],
'-',
[
'command' => "About Pentris",
-command => [ \&over_pentris, $mw
+ ],
-font => $Config{Menuefont},
-underline => 0,
],
],
);
$menu->entryconfigure('Help', -menu => $help_menu);
$mw->bind('<Alt-s>', sub {$menu->postcascade('Menu')});
$mw->bind('<Alt-h>', sub {$menu->postcascade('Help')});
$mw->bind('<Escape>', sub {$quit_b->invoke()});
$mw->bind('<F1>', [ \&help, $mw ] );
$mw->bind('<F2>', [ \&start_game, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix}
]);
$mw->bind('<F3>', [ sub{ $C{withgrid} ^=1;draw_grid($fld,$width
+,$height,$C{rows},$C{cols},$C{rowpix},$C{colpix});},
'dummy' ]);
Tk::MainLoop();
} # sub runtk
sub draw_grid {
my ($fld, $width, $height, $rows, $cols, $rowpix, $colpix) = @_;
my $gridcolor = $C{withgrid} ? '#FFFFFF' : '#000000';
$fld->createLine(1 + $colpix*$_, 1 ,
1 + $colpix*$_, $height,
-fill => $gridcolor)
for 0 .. $cols-1;
$fld->createLine(1, 1 + $rowpix*$_,
$width, 1 + $rowpix*$_,
-fill => $gridcolor)
for 0 .. $rows-1;
} # sub draw_grid
sub start_game {
my (undef, # because the bind
$mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix) =
+@_;
$C{after}->cancel() if exists $C{after} and defined $C{after};
$fld->delete('all');
$C{points} = 0;
$C{speed} = $C{startspeed};
draw_grid($fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix});
{
my $dialog = $mw->Dialog(-text => 'Which Game?',
-bitmap => 'question',
-title => 'Select Game',
-default_button => 'Pentris',
-buttons => [ 'Tetris', 'Pentr
+is' ],
);
$C{gametype} = $dialog->Show(-global);
}
my @field;
for my $r (0..$rows-1) { for my $c (0..$cols-1) { $field[$r][$c] =
+ 0 } }
my $stone = new Pentris::Stone;
my $objects =
show_stone($fld, $width, $height, $rows, $cols, $rowpix, $colpix,
+$stone);
$mw->bind('<Key-p>', [ \&pause_game, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field, $stone
]);
$mw->bind('<Pause>', [ \&pause_game, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field, $stone
]);
$mw->bind('<Right>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field,
$stone, $objects,
+'right'
]);
$mw->bind('<Left>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field,
$stone, $objects,
+'left'
]);
$mw->bind('<Down>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field,
$stone, $objects,
+'down'
]);
$mw->bind('<Key-space>', [ \&drop_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field,
$stone, $objects
]);
$mw->bind('<Up>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field,
$stone, $objects,
+'turn'
]);
$C{after} =
$mw->after($C{speed}, [ \&fall_down, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
\@field,
$stone, $objects
]);
}
sub pause_game {
my (undef, # because the bind
$mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $f
+ield,
$stone)
= @_;
$C{after}->cancel() if exists $C{after} and defined $C{after};
$mw->bind('<Right>', '');
$mw->bind('<Left>', '');
$mw->bind('<Down>', '');
$mw->bind('<Spacebar>', '');
$mw->bind('<Up>', '');
$fld->delete('all');
draw_grid($fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix});
my @pausefield;
for my $r (0..$rows-1) {
for my $c (0..$cols-1) {
$pausefield[$r][$c] = int rand $#Color;
}
}
show_field($fld, $width, $height, $rows, $cols, $rowpix, $colpix,
\@pausefield);
$mw->bind('<Key-p>', [ \&pause_game_doit, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field, $stone
]);
$mw->bind('<Pause>', [ \&pause_game_doit, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field, $stone
]);
sub pause_game_doit {
my (undef, # because the bind
$mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix
+, $field,
$stone)
= @_;
$mw->bind('<Key-p>', '');
$mw->bind('<Pause>', '');
$fld->delete('all');
draw_grid($fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix});
show_field($fld, $width, $height, $rows, $cols, $rowpix, $colp
+ix,
$field);
my $objects =
show_stone($fld, $width, $height, $rows, $cols, $rowpix, $colp
+ix,
$stone);
$mw->bind('<Key-p>', [ \&pause_game, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field, $stone
]);
$mw->bind('<Pause>', [ \&pause_game, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field, $stone
]);
$mw->bind('<Right>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'right'
]);
$mw->bind('<Left>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'left'
]);
$mw->bind('<Down>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'down'
]);
$mw->bind('<Key-space>', [ \&drop_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects
]);
$mw->bind('<Up>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'turn'
]);
$C{after} =
$mw->after($C{speed}, [ \&fall_down, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field,
$stone, $objects
]);
} # sub pause_game_doit
}
sub fall_down {
my ($mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix,
$field, $stone, $objects) = @_;
my $fall_ok = 1;
for my $square (@{$stone->coords()}) {
my ($ri, $ci) = @$square;
$fall_ok = 0, last if $ri >= $rows-1 or
$field->[$ri+1][$ci];
}
if ($fall_ok) {
$fld->move($_, 0, $rowpix ) for @$objects;
++ $stone->coords()->[$_]->[0] for 0 .. $#{ $stone->coords() }
+;
}
else {
$mw->bind('<Key-p>', '');
$mw->bind('<Pause>', '');
$mw->bind('<Right>', '');
$mw->bind('<Left>', '');
$mw->bind('<Down>', '');
$mw->bind('<Spacebar>', '');
$mw->bind('<Up>', '');
for my $square (@{$stone->coords()}) {
my ($ri, $ci) = @$square;
$field->[$ri][$ci] = $stone->color();
}
$C{points} += 3 + $stone->bonus(); # Add bonus for this stone
$stone = undef;
clear_lines($mw, $fld, $width, $height, $rows, $cols,
$rowpix, $colpix, $field);
$stone = new Pentris::Stone;
$objects =
show_stone($fld, $width, $height, $rows, $cols,
$rowpix, $colpix, $stone);
my $insert_ok = 1;
for my $square (@{$stone->coords()}) {
my ($ri, $ci) = @$square;
$insert_ok = 0, last if $field->[$ri][$ci];
}
game_over($mw), return unless $insert_ok;
$mw->bind('<Key-p>', [ \&pause_game, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field, $stone
]);
$mw->bind('<Pause>', [ \&pause_game, $mw, $fld,
$width, $height,
$rows, $cols,
$rowpix, $colpix,
$field, $stone
]);
$mw->bind('<Right>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'right'
]);
$mw->bind('<Left>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'left'
]);
$mw->bind('<Down>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'down'
]);
$mw->bind('<Key-space>', [ \&drop_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects
]);
$mw->bind('<Up>', [ \&move_stone, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix
+},
$field,
$stone, $objects,
+ 'turn'
]);
}
$C{after} =
$mw->after($C{speed}, [ \&fall_down, $mw, $fld,
$width, $height,
$C{rows}, $C{cols},
$C{rowpix}, $C{colpix},
$field,
$stone, $objects
]);
} # sub fall_down
sub move_stone {
my ($obj, # because of the bind
$mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix,
$field, $stone, $objects, $move) = @_;
my @coord;
for my $square (@{$stone->coords()}) {
my ($ri, $ci) = @$square;
push @coord, [$ri, $ci];
}
my @newcoord;
my ($center_row, $center_col) = @{ $coord[0] };
for my $square (@coord) {
my ($ri, $ci) = @$square;
if ($move eq 'right') {
++$ci;
}
elsif ($move eq 'left') {
--$ci;
}
elsif ($move eq 'turn') {
($ri, $ci) = ($center_row - $center_col + $ci,
$center_col + $center_row - $ri);
}
elsif ($move eq 'down') {
++$ri;
}
else {
die "unknown move '$move'";
}
push @newcoord, [$ri, $ci];
}
my $ok_to_move = 1;
for my $square (@newcoord) {
my ($ri, $ci) = @$square;
$ok_to_move = 0, last if #$ri < 0 or # without this stone
+s can be
$ri >= $rows or
$ci < 0 or
$ci >= $cols or
$field->[$ri][$ci];
}
if ($ok_to_move) {
for my $oi (0..$#$objects) {
my $delta_row = $newcoord[$oi]->[0] - $coord[$oi]->[0];
my $delta_col = $newcoord[$oi]->[1] - $coord[$oi]->[1];
$fld->move($objects->[$oi],
$colpix * $delta_col,
$rowpix * $delta_row,
);
$stone->coords()->[$oi]->[0] += $delta_row;
$stone->coords()->[$oi]->[1] += $delta_col;
}
}
return $ok_to_move;
} # sub move_stone
sub drop_stone {
my ($obj, # because of the bind
$mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix,
$field, $stone, $objects) = @_;
my $fall_ok = 1;
while ($fall_ok) {
for my $square (@{$stone->coords()}) {
my ($ri, $ci) = @$square;
$fall_ok = 0, last if $ri >= $rows-1 or
$field->[$ri+1][$ci];
}
if ($fall_ok) {
$fld->move($_, 0, $rowpix ) for @$objects;
++ $stone->coords()->[$_]->[0] for 0 .. $#{ $stone->coords
+() };
}
}
} # sub drop_stone
sub game_over {
my ($mw) = @_;
die "wrong call of game_over" unless defined $mw;
my $player = $ENV{USER} || 'unknown';
my $points = $C{points};
my $date;
{
my ($d, $m, $y) = (localtime)[3,4,5];
++$m; # month are coded as 0..11
$y += 1900; # years are ment as 1900 + year
$date = sprintf "%04s-%02s-%02s", $y, $m, $d;
}
my @highscore;
my $hfile = $C{gametype} eq 'Pentris'
? $Config{highscore_p}
: $Config{highscore_t};
if (open (HIGH, $hfile)) {
chomp( @highscore = <HIGH> );
}
@highscore = sort {my ($aplayer, $apoints, $adate) = split /\t/, $
+a;
my ($bplayer, $bpoints, $bdate) = split /\t/, $
+b;
$bpoints <=> $apoints
}
@highscore;
my $place = 0;
my $placetoday = 0;
for (@highscore) {
my ($hplayer, $hpoints, $hdate) = split /\t/;
++$place if $hpoints >= $points;
++$placetoday if $hpoints >= $points and $hdate eq $date;
}
{
my $tl = $mw->Toplevel();
$tl->title('Spielende');
$tl->Label(-text => 'Herzlichen Glueckwunsch, Sie haben ' .
+$points .
' Punkte erreicht.' . "\n" .
'Damit liegen Sie heute auf Platz ' .
($placetoday+1) .
' und insgesamt auf Platz ' . ($place+1
+) . '.',
-justify => 'left',
)
->pack(-anchor => 'w',
);
$tl->Label(-text => 'Bitte geben Sie Ihren Namen ein:',
-justify => 'left',
)
->pack(-anchor => 'w');
my $entry = $tl->Entry(-textvariable => \$player)
->pack();
my $ok = $tl->Button(-text => 'OK',
-command => sub {$tl->destroy();
$mw->bind('<Escape>'
+,
[ \&my_exi
+t, $mw]);
$mw->focus();
game_over_doit($mw,
$play
+er,
$poin
+ts,
$date
+,
$hfil
+e,
$plac
+e,
$plac
+etoday,
\@hig
+hscore,
);
},
-default => 'active',
-padx => 15,
)
->pack(-expand => '0',
-fill => 'none',
-side => 'right',
);
$mw->bind('<Escape>', '');
$tl->bind('<Escape>', sub{$ok->invoke()});
$tl->bind('<Return>', sub{$ok->invoke()});
$tl->grab();
$tl->focus();
$entry->focus();
}
sub game_over_doit() {
my ($mw, $player, $points, $date, $hfile, $place, $placetoday,
+ $highscore)
= @_;
push @$highscore, "$player\t$points\t$date";
@$highscore = sort {my ($aplayer, $apoints, $adate) = split /\
+t/, $a;
my ($bplayer, $bpoints, $bdate) = split /\
+t/, $b;
$bpoints <=> $apoints
} @$highscore;
my @highscore_today = grep {(undef, undef, $a) = split /\t/; $
+a eq $date}
@$highscore;
if (open (HIGH, ">$hfile")) {
print HIGH $_,"\n" for @$highscore;
}
else {
die "Can't write the highscore file '$hfile'.";
}
my $text = "Spielende!\n".
"~~~~~~~~~~\n\n".
'Herzlichen Glueckwunsch '. $player. ', Sie haben '
+ . $points .
' Punkte erreicht.' . "\n" .
'Damit liegen Sie heute auf Platz ' .
($placetoday+1) .
' und insgesamt auf Platz ' . ($place+1) . '.'."\n\
+n".
"Highscores fuer die Spielart $C{gametype}:\n";
$text .= "\nHighscore heute\n" .
"~~~~~~~~~~~~~~~\n";
$text .= sprintf "%3s: %s\n", $_+1, $highscore_today[$_]
for 0..($#highscore_today<9 ? $#highscore_today : 9);
$text .= "\nHighscore gesamt\n" .
"~~~~~~~~~~~~~~~~\n";
$text .= sprintf "%3s: %s\n", $_+1, $highscore->[$_]
for 0..($#$highscore<9 ? $#$highscore : 9);
show_window($mw,
'Spielende',
'Spielende',
'{Courier New} 10 {normal}',
$text,
);
} # sub game_over_doit
} # sub game_over
sub show_highscore {
my ($mw) = @_;
die "wrong parameters in show_highscrore"
unless defined $mw;
my $date;
{
my ($d, $m, $y) = (localtime)[3,4,5];
++$m; # month are coded as 0..11
$y += 1900; # years are ment as 1900 + year
$date = sprintf "%04s-%02s-%02s", $y, $m, $d;
}
my @highscore_p;
my @highscore_t;
my $hfile_p = $Config{highscore_p};
my $hfile_t = $Config{highscore_t};
if (open (HIGH, $hfile_p)) {
chomp( @highscore_p = <HIGH> );
}
if (open (HIGH, $hfile_t)) {
chomp( @highscore_t = <HIGH> );
}
my @highscore_today_p = grep {(undef, undef, $a) = split /\t/; $a
+eq $date}
@highscore_p;
my @highscore_today_t = grep {(undef, undef, $a) = split /\t/; $a
+eq $date}
@highscore_t;
@highscore_p = sort {my ($aplayer, $apoints, $adate) = split /\t/,
+ $a;
my ($bplayer, $bpoints, $bdate) = split /\t/,
+ $b;
$bpoints <=> $apoints
} @highscore_p;
@highscore_t = sort {my ($aplayer, $apoints, $adate) = split /\t/,
+ $a;
my ($bplayer, $bpoints, $bdate) = split /\t/,
+ $b;
$bpoints <=> $apoints
} @highscore_t;
my $text = "Highscores fuer Pentris heute\n\n";
$text .= sprintf "%3s: %s\n", $_+1, $highscore_today_p[$_]
for 0..$#highscore_today_p;
$text .= "\nHighscore fuer Pentris gesamt\n\n";
$text .= sprintf "%3s: %s\n", $_+1, $highscore_p[$_]
for 0..$#highscore_p;
$text .= "\nHighscores fuer Tetris heute\n\n";
$text .= sprintf "%3s: %s\n", $_+1, $highscore_today_t[$_]
for 0..$#highscore_today_t;
$text .= "\nHighscore fuer Tetris gesamt\n\n";
$text .= sprintf "%3s: %s\n", $_+1, $highscore_t[$_]
for 0..$#highscore_t;
show_window($mw,
'Highscores',
'All highscores of Pentris and Tetris',
'{Courier New} 10 {normal}',
$text,
);
}
sub show_field {
my ($fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field)
+ = @_;
for my $ri (0..$C{rows}-1) {
for my $ci (0..$C{cols}-1) {
paint_square($fld, $width, $height, $rows, $cols,
$rowpix, $colpix, $ri, $ci,
$Color[$field->[$ri][$ci]])
if 0 != $field->[$ri][$ci];
}
}
}
sub show_stone {
my ($fld, $width, $height, $rows, $cols, $rowpix, $colpix, $stone)
+ = @_;
my @objects;
for my $square (@{$stone->coords()}) {
my ($ri, $ci) = @$square;
push @objects,
paint_square($fld, $width, $height, $rows, $cols,
$rowpix, $colpix, $ri, $ci,
$Color[$stone->color()]);
}
return [@objects];
}
sub paint_square {
my ($fld, $width, $height, $rows, $cols, $rowpix, $colpix,
$row, $col, $color) = @_;
my $rect =
$fld->createRectangle(1+1+$colpix*$col, 1+1+$rowpix*$row,
1-1+$colpix*($col+1), 1-1+$rowpix*($row+1),
-fill => $color,
-outline => $color,
);
return $rect;
}
sub my_exit {
my ($mw) = @_;
die "wrong call of my_exit" unless defined $mw;
my $dialog = $mw->Dialog(-text => "Really Exit?",
-bitmap => 'question',
-title => 'Are you sure?',
-default_button => 'Exit',
-buttons => [ 'Cancel', 'Exit' ],
);
my $answer = $dialog->Show(-global);
exit if $answer eq 'Exit';
}
sub show_window {
my $mw = shift;
my $title = shift;
my $label = shift;
my $font = shift;
my $text = shift;
my $width = shift || 80;
my $height = shift || 35;
my $tcolor = shift || 'blue';
my $bcolor = shift || '#d7d7d7';
my $tl = $mw->Toplevel();
$tl->title($title);
$tl->Label(-text => $label,
)
->pack(-anchor => 'w');
my $fr = $tl->Frame()
->pack(-expand => '0',
-fill => 'x',
-side => 'bottom',
);
my $txt = $tl->Scrolled("Text",
-scrollbars => 'osoe',
-background => $bcolor,
-foreground => $tcolor,
-state => 'disabled',
-width => $width,
-height => $height,
-relief => 'flat',
-font => $font,
-wrap => 'none',
)
->pack(-side => 'top',
-expand => 1,
-fill => 'both',
);
my $ok = $fr->Button(-text => 'OK',
-command => sub {$tl->destroy();
$mw->bind('<Escape>',
[ \&my_exit, $
+mw ]);
$mw->focus();
},
-default => 'active',
-padx => 15,
)
->pack(-expand => '0',
-fill => 'none',
-side => 'right',
);
$txt->configure(-state => 'normal');
$txt->delete('1.0', 'end');
$txt->insert('end', $text);
$txt->configure(-state => 'disabled');
$tl->bind('<Return>', sub{$ok->invoke()});
$mw->bind('<Escape>', '');
$tl->bind('<Escape>', sub{$ok->invoke()});
$txt->bind('<Prior>', sub { $txt->yviewScroll(-1, 'units') } );
$txt->bind('<Next>', sub { $txt->yviewScroll( 1, 'units') } );
$txt->bind('<Home>', sub { $txt->yviewMoveto(0) } );
$txt->bind('<End>', sub { $txt->yviewMoveto(1) } );
$txt->bind('<Left>', sub { $txt->yviewScroll(-1, 'units') } );
$txt->bind('<Up>', sub { $txt->yviewScroll(-1, 'units') } );
$txt->bind('<Right>', sub { $txt->yviewScroll( 1, 'units') } );
$txt->bind('<Down>', sub { $txt->yviewScroll( 1, 'units') } );
$tl->grab();
$tl->focus();
$txt->focus();
}
sub help () {
my ($mw) = @_;
my $text = qq(
Pentris V$Config{version} vom $Config{version_date}
~~~~~~~
Pentris is a Tetris clone with extended stone set. Does anyone not
+ know Tetris?
Stones in a lattice fall downward from above. You can move them to
+ the right
and to the left and rotate .
The goal of the game is to make as many completely filled rows as
+possible.
Each filled row is removed from the lattice and the rows above sin
+k further
downward. There are points for the placing of the stones (dependin
+g on the
complexity of the stone form) and filling whole rows.
If four or more rows are cleared at one time, there are points of
+bonus.
Control:
Left Arrow: Stone to the left move
Right Arrow: Stone to the right
Up Arrow: Stone rotates
Down Arrow: Stone a row downward move
Space bar: Stone freefalls
F2: New Game
Pause or p: Pause/Resume
You can select from either the classic Tetris where 4 blocks form
+a stone or
Pentris where up to 5 blocks may form a stone. Pentris is harder.
);
show_window($mw,
'Help for Pentris',
'japh!',
'{Courier New} 10 {normal}',
$text,
);
}
sub history () {
my ($mw) = @_;
my $text = 'Short History!';
show_window($mw,
'History of Pentris',
'History of Pentris:',
'{Courier New} 10 {normal}',
$text,
);
}
sub over_pentris () {
my ($mw) = @_;
die "wrong call of over_pentris" unless defined $mw;
my $text = qq(
Pentris
~~~~~~~
Version : V$Config{version} vom $Config{version_date}
Autor : Christian Duehl
E-Mail : crian AT perl-community DOT de
christian AT duehl DOT de
Website: http://www.duehl.de/christian/perl/pentris.html
);
show_window($mw,
'About Pentris',
'About Pentris',
'{Courier New} 10 {normal}',
$text,
64,16
);
}
sub clear_lines {
my ($mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $f
+ield) = @_;
my $cleared = 0;
for my $row (0..$rows-1) {
my $rowfull = 1;
for my $col (0..$cols-1) {
if (0 == $field->[$row][$col]) {
$rowfull = 0;
last;
}
}
if ($rowfull) {
++$cleared;
$C{points} += 13*($rows-$row)*($cleared+1);
for my $row_t (reverse 1..$row) {
for my $col (0..$cols-1) {
$field->[$row_t][$col] = $field->[$row_t-1][$col];
}
}
for my $col (0..$cols-1) {
$field->[0][$col] = 0;
}
}
}
$C{points} += 47*$cleared if $cleared > 3;
$C{speed} -= $cleared * 10;
if ($cleared) {
$fld->delete('all');
draw_grid ($fld, $width, $height, $rows, $cols, $rowpix, $colp
+ix);
show_field($fld, $width, $height, $rows, $cols, $rowpix, $colp
+ix, $field);
}
}
