diff options
Diffstat (limited to 'Perl')
| -rw-r--r-- | Perl/Zinc/Debug.pm | 74 |
1 files changed, 44 insertions, 30 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm index 244e6dd..4dbcc1b 100644 --- a/Perl/Zinc/Debug.pm +++ b/Perl/Zinc/Debug.pm @@ -736,19 +736,29 @@ sub showcoords { -expand => 1, ); my @contour; - my $i = 0; - while ( 1 ) { - my @coords; - eval '@coords = $zinc->coords0($item, $i)'; - last unless @coords; - if ($deviceflag) { - @coords = $zinc->transform(scalar $zinc->group($item), 1, - [@coords]); + my $contournum = $zinc->contour($item); + for (my $i=0; $i < $contournum; $i++) { + my @coords = $zinc->coords($item, $i); + if (!ref $coords[0]) { + ## The first item of the list is not a reference, so the + ## list is guarranted to be a flat list (x, y, ...) + ## normaly of only one pair of (x y) + @coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords]) + if $deviceflag; + for (my $j=0; $j < @coords; $j += 2) { + push(@{$contour[$i]}, [$coords[$j], $coords[$j+1]]); + } } - for (my $j=0; $j < @coords; $j += 2) { - push(@{$contour[$i]}, [$coords[$j], $coords[$j+1]]); + else { + ## the first element is an array reference, as every + ## other elements of the list + for (my $j=0; $j < @coords; $j ++) { + my ($x,$y,$type) = @{$coords[$j]}; + ($x,$y) = $zinc->transform(scalar $zinc->group($item), 1, [$x, $y]) + if $deviceflag; + push(@{$contour[$i]}, [ $x , $y, $type]); + } } - $i++; } my $row = 1; my $col = 1; @@ -768,7 +778,8 @@ sub showcoords { } $coords->[0] =~ s/\.(\d\d).*/\.$1/; $coords->[1] =~ s/\.(\d\d).*/\.$1/; - $coords_fm->Label(-text => sprintf('%s, %s', $coords->[0], $coords->[1]), + my $pointtype = (defined $coords->[2]) ? " ".$coords->[2] : ""; + $coords_fm->Label(-text => sprintf('%s, %s%s', $coords->[0], $coords->[1],$pointtype), -width => 15, -relief => 'ridge')->grid(-row => $row, -ipadx => 5, @@ -814,7 +825,7 @@ sub showgroupattributes { -columnspan => 2); # coords $fm->Label(-text => 'Coords', -relief => 'ridge') ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - my @coords = $zinc->coords0($item); + my @coords = $zinc->coords($item); my $coords; if (@coords == 2) { my $x0 = int($coords[0]); @@ -826,6 +837,7 @@ sub showgroupattributes { my $x1 = int($coords[2]); my $y1 = int($coords[3]); $coords = "($x0, $y0, $x1, $y1)"; + print "we should not go through this case (1)!\n"; } else { my $x0 = int($coords[0]); my $y0 = int($coords[1]); @@ -833,6 +845,7 @@ sub showgroupattributes { my $yn = int($coords[$#coords]); my $n = @coords/2 - 1; $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + print "we should not go through this case (2d)!\n"; } $fm->Label(-text => $coords, -relief => 'ridge') ->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); @@ -850,6 +863,7 @@ sub showgroupattributes { my $x1 = int($coords[2]); my $y1 = int($coords[3]); $coords = "($x0, $y0, $x1, $y1)"; + print "we should not go through this case (3)!\n"; } else { my $x0 = int($coords[0]); my $y0 = int($coords[1]); @@ -857,6 +871,7 @@ sub showgroupattributes { my $yn = int($coords[$#coords]); my $n = @coords/2 - 1; $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + print "we should not go through this case (4)!\n"; } $fm->Label(-text => $coords, -relief => 'ridge') ->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); @@ -874,7 +889,7 @@ sub showgroupattributes { ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); if ($option and $option eq '-tags') { $value = join("\n", @$value); - } elsif ($option and $option eq '-clip' and $value > 0) { + } elsif ($option and $option eq '-clip' and $value and $value > 0) { $value .= " (". $zinc->type($value) .")"; } $fm->Label(-text => $value, -relief => 'ridge') @@ -1026,7 +1041,6 @@ sub itemisoutside { sub surrounditem { my ($zinc, $item, $level) = @_; $zinc->remove("zincdebug"); - my @coords = $zinc->coords0($item); # get item ancestors my @itemancestors = reverse($zinc->find('ancestors', $item)); # skip group 1 @@ -1036,7 +1050,7 @@ sub surrounditem { for my $g (@itemancestors) { my $gc = $zinc->add('group', $topgroup, -tags => ['zincdebug']); $zinc->tsave($g, "mytrans"); - my @c = $zinc->coords0($g); + my @c = $zinc->coords($g); $zinc->trestore($gc, "mytrans"); $zinc->coords($gc, [@c]); $zinc->tdelete("mytrans"); @@ -1164,25 +1178,25 @@ sub showattributes { -relief => 'ridge') ->grid(-row => $i, -col => 6, -sticky => 'nswe', -ipadx => 5); # coords - my @coords = $zinc->coords0($item); + my @coords = $zinc->coords($item); my $coords; - if (@coords == 2) { + if (!ref $coords[0]) { my $x0 = int($coords[0]); my $y0 = int($coords[1]); $coords = "($x0, $y0)"; - } elsif (@coords == 4) { - my $x0 = int($coords[0]); - my $y0 = int($coords[1]); - my $x1 = int($coords[2]); - my $y1 = int($coords[3]); - $coords = "($x0, $y0, $x1, $y1)"; } else { - my $x0 = int($coords[0]); - my $y0 = int($coords[1]); - my $xn = int($coords[$#coords-1]); - my $yn = int($coords[$#coords]); - my $n = @coords/2 - 1; - $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + my @points0 = @{$coords[0]}; + my $n = $#coords; + my @pointsN = @{$coords[$n]}; + my $x0 = int($points0[0]); + my $y0 = int($points0[1]); + my $xn = int($pointsN[0]); + my $yn = int($pointsN[1]); + if ($n == 1) { ## a couple of points + $coords = "($x0, $y0, $xn, $yn)"; + } else { + $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)"; + } } if ($type eq 'curve' and @coords > 4) { $fm->Button(-text => $coords, |