Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

PONG with TkZinc

by zentara (Archbishop)
on Nov 15, 2003 at 17:14 UTC ( #307332=sourcecode: print w/ replies, xml ) Need Help??

Category: Fun Stuff
Author/Contact Info zentara@zentara.net
Description: This is a PONG game made with the TkZinc module. TkZinc is a "canvas" with excellent 2d translations and rotation, and includes "groups". A PONG screenshot. Also, I have been documenting my "learning process with TkZinc, and have it in a beginner's tutorial at TkZinc Beginners Tutorial.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::Zinc;

my $motion_flag = 0;
my $count = 0;
my $delay = 50; #adjust for speed of your computer 
my $speed = 1000 - $delay;
my $width = 700;
my $height = 600;
my ($leftscore,$rightscore)=(0,0);
my ($up,$left)=(0,0);
my $serve = 'left';
my $randx;
my $randy;
my $dx;
my $dy;
my $lauto = 0;
my $rauto = 0;
my @hits = (-1,1);

my $mw = MainWindow->new;
$mw->geometry($width.'x'.$height);
$mw->resizable(0,0);

my $zinc = $mw->Zinc(-width => $width, -height => $height - 35,
                -backcolor => 'black',
                -borderwidth => 3,
                -relief => 'sunken',
                )->pack;

# Then we create a gray filled rectangle, in which we will display exp
+lain text. 
my $message = $zinc->add('rectangle', 1 , [200, 400, 490, 490],
              -linewidth => 2,
              -visible => 0,
              -filled => 1,
              -fillcolor => 'SkyBlue',
                               );
my $text = $zinc->add('text', 1,
                      -position => [350, 445],
                      -visible => 0,
                      -anchor => 'center',
                      -priority => 2
                      );


my $leftgroup= $zinc->add('group',1,-visible=> 1);
$zinc->translate($leftgroup,0,281);

my $rightgroup= $zinc->add('group',1,-visible=> 1);
$zinc->translate($rightgroup,700,281);


#pong paddles 
my $leftpaddle = $zinc->add('rectangle',$leftgroup ,[0,-20, 20,20],
                            -linewidth => 2,
                            -filled => 1,
                            -fillcolor => 'red',
                            );

my $rightpaddle = $zinc->add('rectangle',$rightgroup, [0,-20,-20,20],
                               -linewidth => 2,
                               -filled => 1,
                               -fillcolor => 'red',
                            );


#my $pongx 
#a circle is bounded by a square box, specify 2 diagonal points  
my $pong = $zinc->add('arc',1, [30, -20, 50, 0], -fillcolor => "yellow
+", -filled => 1);


######################################################################
+######## 
# Display comment 
&comment("Hit Enter to begin. 
$serve is serving 
Up arrow inreases speed  
Down arrow decreases speed  
Escape to pause ");

#set key binding 
$mw->Tk::bind('<Return>', \&start);
$mw->Tk::bind('<a>', sub{ my($x1,$y1) =  $zinc->coords($leftgroup);
                          $zinc->translate($leftgroup,0,-40) unless $y
+1 <= 40 });

$mw->Tk::bind('<z>', sub {my($x1,$y1) =  $zinc->coords($leftgroup);
                         $zinc->translate($leftgroup,0,40) unless $y1 
+>= 535 });

$mw->Tk::bind('<k>', sub{my($x1,$y1) =  $zinc->coords($rightgroup);
                         $zinc->translate($rightgroup,0,-40) unless $y
+1 <= 40 });

$mw->Tk::bind('<m>', sub{my($x1,$y1) =  $zinc->coords($rightgroup);
                         $zinc->translate($rightgroup,0,40) unless $y1
+ >= 535 });

$mw->Tk::bind('<Up>', sub{$delay = ($delay -1) unless $delay <= 1;
                                       $speed = 1000 - $delay;
                                       $mw->update });

$mw->Tk::bind('<Down>', sub{$delay = ($delay + 1)unless $delay >= 1000
+;
                                       $speed = 1000 - $delay;
                                       $mw->update});


my $f1 = $mw->Frame->pack(-side => 'left', -fill => 'both', -expand =>
+ 1,);

   my $lscore = $f1->Label(-textvariable => \$leftscore, -bg => 'black
+', -fg =>'red')->
              pack( -side => 'left', -fill => 'both', -expand => '1',)
+;

   $f1->Label(-text => "<-- a-up\nz-down", -bg => 'green',)->
              pack( -side => 'left', -fill => 'both', -expand => '1',)
+;

my $f2 = $f1->Frame->pack(-side => 'left', -fill => 'both', -expand =>
+ 1,);
  $f2->Label(-text => "Left AutoPlay", -bg => 'grey')->pack;
  my $checkl = $f2->Checkbutton(offvalue => 0,
                 onvalue => 1,
                 state => 'normal',
                 variable => \$lauto)->pack;

$f1->Label(-text => "", -bg => 'black',)->
              pack( -side => 'left', -fill => 'both', -expand => '1',)
+;

my $closebutton = $f1->Button(text => 'Exit', -command => sub{Tk::exit
+(0)})->
                pack( -side => 'left', -fill => 'both', -expand => '0'
+);

my $f3 = $f1->Frame->pack(-side => 'left', -fill => 'both', -expand =>
+ 1,);
   $f3->Label(-text => "Speed", -bg => 'black',-fg =>'green')->
         pack( -side => 'left', -fill => 'both', -expand => '1',);
   my $smeter = $f3->Label(-textvariable => \$speed, -bg => 'black',-f
+g =>'green')->
         pack( -side => 'left', -fill => 'both', -expand => '1',);


$f1->Label(-text => "", -bg => 'black',)->
              pack( -side => 'left', -fill => 'both', -expand => '1',)
+;

my $newgamebutton = $f1->Button(text => "New\nGame", -command => \&new
+game)->
                pack( -side => 'left', -fill => 'both', -expand => '0'
+);

$f1->Label(-text => "", -bg => 'black',)->
              pack( -side => 'left', -fill => 'both', -expand => '1',)
+;


my $f4 = $f1->Frame->pack(-side => 'left', -fill => 'both', -expand =>
+ 1,);
   $f4->Label(-text => 'Right Autoplay', -bg => 'grey')->pack;
   my $checkr = $f4->Checkbutton(offvalue => 0,
                   onvalue => 1,
                   state => 'normal',
                   variable => \$rauto)->pack;

$f1->Label(-text => "k-up-->\nm-down", -bg => 'green')->
    pack( -side => 'left', -fill => 'both', -expand => '1',);

my $rscore = $f1->Label(-textvariable => \$rightscore, -bg => 'black',
+-fg =>'red')->
   pack( -side => 'left', -fill => 'both', -expand => '1',);

MainLoop;

sub start {
    $zinc->itemconfigure($message,-visible => 0);
    $zinc->itemconfigure($text,-visible => 0);
    $checkl->configure(state =>'disable');
    $checkr->configure(state =>'disable');

if($lauto == 1){$mw->Tk::bind('<a>', sub{});
                $mw->Tk::bind('<z>', sub{});
               }
if($rauto == 1){$mw->Tk::bind('<k>', sub{});
                $mw->Tk::bind('<m>', sub{});
               }
               
    $randx = 10 + int rand(5);
    $randy = 5 + int rand(2);
    $dx = $randx;
    $dy = $randy;

    $count =0;
    $motion_flag = 1;
    $mw->Tk::bind('<Return>', sub{});

    &startaction;
}

sub stopaction{
    $motion_flag = 0;
    $mw->Tk::bind('<Return>', \&start);
}

sub startaction {
    $mw->Tk::bind('<Escape>', \&stopaction);

push (@hits,shift(@hits)); #circular list to modify ball movement 

 $dx = $randx;
 $dy = $randy;
#print "$dx  $dy\n"; # for debugging 

if($serve eq 'left'){$zinc->translate($pong,int rand (100),0);$serve =
+ '';}
if($serve eq 'right'){$dx = -$dx;
       $zinc->translate($pong,600 - int rand (100),0);$serve = '';}


my($x1,$y1,$xc1,$yc1) =  $zinc->bbox($pong);
#print "pong-> $x1  $y1  $xc1  $yc1\n"; #for debugging 

my($xl,$yl)= $zinc->coords($leftgroup);
#print "leftpaddle ->$yl\n"; #for debugging 

my($xr,$yr)= $zinc->coords($rightgroup);
#print "rightpaddle ->$yr\n"; #for debugging 

my $mid = $y1/2 + $yc1/2; #midpoint of pong ball 


if($up){$dy = -$dy};
if($left){$dx = -$dx}
$zinc->translate($pong,$dx,$dy);

if($rauto == 1){$zinc->translate($rightgroup,0,$mid - $yr)}
if($lauto == 1){$zinc->translate($leftgroup,0,$mid - $yl)}

if($y1 <= 0){$up = 0} #top bounce 
if($y1 >= 535){$up = 1}; #bottom bounce 

#if($x1 >= 680){$left = 1} #right bounce 
if(($xc1 >= 680)and((($mid)<($yr+20))and(($mid)>($yr-20))))
                        {$left = 1;
                        $randx = $randx + 2*$hits[0]/$randx;
                        $randy = $randy + 2*$hits[0]/$randy;
                         }
                         
    elsif($xc1 >=700){&win('left')}

#if($x1 <= 0){$left = 0} #left bounce 
if(($x1 <= 20)and((($mid)<($yl+20))and(($mid)>($yl-20))))
                           {$left = 0;
                           $randx =  $randx + 2*$hits[0]/$randx;
                           $randy =  $randy + 2*$hits[0]/$randy;
                           }
   elsif($x1<=0){&win('right')}


  if($motion_flag == 1){ $zinc->after($delay, sub {startaction()})}
     else {return}
}
sub resetpos{
$zinc->treset($pong);
 }


# Just display comment  
sub comment {
    $zinc->itemconfigure($message,-visible => 1);
    $zinc->itemconfigure($text,-visible => 1);
    my $string = shift;
    $zinc->itemconfigure($text, -text => $string);
}

# display win  
sub win {
    my $string = shift;
    if($string eq 'left'){$leftscore++;$serve = 'left';$left = 0}
    if($string eq 'right'){$rightscore++;$serve = 'right';$left = 1}
    $mw->update;
    print ("\007");

&comment("Hit Enter to begin. 
$serve is serving 
Up arrow inreases speed  
Down arrow decreases speed  
Escape to pause ");

    $motion_flag=0;
    $zinc->treset($pong);
    $mw->Tk::bind('<Return>', sub{$motion_flag = 1;&start});
}


sub newgame{
$motion_flag = 0;
$count = 0;
($leftscore,$rightscore)=(0,0);
($up,$left)=(0,0);
$serve = 'left';
my $lauto = 0;
my $rauto = 0;

&comment("Hit Enter to begin. 
$serve is serving 
Up arrow inreases speed  
Down arrow decreases speed  
Escape to pause ");

$checkl->configure(state =>'normal');
$checkr->configure(state =>'normal');

    $motion_flag=0;
    $zinc->treset($pong);

    $mw->update;
    $mw->Tk::bind('<Return>', sub{$motion_flag = 1;&start});
}

Comment on PONG with TkZinc
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://307332]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (5)
As of 2015-07-06 06:27 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (70 votes), past polls