tools/perl-5.8.0/lib/site_perl/5.8.0/sun4-solaris/Tk/demos/widget_lib/bounce.pl

# 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_code,
                     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