summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/bounce.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/bounce.pl')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/bounce.pl274
1 files changed, 274 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/bounce.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/bounce.pl
new file mode 100644
index 00000000000..a6012fb818b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/bounce.pl
@@ -0,0 +1,274 @@
+# bounce.pl
+
+use Ball;
+use Tk qw/:eventtypes/;
+use subs qw/ClearMsg DoSingleStep NotDone ShowMsg SimStart SimStop mkmb/;
+use vars qw/$TOP/;
+
+my(@menu_button_list, $quit_flag, $quit_code,
+ $bounce_status, $bounce_speed, $bounce_running, $bounce_counter);
+
+sub bounce {
+
+ # 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)
+ # Tidied up by SOL.
+ #
+ # 97/06/10 This demo is sufficiently bizarre enough that we don't use
+ # WidgetDemo! (-: Plus, you get to see Exists() in action.
+
+ my($demo) = @_;
+
+ $TOP->destroy if Exists($TOP);
+ $TOP = $MW->Toplevel;
+ $TOP->title('Bouncing Ball Simulator');
+ $TOP->iconname('bounce');
+
+ @menu_button_list = ();
+ $quit_flag = 0;
+ $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',
+ [
+ ['Open', \&NotDone, 0],
+ ['New', \&NotDone, 0],
+ ['Print', \&NotDone, 0],
+ ['Exit', sub{$TOP->bell}, 0],
+ ]);
+
+ mkmb($menubar, 'Simulate', 0, 'Simulator control',
+ [
+ ['Start', \&SimStart, 2],
+ ['Stop', \&SimStop, 2],
+ ]);
+
+ mkmb($menubar, 'Display', 0, 'Display settings',
+ [
+ ['Redraw', \&NotDone, 2],
+ ['Clear', \&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],
+ ['Intro', \&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(
+ -relief => 'sunken',
+ -height => 1,
+ -background => 'gray',
+ -borderwidth => 2,
+ );
+ $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(
+ -relief => 'ridge',
+ -height => 400,
+ -width => 600,
+ -borderwidth => 2,
+ );
+ $canvas->pack(-side => 'left', -fill => 'both', -expand => 1);
+
+ $bounce_speed = $drawarea->Scale(
+ -orient => 'vert',
+ -showvalue => 0,
+ -width => 10,
+ -from => 100,
+ -to => 0,
+ -borderwidth => 1,
+ );
+ $bounce_speed->pack(-side => 'left', -fill => 'y');
+ $bounce_speed->bind('<Enter>' => sub {
+ ClearMsg; ShowMsg('Adjust slider for ball speed');
+ });
+ $bounce_speed->bind('<Leave>' => \&ClearMsg);
+ $bounce_speed->set(50);
+
+ my $w_buttons = $TOP->Frame;
+ $w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m));
+ my $w_dismiss = $w_buttons->Button(
+ -text => 'Dismiss',
+ -command => $quit_code,
+ );
+ $w_dismiss->pack(qw(-side left -expand 1));
+ my $w_see = $w_buttons->Button(
+ -text => 'See Code',
+ -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,
+ Tk->findINC('demos/widget_lib') . '/Ball.pm'],
+ );
+ $w_ball->pack(qw(-side left -expand 1));
+
+ $bounce_running = 0;
+ $menu_button_list[1]->cget(-menu)->entryconfigure(1, -state => 'disabled');
+
+ $canvas->Ball;
+ $canvas->Ball(-color => 'red', -size => 30, -position => [200, 75]);
+ $canvas->Ball(
+ -color => 'green',
+ -size => 60,
+ -position => [490, 275],
+ -velocity => [8.0, 12.0],
+ );
+ $canvas->Ball(
+ -color => 'yellow',
+ -size => 100,
+ -position => [360, 60],
+ -velocity => [8.0, 12.0],
+ );
+
+ $bounce_counter = 0;
+ $TOP->repeat(1000 => sub {
+ return unless $bounce_running;
+ ClearMsg;
+ ShowMsg(sprintf("%6d interations/second", $bounce_counter));
+ $bounce_counter = 0
+ });
+
+
+ # 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.
+
+ while (1) {
+ if ($quit_flag) {
+ $TOP->destroy;
+ return;
+ }
+ DoOneEvent($bounce_running ? DONT_WAIT : ALL_EVENTS);
+ DoSingleStep($canvas) if $bounce_running;
+ }
+
+} # end bounce
+
+sub mkmb {
+
+ # (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
+ # warnings with Perl -w.
+
+ my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = @_;
+ my $mb = $mb0->Menubutton(
+ -text => $mb_label,
+ -underline => $mb_label_underline,
+ -background => 'DarkGreen',
+ -foreground => 'Yellow',
+ );
+ 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 => 'DarkGreen',
+ -foreground => 'White',
+ );
+ }
+ $mb->pack(-side => 'left');
+ $TOP->bind($mb, '<Enter>' => sub {ClearMsg; ShowMsg($mb_msg)});
+ $TOP->bind($mb, '<Leave>' => \&ClearMsg);
+
+ push @menu_button_list, $mb;
+ return $mb;
+
+} # end mkmb
+
+sub SimStart {
+
+ if (not $bounce_running) {
+ $bounce_running = 1;
+ $menu_button_list[1]->cget(-menu)->entryconfigure(0,
+ -state => 'disabled',
+ );
+ $menu_button_list[1]->cget(-menu)->entryconfigure(1,
+ -state => 'normal',
+ );
+ }
+
+} # end SimStart
+
+sub SimStop {
+
+ if ($bounce_running) {
+ $bounce_running = 0;
+ $menu_button_list[1]->cget(-menu)->entryconfigure(0,
+ -state => 'normal',
+ );
+ $menu_button_list[1]->cget(-menu)->entryconfigure(1,
+ -state => 'disabled',
+ );
+ }
+
+} # end SimStop
+
+sub NotDone {
+
+ print "Not yet implemented.\n";
+
+} # end NotDone
+
+sub ShowMsg {
+
+ my($msg) = shift;
+ $bounce_status->insert('1.0', $msg);
+
+} # end ShowMsg
+
+sub ClearMsg {
+
+ $bounce_status->delete('1.0', 'end');
+
+} # end ClearMsg
+
+sub DoSingleStep {
+
+ # 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.
+
+ my($canvas) = @_;
+
+ $bounce_counter++;
+ Ball->move_all_balls($canvas, $bounce_speed->get() / 100.0);
+
+} # end DoSingle Step