diff options
| -rw-r--r-- | Perl/Zinc/Debug.pm | 260 |
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. |