From 788d87f44594f85ea2cb3bedc8c2e55b9c516a24 Mon Sep 17 00:00:00 2001 From: etienne Date: Thu, 8 Aug 2002 15:23:45 +0000 Subject: Dans la fenetre Attribut, il est possible de visualiser l'ensemble des coordonn�es d'un item, eventuellement multi-contour. Correction d'un bug concernant le clonage d'un item Curve multi-contour. --- Perl/Zinc/Debug.pm | 160 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 151 insertions(+), 9 deletions(-) diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm index 0c915b5..49b0835 100644 --- a/Perl/Zinc/Debug.pm +++ b/Perl/Zinc/Debug.pm @@ -23,6 +23,8 @@ use Tk::Tree; @EXPORT = qw(finditems snapshot tree); my ($help_tl0, $help_tl, $result_tl, $result_fm, $search_tl, $showitemflag); +my $coords_tl; +my $devicecoords_tl; my ($text_id, $rectangle_id); my ($x0, $y0); my ($help_print, $imagecounter, $saving) = (0,0); @@ -401,7 +403,6 @@ sub searchentry { # test and set $zinc variable sub setwidget { - my $widget = shift; if ($zinc) { if ($zinc ne $widget) { @@ -457,7 +458,6 @@ sub compatseq { # display in a toplevel the result of search ; a new toplevel destroyes the # previous one sub showresult { - print "*** showresult\n"; my ($label, $zinc, @items) = @_; # toplevel (re-)creation $result_tl->destroy if Tk::Exists($result_tl); @@ -497,6 +497,7 @@ sub showotheroptions { my $tl = $zinc->Toplevel; my $title = "Other options of item $item"; $tl->title($title); + my $background = $tl->cget(-background); my $fm = $tl->LabFrame(-labelside => 'acrosstop', -label => $title, )->pack(-padx => 10, -pady => 10, @@ -511,10 +512,15 @@ sub showotheroptions { my @options = $zinc->itemconfigure($item); my $i = 2; for my $elem (@options) { - my ($option, $value) = (@$elem)[0,4]; + my ($option, $type, $value) = (@$elem)[0,1,4]; + #print "option=$option type=$type\n"; next if ($option eq '-visible' or $option eq '-sensitive' or $option eq '-tags' or $option eq '-position' or $option eq '-priority'); + if ($type eq 'gradient') { + my ($gradient) = $zinc->gname($value); + #print "value=$value gradient=$gradient\n"; + } $fm->Label(-text => $option, -relief => 'ridge') ->grid(-row => $i, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); $fm->Label(-text => $value, -relief => 'ridge') @@ -527,6 +533,91 @@ sub showotheroptions { } # end showotheroptions +sub showdevicecoords { + my ($zinc, $item) = @_; + &showcoords($zinc, $item, 1); + +} + + +sub showcoords { + my ($zinc, $item, $deviceflag) = @_; + my $bgcolor = 'ivory'; + $coords_tl->destroy if Tk::Exists($coords_tl); + $coords_tl = $zinc->Toplevel(); + my $title = "Zinc Debug"; + if ($deviceflag) { + $title .= " - Coords of item $item"; + } else { + $title .= " - Device coords of item $item"; + } + $coords_tl->title($title); + $coords_tl->geometry('+10+20'); + $coords_tl->Button(-text => 'Close', + -command => sub { + $coords_tl->destroy; + })->pack(-side => 'bottom'); + # scrolled pane creation + my $heightmax = 500; + my $height = 100 + 50; + $height = $heightmax if $height > $heightmax; + my $coords_fm = $coords_tl->Scrolled('Pane', + -scrollbars => 'se', + -width => scalar $coords_tl->screenwidth, + -height => $height, + ); + $coords_fm->pack(-padx => 10, -pady => 10, + -ipadx => 10, + -fill => 'both', + -expand => 1, + ); + my @contour; + my $i = 0; + while ( 1 ) { + my @coords; + eval '@coords = $zinc->coords($item, $i)'; + last unless @coords; + if ($deviceflag) { + @coords = $zinc->transform(scalar $zinc->group($item), 1, + [@coords]); + } + for (my $j=0; $j < @coords; $j += 2) { + push(@{$contour[$i]}, [$coords[$j], $coords[$j+1]]); + } + $i++; + } + my $row = 1; + 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'); + for my $coords (@{$contour[$i]}) { + if ($col > 10) { + $col = 2; + $row++; + } + $coords->[0] =~ s/\.(\d\d).*/\.$1/; + $coords->[1] =~ s/\.(\d\d).*/\.$1/; + $coords_fm->Label(-text => sprintf('%s, %s', $coords->[0], $coords->[1]), + -width => 15, + -relief => 'ridge')->grid(-row => $row, + -ipadx => 5, + -ipady => 5, + -col => $col++, + -sticky => 'nswe'); + } + $row++; + } + +} # end showcoords + + # display in a toplevel group's attributes sub showgroupattributes { my ($zinc, $item) = @_; @@ -703,6 +794,8 @@ sub highlightitem { } # end highlightitem + +# draw a rectangle arround the selected item sub surrounditem { my ($zinc, $item) = @_; $zinc->remove("zincdebug"); @@ -724,11 +817,13 @@ sub surrounditem { } # cloning my $clone = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']); - # move in group 1 + # move in topgroup $zinc->chggroup($clone, $topgroup); - $zinc->coords($clone, [@coords]); # create a rectangle around + my @bbox1 = $zinc->bbox($item); my @bbox = $zinc->bbox($clone); + my @c = $zinc->coords($clone); + #print "clone_id=$clone | bbox_item=@bbox1 | bbox_clone=@bbox | coords_clone=@c | clone_type=", $zinc->type($clone) ,"\n"; if (scalar @bbox == 4) { @bbox = $zinc->transform(1, $topgroup, [@bbox]); my $i = 0; @@ -748,6 +843,41 @@ sub surrounditem { } # end surrounditem +# not used +# draw a rectangle arround the selected item +# without cloning all the hierarchy +sub surrounditem2 { + my ($zinc, $item) = @_; + $zinc->remove("zincdebug"); + my @coords = $zinc->coords($item); + # cloning + my $clone = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']); + # move in group 1, with transformation adjustment + my $topgroup = 1; + $zinc->chggroup($clone, $topgroup, 1); + # create a rectangle around + my @bbox1 = $zinc->bbox($item); + my @bbox = $zinc->bbox($clone); + my @c = $zinc->coords($clone); + if (scalar @bbox == 4) { + @bbox = $zinc->transform(1, $topgroup, [@bbox]); + my $i = 0; + for ('white', 'red', 'white') { + my $r = $zinc->add('rectangle', $topgroup, + [$bbox[0] - 5 - 2*$i, $bbox[1] - 5 - 2*$i, + $bbox[2] + 5 + 2*$i, $bbox[3] + 5 + 2*$i], + -linecolor => $_, + -linewidth => 1, + -tags => ['zincdebug']); + $i++; + } + } + # raise + $zinc->raise('zincdebug'); + +} # end surrounditem2 + + sub undohighlightitem { my ($btn, $zinc, $items2delete, $group, $visibility) = @_; @@ -882,8 +1012,14 @@ sub showattributes { my $n = @coords/2 - 1; $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; } - $fm->Label(-text => $coords, -relief => 'ridge') - ->grid(-row => $i, -col => 7, -sticky => 'nswe', -ipadx => 5); + if ($type eq 'curve' and @coords > 4) { + $fm->Button(-text => $coords, + -command => [\&showcoords, $zinc, $item]) + ->grid(-row => $i, -col => 7, -sticky => 'nswe', -ipadx => 5); + } else { + $fm->Label(-text => $coords, -relief => 'ridge') + ->grid(-row => $i, -col => 7, -sticky => 'nswe', -ipadx => 5); + } # device coords @coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords]); if (@coords == 2) { @@ -904,8 +1040,14 @@ sub showattributes { my $n = @coords/2 - 1; $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; } - $fm->Label(-text => $coords, -relief => 'ridge') - ->grid(-row => $i, -col => 8, -sticky => 'nswe', -ipadx => 5); + if ($type eq 'curve' and @coords > 4) { + $fm->Button(-text => $coords, + -command => [\&showdevicecoords, $zinc, $item]) + ->grid(-row => $i, -col => 8, -sticky => 'nswe', -ipadx => 5); + } else { + $fm->Label(-text => $coords, -relief => 'ridge') + ->grid(-row => $i, -col => 8, -sticky => 'nswe', -ipadx => 5); + } # bounding box my @bbox = $zinc->bbox($item); $fm->Label(-text => "($bbox[0], $bbox[1]), ($bbox[2], $bbox[3])", -- cgit v1.1