Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / demos / widget_lib / Ball.pm

package Ball;

# Ball.pm, a class module that allows concurrent simulation (canvas) instances.
#
# This is simply a class module, nothing fancy like a derived widget or
# composite widget.  It has two virtual methods, new() and move_one_ball().
# There are two static methods, get_canvas_hash() and move_all_balls().
#
# Essentially, move_all_balls() is invoked to move all of the balls in a
# simulation's @BALLS list once - from their current to their new postion.
# After moving one ball a call to DoOneEvent() is made to handle pending 
# XEvents.  The *user* of this  module, in this case bounce.pl, has their 
# own main loop which also calls DoOneEvent() and move_all_balls() to keep 
# the simulation active.
#
# Gurusamy Sarathy (gsar@engin.umich.edu)
# Tidied up by SOL.

use vars qw/$VERSION/;
$VERSION = '3.009'; # $Id: //depot/Tk8/demos/demos/widget_lib/Ball.pm#9 $

use Tk::Canvas;
use Tk::Widget;
use Tk qw/DoOneEvent DONT_WAIT/;
Construct Tk::Canvas 'Ball';
use strict;

# Class Ball global variables.

my %BALLS = ();			# hold @BALLS list on a per canvas basis
my (%DEFAULTS) = (		# Ball constructor option defaults
		  -color    => 'blue',
		  -size     => 20.0,
		  -position => [12.0,12.0],
		  -velocity => [6.0, 9.0],
		  );

sub new {			# Ball object constructor

    # Create a new Ball object, which just happens to be a Canvas item.
    # Fill-in values for defaulted parameters, create the oval item, and
    # store object-specific information in the ball's hash.
    #
    # Finally, update the class global %BALLS hash, indexed by a hashed canvas
    # reference, with the new ball.  Note the special Tk::bind statement that
    # removes a canvas from the %BALLS hash when the canvas is destroyed, thus
    # keeping %BALLS trimmed and preventing a very slow memory leak.

    my($class, $canvas, %args) = @_;

    my @missing_args = grep ! defined $args{$_}, keys %DEFAULTS;
    @args{@missing_args} = @DEFAULTS{@missing_args};
    my($color, $size, $pos, $vel) = @args{-color, -size, -position, -velocity};

    my $ball = $canvas->create('oval', 
        ($pos->[0] - ($size/2.0)), ($pos->[1] - ($size/2.0)),
        ($pos->[0] + ($size/2.0)), ($pos->[1] + ($size/2.0)),
        -fill => $color,
    );
    $canvas->Tk::bind(
        '<Destroy>' => sub {delete $BALLS{Ball->get_canvas_hash($canvas)}}
    );

    my $ball_obj = {'canvas_ID' => $ball,
		    'canvas'    => $canvas,
		    'color'     => $color, 
		    'size'      => $size,
		    'pos'       => [@$pos],
		    'vel'       => [@$vel],
                   };

    push @{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}, $ball_obj;
    return bless $ball_obj, $class;

} # end new, Ball constructor

sub get_canvas_hash {

    # Hash a canvas reference to a key for indexing into the %BALLS hash.
    # For now, just use the string-ified widget reference.  If this trick
    # were ever to fail in the future then only this code needs to be fixed
    # and the Ball class would be up and running in short oder.

    my($class, $canvas) = @_;

    return $canvas

} # end get_canvas_hash    

sub move_one_ball {

    # Move one ball, belonging to one simulation, one clock tick.

    my ($ball_obj, $speed_ratio) = @_;

    my($ball, $canv, $minx, $miny, $maxx, $maxy);
    my($ballx, $bally, $deltax, $deltay);

    $speed_ratio = 1.0 unless defined $speed_ratio;
    $ball = $ball_obj->{'canvas_ID'};
    $canv = $ball_obj->{'canvas'};
    $ballx = $ball_obj->{'pos'}[0];
    $bally = $ball_obj->{'pos'}[1];

    $minx = $ball_obj->{'size'} / 2.0;
    $maxx = $ball_obj->{'canvas'}->cget(-width) - $minx;

    $miny = $ball_obj->{'size'} / 2.0;
    $maxy = $ball_obj->{'canvas'}->cget(-height) - $miny;

    if ($ballx > $maxx || $ballx < $minx) {
        $ball_obj->{'vel'}[0] = -1.0 * $ball_obj->{'vel'}[0];
    }
    if ($bally > $maxy || $bally < $miny) {
        $ball_obj->{'vel'}[1] = -1.0 * $ball_obj->{'vel'}[1];
    }

    $deltax = $ball_obj->{'vel'}[0] * $speed_ratio;
    $deltay = $ball_obj->{'vel'}[1] * $speed_ratio;

    $canv->move($ball, $deltax, $deltay);
    $ball_obj->{'pos'}[0] = $ballx + $deltax;
    $ball_obj->{'pos'}[1] = $bally + $deltay;

    return $ball_obj;

} # end move_one_ball

sub move_all_balls {

    # Move all the balls belong to one simulation instance one clock tick.

    my($class, $canvas, $speed_ratio) = @_;

    foreach (@{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}) {
        $_->move_one_ball($speed_ratio);
        DoOneEvent(DONT_WAIT);		# be kind and process XEvents if they arise
    }

} # end move_all_balls

1;