use subs qw
/ClearMsg DoSingleStep NotDone ShowMsg SimStart SimStop mkmb/;
my(@menu_button_list, $quit_flag, $quit_code,
$bounce_status, $bounce_speed, $bounce_running, $bounce_counter);
# This began as a borrowed idea from Python distribution examples, ended up
# with a Ball module of its own. It illustrates how one can run something
# without blocking XEvent processing in a simple-minded sorta way.
# Handles resizes to the main window
# Gurusamy Sarathy (gsar@engin.umich.edu)
# 97/06/10 This demo is sufficiently bizarre enough that we don't use
# WidgetDemo! (-: Plus, you get to see Exists() in action.
$TOP->destroy if Exists
($TOP);
$TOP->title('Bouncing Ball Simulator');
$TOP->iconname('bounce');
$quit_code = sub {$quit_flag = 1};
$TOP->protocol('WM_DELETE_WINDOW' => $quit_code);
my $menubar = $TOP->Frame(qw
/-relief raised -background DarkGreen -bd 2/);
$menubar->pack(-side
=> 'top', -fill
=> 'x');
mkmb
($menubar, 'File', 0, 'File related stuff',
['Exit', sub{$TOP->bell}, 0],
mkmb
($menubar, 'Simulate', 0, 'Simulator control',
['Start', \
&SimStart
, 2],
mkmb
($menubar, 'Display', 0, 'Display settings',
['Redraw', \
&NotDone
, 2],
mkmb
($menubar, 'Options', 0, 'Various preferences',
['Steptime', \
&NotDone
, 0],
['Colors', \
&NotDone
, 0],
['Display', \
&NotDone
, 0],
mkmb
($menubar, 'Help', 0, 'There when you need it',
['About..', \
&NotDone
, 0],
['Contents', \
&NotDone
, 0],
$menu_button_list[$#menu_button_list]->pack(-side
=> 'right');
my $feedback = $TOP->Frame();
$feedback->pack(-side
=> 'bottom', -fill
=> 'x');
$bounce_status = $feedback->Text(
$bounce_status->pack(-side
=> 'left', -fill
=> 'x', -expand
=> 1);
my $drawarea = $TOP->Frame();
$drawarea->pack(-side
=> 'top', -fill
=> 'both', -expand
=> 1);
my $canvas = $drawarea->Canvas(
$canvas->pack(-side
=> 'left', -fill
=> 'both', -expand
=> 1);
$bounce_speed = $drawarea->Scale(
$bounce_speed->pack(-side
=> 'left', -fill
=> 'y');
$bounce_speed->bind('<Enter>' => sub {
ClearMsg
; ShowMsg
('Adjust slider for ball speed');
$bounce_speed->bind('<Leave>' => \
&ClearMsg
);
my $w_buttons = $TOP->Frame;
$w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m));
my $w_dismiss = $w_buttons->Button(
$w_dismiss->pack(qw(-side left -expand 1));
my $w_see = $w_buttons->Button(
-command
=> [\
&see_code
, $demo],
$w_see->pack(qw(-side left -expand 1));
my $w_ball = $w_buttons->Button(
-text
=> 'View Ball Class Module',
-command
=> [\
&view_widget_code
,
Tk
->findINC('demos/widget_lib') . '/Ball.pm'],
$w_ball->pack(qw(-side left -expand 1));
$menu_button_list[1]->cget(-menu
)->entryconfigure(1, -state => 'disabled');
$canvas->Ball(-color
=> 'red', -size
=> 30, -position
=> [200, 75]);
-velocity
=> [8.0, 12.0],
-velocity
=> [8.0, 12.0],
$TOP->repeat(1000 => sub {
return unless $bounce_running;
ShowMsg
(sprintf("%6d interations/second", $bounce_counter));
# This runs the Tk mainloop. Note that the simulation itself has a main
# loop which must be processed. DoSingleStep runs a bit of the simulation
# during every iteration. Also note that, with a flag of 0,
# Tk::DoOneEvent will suspend the process until an X-event arrives,
# effectively blocking the while loop.
# My original idea was to run the simulation mainloop as an asynchronous
# proc handler that runs when Tk is idle, but the necessary Async(3) calls
# from Tcl haven't made it into nTk yet.
DoOneEvent
($bounce_running ? DONT_WAIT
: ALL_EVENTS
);
DoSingleStep
($canvas) if $bounce_running;
# (Ripped from nTk examples)
# Make a Menubutton widget; note that the menu is automatically created.
# We maintain a list of the Menubutton references since some callers
# need to refer to the Menubutton, as well as to suppress stray name
my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = @_;
my $mb = $mb0->Menubutton(
-underline
=> $mb_label_underline,
-background
=> 'DarkGreen',
my($menu) = $mb->Menu(-tearoff
=> 0);
$mb->configure(-menu
=> $menu);
foreach $mb_list (@
{$mb_list_ref}) {
-command
=> $mb_list->[1] ,
-underline
=> $mb_list->[2],
-background
=> 'DarkGreen',
$mb->pack(-side
=> 'left');
$TOP->bind($mb, '<Enter>' => sub {ClearMsg
; ShowMsg
($mb_msg)});
$TOP->bind($mb, '<Leave>' => \
&ClearMsg
);
push @menu_button_list, $mb;
if (not $bounce_running) {
$menu_button_list[1]->cget(-menu
)->entryconfigure(0,
$menu_button_list[1]->cget(-menu
)->entryconfigure(1,
$menu_button_list[1]->cget(-menu
)->entryconfigure(0,
$menu_button_list[1]->cget(-menu
)->entryconfigure(1,
print "Not yet implemented.\n";
$bounce_status->insert('1.0', $msg);
$bounce_status->delete('1.0', 'end');
# The simulation handler.
# Note that this handler must be cooperative and return after a short
# period, so that other X events may be processed by the mainloop below.
Ball
->move_all_balls($canvas, $bounce_speed->get() / 100.0);