Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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:

  1. Most of your functions take args $mw,$fld,$width,$height,$C{rows},$C{cols},$C{rowpix},$C{colpix} - passing these as an object or just in the %C hash would make sense - they are all effectively constants AFAIK.
  2. You have lots of code that essentially does just this: die "function X did not get Y arguments!\n" unless @_ == Y except you are using unless .... and .... and .... and ....

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); } }

In reply to Re: Pentris - a Tetris clone by tachyon
in thread Pentris - a Tetris clone by Crian

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others pondering the Monastery: (14)
    As of 2014-10-21 12:17 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      For retirement, I am banking on:










      Results (103 votes), past polls