summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/Ball.pm
blob: c05605e4aaac27490ebb7cee303eefbc1c74eb84 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

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 = '4.004'; # $Id: //depot/Tkutf8/demos/demos/widget_lib/Ball.pm#4 $

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;