From 23c192cd8768d9b6b43724de8d31632914f89ad9 Mon Sep 17 00:00:00 2001 From: mertz Date: Fri, 22 Mar 2002 10:55:19 +0000 Subject: Version initiale faite par Marcellin Buisson! --- Perl/demos/Tk/demos/zinc_lib/Zetris.pl | 956 +++++++++++++++++++++++++++++++++ 1 file changed, 956 insertions(+) create mode 100644 Perl/demos/Tk/demos/zinc_lib/Zetris.pl (limited to 'Perl/demos') diff --git a/Perl/demos/Tk/demos/zinc_lib/Zetris.pl b/Perl/demos/Tk/demos/zinc_lib/Zetris.pl new file mode 100644 index 0000000..3a83bf7 --- /dev/null +++ b/Perl/demos/Tk/demos/zinc_lib/Zetris.pl @@ -0,0 +1,956 @@ +#!/usr/bin/perl + +#------------------------------------------------------------------------------ +# +# Zetris - A Zinc Toy-Appli based on cool TkTetris from Slaven Rezic +# +# $Id$ +# +# Copyright (C) 2002 Centre d'Etudes de la Navigation Aérienne +# Author: Marcellin Buisson +# +# Hacked from Original Code to adapt to Tk::Zinc Widget : +# +#------------------------------------------------------------------------------ +# +# Author: Slaven Rezic +# +# Copyright (C) 1997, 1999, 2000, 2002 Slaven Rezic. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Mail: slaven.rezic@berlin.de +# WWW: http://www.rezic.de/eserte/ +# +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# What are the differences with the original TkTetris ? +#------------------------------------------------------------------------------ +# +# - This TkTetris-like uses a tk widget similar to the canvas +# and called "Zinc". Zinc bring to Tk widgets openGL features +# like transparency, color gradiants, scaling. +# So to use Zetris you need openGL capability. +# Zinc comes with other features like grouping and clipping. +# +# - A color gradiant is used for Zetris background, +# +# - Zetris balls are filled with transparently color gradiants, +# (transparency is visible when balls fall over TkZinc logo) +# +# - Zetris balls have a little transparent shadow, +# +# - The TkZinc logo is animated by rotation and scaling effects, +# +# - Introducing of groups provided by Zinc for grouping items +# This feature is particularly useful for applying transformations, +# +# - The TkZinc logo over background isn't an image but only curves +# and color gradiants (made by ) +# +# - Please feel free to provide any feedback to +# +# +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# ToDos : +# +# - Complete this basic version in a full playable game like tktetris. +# - Review conception through Zinc features. +# (using groups capabilities for drawing blocks for instance) +# - Adding special effects when completing a line or changing level. +# +#------------------------------------------------------------------------------ +use Tk; +use Tk::Zinc; +use strict; +use LogoZinc; + +package main; + +use Getopt::Long; + +use vars qw($VERSION); + +$VERSION = sprintf("%d.%00d", q$Revision$ =~ /(\d+)\.(\d+)/); + +my $max_size = 4; +my $nmbr_blks = 7; +my $width = 12; +my $height = 20; +my $geometry; + +my $level; +my $just_started = 1; +my $speed; +my $base_speed = 500; + +my $last_resize; +my $fontheight = 0; + +my $basefont + = sub { sprintf "-*-helvetica-medium-r-normal--%s-*", $_[0] }; +my $base2font + = sub { sprintf "-*-courier-medium-r-normal--%s-*", $_[0] }; + +my $blocks = 0; +my $lines = 0; +my $mylines = 0; + +my $pause = undef; +my $pause_w; +my $freefall = 0; +my $points = 0; +my $flat = 0; +my $moveable_drop = 0; + +my $old_win_height; +my $draw_shadow = 1; + +# Animation constants +my $afterdelay = 1; +my $stepsnumber = 10; +my $zoomrate = 1.1; + +my $active_block = undef; +my $active_block_nr = undef; +my $active_dir = undef; +my $next_block = undef; +my $next_block_nr = undef; +my $next_dir = undef; +my $posx = undef; +my $posy = undef; + +my $n = 0; + +my(%color_dark, %color_very_dark); +my %color_bright = + (2 => 'red', + 3 => 'green', + 4 => 'blue', + 5 => 'cyan', + 6 => 'yellow', + 7 => 'orange', + 8 => 'pink', + ); + +# Blocks matrix +my $block = + [[[qw(0 0 0 0)], + [qw(0 2 0 0)], + [qw(0 2 2 0)], + [qw(0 2 0 0)]], + [[qw(0 0 0 0)], + [qw(3 3 0 0)], + [qw(0 3 0 0)], + [qw(0 3 0 0)]], + [[qw(0 0 0 0)], + [qw(0 4 4 0)], + [qw(0 4 0 0)], + [qw(0 4 0 0)]], + [[qw(0 0 0 0)], + [qw(0 5 0 0)], + [qw(0 5 5 0)], + [qw(0 0 5 0)]], + [[qw(0 0 0 0)], + [qw(0 6 0 0)], + [qw(6 6 0 0)], + [qw(6 0 0 0)]], + [[qw(0 7 0 0)], + [qw(0 7 0 0)], + [qw(0 7 0 0)], + [qw(0 7 0 0)]], + [[qw(0 0 0 0)], + [qw(0 0 0 0)], + [qw(8 8 0 0)], + [qw(8 8 0 0)]], + ]; + +my $playfield; +reset_playfield(); + +my $step_x = 20; +my $step_y = 20; +my $boxsize_x = $step_x-2; +my $boxsize_y = $step_y-2; +my $block_border = int($boxsize_x/10); +my $help_top; + +my $top = MainWindow->new(); +$top->minsize(181, 83); +$top->title('Zetris'); + +{ + my $width_height_set = 0; + if ($geometry) + { + if ($geometry =~ /^(=?(\d+)x(\d+))?(([+-]\d+)([+-]\d+))?$/) + { + if (defined $2 and defined $3) + { + my($width, $height) = ($2, $3); + $top->GeometryRequest($width, $height); + $width_height_set++; + } + if (defined $5 and defined $6) + { + my($x, $y) = ($5, $6); + $top->geometry("$x$y"); + } + } + else + { + die "Can't parse geometry: $geometry"; + } + } + if (!$width_height_set) + { + $top->GeometryRequest($top->screenwidth, + $top->screenheight); + } +} + +my $base_level = 1; + +$level = level(); +$speed = speed(); + +resize_calc(); + +while(my($k, $v) = each %color_bright) + { + $color_dark{$k} = $top->Darken($v, 80); + $color_very_dark{$k} = $top->Darken($v, 60); + } + + +# Zinc Widget (openGl rendering option set to 1) +my $tetris = $top->Zinc(-width => $step_x*($width-2), + -height => $step_y*($height-1), + -backcolor => '#707070', + -lightangle => 130, + -render => 1, + )->pack; +die "no openGL rendering on this X server" unless $tetris->cget(-render); + +my $shadow_group = $tetris->add('group',1, -visible => 1); + +my $pause_group = $tetris->add('group',1, -visible => 1); + +my $topgroup = 1; + +$tetris->pack(-fill => 'both', + -expand=> 1); + +$tetris->add('rectangle', + 1, # Zinc group + [0, 0,$step_x*($width-2) ,$step_y*($height-1)] , + -filled => 1, + -linewidth => 0, + -fillcolor => "black:40|gray80:60/90", + -visible => 1); + +my $group = $tetris->add('group', 1, ); +my $logo = $tetris->LogoZinc(-parent => $group, + -position => [$step_x*($width-2)/2-200, $step_y*($height-1)/2], + ); + +$tetris->lower($group); + +my $score_group = $tetris->add('group',1, -visible => 1); +my $new = $tetris->add('text',$score_group, + -text => " $lines Line\n", + #-anchor => 'e', + -position => [$width-2,10], + ); + +$tetris->lower($score_group); + +my $timer = $top->after(speed(), sub { + $old_win_height = $top->height; + $just_started = 0; + action(); + }); + +make_key_bindings($top); + +print "\n***********************************************\n\n For help on the game toggle pause with 'p'\n\n***********************************************\n\n"; + +MainLoop; + +#------------------------------------------------------------------------ +sub reset_playfield + { + my $i; + # $fake_height: mit negativen Indices können die n-letzten Elemente + # angesprochen werden... + my $fake_height = $height+$max_size+1; + for $i (0 .. $fake_height-1) + { + $playfield->[$i][0] = 1; + my $j; + for $j (1 .. $width-2) + { + $playfield->[$i][$j] = 0; + } + $playfield->[$i][$width-1] = 1; + } + for $i (0 .. $width-1) + { + $playfield->[$height-1][$i] = 1; + } + } + +sub speed + { + my $speed = $base_speed - ($base_speed*$level)/20; + if ($speed <= 5) { $speed = 5 } + $speed; + } + +sub level + { + int($lines / 10) + 1 + $base_level + } + +sub resize_calc + { + $last_resize = time(); + my $win_height; + if ($just_started) + { + $win_height = $top->reqheight; + } + else + { + $win_height = $top->height; + } + $step_x = $step_y = int($win_height/($height+3)); + my $gap = ($step_x > 10 ? 2 : 1); + $boxsize_x = $step_x-$gap; + $boxsize_y = $step_y-$gap; + $block_border = int($boxsize_x/10); + if ($block_border < 1) { $block_border = 1 } + my @font_height = (10, 11, 12, 14, 17, 18, 20, 24, 25, 34); + my $req_fontheight = $win_height/30; + $fontheight = 0; + foreach (@font_height) + { + if ($_ > $req_fontheight) + { + $fontheight = $_; + last; + } + } + if (!$fontheight) { $fontheight = $font_height[$#font_height] } + $top->optionAdd("*font" => $basefont->($fontheight)); + } + +sub make_key_bindings + { + my $top = shift; + $top->bind('' => \&quit_game); + $top->bind('' => \&quit_game); + $top->bind('' => \&quit_game); + $top->bind('' => sub { move('left') }); + $top->bind('' => sub { move('right') }); + $top->bind('' => sub { move('antiturn') }); + $top->bind('' => sub { move('turn') }); + $top->bind('' => sub { move('left') }); + $top->bind('' => sub { move('right') }); + $top->bind('' => sub { move('turn') }); + foreach (qw/space KP_Enter/) { + $top->bind("<$_>" => sub { move('freefall') }); + } + $top->bind('

