aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/Zinc/Debug.pm260
1 files changed, 240 insertions, 20 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index 271dcd3..49d1f1a 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -30,7 +30,7 @@ use Tk::FBox;
my ($itemstyle, $groupstyle, $step);
my (%help_tl, $result_tl, $result_fm, $search_tl, $helptree_tl, $coords_tl,
- $searchtree_tl, $tree_tl, $tree, $transfo_tl);
+ $helpcoords_tl, $searchtree_tl, $tree_tl, $tree, $transfo_tl);
my $showitemflag;
my ($x0, $y0);
my ($help_print, $imagecounter, $saving) = (0, 0, 0);
@@ -1055,10 +1055,15 @@ sub showcoords {
}
$coords_tl->title($title);
$coords_tl->geometry('+10+20');
- $coords_tl->Button(-text => 'Close',
- -command => sub {
- $coords_tl->destroy;
- })->pack(-side => 'bottom');
+ my $coords_fm0 = $coords_tl->Frame()->pack(-side => 'bottom');
+ $coords_fm0->Button(-text => 'Help',
+ -command => [\&showHelpAboutCoords, $zinc]
+ )->pack(-side => 'left', -padx => 40, -pady => 10);
+ $coords_fm0->Button(-text => 'Close',
+ -command => sub {
+ &hidecontour($zinc);
+ $coords_tl->destroy;
+ })->pack(-side => 'left', -padx => 40, -pady => 10);
# scrolled pane creation
my $coords_fm = $coords_tl->Scrolled('Pane',
-scrollbars => 'oe',
@@ -1096,13 +1101,42 @@ sub showcoords {
my $col = 1;
for (my $i=0; $i < @contour; $i++) {
$col = 1;
- $coords_fm->Label(-text => "Contour $i",
- -background => $bgcolor,
- -relief => 'ridge')->grid(-row => $row,
- -col => $col++,
- -ipadx => 5,
- -ipady => 5,
- -sticky => 'nswe');
+ my $lab = $coords_fm->Label(-text => "Contour $i",
+ -background => $bgcolor,
+ -relief => 'ridge')->grid(-row => $row,
+ -col => $col,
+ -ipadx => 5,
+ -ipady => 5,
+ -sticky => 'nswe');
+ $lab->bind('<1>', [\&showcontour, $zinc, 'black', $item, $contour[$i],
+ $deviceflag]);
+ $lab->bind('<2>', [\&showcontour, $zinc, 'white', $item, $contour[$i],
+ $deviceflag]);
+ $lab->bind('<3>', [\&showcontour, $zinc, 'red', $item, $contour[$i],
+ $deviceflag]);
+ $lab->bind('<ButtonRelease-1>', sub { &hidecontour($zinc); });
+ $lab->bind('<ButtonRelease-2>', sub { &hidecontour($zinc); });
+ $lab->bind('<ButtonRelease-3>', sub { &hidecontour($zinc); });
+ if (@{$contour[$i]} >= 10) {
+ my $lab1 = $coords_fm->Label(-text => scalar(@{$contour[$i]})." points",
+ -background => $bgcolor,
+ -relief => 'ridge')->grid(-row => $row+1,
+ -col => $col,
+ -ipadx => 5,
+ -ipady => 5,
+ -sticky => 'nswe');
+ $lab1->bind('<1>', [\&showcontourpts, $zinc, 'black', $item, $contour[$i],
+ $deviceflag]);
+ $lab1->bind('<2>', [\&showcontourpts, $zinc, 'white', $item, $contour[$i],
+ $deviceflag]);
+ $lab1->bind('<3>', [\&showcontourpts, $zinc, 'red', $item, $contour[$i],
+ $deviceflag]);
+ $lab1->bind('<ButtonRelease-1>', sub { &hidecontour($zinc); });
+ $lab1->bind('<ButtonRelease-2>', sub { &hidecontour($zinc); });
+ $lab1->bind('<ButtonRelease-3>', sub { &hidecontour($zinc); });
+ }
+ $col++;
+ my @lab;
for my $coords (@{$contour[$i]}) {
if ($col > 10) {
$col = 2;
@@ -1118,19 +1152,150 @@ sub showcoords {
} else {
@opt = (-text => sprintf('%s, %s', @{$coords}[0,1]));
}
- $coords_fm->Label(@opt,
- -width => 15,
- -relief => 'ridge')->grid(-row => $row,
- -ipadx => 5,
- -ipady => 5,
- -col => $col++,
- -sticky => 'nswe');
+ push (@lab, $coords_fm->Label(@opt,
+ -width => 15,
+ -relief => 'ridge')->grid(-row => $row,
+ -ipadx => 5,
+ -ipady => 5,
+ -col => $col++,
+ -sticky => 'nswe'));
}
$row++;
+ my $j = 0;
+ for (@lab) {
+ $_->bind('<1>', [\&showcontourpt, $zinc, 'black',
+ $item, $j, $deviceflag, \@lab, @{$contour[$i]}]);
+ $_->bind('<2>', [\&showcontourpt, $zinc, 'white',
+ $item, $j, $deviceflag, \@lab, @{$contour[$i]}]);
+ $_->bind('<3>', [\&showcontourpt, $zinc, 'red',
+ $item, $j, $deviceflag, \@lab, @{$contour[$i]}]);
+ $j++;
+ }
+
}
+
} # end showcoords
+sub showcontour {
+ my ($widget, $zinc, $color, $item, $contourcoords, $deviceflag) = @_;
+ if ($deviceflag) {
+ $zinc->add('curve', 1, $contourcoords,
+ -filled => 0,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+
+ } else {
+ $zinc->add('curve', 1, [$zinc->transform($item, 1, $contourcoords)],
+ -filled => 0,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ }
+
+} # end showcontour
+
+sub hidecontour {
+ my ($zinc) = @_;
+ $zinc->remove('zincdebugcontour');
+
+} # end hidecontour
+
+sub showcontourpts {
+ my ($widget, $zinc, $color, $item, $contourcoords, $deviceflag) = @_;
+ my $i = 0;
+ for my $coords (@$contourcoords) {
+ my ($x, $y);
+ if ($deviceflag) {
+ ($x, $y) = @$coords;
+ } else {
+ ($x, $y) = $zinc->transform($item, 1, $coords);
+ }
+ if ($i == 0) {
+ $zinc->add('arc', 1, [$x-10, $y-10, $x+10, $y+10],
+ -filled => 0,
+ -linewidth => 1,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ } elsif ($i == @$contourcoords -1) {
+ $zinc->add('arc', 1, [$x-10, $y-10, $x+10, $y+10],
+ -filled => 0,
+ -linewidth => 1,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ $zinc->add('arc', 1, [$x-13, $y-13, $x+13, $y+13],
+ -filled => 0,
+ -linewidth => 1,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ }
+ my $dx = 3;
+ if (@$coords > 2) {
+ $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
+ -filled => 0,
+ -linewidth => 1,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ } else {
+ $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
+ -filled => 1,
+ -linewidth => 1,
+ -fillcolor => $color,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ }
+ $i++;
+ }
+
+} # end showcontourpts
+
+
+sub showcontourpt {
+ my ($widget, $zinc, $color, $item, $index, $deviceflag, $labels, @contour) = @_;
+ $widget->focus;
+ if ($index < 0 or $index >= @contour) {
+ $widget->bell;
+ return;
+ }
+ &hidecontour($zinc);
+ my $bgcolor = ($labels->[0]->configure(-background))[3];
+ for (@$labels) {
+ $_->configure(-background => $bgcolor);
+ }
+ $labels->[$index]->configure(-background => 'bisque');
+ my @coords = @{$contour[$index]};
+ my ($x, $y);
+ if ($deviceflag) {
+ ($x, $y) = @coords;
+ } else {
+ ($x, $y) = $zinc->transform($item, 1, [@coords]);
+ }
+ my $dx = 3;
+ if (@coords > 2) {
+ $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
+ -filled => 0,
+ -linewidth => 1,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ } else {
+ $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
+ -filled => 1,
+ -linewidth => 1,
+ -fillcolor => $color,
+ -linecolor => $color,
+ -tags => ['zincdebugcontour']);
+ }
+ $widget->bind('<Key-Down>', [\&showcontourpt, $zinc, $color,
+ $item, $index+1, $deviceflag, $labels, @contour]);
+ $widget->bind('<Key-Right>', [\&showcontourpt, $zinc, $color,
+ $item, $index+1, $deviceflag, $labels, @contour]);
+ $widget->bind('<Key-Up>', [\&showcontourpt, $zinc, $color,
+ $item, $index-1, $deviceflag, $labels, @contour]);
+ $widget->bind('<Key-Left>', [\&showcontourpt, $zinc, $color,
+ $item, $index-1, $deviceflag, $labels, @contour]);
+
+
+} # end showcontourpt
+
# display in a toplevel group's attributes
sub showgroupattributes {
@@ -1927,7 +2092,7 @@ sub showinstancehelp {
$text->insert('end', " To generate perl code\n", 'title');
$text->insert('end', "\nUse the <");
$text->insert('end', $treeKey{$zinc}, 'keyword');
- $text->insert('end', "> sequence. Then select a branch of the tree ");
+ $text->insert('end', "> sequence to display the item tree. Then select a branch of the tree ");
$text->insert('end', "and press on the ");
$text->insert('end', "Build code", 'keyword');
$text->insert('end', " button.\n\n");
@@ -2101,6 +2266,59 @@ sub showHelpAboutAttributes {
} # end showHelpAboutAttributes
+sub showHelpAboutCoords {
+ my $zinc = shift;
+ $helpcoords_tl->destroy if $helpcoords_tl and Tk::Exists($helpcoords_tl);
+ $helpcoords_tl = $zinc->Toplevel;
+ $helpcoords_tl->title("Help about coordinates");
+
+ my $text = $helpcoords_tl->Scrolled('Text',
+ -font => scalar $zinc->cget(-font),
+ -wrap => 'word',
+ -height => 30,
+ -foreground => 'gray10',
+ -scrollbars => 'oe',
+ );
+ $text->tagConfigure('keyword', -foreground => 'darkblue');
+ $text->tagConfigure('title', -foreground => 'ivory',
+ -background => 'gray60',
+ -spacing1 => 3,
+ -spacing3 => 3);
+
+
+ $text->insert('end', " To display a contour\n", 'title');
+ $text->insert('end', "Press button labeled ");
+ $text->insert('end', 'Contour i', 'keyword');
+ $text->insert('end', " (*). Release it to hide contour.");
+ $text->insert('end', "\n\n");
+ $text->insert('end', " To display all the points of a contour\n", 'title');
+ $text->insert('end', "Press button labeled ");
+ $text->insert('end', 'n points', 'keyword');
+ $text->insert('end', " (*). Release it to hide points. First plot is ".
+ "particularized by a circle, last one by a double circle. ".
+ "Non-filled plots represent control points of a Bezier curve.");
+ $text->insert('end', "\n\n");
+ $text->insert('end', " To navigate in the contour\n", 'title');
+ $text->insert('end', "Select first a point by clicking in the coordinates table ");
+ $text->insert('end', "(*). Th corresponding plot is displayed. Then use the ");
+ $text->insert('end', "Up/Down", 'keyword');
+ $text->insert('end', " (or ");
+ $text->insert('end', "Left/Right", 'keyword');
+ $text->insert('end', ") arrows keys to navigate in the contour");
+ $text->insert('end', "\n\n");
+ $text->insert('end', "\n\n");
+ $text->insert('end', "(*) The color of displayed elements depends on the mouse ".
+ "button you press.");
+ $text->insert('end', "\n\n");
+ $text->configure(-state => 'disabled');
+
+ $helpcoords_tl->Button(-command => sub {$helpcoords_tl->destroy},
+ -text => 'Close')->pack(-side => 'bottom',
+ -pady => 10);
+ $text->pack->pack(-side => 'top', -pady => 10, -padx => 10);
+
+} # end showHelpAboutCoords
+
sub infoAboutHighlighting {
@@ -2345,6 +2563,8 @@ Daniel Etienne <etienne@cena.fr>
=head1 HISTORY
+Oct 07 2003 : contours of curves can be displayed and explored.
+
Sep 15 2003 : due to CPAN-isation, the ZincDebug module has been renamed Tk::Zinc::Debug
May 20 2003 : perl code can be generated from the items tree, with some limitations concerning transformations and images.
generated by cgit v1.1 at 2024-11-07 23:22:28 +0000