aboutsummaryrefslogtreecommitdiff
path: root/Perl/demos/Tk
diff options
context:
space:
mode:
Diffstat (limited to 'Perl/demos/Tk')
-rw-r--r--Perl/demos/Tk/demos/zinc_contrib_lib/README1
-rw-r--r--Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm231
-rw-r--r--Perl/demos/Tk/demos/zinc_pm/Wheel.pm280
3 files changed, 512 insertions, 0 deletions
diff --git a/Perl/demos/Tk/demos/zinc_contrib_lib/README b/Perl/demos/Tk/demos/zinc_contrib_lib/README
new file mode 100644
index 0000000..4decc6a
--- /dev/null
+++ b/Perl/demos/Tk/demos/zinc_contrib_lib/README
@@ -0,0 +1 @@
+This directory is for deposing zinc demos contribs \ No newline at end of file
diff --git a/Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm b/Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm
new file mode 100644
index 0000000..30fffb4
--- /dev/null
+++ b/Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm
@@ -0,0 +1,231 @@
+# $Id$
+# This simple radar has been initially developped by P. Lecoanet <lecoanet@cena.fr>
+# It has been adapted by C. Mertz <mertz@cena.fr> for demo purpose.
+# Thanks to Dunnigan,Jack [Edm]" <Jack.Dunnigan@EC.gc.ca> for a bug correction.
+
+package SimpleRadarControls;
+
+$top = 1;
+
+sub new {
+ my $proto = shift;
+ my $type = ref($proto) || $proto;
+ my ($zinc) = @_;
+ my $self = {};
+
+ $self{'zinc'} = $zinc;
+ $self{'cur_x'} = 0;
+ $self{'cur_y'} = 0;
+ $self{'cur_angle'} = 0;
+ $self{'corner_x'} = 0;
+ $self{'corner_y'} = 0;
+
+ $self{'tlbbox'} = $zinc->add('group', $top,
+ -sensitive => 0, -visible => 0,
+ -tags => 'currentbbox');
+ $zinc->add('rectangle', $self{'tlbbox'}, [-3, -3, +3, +3]);
+ $self{'trbbox'} = $zinc->add('group', $top,
+ -sensitive => 0, -visible => 0,
+ -tags => 'currentbbox');
+ $zinc->add('rectangle', $self{'trbbox'}, [-3, -3, +3, +3]);
+ $self{'blbbox'} = $zinc->add('group', $top,
+ -sensitive => 0, -visible => 0,
+ -tags => 'currentbbox');
+ $zinc->add('rectangle', $self{'blbbox'}, [-3, -3, +3, +3]);
+ $self{'brbbox'} = $zinc->add('group', $top,
+ -sensitive => 0, -visible => 0,
+ -tags => 'currentbbox');
+ $zinc->add('rectangle', $self{'brbbox'}, [-3, -3, +3, +3]);
+ $zinc->add('rectangle', $top, [0, 0, 1, 1],
+ -linecolor => 'red', -tags => 'lasso',
+ -visible => 0, -sensitive => 0);
+
+ $zinc->Tk::bind('<Shift-ButtonPress-1>', [\&start_lasso, $self]);
+ $zinc->Tk::bind('<Shift-ButtonRelease-1>', [\&fin_lasso, $self]);
+
+ $zinc->Tk::bind('<ButtonPress-2>', sub { my $ev = $zinc->XEvent();
+ my @closest = $zinc->find('closest',
+ $ev->x, $ev->y);
+ print "at point=$closest[0]\n" });
+
+ $zinc->Tk::bind('<ButtonPress-3>', [\&press, $self, \&motion]);
+ $zinc->Tk::bind('<ButtonRelease-3>', [\&release, $self]);
+
+ $zinc->Tk::bind('<Shift-ButtonPress-3>', [\&press, $self, \&zoom]);
+ $zinc->Tk::bind('<Shift-ButtonRelease-3>', [\&release, $self]);
+
+ $zinc->Tk::bind('<Control-ButtonPress-3>', [\&press, $self, \&rotate]);
+ $zinc->Tk::bind('<Control-ButtonRelease-3>', [\&release, $self]);
+
+ $zinc->Tk::bind('current', '<Enter>', [\&showbox, $self]);
+ $zinc->Tk::bind('current', '<Leave>', [\&hidebox, $self]);
+
+ bless ($self, $type);
+ return $self;
+}
+
+#
+# Controls for the window transform.
+#
+sub press {
+ my ($zinc, $self, $action) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+
+ $self->{'cur_x'} = $lx;
+ $self->{'cur_y'} = $ly;
+ $self->{'cur_angle'} = atan2($ly, $lx);
+ $zinc->Tk::bind('<Motion>', [$action, $self]);
+}
+
+sub motion {
+ my ($zinc, $self) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+ my @it;
+ my @res;
+
+ @it = $zinc->find('withtag', 'controls');
+ if (scalar(@it) == 0) {
+ return;
+ }
+ @res = $zinc->transform($it[0], [$lx, $ly, $self->{'cur_x'}, $self->{'cur_y'}]);
+ $zinc->translate('controls', $res[0] - $res[2], $res[1] - $res[3]);
+ $self->{'cur_x'} = $lx;
+ $self->{'cur_y'} = $ly;
+}
+
+sub zoom {
+ my ($zinc, $self) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+ my $maxx;
+ my $maxy;
+ my $sx;
+ my $sy;
+
+ if ($lx > $self->{'cur_x'}) {
+ $maxx = $lx;
+ } else {
+ $maxx = $self->{'cur_x'};
+ }
+ if ($ly > $self->{'cur_y'}) {
+ $maxy = $ly
+ } else {
+ $maxy = $self->{'cur_y'};
+ }
+ #avoid illegal division by zero
+ return unless ($maxx && $maxy);
+
+ $sx = 1.0 + ($lx - $self->{'cur_x'})/$maxx;
+ $sy = 1.0 + ($ly - $self->{'cur_y'})/$maxy;
+ $self->{'cur_x'} = $lx if ($lx>0); # avoid ZnTransfoDecompose :singular matrix
+ $self->{'cur_y'} = $ly if ($ly>0); # error messages
+ $zinc->scale('controls', $sx, $sy);
+# $main::scale *= $sx;
+# main::update_transform($zinc);
+}
+
+sub rotate {
+ my ($zinc, $self) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+ my $langle;
+
+ $langle = atan2($ly, $lx);
+ $zinc->rotate('controls', -($langle - $self->{'cur_angle'}));
+ $self->{'cur_angle'} = $langle;
+}
+
+sub release {
+ my ($zinc, $self) = @_;
+ $zinc->Tk::bind('<Motion>', '');
+}
+
+sub start_lasso {
+ my ($zinc, $self) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+ my @coords;
+
+ $self->{'cur_x'} = $lx;
+ $self->{'cur_y'} = $ly;
+ $self->{'corner_x'} = $lx;
+ $self->{'corner_y'} = $ly;
+ @coords = $zinc->transform($top, [$lx, $ly]);
+ $zinc->coords('lasso', [$coords[0], $coords[1], $coords[0], $coords[1]]);
+ $zinc->itemconfigure('lasso', -visible => 1);
+ $zinc->raise('lasso');
+ $zinc->Tk::bind('<Motion>', [\&lasso, $self]);
+}
+
+sub lasso {
+ my ($zinc, $self) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+ my @coords;
+
+ $self->{'corner_x'} = $lx;
+ $self->{'corner_y'} = $ly;
+ @coords = $zinc->transform($top, [$self->{'cur_x'}, $self->{'cur_y'}, $lx, $ly]);
+ $zinc->coords('lasso', [$coords[0], $coords[1], $coords[2], $coords[3]]);
+}
+
+sub fin_lasso {
+ my ($zinc, $self) = @_;
+ my $enclosed;
+ my $overlapping;
+
+ $zinc->Tk::bind('<Motion>', '');
+ $zinc->itemconfigure('lasso', -visible => 0);
+ $enclosed = join(', ', $zinc->find('enclosed',
+ $self->{'cur_x'}, $self->{'cur_y'},
+ $self->{'corner_x'}, $self->{'corner_y'}));
+ $overlapping = join(', ', $zinc->find('overlapping',
+ $self->{'cur_x'}, $self->{'cur_y'},
+ $self->{'corner_x'}, $self->{'corner_y'}));
+ print "enclosed=$enclosed, overlapping=$overlapping\n";
+}
+
+sub showbox {
+ my ($zinc, $self) = @_;
+ my @coords;
+ my @it;
+
+ if (! $zinc->hastag('current', 'currentbbox')) {
+ @it = $zinc->find('withtag', 'current');
+ if (scalar(@it) == 0) {
+ return;
+ }
+ @coords = $zinc->transform($top, $zinc->bbox('current'));
+
+ $zinc->coords($self->{'tlbbox'}, [$coords[0], $coords[1]]);
+ $zinc->coords($self->{'trbbox'}, [$coords[2], $coords[1]]);
+ $zinc->coords($self->{'brbbox'}, [$coords[2], $coords[3]]);
+ $zinc->coords($self->{'blbbox'}, [$coords[0], $coords[3]]);
+ $zinc->itemconfigure('currentbbox', -visible => 1);
+ }
+}
+
+sub hidebox {
+ my ($zinc, $self) = @_;
+ my $ev = $zinc->XEvent();
+ my $lx = $ev->x;
+ my $ly = $ev->y;
+ my @next;
+
+ @next = $zinc->find('closest', $lx, $ly);
+ if ((scalar(@next) == 0) ||
+ ! $zinc->hastag($next[0], 'currentbbox') ||
+ $zinc->hastag('current', 'currentbbox')) {
+ $zinc->itemconfigure('currentbbox', -visible => 0);
+ }
+}
+
+
diff --git a/Perl/demos/Tk/demos/zinc_pm/Wheel.pm b/Perl/demos/Tk/demos/zinc_pm/Wheel.pm
new file mode 100644
index 0000000..21ea7a6
--- /dev/null
+++ b/Perl/demos/Tk/demos/zinc_pm/Wheel.pm
@@ -0,0 +1,280 @@
+package Wheel;
+
+use strict 'vars';
+use Carp;
+
+# Animation constants
+my $afterdelay = 60;
+my $stepsnumber = 10;
+# Zoom constants
+my $shrinkrate = 0.80;
+my $zoomrate = 1.1;
+
+#====================
+# Object constructor
+#====================
+sub new {
+ my ($proto, $widget, $x, $y, $radius) = @_;
+
+ # object attributes
+ my $self = {
+ 'widget' => $widget, # widget reference
+ 'origin' => [$x, $y], # origin coordinates
+ 'radius' => $radius, # wheel radius
+ 'topgroup' => undef, # top Group item
+ 'itemclip' => undef, # id of item which clips the wheel
+ 'hand' => undef, # id of item wich represents the hand
+ 'angle' => 60 # the angle between hand and jackpot
+ };
+ bless $self;
+
+ # First, we create a new Group item for the wheel. Why a Group item ?
+ # At least two reasons. Wheel object consists of several Zinc items,
+ # we'll see below; it moves when it is mapped or unmapped, grows when
+ # you hit the jackpot. So, it's more easy to apply such transformations
+ # to a structured items set, using Group capability, rather than apply
+ # to each item separately or using canvas-like Tags mechanism.
+ # Second reason refers to clipping. When it is mapped or unmapped, wheel
+ # object is drawn inside a circle with variant radius; clipping is a
+ # specific property of Group item
+
+ # That's why we create a Group item in the top group, and set its
+ # coordinates.
+ $self->{topgroup} = $widget->add('group', 1, -visible => 0);
+ $widget->coords($self->{topgroup}, [$x, $y]);
+ # All the following items will be created in this group...
+
+ # Create the invisible Arc item used to clip the wheel, centered on the
+ # group origin.
+ $self->{itemclip} = $widget->add('arc', $self->{topgroup},
+ [-$radius, -$radius, $radius, $radius],
+ -visible => 0,
+ );
+ $widget->itemconfigure($self->{topgroup}, -clip => $self->{itemclip});
+
+ # Create the wheel with 6 filled Arc items centered on the group origin
+ my $i = 0;
+ for my $color (qw(magenta blue cyan green yellow red)) {
+ $widget->add('arc', $self->{topgroup},
+ [-$radius, -$radius, $radius, $radius],
+ -visible => 1,
+ -filled => 1,
+ -closed => 1,
+ -extent => 60,
+ -pieslice => 1,
+ -fillcolor => $color,
+ -linewidth => 0,
+ -startangle => 60*$i ,
+ -tags => [$self],
+ );
+ $i++;
+ }
+
+ # Create the Text item representing the jackpot.
+ $widget->add('text', $self->{topgroup},
+ -position => [0, -$radius+20],
+ -font =>
+ '-adobe-helvetica-bold-o-normal--34-240-100-100-p-182-iso8859-1',
+ -anchor => 'center',
+ -text => "\$",
+ );
+
+ # Create the closed Curve item representing the hand.
+ # In order to make processing easier, its rotation axis will be placed
+ # on the group origin.
+ $self->{hand} = $widget->add('curve', $self->{topgroup},
+ [0, -$radius + 10, 20, -$radius + 40,
+ 6, -$radius + 40, 20, 10,
+ -20, 10, -6, -$radius + 40,
+ -20, -$radius + 40],
+ -linewidth => 3,
+ -linecolor => 'gray40',
+ -filled => 1,
+ -fillcolor => 'gray80',
+ -closed => 1,
+ -tags => [$self]);
+ # Then, we apply rotation to the hand using the Zinc 'rotation' method.
+ $widget->rotate($self->{hand}, 3.1416/3);
+
+ # Then we unmap the wheel; in fact, Group item is translated and its
+ # clipping circle is shrunk to a point.
+ $self->_clipAndTranslate($shrinkrate**$stepsnumber);
+
+ return $self;
+
+}
+
+#================
+# Public methods
+#================
+
+# Return 1 if wheel is moving (opening or closing animation)
+sub ismoving {
+ my $self = shift;
+ return 1 if $self->{opening} or $self->{closing};
+}
+
+# Display wheel with animation effect
+sub show {
+ my ($self, $x, $y) = @_;
+ # simple lock management
+ return if $self->{opening} or $self->{closing};
+ $self->{opening} = 1;
+ # start animation
+ $self->_open($x, $y, 0);
+}
+
+
+# Unmap wheel with animation effect
+sub hide {
+ my ($self, $x, $y) = @_;
+ # simple lock management
+ return if $self->{opening} or $self->{closing};
+ $self->{closing} = 1;
+ # start animation
+ $self->_close($x, $y, 0);
+}
+
+
+# Just rotate the hand with animation effect.
+sub rotatehand {
+ my $self = shift;
+ my $angle = shift;
+ return if $self->{turning};
+ $angle = 360 unless $angle;
+ $self->{angle} += $angle;
+ if ($self->{angle} % 360 == 0) {
+ $self->{fortune} = 1;
+ }
+ $self->_rotatehand(2*3.1416*$angle/360);
+}
+
+
+#=================
+# Private methods
+#=================
+
+# Generate opening animation; see below _clipAndTranslate method for
+# Zinc specific use.
+sub _open {
+ my ($self, $x, $y, $cnt) = @_;
+ my $widget = $self->{widget};
+ my $group = $self->{topgroup};
+ # first step of animation
+ if ($cnt == 0) {
+ $widget->itemconfigure($group, -visible => 1);
+ my @pos = $widget->coords($group);
+ $x = ($x - $pos[0])/$stepsnumber;
+ $y = ($y - $pos[1])/$stepsnumber;
+ # last step
+ } elsif ($cnt == $stepsnumber) {
+ $self->{opening} = undef;
+ return;
+ }
+ $cnt++;
+ # move and grow the wheel
+ $self->_clipAndTranslate(1/$shrinkrate, $x, $y);
+ # process the animation using the 'after' Tk defering method
+ $widget->after($afterdelay, sub {$self->_open($x, $y, $cnt)});
+}
+
+
+# Generate closing animation; see below _clipAndTranslate method for
+# Zinc specific use.
+sub _close {
+ my ($self, $x, $y, $cnt) = @_;
+ my $widget = $self->{widget};
+ my $group = $self->{topgroup};
+ # first step of animation
+ if ($cnt == 0) {
+ my @pos = $widget->coords($group);
+ $x = ($x - $pos[0])/$stepsnumber;
+ $y = ($y - $pos[1])/$stepsnumber;
+ # last step
+ } elsif ($cnt == $stepsnumber) {
+ $widget->itemconfigure($group, -visible => 0);
+ $self->{closing} = undef;
+ return;
+ }
+ $cnt++;
+ # move and shrink the wheel
+ $self->_clipAndTranslate($shrinkrate, $x, $y);
+ # process the animation using the 'after' Tk defering method
+ $widget->after($afterdelay, sub {$self->_close($x, $y, $cnt)});
+}
+
+
+# Generate hand rotation animation.
+sub _rotatehand {
+ my ($self, $angle, $cnt) = @_;
+ my $widget = $self->{widget};
+ my $group = $self->{topgroup};
+ $self->{turning} = 1;
+ # first step of animation
+ if (not $cnt) {
+ $angle /= $stepsnumber;
+ # last step
+ } elsif ($cnt == $stepsnumber) {
+ if ($self->{fortune}) {
+ $self->_fortune;
+ } else {
+ $self->{turning} = undef;
+ }
+ return;
+ }
+ $cnt++;
+ # use 'rotation' Zinc method.
+ $widget->rotate($self->{hand}, $angle);
+
+ # process the animation using the 'after' Tk defering method
+ $widget->after($afterdelay, sub {$self->_rotatehand($angle, $cnt)});
+
+}
+
+# Generate growing animation to notify jackpot
+sub _fortune {
+ my ($self, $cnt) = @_;
+ my $zf;
+ my $widget = $self->{widget};
+ my $group = $self->{topgroup};
+ my @pos = $widget->coords($group);
+ # last step of animation
+ if ($cnt == 6) {
+ $self->{fortune} = undef;
+ $self->{turning} = undef;
+ return;
+ # event steps : wheel grows
+ } elsif ($cnt % 2 == 0) {
+ $zf = $zoomrate;
+ # odd steps : wheel is shrunk
+ } else {
+ $zf = 1/$zoomrate;
+ }
+ $cnt++;
+
+ # Now, we apply scale transformation to the Group item, using the 'scale'
+ # Zinc method. Note that we reset group coords before scaling it, in order
+ # that the origin of the transformation corresponds to the center of the
+ # wheel. When scale is done, we restore previous coords of group.
+ $widget->coords($group, [0, 0]);
+ $widget->scale($group, $zf, $zf);
+ $widget->coords($group, \@pos);
+
+ # process the animation using the 'after' Tk defering method
+ $widget->after(100, sub {$self->_fortune($cnt)});
+
+}
+
+# Update group clipping and translation, using 'scale' and 'translate'
+# Zinc methods.
+sub _clipAndTranslate {
+ my ($self, $shrinkfactor, $x, $y) = @_;
+ $x = 0 unless $x;
+ $y = 0 unless $y;
+ $self->{widget}->scale($self->{itemclip}, $shrinkfactor, $shrinkfactor);
+ $self->{widget}->translate($self->{topgroup}, $x, $y);
+
+}
+
+
+1;
generated by cgit v1.1 at 2024-11-07 22:21:06 +0000