diff options
Diffstat (limited to 'Perl/t/Bbox-curve-multi-contour.pl')
| -rw-r--r-- | Perl/t/Bbox-curve-multi-contour.pl | 183 |
1 files changed, 183 insertions, 0 deletions
diff --git a/Perl/t/Bbox-curve-multi-contour.pl b/Perl/t/Bbox-curve-multi-contour.pl new file mode 100644 index 0000000..cf66e40 --- /dev/null +++ b/Perl/t/Bbox-curve-multi-contour.pl @@ -0,0 +1,183 @@ +#!/usr/bin/perl -w + +# +# $Id$ +# Author: Christophe Mertz mertz@intuilab.com, adapted from a script +# reported by Daniel Etienne for a bug report in Tk::Zinc 3.3.0 +# + +use strict; + +# testing all the import + +BEGIN { + if (!eval q{ +# use Test::More qw(no_plan); + use Test::More tests => 4; + 1; + }) { + print "# tests only work properly with installed Test::More module\n"; + print "1..1\n"; + print "ok 1\n"; + exit; + } + if (!eval q{ + use Tk::Zinc; + 1; + }) { + print "unable to load Tk::Zinc"; + print "1..1\n"; + print "ok 1\n"; + exit; + } +} +use Tk; + +my $mw = MainWindow->new; +my $zinc = $mw->Zinc(-render => 1, -width => 800, -height => 500); +$zinc->pack; +like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); + +my $n = 8; + + +# first +my $group = $zinc->add('group', 1); +$zinc->coords($group, [100, 250]); + +my $curve = $zinc->add('curve', $group, [], + -fillrule => 'nonzero', + -closed => 1, + -filled => 1, + -fillcolor => 'black', + -linecolor => 'red', + ); +my $arc = $zinc->add('arc', $group, [-50, -50, 50, 50]); +$zinc->contour($curve, 'add', 1, $arc); +$zinc->remove($arc); + +for (1..$n) { + my $arc = $zinc->add('arc', $group, [-15, -70, 15, -40]); + $zinc->rotate($arc, ($_-1)*(360/$n), 'degree'); + $zinc->contour($curve, 'add', 1, $arc); + $zinc->remove($arc); +} + +ok(&similarFlatArray ([$zinc->bbox($group)], + [28,178, 172, 322], # beware this coordinates are + # not exactly the good one + [2,2, 2,2 ], + ), + "bbox of left figure"); + + +# second +$group = $zinc->add('group', 1); +$zinc->coords($group, [350, 250]); + +$curve = $zinc->add('curve', $group, [], + -fillrule => 'nonzero', + -closed => 1, + -filled => 1, + -fillcolor => 'black', + -linecolor => 'red', + ); +$arc = $zinc->add('arc', $group, [-30, -30, 30, 30]); +$zinc->contour($curve, 'add', 1, $arc); +$zinc->remove($arc); + +for (1..$n) { + my $arc = $zinc->add('arc', $group, [-15, -70, 15, -40]); + $zinc->rotate($arc, ($_-1)*(360/$n), 'degree'); + $zinc->contour($curve, 'add', 1, $arc); + $zinc->remove($arc); +} +&showbbox($group); +ok(&similarFlatArray ([$zinc->bbox($group)], + [278,178, 422,322], # beware this coordinates are + # not exactly the good one + [2,2, 2,2 ], + ), + "bbox of middle figure"); + + +# third +$group = $zinc->add('group', 1); +$zinc->coords($group, [600, 250]); + +$curve = $zinc->add('curve', $group, [], + -fillrule => 'nonzero', + -closed => 1, + -filled => 1, + -fillcolor => 'black', + -linecolor => 'red', + ); +$arc = $zinc->add('arc', $group, [-30, -30, 30, 30]); +$zinc->contour($curve, 'add', 1, $arc); +$zinc->remove($arc); +$n = 3*$n; +for (1..$n) { + $arc = $zinc->add('arc', $group, [-5, -70, 5, -40]); + $zinc->rotate($arc, ($_-1)*(360/$n), 'degree'); + $zinc->contour($curve, 'add', 1, $arc); + $zinc->remove($arc); +} +&showbbox($group); +ok(&similarFlatArray ([$zinc->bbox($group)], + [528,178, 672, 322], # beware this coordinates are + # not exactly the good one + [2,2, 2,2 ], + ), + "bbox of right figure"); + + +$zinc->update; +#sleep 2; + +#MainLoop; + + + +sub showbbox { + my @b = $zinc->bbox(shift); +# print "bbox @b\n"; + $zinc->add('rectangle', 1, [@b], + -filled => 0, -linecolor => 'green', -tags => ['bbox']); +} + +## ref1 is the gotten array +## ref2 is the expected array +sub similarFlatArray { + my ($ref1, $ref2, $deltaref)= @_; + diag ("waiting a reference for \$ref1"), return 0 unless ref ($ref1) eq 'ARRAY'; + diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY'; + diag ("waiting a reference for \$deltaref"), return 0 unless ref ($deltaref) eq 'ARRAY'; + + my @array1 = @{$ref1}; + my @array2 = @{$ref2}; + my @deltaarray = @{$deltaref}; + diag ("arrays gotten, expected and deltas are not of same length,".$#array1.",".$#array2.",".$#deltaarray), return 0 + unless ($#array1 == $#array2) and ($#array2 == $#deltaarray); + for my $i (0.. $#array1) { + my $a = $array1[$i]; + my $b = $array2[$i]; + my $delta = $deltaarray[$i]; + diag ("waiting a numeric value for elt $i of gotten array"), return 0 + unless &numerical($a); + diag ("waiting a numeric value for elt $i of expected array"), return 0 + unless &numerical($b); + diag ("waiting a numeric value for elt $i of deltas array"), return 0 + unless &numerical($delta); + + diag ("delta > $delta between elt $i of gotten array ($a) and expected array ($b)"), return 0 + if (abs($a-$b) > $delta) ; + } + return 1; +} + +sub numerical { + my ($v) = @_; + return 0 unless defined $v; + ### this really works!! + return $v eq $v*1; +} |