home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _2ffab3f95decfd076867eeeca04db204 < prev    next >
Encoding:
Text File  |  2004-06-01  |  7.7 KB  |  275 lines
  1. # bounce.pl
  2.  
  3. use Ball;
  4. use Tk qw/:eventtypes/;
  5. use subs qw/ClearMsg DoSingleStep NotDone ShowMsg SimStart SimStop mkmb/;
  6. use vars qw/$TOP/;
  7.  
  8. my(@menu_button_list, $quit_flag, $quit_code,
  9.    $bounce_status, $bounce_speed, $bounce_running, $bounce_counter);
  10.  
  11. sub bounce {
  12.  
  13.     # This began as a borrowed idea from Python distribution examples, ended up
  14.     # with a Ball module of its own. It illustrates how one can run something
  15.     # without blocking XEvent processing in a simple-minded sorta way.
  16.     #
  17.     # Handles resizes to the main window
  18.     #
  19.     # Gurusamy Sarathy (gsar@engin.umich.edu)
  20.     # Tidied up by SOL.
  21.     #
  22.     # 97/06/10 This demo is sufficiently bizarre enough that we don't use
  23.     #          WidgetDemo! (-:  Plus, you get to see Exists() in action.
  24.  
  25.     my($demo) = @_;
  26.  
  27.     $TOP->destroy if Exists($TOP);
  28.     $TOP = $MW->Toplevel;
  29.     $TOP->title('Bouncing Ball Simulator');
  30.     $TOP->iconname('bounce');
  31.  
  32.     @menu_button_list = ();
  33.     $quit_flag = 0;
  34.     $quit_code = sub {$quit_flag = 1};
  35.     $TOP->protocol('WM_DELETE_WINDOW' => $quit_code);
  36.  
  37.     my $menubar = $TOP->Frame(qw/-relief raised -background DarkGreen -bd 2/);
  38.     $menubar->pack(-side => 'top', -fill => 'x');
  39.  
  40.     mkmb($menubar, 'File', 0, 'File related stuff',
  41.          [
  42.           ['Open',      \&NotDone,     0],
  43.           ['New',       \&NotDone,     0],
  44.           ['Print',     \&NotDone,     0],
  45.           ['Exit',      sub{$TOP->bell},        0],
  46.           ]);
  47.  
  48.     mkmb($menubar, 'Simulate', 0, 'Simulator control',
  49.      [
  50.       ['Start',     \&SimStart,    2],
  51.       ['Stop',      \&SimStop,     2],
  52.       ]);
  53.  
  54.     mkmb($menubar, 'Display', 0, 'Display settings',
  55.      [
  56.       ['Redraw',    \&NotDone,     2],
  57.       ['Clear',     \&NotDone,     2],
  58.       ]);
  59.  
  60.     mkmb($menubar, 'Options', 0, 'Various preferences',
  61.      [
  62.       ['Steptime',  \&NotDone,     0],
  63.       ['Colors',    \&NotDone,     0],
  64.       ['Display',   \&NotDone,     0],
  65.       ]);
  66.  
  67.     mkmb($menubar, 'Help', 0, 'There when you need it',
  68.      [
  69.       ['About..',   \&NotDone,     0],
  70.       ['Intro',     \&NotDone,     0],
  71.       ['Contents',  \&NotDone,     0],
  72.       ]);
  73.     $menu_button_list[$#menu_button_list]->pack(-side => 'right');
  74.  
  75.     my $feedback = $TOP->Frame();
  76.     $feedback->pack(-side => 'bottom', -fill => 'x');
  77.     $bounce_status = $feedback->Text(
  78.         -relief      => 'sunken',
  79.     -height      => 1,
  80.     -background  => 'gray',
  81.     -borderwidth => 2,
  82.     );
  83.     $bounce_status->pack(-side => 'left', -fill => 'x', -expand => 1);
  84.  
  85.     my $drawarea = $TOP->Frame();
  86.     $drawarea->pack(-side => 'top', -fill => 'both', -expand => 1);
  87.  
  88.     my $canvas = $drawarea->Canvas(
  89.         -relief      => 'ridge',
  90.     -height      => 400,
  91.     -width       => 600,
  92.     -borderwidth => 2,
  93.     );
  94.     $canvas->pack(-side => 'left', -fill => 'both', -expand => 1);
  95.  
  96.     $bounce_speed = $drawarea->Scale(
  97.         -orient      => 'vert',
  98.     -showvalue   => 0,
  99.     -width       => 10,
  100.     -from        => 100,
  101.     -to          => 0,
  102.         -borderwidth => 1,
  103.     );
  104.     $bounce_speed->pack(-side => 'left', -fill => 'y');
  105.     $bounce_speed->bind('<Enter>' => sub {
  106.     ClearMsg; ShowMsg('Adjust slider for ball speed');
  107.     });
  108.     $bounce_speed->bind('<Leave>' => \&ClearMsg);
  109.     $bounce_speed->set(50);
  110.  
  111.     my $w_buttons = $TOP->Frame;
  112.     $w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m));
  113.     my $w_dismiss = $w_buttons->Button(
  114.         -text    => 'Dismiss',
  115.         -command => $quit_code,
  116.     );
  117.     $w_dismiss->pack(qw(-side left -expand 1));
  118.     my $w_see = $w_buttons->Button(
  119.         -text    => 'See Code',
  120.         -command => [\&see_code, $demo],
  121.     );
  122.     $w_see->pack(qw(-side left -expand 1));
  123.     my $w_ball = $w_buttons->Button(
  124.         -text    => 'View Ball Class Module',
  125.         -command => [\&view_widget,
  126.              Tk->findINC('demos/widget_lib') . '/Ball.pm'],
  127.     );
  128.     $w_ball->pack(qw(-side left -expand 1));
  129.  
  130.     $bounce_running = 0;
  131.     $menu_button_list[1]->cget(-menu)->entryconfigure(1, -state => 'disabled');
  132.  
  133.     $canvas->Ball;
  134.     $canvas->Ball(-color => 'red', -size => 30, -position => [200, 75]);
  135.     $canvas->Ball(
  136.         -color    => 'green',
  137.         -size     => 60,
  138.         -position => [490, 275],
  139.         -velocity => [8.0, 12.0],
  140.     );
  141.     $canvas->Ball(
  142.         -color    => 'yellow',
  143.         -size     => 100,
  144.         -position => [360, 60],
  145.         -velocity => [8.0, 12.0],
  146.     );
  147.  
  148.     $bounce_counter = 0;
  149.     $TOP->repeat(1000 => sub {
  150.     return unless $bounce_running;
  151.     ClearMsg;
  152.     ShowMsg(sprintf("%6d interations/second", $bounce_counter));
  153.     $bounce_counter = 0
  154.     });
  155.  
  156.  
  157.     # This runs the Tk mainloop. Note that the simulation itself has a main
  158.     # loop which must be processed. DoSingleStep runs a bit of the simulation
  159.     # during every iteration. Also note  that, with a flag of 0,
  160.     # Tk::DoOneEvent will suspend the  process until an X-event arrives,
  161.     # effectively blocking the  while loop.
  162.     #
  163.     # My original idea was to run the simulation mainloop as an  asynchronous
  164.     # proc handler that runs when Tk is idle, but the necessary Async(3) calls
  165.     # from Tcl haven't made it into nTk yet.
  166.  
  167.     while (1) {
  168.     if ($quit_flag) {
  169.         $TOP->destroy;
  170.         return;
  171.     }
  172.     DoOneEvent($bounce_running ? DONT_WAIT : ALL_EVENTS);
  173.     DoSingleStep($canvas) if $bounce_running;
  174.     }
  175.  
  176. } # end bounce
  177.  
  178. sub mkmb {
  179.  
  180.     # (Ripped from nTk examples)
  181.     # Make a Menubutton widget; note that the menu is automatically created.
  182.     # We maintain a list of the Menubutton references since some callers
  183.     # need to refer to the Menubutton, as well as to suppress stray name
  184.     # warnings with Perl -w.
  185.  
  186.     my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = @_;
  187.     my $mb = $mb0->Menubutton(
  188.         -text       => $mb_label,
  189.     -underline  => $mb_label_underline,
  190.     -background => 'DarkGreen',
  191.         -foreground => 'Yellow',
  192.     );
  193.     my($menu) = $mb->Menu(-tearoff => 0);
  194.     $mb->configure(-menu => $menu);
  195.  
  196.     my $mb_list;
  197.     foreach $mb_list (@{$mb_list_ref}) {
  198.         $mb->command(
  199.             -label      => $mb_list->[0],
  200.             -command    => $mb_list->[1] ,
  201.             -underline  => $mb_list->[2],
  202.             -background => 'DarkGreen',
  203.             -foreground => 'White',
  204.         );
  205.     }
  206.     $mb->pack(-side => 'left');
  207.     $TOP->bind($mb, '<Enter>' => sub {ClearMsg; ShowMsg($mb_msg)});
  208.     $TOP->bind($mb, '<Leave>' => \&ClearMsg);
  209.  
  210.     push @menu_button_list, $mb;
  211.     return $mb;
  212.  
  213. } # end mkmb
  214.  
  215. sub SimStart {
  216.  
  217.     if (not $bounce_running) {
  218.         $bounce_running = 1;
  219.         $menu_button_list[1]->cget(-menu)->entryconfigure(0,
  220.             -state => 'disabled',
  221.         );
  222.         $menu_button_list[1]->cget(-menu)->entryconfigure(1,
  223.             -state => 'normal',
  224.         );
  225.     }
  226.  
  227. } # end SimStart
  228.  
  229. sub SimStop {
  230.  
  231.     if ($bounce_running) {
  232.         $bounce_running = 0;
  233.         $menu_button_list[1]->cget(-menu)->entryconfigure(0,
  234.             -state => 'normal',
  235.         );
  236.         $menu_button_list[1]->cget(-menu)->entryconfigure(1,
  237.             -state => 'disabled',
  238.         );
  239.     }
  240.  
  241. } # end SimStop
  242.  
  243. sub NotDone {
  244.  
  245.     print "Not yet implemented.\n";
  246.  
  247. } # end NotDone
  248.  
  249. sub ShowMsg {
  250.  
  251.     my($msg) = shift;
  252.     $bounce_status->insert('1.0', $msg);
  253.  
  254. } # end ShowMsg
  255.  
  256. sub ClearMsg {
  257.  
  258.     $bounce_status->delete('1.0', 'end');
  259.  
  260. } # end ClearMsg
  261.  
  262. sub DoSingleStep {
  263.  
  264.     # The simulation handler.
  265.     #
  266.     # Note that this handler must be cooperative and return after a short
  267.     # period, so that other X events may be  processed by the mainloop below.
  268.  
  269.     my($canvas) = @_;
  270.  
  271.     $bounce_counter++;
  272.     Ball->move_all_balls($canvas, $bounce_speed->get() / 100.0);
  273.  
  274. } # end DoSingle Step
  275.