From 29dd44adea35da3a55fe953aae32ed74cc56f6d2 Mon Sep 17 00:00:00 2001 From: mertz Date: Wed, 13 Mar 2002 16:29:12 +0000 Subject: initial release --- Perl/demos/Tk/demos/zinc_contrib_lib/README | 1 + Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm | 231 ++++++++++ Perl/demos/Tk/demos/zinc_pm/Wheel.pm | 280 ++++++++++++ Perl/demos/zinc-demos | 468 +++++++++++++++++++++ 4 files changed, 980 insertions(+) create mode 100644 Perl/demos/Tk/demos/zinc_contrib_lib/README create mode 100644 Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm create mode 100644 Perl/demos/Tk/demos/zinc_pm/Wheel.pm create mode 100644 Perl/demos/zinc-demos (limited to 'Perl/demos') 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 +# It has been adapted by C. Mertz for demo purpose. +# Thanks to Dunnigan,Jack [Edm]" 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('', [\&start_lasso, $self]); + $zinc->Tk::bind('', [\&fin_lasso, $self]); + + $zinc->Tk::bind('', sub { my $ev = $zinc->XEvent(); + my @closest = $zinc->find('closest', + $ev->x, $ev->y); + print "at point=$closest[0]\n" }); + + $zinc->Tk::bind('', [\&press, $self, \&motion]); + $zinc->Tk::bind('', [\&release, $self]); + + $zinc->Tk::bind('', [\&press, $self, \&zoom]); + $zinc->Tk::bind('', [\&release, $self]); + + $zinc->Tk::bind('', [\&press, $self, \&rotate]); + $zinc->Tk::bind('', [\&release, $self]); + + $zinc->Tk::bind('current', '', [\&showbox, $self]); + $zinc->Tk::bind('current', '', [\&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('', [$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('', ''); +} + +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('', [\&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('', ''); + $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 / => \&invoke); +my $last_line = ''; +$T->tagBind(qw/demo / => [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 / => [sub { + my($text, $sv) = @_; + $text->tagRemove(qw/hot 1.0 end/); + $text->configure(qw/-cursor xterm/); + $$sv = ''; + }, \$STATUS_VAR] +); +$T->tagBind(qw/demo / => [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$/; + $_ = ; + 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', ); + } + 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', ); + } + 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 , 2002/03/06, CENA fr + # adaptation for zinc demos purposes. + +=head1 AUTHOR + +Steve Lidie and slight adaptation by Christophe Mertz + +=cut -- cgit v1.1