1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
#!/usr/bin/perl -w
#
# $Id: Bbox-curve-multi-contour.t,v 1.2 2006-02-12 09:38:07 mertz Exp $
# 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;
## test cannot be run directly since $zinc->update does not work properly
## when not in a mainloop
## so I use a timer to trigger tests after entering the mainloop
$zinc->after(10, \&testExecute);
Tk::MainLoop;
sub testExecute {
# 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");
diag("############## end of text test");
exit;
}
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;
}
|