' => sub { toggle_pause() }); + $top->bind('' => \&stop_and_new_game); + $top->bind('' => \&help); + #$top->bind('all', '' => \&help); # don't pause + $top->bind('all', '' => \&lost); + #XXX Leave und Enter herausnehmen + $top->bind('' => sub { inc_pause(1) }); + # $top->bind('' => sub { inc_pause(1) }); + $top->bind('' => sub { dec_pause(1) }); + #$top->bind('' => sub { toggle_pause()}); + #$top->bind('' => sub { toggle_pause()}); + # $top->bind('' => sub { dec_pause(1) }); + } + + +sub inc_pause + { + my $quiet = shift; + $pause++; + if (!$quiet && !Tk::Exists($pause_w)) + { + my $width = $top->width; + my $height = $top->height; + $pause_w = $tetris->add('text',$pause_group, + -text => "PAUSE MODE :\n Type p to continue\n +\n\n\nHELP : \n\n- 'p' toggle pause\n\n- 'q' or 'F2' to quit game\n\n- Arrow keys to move blocks\n\n- 'n' to start a new game\n\n ", + -position => [30,50], + -anchor => 'nw', + + ); + } +} + +sub dec_pause + { + if ($pause) + { + $pause--; + if ($pause < 1) + { + $tetris->remove($pause_w); + undef $pause; + } + } + } + +sub toggle_pause + { + my $quiet = shift; + if ($pause) + { + $tetris->remove($pause_w);# if Tk::Exists($pause_w); + undef $pause; + } + else + { + + inc_pause($quiet); + } + } + + +sub action + { + if (!$pause) + { + if (!defined $active_block_nr) + { + if (!defined $next_block_nr) + { + get_next_block(); + } + $active_block_nr = $next_block_nr; + $blocks++; + $active_block = []; + copyblock($next_block, $active_block); + $active_dir = $next_dir; + get_next_block(); + } + if (defined $posx) + { + # erstes Zeichnen + if (testblock($active_block, $posx, $posy+1)) + { + drawblock($posx, $posy, 0); + $posy++; + drawblock($posx, $posy, 1); + } + else + { + array_update(($level+1) * int(($height-$posy+5)/5), + $posx, $posy); + return; + } + } + else + { + $posx = int($width / 2) - 1; + $posy = -$max_size; + } + } + $timer = $top->after($freefall ? 1 : speed(), \&action); + } + +sub get_next_block + { + $next_block_nr = int(rand()*$nmbr_blks); + $next_dir = int(rand()*4); + $next_block = $block->[$next_block_nr]; + for (0 .. $next_dir) + { + turn($next_block_nr, $next_block); + } + } + +sub turn + { + my($number, $block) = @_; + my($i, $j, $help_block); + if ($number != 6) + { + if ($number < 5) + { + for $i (1 .. $max_size-1) + { + for $j (0 .. $max_size-2) + { + $help_block->[$max_size-1-$j][$i-1] = $block->[$i][$j]; + } + } + for $i (1 .. $max_size-1) + { + for $j (0 .. $max_size-2) + { + $block->[$i][$j] = $help_block->[$i][$j]; + } + } + } + else + { + for $i (0 .. $max_size-1) + { + for $j (0 .. $max_size-1) + { + $help_block->[$max_size-1-$j][$i] = $block->[$i][$j]; + } + } + copyblock($help_block, $block); + } + } + } + +sub copyblock + { + my($from, $to) = @_; + die if ref $from ne 'ARRAY' || ref $to ne 'ARRAY'; + my($i, $j); + for $i (0 .. $max_size-1) + { + for $j (0 .. $max_size-1) + { + $to->[$i][$j] = $from->[$i][$j]; + } + } + } +sub rectangle + { + my($x, $y, $mode, $zinc) = @_; + $zinc->remove("$x-$y"); # Zinc command for deleting items + $zinc->remove("ombre$x-$y"); + if ($mode) + { + my($xx, $yy); + ($xx, $yy) = (($x-1)*$step_x, $y*$step_y); + my $dark_color; + $dark_color = $color_dark{$mode}; + my $color = $color_bright{$mode}; + my $center_ball_x = $xx+0.5*$boxsize_x; + my $center_ball_y = $yy+0.5*$boxsize_y; + my $center_for_ball_x = $xx+0.5*0.5*$boxsize_x; + my $center_for_ball_y = $yy+0.5*0.5*$boxsize_y; + my $corner_x = $xx+$boxsize_x; + my $corner_y = $yy+$boxsize_y; + # Adding new Zinc item : ball shadow + my $ombre=$zinc->add( + 'arc',$shadow_group,[$xx+10,$yy+10,$xx+$boxsize_x+10,$yy+$boxsize_y+10], + -visible=>1, + -filled=>1, + -fillcolor => "black:100 0|black:80 20|black:10 100[$corner_x $corner_y", # color gradiant + -linewidth => 0, + -linecolor => 'yellow', + -tags => ["ombre$x-$y"]); + + $zinc->itemconfigure($shadow_group, -priority => 2); + + # Adding new Zinc item : ball + my $cercle=$zinc->add( + 'arc',$topgroup,[$xx,$yy,$xx+$boxsize_x,$yy+$boxsize_y], + -visible=>1, + -filled=>1, + -fillcolor => "white:120|$color:80($center_for_ball_x $center_for_ball_y" , + -linewidth => 1, + -linecolor => "$color:80", + -tags => ["$x-$y"]); + } + } + +sub testblock + { + my($active_block, $posx, $posy) = @_; + for(my $i = 0; $i <= $max_size-1; $i++) + { + for(my $j = 0; $j <= $max_size-1; $j++) + { + if ($active_block->[$i][$j]) + { + if ($playfield->[$posy+$i][$posx+$j]) + { + return 0; + } + } + } + } + 1; + } + +sub drawblock + { + my($posx, $posy, $mode, $zinc) = @_; + my $y = $posy; + $zinc = $tetris if !$zinc; + for(my $i = 0; $i <= $max_size-1; $i++) + { + my $x = $posx; + for(my $j = 0; $j <= $max_size-1; $j++) + { + if ($active_block->[$i][$j]) + { + if (!$mode) + { + rectangle($x, $y, 0, $zinc); + } + else + { + rectangle($x, $y, $active_block->[$i][$j], $zinc); + } + } + $x++; + } + $y++; + } + } + + + +sub new_game { + reset_playfield(); + renew_field(); + reset_block(); + $next_block_nr = undef; + reset_game_param(); + action(); +} + +sub stop_and_new_game { + stop_game(); + new_game(), + } + +sub quit_game { + + print "Bye!\n"; + exit; +} + +sub lost { + $top->destroy; + print "You lost :o( !\n"; + exit; + } + +sub reset_game_param { + $points = $blocks = $lines = 0; + $level = level(); + $speed = speed(); + $pause = undef; +} + +sub stop_game { + undef_timer(); + undef $active_block; +} + +sub delete_line + { + my($y) = @_; + my $yy = $y*$step_y; + my $x; + for $x (1 .. $width-2) + { + my $xx = ($x-1)*$step_x; + $tetris->add + ('rectangle',1, + [$xx, $yy, $xx+$boxsize_x, $yy+$boxsize_y], + -filled => 1, + -fillcolor => 'orange:50', + -tags => ['delline'], + ); + } + $tetris->idletasks; + short_sleep(0.05); + $tetris->remove('delline'); + my $deuxpi = 3.1416; + my $i = 1; + my $angle = 360; + # special effect on TkZinc logo + rotation($deuxpi*$angle/360); + $mylines++; + $tetris->itemconfigure($new,-text => " $mylines Lines\n"); + } + +sub rotation + { + my ($angle, $cnt) = @_; + # first step of animation + if ($cnt == $stepsnumber) + { + inflation(); # scaling effect + return; + } + $cnt++; + # use 'rotation' Zinc method. + my $stepi = 360/$stepsnumber; + $angle = $stepi*2*3.1416/360; + $tetris->rotate($group, $angle, 250, 450 ); + # process the animation using the 'after' Tk defering method + $tetris->after($afterdelay, sub {rotation($angle, $cnt)}); + } + +sub inflation + { + my ($cnt) = @_; + my @pos = $tetris->coords($group); + my $zf; + # last step of animation + if ($cnt == 6) + { + return; + # event steps : wheel grows + } + elsif ($cnt % 2 == 0) + { + $zf = 4*$zoomrate; + # odd steps : wheel is shrunk + } + else + { + $zf = 1/(4*$zoomrate); + } + $cnt++; + # Now, we apply scale transformation to the Group item, using the 'scale' + # Zinc method. Note that we reset group coords before scaling it, in order + # that the origin of the transformation corresponds to the center of the + # wheel. When scale is done, we restore previous coords of group. + $tetris->coords($group, [0, 0]); + $tetris->scale($group, $zf, $zf); + $tetris->coords($group, \@pos); + # process the animation using the 'after' Tk defering method + $tetris->after(100, sub {inflation($cnt)}); + } + +sub game_over { + stop_game(); + # insert_highscore(); + # show_highscore('Game over'); + # save_highscore(); + #toggle_pause(); + my $width = $top->width; + my $height = $top->height; + my $new = $tetris->add('text',$pause_group, + -text => "You lost ! :o)\ntype 'n' to try again !", + -position => [20,100], + ); + $top->update('idletasks'); + short_sleep(1); + $tetris->remove($new); + } + +sub move { + my($dir) = @_; + if (!$active_block || !defined $posx || $pause) { + $top->bell; + return; + } + if ($dir eq 'right' and testblock($active_block, $posx+1, $posy)) { + drawblock($posx, $posy, 0); + $posx++; + drawblock($posx, $posy, 1); + } elsif ($dir eq 'left' and testblock($active_block, $posx-1, $posy)) { + drawblock($posx, $posy, 0); + $posx--; + drawblock($posx, $posy, 1); + } elsif ($dir eq 'turn') { + my $help_block = []; + copyblock($active_block, $help_block); + turn($active_block_nr, $help_block); + if (testblock($help_block, $posx, $posy)) { + drawblock($posx, $posy, 0); + copyblock($help_block, $active_block); + drawblock($posx, $posy, 1); + } + } elsif ($dir eq 'antiturn') { + my $help_block = []; + copyblock($active_block, $help_block); + anti_turn($active_block_nr, $help_block); + if (testblock($help_block, $posx, $posy)) { + drawblock($posx, $posy, 0); + copyblock($help_block, $active_block); + drawblock($posx, $posy, 1); + } + } elsif ($dir eq 'freefall') { + if ($moveable_drop) { + $freefall = 1; + undef_timer(); + action(); + } else { + my $free_fall = 0; + while (testblock($active_block, $posx, $posy+1)) { + drawblock($posx, $posy, 0); + $posy++; + $free_fall++; + drawblock($posx, $posy, 1); + $top->idletasks; + } + array_update(($level+1)*int(($free_fall+$height-$posy+5)/5), + $posx, $posy); + } + } + } + +sub array_update + { + my($plus, $posx, $posy) = @_; + my($i, $j); + undef_timer(); + delete_shadow(); + for $i (0 .. $max_size-1) + { + for $j (0 .. $max_size-1) { + if ($active_block->[$i][$j] and $posy+$i >= 0) { + $playfield->[$posy+$i][$posx+$j] = $active_block->[$i][$j]; + } else { + if ($active_block->[$i][$j]) { + game_over(); + return; + } + } + } + } + $points += $plus; + + if ($posy >= 0) { + for $i ($posy .. $height-2) { + if (to_del_line($i)) { + delete_line($i); + $lines++; + $points += 10*($level+1); + for $j (reverse(0 .. $i-1)) { + my $k; + for $k (1 .. $width-2) { + $playfield->[$j+1][$k] = $playfield->[$j][$k]; + } + } + renew_field($i); + } + } + } + + my $oldlevel = $level; + $level = level(); + if ($oldlevel != $level) { + my $width = $top->width; + my $height = $top->height; + my $newlevel = $tetris->add('text',$pause_group, + -text => 'NEW LEVEL', + -position => [20,20], + ); + $top->update('idletasks'); + short_sleep(0.5); + $tetris->remove($newlevel); + } + + reset_block(); + action(); +} + +sub anti_turn + { + my($number, $block) = @_; + for (1 .. 3) { turn($number, $block) } +} + +sub undef_timer { + if ($timer) { + $timer->cancel; + undef $timer; + } +} + +sub delete_shadow { + return if !$draw_shadow; + for(my $x = 1; $x <= $width-1; $x++) { +# rectangle($x, 0, 0, $shadow); + } +} + +sub to_del_line { + my($posy) = @_; + my $i; + + for $i (1 .. $width-2) { + if ($posy >= 0 and !$playfield->[$posy][$i]) { + return 0; + } + } + 1; +} +sub reset_block { + undef $active_block_nr; + undef $posx; + $freefall = 0; +} + +sub short_sleep { + my $sleep = shift; + if ($^O =~ /win/i) { + $top->Busy; + my $wait = 0; + $top->after($sleep*1000, sub { $wait = 1 }); + $top->waitVariable(\$wait); + $top->Unbusy; + } else { + eval { select(undef, undef, undef, $sleep) }; + } +} + +sub renew_field { + my($max_y) = @_; + $max_y = $height-2 if !defined $max_y; + my($i, $j); + for $i (0 .. $max_y) { + for $j (1 .. $width-2) { + if ($playfield->[$i][$j]) { + rectangle($j, $i, $playfield->[$i][$j], $tetris); + } else { + rectangle($j, $i, 0, $tetris); + } + } + } +} + +sub help + { + inc_pause(); + if (defined $help_top and Tk::Exists($help_top)) + { + $help_top->raise; + return; + } + require Tk::ROText; + my $firebutton = 'Button'; + eval { require Tk::FireButton; Tk::FireButton->VERSION(1.04); }; + $help_top = $top->Toplevel(-title => 'Tetris Help'); + make_key_bindings($help_top); + my $ti = "Zetris help :\n - truc 1\n - truc 2\n - truc 3\n \n"; + my $create_but = sub { + my($t, $command, $fire) = @_; + my $button = ($fire ? $firebutton : 'Button'); + my $but = $tetris->add('text',$pause_group, + -text => $ti, + -font => $base2font->(12), + -position => [20,20], + ); + }; + + my $cb = $help_top->Button(-text => 'Close', + -font => $base2font->(12), + -command => sub { $help_top->destroy })->pack; + $help_top->bind('' => sub { $cb->invoke }); +} -- cgit v1.1