#!/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, 'dummy', $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $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('', sub {$menu->postcascade('Menu')}); $mw->bind('', sub {$menu->postcascade('Help')}); $mw->bind('', sub {$quit_b->invoke()}); $mw->bind('', [ \&help, $mw ] ); $mw->bind('', [ \&start_game, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix} ]); $mw->bind('', [ 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', 'Pentris' ], ); $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('', [ \&pause_game, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, \@field, $stone ]); $mw->bind('', [ \&pause_game, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, \@field, $stone ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, \@field, $stone, $objects, 'right' ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, \@field, $stone, $objects, 'left' ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, \@field, $stone, $objects, 'down' ]); $mw->bind('', [ \&drop_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, \@field, $stone, $objects ]); $mw->bind('', [ \&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, $field, $stone) = @_; $C{after}->cancel() if exists $C{after} and defined $C{after}; $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); $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('', [ \&pause_game_doit, $mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field, $stone ]); $mw->bind('', [ \&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('', ''); $mw->bind('', ''); $fld->delete('all'); draw_grid($fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}); show_field($fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field); my $objects = show_stone($fld, $width, $height, $rows, $cols, $rowpix, $colpix, $stone); $mw->bind('', [ \&pause_game, $mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field, $stone ]); $mw->bind('', [ \&pause_game, $mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field, $stone ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects, 'right' ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects, 'left' ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects, 'down' ]); $mw->bind('', [ \&drop_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects ]); $mw->bind('', [ \&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('', ''); $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); $mw->bind('', ''); 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('', [ \&pause_game, $mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field, $stone ]); $mw->bind('', [ \&pause_game, $mw, $fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field, $stone ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects, 'right' ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects, 'left' ]); $mw->bind('', [ \&move_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects, 'down' ]); $mw->bind('', [ \&drop_stone, $mw, $fld, $width, $height, $C{rows}, $C{cols}, $C{rowpix}, $C{colpix}, $field, $stone, $objects ]); $mw->bind('', [ \&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 stones 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 = ); } @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('', [ \&my_exit, $mw]); $mw->focus(); game_over_doit($mw, $player, $points, $date, $hfile, $place, $placetoday, \@highscore, ); }, -default => 'active', -padx => 15, ) ->pack(-expand => '0', -fill => 'none', -side => 'right', ); $mw->bind('', ''); $tl->bind('', sub{$ok->invoke()}); $tl->bind('', 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 = ); } if (open (HIGH, $hfile_t)) { chomp( @highscore_t = ); } 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('', [ \&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('', sub{$ok->invoke()}); $mw->bind('', ''); $tl->bind('', sub{$ok->invoke()}); $txt->bind('', sub { $txt->yviewScroll(-1, 'units') } ); $txt->bind('', sub { $txt->yviewScroll( 1, 'units') } ); $txt->bind('', sub { $txt->yviewMoveto(0) } ); $txt->bind('', sub { $txt->yviewMoveto(1) } ); $txt->bind('', sub { $txt->yviewScroll(-1, 'units') } ); $txt->bind('', sub { $txt->yviewScroll(-1, 'units') } ); $txt->bind('', sub { $txt->yviewScroll( 1, 'units') } ); $txt->bind('', 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 sink further downward. There are points for the placing of the stones (depending 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, $field) = @_; 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, $colpix); show_field($fld, $width, $height, $rows, $cols, $rowpix, $colpix, $field); } }