Beefy Boxes and Bandwidth Generously Provided by pair Networks
Come for the quick hacks, stay for the epiphanies.
 
PerlMonks  

PONG with TkZinc

by zentara (Archbishop)
on Nov 15, 2003 at 17:14 UTC ( [id://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});
}

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: sourcecode [id://307332]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others browsing the Monastery: (5)
As of 2024-04-18 18:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found