home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _5db764f3d7288c9935305e2397964f2b < prev    next >
Encoding:
Text File  |  2004-06-01  |  4.6 KB  |  144 lines
  1.  
  2. package Ball;
  3.  
  4. # Ball.pm, a class module that allows concurrent simulation (canvas) instances.
  5. #
  6. # This is simply a class module, nothing fancy like a derived widget or
  7. # composite widget.  It has two virtual methods, new() and move_one_ball().
  8. # There are two static methods, get_canvas_hash() and move_all_balls().
  9. #
  10. # Essentially, move_all_balls() is invoked to move all of the balls in a
  11. # simulation's @BALLS list once - from their current to their new postion.
  12. # After moving one ball a call to DoOneEvent() is made to handle pending
  13. # XEvents.  The *user* of this  module, in this case bounce.pl, has their
  14. # own main loop which also calls DoOneEvent() and move_all_balls() to keep
  15. # the simulation active.
  16. #
  17. # Gurusamy Sarathy (gsar@engin.umich.edu)
  18. # Tidied up by SOL.
  19.  
  20. use vars qw/$VERSION/;
  21. $VERSION = '4.004'; # $Id: //depot/Tkutf8/demos/demos/widget_lib/Ball.pm#4 $
  22.  
  23. use Tk::Canvas;
  24. use Tk::Widget;
  25. use Tk qw/DoOneEvent DONT_WAIT/;
  26. Construct Tk::Canvas 'Ball';
  27. use strict;
  28.  
  29. # Class Ball global variables.
  30.  
  31. my %BALLS = ();            # hold @BALLS list on a per canvas basis
  32. my (%DEFAULTS) = (        # Ball constructor option defaults
  33.           -color    => 'blue',
  34.           -size     => 20.0,
  35.           -position => [12.0,12.0],
  36.           -velocity => [6.0, 9.0],
  37.           );
  38.  
  39. sub new {            # Ball object constructor
  40.  
  41.     # Create a new Ball object, which just happens to be a Canvas item.
  42.     # Fill-in values for defaulted parameters, create the oval item, and
  43.     # store object-specific information in the ball's hash.
  44.     #
  45.     # Finally, update the class global %BALLS hash, indexed by a hashed canvas
  46.     # reference, with the new ball.  Note the special Tk::bind statement that
  47.     # removes a canvas from the %BALLS hash when the canvas is destroyed, thus
  48.     # keeping %BALLS trimmed and preventing a very slow memory leak.
  49.  
  50.     my($class, $canvas, %args) = @_;
  51.  
  52.     my @missing_args = grep ! defined $args{$_}, keys %DEFAULTS;
  53.     @args{@missing_args} = @DEFAULTS{@missing_args};
  54.     my($color, $size, $pos, $vel) = @args{-color, -size, -position, -velocity};
  55.  
  56.     my $ball = $canvas->create('oval',
  57.         ($pos->[0] - ($size/2.0)), ($pos->[1] - ($size/2.0)),
  58.         ($pos->[0] + ($size/2.0)), ($pos->[1] + ($size/2.0)),
  59.         -fill => $color,
  60.     );
  61.     $canvas->Tk::bind(
  62.         '<Destroy>' => sub {delete $BALLS{Ball->get_canvas_hash($canvas)}}
  63.     );
  64.  
  65.     my $ball_obj = {'canvas_ID' => $ball,
  66.             'canvas'    => $canvas,
  67.             'color'     => $color,
  68.             'size'      => $size,
  69.             'pos'       => [@$pos],
  70.             'vel'       => [@$vel],
  71.                    };
  72.  
  73.     push @{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}, $ball_obj;
  74.     return bless $ball_obj, $class;
  75.  
  76. } # end new, Ball constructor
  77.  
  78. sub get_canvas_hash {
  79.  
  80.     # Hash a canvas reference to a key for indexing into the %BALLS hash.
  81.     # For now, just use the string-ified widget reference.  If this trick
  82.     # were ever to fail in the future then only this code needs to be fixed
  83.     # and the Ball class would be up and running in short oder.
  84.  
  85.     my($class, $canvas) = @_;
  86.  
  87.     return $canvas
  88.  
  89. } # end get_canvas_hash
  90.  
  91. sub move_one_ball {
  92.  
  93.     # Move one ball, belonging to one simulation, one clock tick.
  94.  
  95.     my ($ball_obj, $speed_ratio) = @_;
  96.  
  97.     my($ball, $canv, $minx, $miny, $maxx, $maxy);
  98.     my($ballx, $bally, $deltax, $deltay);
  99.  
  100.     $speed_ratio = 1.0 unless defined $speed_ratio;
  101.     $ball = $ball_obj->{'canvas_ID'};
  102.     $canv = $ball_obj->{'canvas'};
  103.     $ballx = $ball_obj->{'pos'}[0];
  104.     $bally = $ball_obj->{'pos'}[1];
  105.  
  106.     $minx = $ball_obj->{'size'} / 2.0;
  107.     $maxx = $ball_obj->{'canvas'}->cget(-width) - $minx;
  108.  
  109.     $miny = $ball_obj->{'size'} / 2.0;
  110.     $maxy = $ball_obj->{'canvas'}->cget(-height) - $miny;
  111.  
  112.     if ($ballx > $maxx || $ballx < $minx) {
  113.         $ball_obj->{'vel'}[0] = -1.0 * $ball_obj->{'vel'}[0];
  114.     }
  115.     if ($bally > $maxy || $bally < $miny) {
  116.         $ball_obj->{'vel'}[1] = -1.0 * $ball_obj->{'vel'}[1];
  117.     }
  118.  
  119.     $deltax = $ball_obj->{'vel'}[0] * $speed_ratio;
  120.     $deltay = $ball_obj->{'vel'}[1] * $speed_ratio;
  121.  
  122.     $canv->move($ball, $deltax, $deltay);
  123.     $ball_obj->{'pos'}[0] = $ballx + $deltax;
  124.     $ball_obj->{'pos'}[1] = $bally + $deltay;
  125.  
  126.     return $ball_obj;
  127.  
  128. } # end move_one_ball
  129.  
  130. sub move_all_balls {
  131.  
  132.     # Move all the balls belong to one simulation instance one clock tick.
  133.  
  134.     my($class, $canvas, $speed_ratio) = @_;
  135.  
  136.     foreach (@{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}) {
  137.         $_->move_one_ball($speed_ratio);
  138.         DoOneEvent(DONT_WAIT);        # be kind and process XEvents if they arise
  139.     }
  140.  
  141. } # end move_all_balls
  142.  
  143. 1;
  144.