initial release

4 files changed, 980 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;
diff --git a/Perl/demos/zinc-demos b/Perl/demos/zinc-demos
new file mode 100644
index 0000000..79446c7
--- /dev/null
+++ b/Perl/demos/zinc-demos
@@ -0,0 +1,468 @@
+#!/usr/bin/perl -w
+
+eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
+    if 0; # not running under some shell
+
+require 5.004;
+
+use Tk 800.000;
+use lib Tk->findINC('demos/widget_lib');
+use Tk::widgets qw/Dialog ErrorDialog ROText/;
+use WidgetDemo;
+use subs qw/invoke lsearch see_code see_vars show_stat view_widget_code/;
+use vars qw/$MW $FONT $WIDTRIB/;
+use vars qw/$CODE $CODE_RERUN $CODE_TEXT $VARS $VIEW $VIEW_TEXT/;
+use vars qw/$BRAKES $LIGHTS $OIL $SOBER $TRANS $WIPERS/;
+use vars qw/$COLOR $FONT_STYLE $POINT_SIZE $DEMO_FILE %DEMO_DESCRIPTION/;
+use strict;
+
+
+$MW = Tk::MainWindow->new;
+$MW->configure(-menu => my $menubar = $MW->Menu);
+
+{
+    package WidgetWrap;
+    @WidgetWrap::ISA = qw/Tk::MainWindow/;
+
+    # This magic conspires with widget's AUTOLOAD subroutine to make user
+    # contributed demonstrations that don't use WidgetDemo embed properly.
+    # The trick works because widget creates a superclass of Tk::MainWindow
+    # which invokes WidgetDemo() implicitly. You loose if you bypass the
+    # inheritance mechanism and call Tk::MainWindow directly.
+
+    sub new {
+	my ($name) = $::DEMO_FILE =~ m#([^/]+).pl$#;
+	$::MW->WidgetDemo(-name => $name, -text => $::DEMO_DESCRIPTION{$name});
+    }
+}
+
+@MainWindow::ISA = 'WidgetWrap';
+
+$MW->title('Widget Demonstration');
+$FONT = '-*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*';
+my $widget_lib = Tk->findINC('demos/widget_lib');
+my $zinc_lib = Tk->findINC('demos/zinc_lib');
+my $wd = "$widget_lib/WidgetDemo.pm";
+$WIDTRIB = Tk->findINC('demos/zinc_contrib_lib');
+unless (Tk::tainting) {
+    $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB};
+    $WIDTRIB = $ARGV[0] if defined $ARGV[0];
+}
+
+# The code below creates the main window, consisting of a menu bar
+# and a text widget that explains how to use the program, plus lists
+# all of the demos as hypertext items.
+
+my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
+    [
+      [cascade    => '~View', -menuitems =>
+        [
+          [command  => '~widget', -command => [\&view_widget_code, __FILE__]],
+          [command  => '~WidgetDemo', -command => [\&view_widget_code, $wd]],
+        ], # end cascade menuitems
+      ], # end view cascade
+      '',
+      [command    => '~Quit', -command => [\&exit]],
+    ]);
+
+my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
+    [
+      [command    => '~About'],
+    ]);
+
+my $T = $MW->Scrolled('ROText',
+    -scrollbars => 'e',		
+    -wrap       => 'word',
+    -width      => 60,
+    -height     => 30,
+    -font       => $FONT,
+    -setgrid    => 1,
+)->grid(qw/-sticky nsew/);
+$MW->gridRowconfigure(   0, -weight => 1); # allow expansion in both ...
+$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions
+
+my $STATUS_VAR;
+my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/);
+$status->grid(qw/-sticky ew/);
+
+# Create a bunch of tags to use in the text widget, such as those for
+# section titles and demo descriptions.  Also define the bindings for
+# tags.
+
+$T->tagConfigure(qw/title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*/);
+$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/);
+
+if ($MW->depth  == 1) {
+    $T->tagConfigure(qw/hot -background black -foreground white/);
+    $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/);
+} else {
+    $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/);
+    $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ =>
+	    '#303080');
+}
+
+$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke);
+my $last_line = '';
+$T->tagBind(qw/demo <Enter>/ => [sub {
+	my($text, $sv) = @_;
+	my $e = $text->XEvent;
+	my($x, $y) = ($e->x, $e->y);
+	$last_line = $text->index("\@$x,$y linestart");
+	$text->tagAdd('hot', $last_line, "$last_line lineend");
+	$text->configure(qw/-cursor hand2/);
+	show_stat $sv, $text, $text->index('current');
+    }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Leave>/ => [sub {
+	my($text, $sv) = @_;
+	$text->tagRemove(qw/hot 1.0 end/);
+	$text->configure(qw/-cursor xterm/);
+	$$sv = '';
+    }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Motion>/ => [sub {
+	my($text, $sv) = @_;
+	my $e = $text->XEvent;
+	my($x, $y) = ($e->x, $e->y);
+	my $new_line = $text->index("\@$x,$y linestart");
+	if ($new_line ne $last_line) {
+	    $text->tagRemove(qw/hot 1.0 end/);
+	    $last_line = $new_line;
+	    $text->tagAdd('hot', $last_line, "$last_line lineend");
+	}
+	show_stat $sv, $text, $text->index('current');
+    }, \$STATUS_VAR]
+);
+
+# Create the text for the text widget.
+
+$T->insert('end', "Zinc perl/Tk Demonstrations\n", 'title');
+$T->insert('end',
+"\nThis application provides a front end for several short scripts in perl/Tk that demonstrate what you can do with the Zinc widget.  Each of the numbered lines below describes a demonstration;  you can click on it to invoke the demonstration.  Once the demonstration window appears, you can click the \"See Code\" button to see the Perl/Tk code that created the demonstration.\n");
+
+$T->insert('end', "\n", '', "Small applications\n", 'title');
+$T->insert('end', "1. A simple animated application \"the Wheel of Fortune\".\n", [qw/demo demo-wheelOfFortune/]);
+$T->insert('end', "2. A simple radar display.\n", [qw/demo demo-simpleradar/]);
+
+
+$T->insert('end', "\n", '', "All Items\n", 'title');
+$T->insert('end', "1. Exemples of all items.\n", [qw/demo demo-items/]);
+$T->insert('end', "2. All items options (and their types).\n", [qw/demo demo-all_options/]);
+$T->insert('end', "3. Examples of line style and line termination.\n", [qw/demo demo-lines/]);
+$T->insert('end', "4. Curves with multiple contours.\n", [qw/demo demo-contours/]);
+$T->insert('end', "5. Use of mapinfos.\n", [qw/demo demo-mapinfo/]);
+
+
+$T->insert('end', "\n", '', "Groups, Priority and Clipping\n", 'title');
+$T->insert('end', "1. Groups and Priorities.\n", [qw/demo demo-groups_priority/]);
+$T->insert('end', "2. Clipping examples (with simple or multiple contours).\n", [qw/demo demo-clipping/]);
+$T->insert('end', "3. \"Windows\" with four glasses using curve with multiple contours.\n", [qw/demo demo-window-contours/]);
+$T->insert('end', "4. A counter quite impossible to do without clipping (needs openGL).\n", [qw/demo demo-counter/]);
+
+$T->insert('end', "\n", '', "Interactions\n", 'title');
+$T->insert('end', "1. Simple interaction on a track.\n", [qw/demo demo-simple_interaction_track/]);
+
+
+$T->insert('end', "\n", '', "Transformation\n", 'title');
+$T->insert('end', "1. Translating.\n", [qw/demo demo-translation/]);
+$T->insert('end', "2. Rotating.\n",    [qw/demo demo-rotation/]);
+$T->insert('end', "3. Zooming.\n",     [qw/demo demo-zoom/]);
+
+$T->insert('end', "\n", '', "Use of openGL\n", 'title');
+$T->insert('end', "1. The tkZinc Logo (needs openGL).\n",  [qw/demo demo-tkZincLogo/]);
+$T->insert('end', "2. Axial color variation on the X axis (needs openGL).\n", [qw/demo demo-color-x/]);
+$T->insert('end', "3. Axial color variation on the Y axis (needs openGL).\n", [qw/demo demo-color-y/]);
+$T->insert('end', "4. Circular color variation (needs openGL).\n", [qw/demo demo-color-circular/]);
+$T->insert('end', "5. The triangles item (needs openGL).\n",  [qw/demo demo-triangles/]);
+
+
+
+$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title');
+opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!";
+my(@dirent) = grep /^.+\.pl$/, sort(readdir C);
+closedir C;
+unshift @dirent, 'TEMPLATE.pl';	# I want it first
+my $i = 0;
+while ($_ = shift @dirent) {
+    next if /TEMPLATE\.pl/ and $i != 0;
+    unless (open(C, "$WIDTRIB/$_")) {
+	warn "Cannot open $_: $!" unless /TEMPLATE\.pl/;
+	next;
+    }
+    my($name) = /^(.*)\.pl$/;
+    $_ = <C>;
+    my($title) = /^#\s*(.*)$/;
+    $DEMO_DESCRIPTION{$name} = $title;
+    close C;
+    $T->insert('end', ++$i . ". $title\n", ['demo', "demo-$name"]);
+}
+
+# Create all the dialogs required by this demonstration.
+
+my $DIALOG_ABOUT = $MW->Dialog(
+    -title          => 'About widget',
+    -bitmap         => 'info',
+    -default_button => 'OK',
+    -buttons        => ['OK'],
+    -text           => "         widget\n\nPerl Version $]" .
+		       "\nTk Version $Tk::VERSION\n\n      2000/07/07",
+);
+$help->cget(-menu)->entryconfigure('About',
+    -command => [$DIALOG_ABOUT => 'Show'],
+);
+
+my $DIALOG_ICON = $MW->Dialog(
+    -title          => 'Bitmap Menu Entry',
+    -bitmap         => undef,
+    -default_button => 'OK',
+    -buttons        => ['OK'],
+    -text           => 'The menu entry you invoked displays a bitmap rather than a text string.  Other than this, it is just like any other menu entry.',
+);
+$DIALOG_ICON->configure(-bitmap => undef); # keep -w from complaining
+
+MainLoop;
+
+sub AUTOLOAD {
+
+    # This routine handles the loading of most demo methods.
+
+    my($demo) = @_;
+
+    $T->Busy;
+    {
+	$DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl";
+	$DEMO_FILE = "$zinc_lib/${demo}.pl" if -f "$zinc_lib/${demo}.pl";
+	do $DEMO_FILE;
+	warn $@ if $@;
+    }
+    $T->Unbusy;
+    goto &$::AUTOLOAD if defined &$::AUTOLOAD;
+
+} # end AUTOLOAD
+
+sub invoke {
+
+    # This procedure is called when the user clicks on a demo description.
+
+    my($text) = @_;
+
+    my $index = $text->index('current');
+    my @tags = $T->tagNames($index);
+    my $i = lsearch('demo\-.*', @tags);
+    return if $i < 0;
+    my($demo) = $tags[$i] =~ /demo-(.*)/;
+    $T->tagAdd('visited', "$index linestart", "$index lineend");
+    {
+	no strict 'refs';
+	&$demo($demo);
+    }
+
+} # end invoke
+
+sub lsearch {
+
+    # Search the list using the supplied regular expression and return it's
+    # ordinal, or -1 if not found.
+
+    my($regexp, @list) = @_;
+    my($i);
+
+    for ($i=0; $i<=$#list; $i++) {
+        return $i if $list[$i] =~ /$regexp/;
+    }
+    return -1;
+
+} # end lsearch
+
+sub see_code {
+
+    # This procedure creates a toplevel window that displays the code for
+    # a demonstration and allows it to be edited and reinvoked.
+
+    my($demo) = @_;
+
+    my $file = "${demo}.pl";
+    if (not Exists $CODE) {
+	$CODE = $MW->Toplevel;
+	my $code_buttons = $CODE->Frame;
+	$code_buttons->pack(qw/-side bottom -fill x/);
+	my $code_buttons_dismiss = $code_buttons->Button(
+            -text    => 'Dismiss',
+            -command => [$CODE => 'withdraw'],
+	);
+	$CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo');
+	$CODE_TEXT = $CODE->Scrolled('Text',
+				     qw/-scrollbars e -height 40 -setgrid 1/);
+	$code_buttons_dismiss->pack(qw/-side left -expand 1/);
+	$CODE_RERUN->pack(qw/-side left -expand 1/);
+	$CODE_TEXT->pack(qw/-side left -expand 1 -fill both/);
+    } else {
+	$CODE->deiconify;
+	$CODE->raise;
+    }
+    $CODE_RERUN->configure(-command => sub {
+	eval $CODE_TEXT->get(qw/1.0 end/);
+	{
+	    no strict 'refs';
+	    &$demo($demo);
+	}
+    });
+    $CODE->iconname($file);
+    $file = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl";
+    $file = "$zinc_lib/${demo}.pl" if -f "$zinc_lib/${demo}.pl";
+    $CODE->title("Demo code: $file");
+    $CODE_TEXT->delete(qw/1.0 end/);
+    open(CODE, "<$file") or warn "Cannot open demo file $file: $!";
+    {
+	local $/ = undef;
+	$CODE_TEXT->insert('1.0', <CODE>);
+    }
+    close CODE;
+    $CODE_TEXT->markSet(qw/insert 1.0/);
+
+} # end see_code
+
+sub see_vars {
+
+    # Create a top-level window that displays a bunch of global variable values
+    # and keeps the display up-to-date even when the variables change value.
+    # $args is a pointer to a list of list of 2:
+    #
+    #   ["variable description", \$VAR]
+    #
+    # The old trick of passing a string to serve as the description and a soft
+    # reference to the variable no longer works with lexicals and use strict.
+
+    my($parent, $args) = @_;
+
+    $VARS->destroy if Exists($VARS);
+    $VARS = $parent->Toplevel;
+    $VARS->geometry('+300+300');
+    $VARS->title('Variable Values');
+    $VARS->iconname('Variables');
+
+    my $title = $VARS->Label(
+        -text   => 'Variable Values:',
+        -width  => 20,
+        -anchor => 'center',
+        -font   => '-*-helvetica-medium-r-normal--*-180-*-*-*-*-*-*',
+    );
+    $title->pack(qw/-side top -fill x/);
+    my($label, $var);
+    foreach my $i (@$args) {
+	($label, $var) = @$i;
+	my $wf = $VARS->Frame->pack(qw/-anchor w/);
+	$wf->Label(-text => "$label: ")->pack(qw/-side left/);
+	$wf->Label(-textvariable => $var)->pack(qw/-side left/);
+    }
+    $VARS->Button(-text => 'OK', -command => [$VARS => 'destroy'])->
+        pack(qw/-side bottom -pady 2/);
+
+} # end see_vars
+
+sub show_stat {
+
+    # Display name of current demonstration.  $sv is a reference to the
+    # status Label -textvariable, $text is the Text widget reference and
+    # $index is the demonstration index in the Text widget.
+
+    my($sv, $text, $index) = @_;
+
+    my @tags = $text->tagNames($index);
+    my $i = lsearch('demo\-.*', @tags);
+    return if $i < 0;
+    my($demo) = $tags[$i] =~ /demo-(.*)/;
+    $$sv = "Click Button-1 to run the \"$demo\" demonstration.";
+
+} # end show_stat
+
+sub view_widget_code {
+
+    # Expose a file's innards to the world too, but only for viewing.
+
+    my($widget) = @_;
+
+    if (not Exists $VIEW) {
+	$VIEW = $MW->Toplevel;
+	$VIEW->iconname('widget');
+	my $view_buttons = $VIEW->Frame;
+	$view_buttons->pack(qw/-side bottom -expand 1 -fill x/);
+	my $view_buttons_dismiss = $view_buttons->Button(
+            -text    => 'Dismiss',
+            -command => [$VIEW => 'withdraw'],
+	);
+	$view_buttons_dismiss->pack(qw/-side left -expand 1/);
+	$VIEW_TEXT = $VIEW->Scrolled('Text',
+				     qw/-scrollbars e -height 40 -setgrid 1/);
+	$VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/);
+    } else {
+	$VIEW->deiconify;
+	$VIEW->raise;
+    }
+    $VIEW->title("Demo code: $widget");
+    $VIEW_TEXT->configure(qw/-state normal/);
+    $VIEW_TEXT->delete(qw/1.0 end/);
+    open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!";
+    {
+	local $/ = undef;
+	$VIEW_TEXT->insert('1.0', <VIEW>);
+    }
+    close VIEW;
+    $VIEW_TEXT->markSet(qw/insert 1.0/);
+    $VIEW_TEXT->configure(qw/-state disabled/);
+
+} # end view_widget_code
+
+__END__
+
+=head1 NAME
+
+zinc-demos - Demonstration of TkZinc widget functionnality
+
+=head1 SYNOPSYS
+
+  zinc-demos [ directory ]
+
+=head1 DESCRIPTION
+
+This script demonstrates the various functions offered by Tk Zinc widget.
+This file only contains code to
+generate the main window for the application, which invokes individual
+demonstrations.  The code for the actual demonstrations is contained in
+separate ".pl" files in the "zinc_lib" directory, which are autoloaded
+by this script as needed.
+
+widget looks in the directory specified on the command line to load user
+contributed demonstrations.  If no directory name is specified when widget is
+invoked and the environment variable WIDTRIB is defined then demonstrations
+are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget
+defaults to the released user contributed directory, "zinc_contrib_lib".
+
+=head2 History
+
+ #
+ # Stephen O. Lidie, LUCC, 96/03/11.  lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/01/01.  lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/02/11.  lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/06/07.  lusol@Lehigh.EDU
+ #     Update for Tk402.00x.  Total revamp:  WidgetDemo, Scrolled, released
+ #     composites, -menuitems, qw//, etcetera.  Perl 5.004 required.
+ # Stephen O. Lidie, LUCC, 98/03/10.  lusol@Lehigh.EDU
+ #     Update for Tk8.
+ # Stephen O. Lidie, LUCC, 98/06/26.  Stephen.O.Lidie@Lehigh.EDU
+ #     Add Common Dialogs for Tk800.007.
+ # Stephen.O.Lidie@Lehigh.EDU, 1999/11/29, Lehigh University.
+ #     Demo some "dash patch" changes.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/01/11, Lehigh University.
+ #     Update menubar to Tk 8, fix color palette Menubutton demo.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/07/06, Lehigh University.
+ #     Remove inswt() from widget and styles.pl to show the proper Perl/Tk
+ #     idiom for inserting Text tags.  Various and sundry cleanups.
+ # Christophe Mertz <mertz@cena.fr>, 2002/03/06, CENA fr
+ #     adaptation for zinc demos purposes.
+
+=head1 AUTHOR
+
+Steve Lidie <Stephen.O.Lidie@Lehigh.EDU> and slight adaptation by Christophe Mertz <mertz@cena.fr>
+
+=cut