pong
0001 #!/usr/bin/perl
0002 use warnings;
0003 use strict;
0004 use Tk;
0005 use Tk::Zinc;
0006
0007 my $motion_flag = 0;
0008 my $count = 0;
0009 my $delay = 50; #adjust for speed of your computer
0010 my $speed = 1000 - $delay;
0011 my $width = 700;
0012 my $height = 600;
0013 my ($leftscore,$rightscore)=(0,0);
0014 my ($up,$left)=(0,0);
0015 my $serve = 'left';
0016 my $randx;
0017 my $randy;
0018 my $dx;
0019 my $dy;
0020 my $lauto = 0;
0021 my $rauto = 0;
0022 my @hits = (-1,1);
0023
0024 my $mw = MainWindow->new;
0025 $mw->geometry($width.'x'.$height);
0026 $mw->resizable(0,0);
0027
0028 my $zinc = $mw->Zinc(-width => $width, -height => $height - 35,
0029 -backcolor => 'black',
0030 -borderwidth => 3,
0031 -relief => 'sunken',
0032 )->pack;
0033
0034 # Then we create a gray filled rectangle, in which we will display explain text.
0035 my $message = $zinc->add('rectangle', 1 , [200, 400, 490, 490],
0036 -linewidth => 2,
0037 -visible => 0,
0038 -filled => 1,
0039 -fillcolor => 'SkyBlue',
0040 );
0041 my $text = $zinc->add('text', 1,
0042 -position => [350, 445],
0043 -visible => 0,
0044 -anchor => 'center',
0045 -priority => 2
0046 );
0047
0048
0049 my $leftgroup= $zinc->add('group',1,-visible=> 1);
0050 $zinc->translate($leftgroup,0,281);
0051
0052 my $rightgroup= $zinc->add('group',1,-visible=> 1);
0053 $zinc->translate($rightgroup,700,281);
0054
0055
0056 #pong paddles
0057 my $leftpaddle = $zinc->add('rectangle',$leftgroup ,[0,-20, 20,20],
0058 -linewidth => 2,
0059 -filled => 1,
0060 -fillcolor => 'red',
0061 );
0062
0063 my $rightpaddle = $zinc->add('rectangle',$rightgroup, [0,-20,-20,20],
0064 -linewidth => 2,
0065 -filled => 1,
0066 -fillcolor => 'red',
0067 );
0068
0069
0070 #my $pongx
0071 #a circle is bounded by a square box, specify 2 diagonal points
0072 my $pong = $zinc->add('arc',1, [30, -20, 50, 0], -fillcolor => "yellow", -filled => 1);
0073
0074 ##############################################################################
0075 # Display comment
0076 &comment("Hit Enter to begin.
0077 $serve is serving
0078 Up arrow inreases speed
0079 Down arrow decreases speed
0080 Escape to pause ");
0081
0082 #set key binding
0083 $mw->Tk::bind('<Return>', \&start);
0084 $mw->Tk::bind('<a>', sub{ my($x1,$y1) = $zinc->coords($leftgroup);
0085 $zinc->translate($leftgroup,0,-40) unless $y1 <= 40 });
0086
0087 $mw->Tk::bind('<z>', sub {my($x1,$y1) = $zinc->coords($leftgroup);
0088 $zinc->translate($leftgroup,0,40) unless $y1 >= 535 });
0089
0090 $mw->Tk::bind('<k>', sub{my($x1,$y1) = $zinc->coords($rightgroup);
0091 $zinc->translate($rightgroup,0,-40) unless $y1 <= 40 });
0092
0093 $mw->Tk::bind('<m>', sub{my($x1,$y1) = $zinc->coords($rightgroup);
0094 $zinc->translate($rightgroup,0,40) unless $y1 >= 535 });
0095
0096 $mw->Tk::bind('<Up>', sub{$delay = ($delay -1) unless $delay <= 1;
0097 $speed = 1000 - $delay;
0098 $mw->update });
0099
0100 $mw->Tk::bind('<Down>', sub{$delay = ($delay + 1)unless $delay >= 1000;
0101 $speed = 1000 - $delay;
0102 $mw->update});
0103
0104
0105 my $f1 = $mw->Frame->pack(-side => 'left', -fill => 'both', -expand => 1,);
0106
0107 my $lscore = $f1->Label(-textvariable => \$leftscore, -bg => 'black', -fg =>'red')->
0108 pack( -side => 'left', -fill => 'both', -expand => '1',);
0109
0110 $f1->Label(-text => "<-- a-up\nz-down", -bg => 'green',)->
0111 pack( -side => 'left', -fill => 'both', -expand => '1',);
0112
0113 my $f2 = $f1->Frame->pack(-side => 'left', -fill => 'both', -expand => 1,);
0114 $f2->Label(-text => "Left AutoPlay", -bg => 'grey')->pack;
0115 my $checkl = $f2->Checkbutton(offvalue => 0,
0116 onvalue => 1,
0117 state => 'normal',
0118 variable => \$lauto)->pack;
0119
0120 $f1->Label(-text => "", -bg => 'black',)->
0121 pack( -side => 'left', -fill => 'both', -expand => '1',);
0122
0123 my $closebutton = $f1->Button(text => 'Exit', -command => sub{Tk::exit(0)})->
0124 pack( -side => 'left', -fill => 'both', -expand => '0');
0125
0126 my $f3 = $f1->Frame->pack(-side => 'left', -fill => 'both', -expand => 1,);
0127 $f3->Label(-text => "Speed", -bg => 'black',-fg =>'green')->
0128 pack( -side => 'left', -fill => 'both', -expand => '1',);
0129 my $smeter = $f3->Label(-textvariable => \$speed, -bg => 'black',-fg =>'green')->
0130 pack( -side => 'left', -fill => 'both', -expand => '1',);
0131
0132
0133 $f1->Label(-text => "", -bg => 'black',)->
0134 pack( -side => 'left', -fill => 'both', -expand => '1',);
0135
0136 my $newgamebutton = $f1->Button(text => "New\nGame", -command => \&newgame)->
0137 pack( -side => 'left', -fill => 'both', -expand => '0');
0138
0139 $f1->Label(-text => "", -bg => 'black',)->
0140 pack( -side => 'left', -fill => 'both', -expand => '1',);
0141
0142
0143 my $f4 = $f1->Frame->pack(-side => 'left', -fill => 'both', -expand => 1,);
0144 $f4->Label(-text => 'Right Autoplay', -bg => 'grey')->pack;
0145 my $checkr = $f4->Checkbutton(offvalue => 0,
0146 onvalue => 1,
0147 state => 'normal',
0148 variable => \$rauto)->pack;
0149
0150 $f1->Label(-text => "k-up-->\nm-down", -bg => 'green')->
0151 pack( -side => 'left', -fill => 'both', -expand => '1',);
0152
0153 my $rscore = $f1->Label(-textvariable => \$rightscore, -bg => 'black',-fg =>'red')->
0154 pack( -side => 'left', -fill => 'both', -expand => '1',);
0155
0156 MainLoop;
0157
0158 sub start {
0159 $zinc->itemconfigure($message,-visible => 0);
0160 $zinc->itemconfigure($text,-visible => 0);
0161 $checkl->configure(state =>'disable');
0162 $checkr->configure(state =>'disable');
0163
0164 if($lauto == 1){$mw->Tk::bind('<a>', sub{});
0165 $mw->Tk::bind('<z>', sub{});
0166 }
0167 if($rauto == 1){$mw->Tk::bind('<k>', sub{});
0168 $mw->Tk::bind('<m>', sub{});
0169 }
0170
0171 $randx = 10 + int rand(5);
0172 $randy = 5 + int rand(2);
0173 $dx = $randx;
0174 $dy = $randy;
0175
0176 $count =0;
0177 $motion_flag = 1;
0178 $mw->Tk::bind('<Return>', sub{});
0179
0180 &startaction;
0181 }
0182
0183 sub stopaction{
0184 $motion_flag = 0;
0185 $mw->Tk::bind('<Return>', \&start);
0186 }
0187
0188 sub startaction {
0189 $mw->Tk::bind('<Escape>', \&stopaction);
0190
0191 push (@hits,shift(@hits)); #circular list to modify ball movement
0192
0193 $dx = $randx;
0194 $dy = $randy;
0195 #print "$dx $dy\n"; # for debugging
0196
0197 if($serve eq 'left'){$zinc->translate($pong,int rand (100),0);$serve = '';}
0198 if($serve eq 'right'){$dx = -$dx;
0199 $zinc->translate($pong,600 - int rand (100),0);$serve = '';}
0200
0201
0202 my($x1,$y1,$xc1,$yc1) = $zinc->bbox($pong);
0203 #print "pong-> $x1 $y1 $xc1 $yc1\n"; #for debugging
0204
0205 my($xl,$yl)= $zinc->coords($leftgroup);
0206 #print "leftpaddle ->$yl\n"; #for debugging
0207
0208 my($xr,$yr)= $zinc->coords($rightgroup);
0209 #print "rightpaddle ->$yr\n"; #for debugging
0210
0211 my $mid = $y1/2 + $yc1/2; #midpoint of pong ball
0212
0213
0214 if($up){$dy = -$dy};
0215 if($left){$dx = -$dx}
0216 $zinc->translate($pong,$dx,$dy);
0217
0218 if($rauto == 1){$zinc->translate($rightgroup,0,$mid - $yr)}
0219 if($lauto == 1){$zinc->translate($leftgroup,0,$mid - $yl)}
0220
0221 if($y1 <= 0){$up = 0} #top bounce
0222 if($y1 >= 535){$up = 1}; #bottom bounce
0223
0224 #if($x1 >= 680){$left = 1} #right bounce
0225 if(($xc1 >= 680)and((($mid)<($yr+20))and(($mid)>($yr-20))))
0226 {$left = 1;
0227 $randx = $randx + 2*$hits[0]/$randx;
0228 $randy = $randy + 2*$hits[0]/$randy;
0229 }
0230
0231 elsif($xc1 >=700){&win('left')}
0232
0233 #if($x1 <= 0){$left = 0} #left bounce
0234 if(($x1 <= 20)and((($mid)<($yl+20))and(($mid)>($yl-20))))
0235 {$left = 0;
0236 $randx = $randx + 2*$hits[0]/$randx;
0237 $randy = $randy + 2*$hits[0]/$randy;
0238 }
0239 elsif($x1<=0){&win('right')}
0240
0241
0242 if($motion_flag == 1){ $zinc->after($delay, sub {startaction()})}
0243 else {return}
0244 }
0245
0246 sub resetpos{
0247 $zinc->treset($pong);
0248 }
0249
0250
0251 # Just display comment
0252 sub comment {
0253 $zinc->itemconfigure($message,-visible => 1);
0254 $zinc->itemconfigure($text,-visible => 1);
0255 my $string = shift;
0256 $zinc->itemconfigure($text, -text => $string);
0257 }
0258
0259 # display win
0260 sub win {
0261 my $string = shift;
0262 if($string eq 'left'){$leftscore++;$serve = 'left';$left = 0}
0263 if($string eq 'right'){$rightscore++;$serve = 'right';$left = 1}
0264 $mw->update;
0265 print ("\007");
0266
0267 &comment("Hit Enter to begin.
0268 $serve is serving
0269 Up arrow inreases speed
0270 Down arrow decreases speed
0271 Escape to pause ");
0272
0273 $motion_flag=0;
0274 $zinc->treset($pong);
0275 $mw->Tk::bind('<Return>', sub{$motion_flag = 1;&start});
0276 }
0277
0278
0279 sub newgame{
0280 $motion_flag = 0;
0281 $count = 0;
0282 ($leftscore,$rightscore)=(0,0);
0283 ($up,$left)=(0,0);
0284 $serve = 'left';
0285 my $lauto = 0;
0286 my $rauto = 0;
0287
0288 &comment("Hit Enter to begin.
0289 $serve is serving
0290 Up arrow inreases speed
0291 Down arrow decreases speed
0292 Escape to pause ");
0293
0294 $checkl->configure(state =>'normal');
0295 $checkr->configure(state =>'normal');
0296
0297 $motion_flag=0;
0298 $zinc->treset($pong);
0299
0300 $mw->update;
0301 $mw->Tk::bind('<Return>', sub{$motion_flag = 1;&start});
0302 }
0303
0304