The Labs.Com Issue_03_Tk

TPJ: Issue_03_Tk

This is a collection of programs published by The Perl Journal. You can download all source-code also from TPJ: Programs.

1. breakout
2. flash
3. idle
4. neko
5. ptksh1
6. ptksh2
7. rpt
8. images
9. Tk
10. More Samples on Tk

Download breakout

#!/usr/local/bin/perl -w

#

# breakout - a Breakout-like game that highlights event handling and a

# derived widget.

#

# This code was inspired by the bouncing ball simulation written by

# Gurusamy Sarathy (gsar@engin.umich.edu)

#

# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.E\

DU

# 96/07/22.

#

# Copyright (C) 1996 - 1996 Stephen O. Lidie. All rights reserved.

#

# This program is free software; you can redistribute it and/or modify\

it under

# the same terms as Perl itself.

require 5.002;

use English;

use Tk;

use Tk::Dialog;

use Tk::DoOneEvent;

use Tk::Breakout;

use strict;

use subs qw(clear_msg mkmb pause play initialize show_msg);

my($ABOUT, $COUNTER, @MBS, $MW, $BREAKOUT, $QUIT, $RUNNING, $STATUS, $\

SPEED);

my($GAME, $GO, $NO) = (1, 0, 1); # "Game" menu item ordinals

initialize;

# This code replaces the standard Tk MainLoop().  If the game is activ\

e then

# a single Tk event is processed and a bit of the game is run.  But ca\

lling

# DoOneEvent() with $TK_WAIT blocks the while loop until an X-event ar\

rives,

# effectively pausing the game.

while (1) {

exit if $QUIT;

DoOneEvent($RUNNING ? $TK_DONT_WAIT : $TK_WAIT);

$BREAKOUT->move_balls($SPEED->get / 100.0) if $RUNNING;

} # whilend MainLoop

sub initialize {

$MW = MainWindow->new;

$QUIT = 0;

my $quit_code = sub {$QUIT = 1};

$RUNNING = 0;

$MW->title('Breakout Simulator');

$MW->iconname('breakout');

$MW->protocol('WM_DELETE_WINDOW' => $quit_code);

$ABOUT = $MW->Dialog(-text => <<"END"

breakout Version 1.0\n

Keep ball from hitting ceiling or floor.\n

p   Toggle play/pause

-   Decrease speed by 5%

=   Increase speed by 5%

END

);

my $menubar = $MW->Frame(

-relief      => 'raised',

-background  => 'blue',

-borderwidth => 2,

);

$menubar->pack(-side => 'top', -fill => 'x');

mkmb($menubar, 'File', 0, 'Breakout File Related Stuff',

[

['Quit',  $quit_code,    0],

]);

mkmb($menubar, 'Game', 0, 'Breakout Control',

[

['Play',  \&play,  1],

['Pause', \&pause,  1],

]);

mkmb($menubar, 'Help', 0, 'Breakout Help',

[

['About',  [$ABOUT => 'Show'],  0],

]);

$MBS[$#MBS]->pack(-side => 'right');

my $feedback = $MW->Frame;

$feedback->pack(-side => 'bottom', -fill => 'x');

$STATUS = $feedback->Text(

-relief      => 'sunken',

-height      => 1,

-background  => 'gray',

-borderwidth => 2,

);

$STATUS->pack(-side => 'left', -fill => 'x', -expand =>\

; 1);

my $drawarea = $MW->Frame(-borderwidth => 30);

$drawarea->pack(-side => 'top', -fill => 'both', -expand \

=> 1);

$BREAKOUT = $drawarea->Breakout(

-relief => 'ridge',

-height => 400,

-width  => 600,

-bd     => 2,

-balls  => [{-color => 'yellow', -size => 40, -positi\

on => [90, 250]}],

);

$BREAKOUT->pack(-side => 'left', -fill => 'both', -expand\

=> 1);

$SPEED = $drawarea->Scale(

-orient            => 'vertical',

-width             => 10,

-from              => 100,

-to                => 0,

-borderwidth       => 1,

-activebackground  => 'yellow',

);

$SPEED->pack(-side => 'left', -fill => 'y');

$SPEED->bind('<Enter>' => sub {

show_msg('Adjust slider for ball speed');

});

$SPEED->bind('<Leave>' => \&clear_msg);

$SPEED->set(5);

# Keyboard shortcuts for common game actions.

$MW->bind('<Key-p>' => sub {$RUNNING ? &pause : &play}\

);

$MW->bind('<Key-equal>' => [\&change_speed, $SPEED, +5\

]);

$MW->bind('<Key-minus>' => [\&change_speed, $SPEED, -5\

]);

$MBS[$GAME]->cget(-menu)->entryconfigure($NO, -state => '\

disabled');

} # end initialize

sub change_speed {

my($MW, $scale, $delta) = @ARG;

$scale->set($scale->get + $delta);

} # end change_speed

sub clear_msg {

$STATUS->delete('1.0', 'end');

} # end clear_msg

sub mkmb {

# (Ripped from nTk examples)

# Make a Menubutton widget; note that the menu is automatically cr\

eated.

# We maintain a list of the Menubutton references since some calle\

rs

# need to refer to the Menubutton, as well as to suppress stray na\

me

# warnings with Perl -w.

my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = \

@ARG;

my $mb = $mb0->Menubutton(

-text             => $mb_label,

-underline        => $mb_label_underline,

-background       => 'blue',

-foreground       => 'Yellow',

-activebackground => 'yellow',

-activeforeground => 'blue',

);

my($menu) = $mb->Menu(-tearoff => 0);

$mb->configure(-menu => $menu);

my $mb_list;

foreach $mb_list (@{$mb_list_ref}) {

$mb->command(

-label            => $mb_list->[0],

-command          => $mb_list->[1] ,

-underline        => $mb_list->[2],

-background       => 'blue',

-foreground       => 'yellow',

-activebackground => 'yellow',

-activeforeground => 'blue',

);

}

$mb->pack(-side => 'left');

$MW->bind($mb, '<Enter>' => sub {show_msg($mb_msg)});

$MW->bind($mb, '<Leave>' => \&clear_msg);

push @MBS, $mb;                # keep track of new menubutton

return $mb;

} # end mkmb

sub pause {

if ($RUNNING) {

$RUNNING = 0;

$MBS[$GAME]->cget(-menu)->entryconfigure($GO, -state =&g\

t; 'normal');

$MBS[$GAME]->cget(-menu)->entryconfigure($NO, -state =&g\

t; 'disabled');

}

} # end pause

sub play {

if (not $RUNNING) {

$RUNNING = 1;

$MBS[$GAME]->cget(-menu)->entryconfigure($GO, -state =&g\

t; 'disabled');

$MBS[$GAME]->cget(-menu)->entryconfigure($NO, -state =&g\

t; 'normal');

}

} # end play

sub show_msg {

my($msg) = shift;

clear_msg;

$STATUS->insert('1.0', $msg);

} # end show_msg

Issue_03_Tk 2. flash

Download flash

#!/usr/local/bin/perl -w

#

# Flash a button, that's all!

require 5.002;

use English;

use Tk;

use strict;

use subs qw(flash_widget);

my $MW = MainWindow->new;

my $b = $MW->Button(-text => 'Hello World!', -command => \&ex\

it)->pack;

flash_widget $b, -background, qw(blue yellow), 500;

MainLoop;

sub flash_widget {

# Flash a widget attribute periodically.

my($w, $opt, $val1, $val2, $interval) = @ARG;

$w->configure($opt => $val1);

$MW->after($interval, [\&flash_widget, $w, $opt, $val2, $val1, \

$interval]);

}

Issue_03_Tk 3. idle

Download idle

#!/usr/local/bin/perl -w

#

# Demonstrate use of afterIdle() to queue a low priority callback.

require 5.002;

use English;

use Tk;

use Tk::DoOneEvent;

use strict;

my $MW = MainWindow->new;

$MW->Button(-text => 'afterIdle', -command => \&queue_afterId\

le)->pack;

MainLoop;

sub queue_afterIdle {

$MW->afterIdle(sub {$MW->bell});

print "afterIdle event queued, block for 5 seconds...\n";

$MW->after(5000);

print "It's 5 seconds later, call idletasks() to activate the hand\

ler.\n";

$MW->idletasks;

print "The bell should have sounded ...\n";

$MW->destroy;

}

Issue_03_Tk 4. neko

Download neko

#!/usr/local/bin/perl -w

#

# Simple neko animation using non-blocking techniques.  Idea and bitma\

ps

# (now color PPM files) based on xneko by Masayuki Koba.

#

# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.E\

DU

# 96/06/28.

#

# Copyright (C) 1996 - 1996 Stephen O. Lidie. All rights reserved.

#

# This program is free software; you can redistribute it and/or modify\

it under

# the same terms as Perl itself.

require 5.002;

use English;

use Tk;

use strict;

use subs qw(animate hide_frame hide_nekos move_frame snooze);

my ($ANIMATE, $BLOCK, $HIDE, $SCAMPER_Y, $SNZ_X, @IDS) = (0, 0, 30, 10\

0, 28);

my ($DELTA_X, $MW) = (16, MainWindow->new);

# Create the canvas and some window items to stuff inside it.  Some wi\

dgets

# are realized now, the rest after presentation of the neko frames is \

complete.

my @bg = qw(-background white);

my @ht = qw(-highlightthickness 0);

my @pk = qw(-side left);

my $C = $MW->Canvas(-height => 150, -width => 500, @ht, @bg)-\

>pack(@pk);

my $f = $MW->Frame(@bg);

$C->create('window', 250, $HIDE, -window => $f);

my $A = $f->Button(-text => 'Presenting neko!', @bg,

-command => [$MW => 'bell'])->pack;

my $B = $f->Checkbutton(-text => 'Block?', -variable => \$BLO\

CK,

-onvalue => 1, -offvalue => 0, @ht, @bg)\

;

my $D = $MW->Label(-textvariable => \$DELTA_X, @bg);

my $Q = $f->Button(-text => 'Quit', -command => \&exit, @bg);

my $S = $MW->Scale(-orient => 'vertical', -from => 1, -to =&g\

t; 100, @bg, @ht,

-variable => \$DELTA_X, -width => 5, -showval\

ue => 0);

# Create the six Photo images from the color PPM files and display the\

m in a

# row.  The canvas image item ids are stored in the global array @IDS \

for use

# by the rest of the neko code.  For instance, to perform a canvas ope\

ration

# on the neko icon, simply fetch its item id from $IDS[5].  Sorry for \

using

# hardcoded values, but this is just "proof of concept" code!

my $x = 125;

foreach (qw(left1 left2 sleep1 sleep2 awake icon)) {

push @IDS, $C->create('image', $x, $SCAMPER_Y,

-image => $MW->Photo(-file => "imag\

es/$ARG.ppm"));

$x += 50;

}

# Wait for the main window to appear before hiding the neko frames, ot\

herwise,

# you might never get to see them.

$MW->waitVisibility($MW);

$MW->after(2000, \&hide_nekos);

MainLoop;

sub animate {

my($id, $done, $delay) = (0, 0, 0);

my $cb = sub {$done++};

# Hide the snoozing neko.

$ANIMATE = 1;

$A->configure(-state => 'disabled');

foreach $id (@IDS[2..3]) {hide_frame $id}

# Awaken neko for 2 seconds, then hide the frame.

$id = $IDS[4];

move_frame $id, 460, $SCAMPER_Y;

$delay = 2000;

if ($BLOCK) {

$MW->after($delay);

} else {

$MW->after($delay => $cb);

$MW->waitVariable(\$done);

}

hide_frame $id;

# Move neko right to left by exposing successive frames for 0.1 se\

cond.

my($i, $k) = (0, -1);

$delay = 100;

for($i = 460; $i >= 40; $i -= $DELTA_X) {

$id = $IDS[++$k % 2];

move_frame $id, $i, $SCAMPER_Y;

if ($BLOCK) {

$MW->after($delay);

} else {

$MW->after($delay => $cb);

$MW->waitVariable(\$done);

}

hide_frame $id;

}

# Snooze - neko is tired.

$ANIMATE = 0;

$A->configure(-state => 'normal');

snooze;

}

sub hide_frame {

# Hide a neko frame "under" the neko icon which is top of the disp\

lay list.

my $id = shift;

my ($x, $y) = $C->coords($id);

$C->move($id, $HIDE-$x, $HIDE-$y);

$MW->idletasks;

}

sub hide_nekos {

# First, "hide" the various nekos by moving all of them to ($HIDE,\

$HIDE).

# Since the neko icon is the last item in the canvas display list,\

it ends

# up being on "top of the pile".  Wait until all the frames are tu\

cked away

# before reconfiguring the Animation button and packing the Quit b\

utton.

my($i, $done, $rptid, $cb) = ($#IDS, 0, 0, 0);

$cb = sub {my($ir) = @ARG; hide_frame $IDS[$$ir--]; $done++ if $$i\

r < 0};

my $rptid = $MW->repeat(1000 => [$cb, \$i]);

$MW->waitVariable(\$done);

$MW->afterCancel($rptid);

$A->packForget;

$A->configure(-text => 'Animate', -command => \&animate);

$B->pack(-side => 'left');

$A->pack(-side => 'left');

$Q->pack(-side => 'left');

$S->pack(-side => 'left', -fill => 'both');

$C->create('window', 485, $HIDE, -window => $D);

snooze;

}

sub move_frame {

# Move a neko frame to an absolute canvas position.

my($id, $absx, $absy) = @ARG;

my ($x, $y) = $C->coords($id);

$C->move($id, $absx-$x, $absy-$y);

$MW->idletasks;

}

sub snooze {

my($id, $k, $done) = (0, -1, 0);

while (1) {

return if $ANIMATE;

$id = $IDS[(++$k % 2) + 2];

move_frame $id, $SNZ_X, $SCAMPER_Y;

$MW->after(500 => sub {$done++});

$MW->waitVariable(\$done);

hide_frame $id;

}

}

Issue_03_Tk 5. ptksh1

Download ptksh1

#!/usr/local/bin/perl -w

# Perl/Tk shell - interactively execute input captured by a fileevent \

on STDIN.

#

# Variable $MW is an object reference to the main window, from which y\

ou can

# create and manipulate child widgets.  Variable names beginning with \

an

# underscore are reserved for this application.

require 5.002;

use English;

use Tk;

use Tk::Pretty qw(Pretty);

use Tk::Dialog;

use strict;

use subs qw(doit ptksh user_input);

my($MW, $_PTKSH, $_VERSION, $_HELP, $_SHELL, $_TAB, $_PARA);

ptksh;                          # main

sub doit {

# Eval some code without use strict constraints.

my($code) = @ARG;

{

no strict;

eval $code;

print $EVAL_ERROR if $EVAL_ERROR;

}

} # end doit

sub ptksh {

# Nothing fancy here, just create the main window and the help dia\

log

# object, establish the input fileevent handler and away we go.

$OUTPUT_AUTOFLUSH = 1;

$_PTKSH = 'ptksh';

$_VERSION = '0.4';

$_SHELL = '/bin/sh';

$_SHELL = $ENV{'SHELL'} if $ENV{'SHELL'};

$_TAB = 0;

$_PARA = '';

$MW = MainWindow->new;

$MW->title($_PTKSH);

$MW->iconname($_PTKSH);

$_HELP = $MW->Dialog(

-title      => "$_PTKSH Help",

-font       => 'fixed',

-wraplength => '6i',

-justify    => 'left',

-text       =>

"?    - this text.\n" .

"!    - pass arguments to your shell (default /bin/sh).\n"\

.

"p    - use Tk::Pretty to \"pretty-print\" arguments.\n" .

"\\t   - a tab starts/stops multiline input mode.\n" .

"exit - quit $_PTKSH.\n" .

"\nOther input is assumed to be a Perl/Tk command.\n" .

"\n\$MW is the MainWindow.\n",

);

$_HELP->configure(-foreground => 'blue');

$MW->fileevent('STDIN', 'readable' => \&user_input);

print "\nPerl/Tk Shell $_VERSION, enter ? for help.\n\n$_PTKSH>\

";

MainLoop;

} # end ptksh

sub user_input {

# Called when input is available on STDIN.

$ARG = <>;

if (not defined $ARG) {

print "\n";

exit;

}

if (/^\?(.*)/) {            # help

$_HELP->Show;

} elsif (/^!(.*)/) {        # bang

system "$_SHELL -c \"$1\"";

print "/bin/sh error status=$CHILD_ERROR.\n" if $CHILD_ERROR;

} elsif (/^\t$/) {

$_TAB++;

if ($_TAB % 2) {

$_PARA = '';

} else {

doit $_PARA;

}

} else {                    # Perl/Tk command

$ARG = "print Pretty($1), \"\n\";" if (/^p\s(.*)$/);

if ($_TAB % 2) {

$_PARA .= $ARG;

} else {

doit $ARG;

}

} # ifend

print $_PTKSH, $_TAB % 2 ? ' ...\\' : '>';

} # end user_input

Issue_03_Tk 6. ptksh2

Download ptksh2

#!/usr/local/bin/perl -w

#

# ptksh2 - another Perl/Tk shell using DoOneEvent() rather than fileev\

ent().

require 5.002;

use English;

use Tk;

use Tk::DoOneEvent;

use strict;

my $MW = MainWindow->new;

$MW->title('ptksh2');

$MW->iconname('ptksh2');

while(1) {

while(1) {

last unless DoOneEvent($TK_DONT_WAIT);

}

print "ptksh> ";

{no strict; eval <>;}

print $EVAL_ERROR if $EVAL_ERROR;

}

Issue_03_Tk 7. rpt

Download rpt

#!/usr/local/bin/perl -w

#

# Repeat a callback indefinitely.

require 5.002;

use English;

use Tk;

use strict;

my $MW = MainWindow->new;

$MW->Button(-text => 'Quit', -command => \&exit)->pack;

$MW->repeat(1000, sub {print "Hello World!\n"});

MainLoop;

Issue_03_Tk 8. images

Download images

Issue_03_Tk 9. Tk

Download Tk

Issue_03_Tk 10. More Samples on Tk

• Issue_01_Tk
• Issue_02_Tk
• Issue_03_Tk
• Issue_04_Tk
• Issue_05_Tk
• Issue_06_Tk
• Issue_07_Tk
• Issue_09_Tk