Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 280 lines (231 sloc) 7.432 kb
1c5252e merge the thickline branch polygon fix
Tony Cook authored
1 #!perl -w
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
2
1c5252e merge the thickline branch polygon fix
Tony Cook authored
3 use strict;
4 use Test::More tests => 18;
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
5
1c5252e merge the thickline branch polygon fix
Tony Cook authored
6 use Imager qw/NC/;
7 use Imager::Test qw(is_image is_color3);
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
8
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
9 sub PI () { 3.14159265358979323846 }
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
10
40e78f9 @tonycoz RT#65088 make sure each test script that needs testout/ creates it
authored
11 -d "testout" or mkdir "testout";
12
1c5252e merge the thickline branch polygon fix
Tony Cook authored
13 Imager::init_log("testout/t75aapolyaa.log",1);
14
15 my $red = Imager::Color->new(255,0,0);
16 my $green = Imager::Color->new(0,255,0);
17 my $blue = Imager::Color->new(0,0,255);
18 my $white = Imager::Color->new(255,255,255);
19
20 { # artifacts with multiple vertical lobes
21 # https://rt.cpan.org/Ticket/Display.html?id=43518
22 # previously this would have a full coverage pixel at (0,0) caused
23 # by the (20,0.5) point in the right lobe
24
25 my @pts =
26 (
27 [ 0.5, -9 ],
28 [ 10, -9 ],
29 [ 10, 11 ],
30 [ 15, 11 ],
31 [ 15, -9 ],
32 [ 17, -9 ],
33 [ 20, 0.5 ],
34 [ 17, 11 ],
35 [ 0.5, 11 ],
36 );
37 my $im = Imager->new(xsize => 10, ysize => 2);
38 ok($im->polygon(points => \@pts,
39 color => $white),
40 "draw with inside point");
41 ok($im->write(file => "testout/t75inside.ppm"), "save to file");
42 # both scanlines should be the same
43 my $line0 = $im->crop(top => 0, height => 1);
44 my $line1 = $im->crop(top => 1, height => 1);
45 is_image($line0, $line1, "both scanlines should be the same");
46 }
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
47
1c5252e merge the thickline branch polygon fix
Tony Cook authored
48 { # check vertical edges are consistent
49 my $im = Imager->new(xsize => 10, ysize => 10);
50 ok($im->polygon(points => [ [ 0.5, 0 ], [ 9.25, 0 ],
51 [ 9.25, 10 ], [ 0.5, 10 ] ],
52 color => $white,
53 aa => 1),
54 "draw polygon with mid pixel vertical edges")
55 or diag $im->errstr;
56 my @line0 = $im->getscanline(y => 0);
57 my $im2 = Imager->new(xsize => 10, ysize => 10);
58 for my $y (0..9) {
59 $im2->setscanline(y => $y, pixels => \@line0);
60 }
61 is_image($im, $im2, "all scan lines should be the same");
62 is_color3($line0[0], 128, 128, 128, "(0,0) should be 50% coverage");
63 is_color3($line0[9], 64, 64, 64, "(9,0) should be 25% coverage");
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
64 }
65
1c5252e merge the thickline branch polygon fix
Tony Cook authored
66 { # check horizontal edges are consistent
67 my $im = Imager->new(xsize => 10, ysize => 10);
68 ok($im->polygon(points => [ [ 0, 0.5 ], [ 0, 9.25 ],
69 [ 10, 9.25 ], [ 10, 0.5 ] ],
70 color => $white,
71 aa => 1),
72 "draw polygon with mid-pixel horizontal edges");
73 is_deeply([ $im->getsamples(y => 0, channels => [ 0 ]) ],
74 [ (128) x 10 ],
75 "all of line 0 should be 50% coverage");
76 is_deeply([ $im->getsamples(y => 9, channels => [ 0 ]) ],
77 [ (64) x 10 ],
78 "all of line 9 should be 25% coverage");
79 }
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
80
1c5252e merge the thickline branch polygon fix
Tony Cook authored
81 {
82 my $img = Imager->new(xsize=>20, ysize=>10);
83 my @data = translate(5.5,5,
84 rotate(0,
85 scale(5, 5,
86 get_polygon(n_gon => 5)
87 )
88 )
89 );
90
91
92 my ($x, $y) = array_to_refpair(@data);
93 ok(Imager::i_poly_aa($img->{IMG}, $x, $y, $white), "primitive poly");
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
94
1c5252e merge the thickline branch polygon fix
Tony Cook authored
95 ok($img->write(file=>"testout/t75.ppm"), "write to file")
96 or diag $img->errstr;
d0e7bfe A segfault bug fixed in polygon.c where it would crash when invalid poly...
Arnar Mar Hrafnkelsson authored
97
1c5252e merge the thickline branch polygon fix
Tony Cook authored
98 my $zoom = make_zoom($img, 8, \@data, $red);
99 ok($zoom, "make zoom of primitive");
100 $zoom->write(file=>"testout/t75zoom.ppm") or die $zoom->errstr;
101 }
d0e7bfe A segfault bug fixed in polygon.c where it would crash when invalid poly...
Arnar Mar Hrafnkelsson authored
102
1c5252e merge the thickline branch polygon fix
Tony Cook authored
103 {
104 my $img = Imager->new(xsize=>300, ysize=>100);
105
106 my $good = 1;
107 for my $n (0..55) {
108 my @data = translate(20+20*($n%14),18+20*int($n/14),
109 rotate(15*$n/PI,
110 scale(15, 15,
111 get_polygon('box')
112 )
113 )
114 );
115 my ($x, $y) = array_to_refpair(@data);
116 Imager::i_poly_aa($img->{IMG}, $x, $y, NC(rand(255), rand(255), rand(255)))
117 or $good = 0;
118 }
119
120 $img->write(file=>"testout/t75big.ppm") or die $img->errstr;
d0e7bfe A segfault bug fixed in polygon.c where it would crash when invalid poly...
Arnar Mar Hrafnkelsson authored
121
1c5252e merge the thickline branch polygon fix
Tony Cook authored
122 ok($good, "primitive squares");
123 }
fe24d68 Bug fixes for the polygon rendering code where naming the same pixel twi...
Arnar Mar Hrafnkelsson authored
124
1c5252e merge the thickline branch polygon fix
Tony Cook authored
125 {
126 my $img = Imager->new(xsize => 300, ysize => 300);
127 ok($img -> polygon(color=>$white,
128 points => [
129 translate(150,150,
130 rotate(45*PI/180,
131 scale(70,70,
132 get_polygon('wavycircle', 32*8, sub { 1.2+1*cos(4*$_) }))))
133 ],
134 ), "method call")
135 or diag $img->errstr();
136
137 $img->write(file=>"testout/t75wave.ppm") or die $img->errstr;
138 }
fe24d68 Bug fixes for the polygon rendering code where naming the same pixel twi...
Arnar Mar Hrafnkelsson authored
139
1c5252e merge the thickline branch polygon fix
Tony Cook authored
140 {
141 my $img = Imager->new(xsize=>10,ysize=>6);
142 my @data = translate(165,5,
143 scale(80,80,
144 get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })));
145
146 ok($img -> polygon(color=>$white,
fe24d68 Bug fixes for the polygon rendering code where naming the same pixel twi...
Arnar Mar Hrafnkelsson authored
147 points => [
148 translate(165,5,
149 scale(80,80,
150 get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
151 ],
1c5252e merge the thickline branch polygon fix
Tony Cook authored
152 ), "bug check")
153 or diag $img->errstr();
fe24d68 Bug fixes for the polygon rendering code where naming the same pixel twi...
Arnar Mar Hrafnkelsson authored
154
1c5252e merge the thickline branch polygon fix
Tony Cook authored
155 make_zoom($img,20,\@data, $blue)->write(file=>"testout/t75wavebug.ppm") or die $img->errstr;
fe24d68 Bug fixes for the polygon rendering code where naming the same pixel twi...
Arnar Mar Hrafnkelsson authored
156
1c5252e merge the thickline branch polygon fix
Tony Cook authored
157 }
fe24d68 Bug fixes for the polygon rendering code where naming the same pixel twi...
Arnar Mar Hrafnkelsson authored
158
1c5252e merge the thickline branch polygon fix
Tony Cook authored
159 {
160 my $img = Imager->new(xsize=>300, ysize=>300);
161 ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF', dx=>3 },
43c5dac move the combining function call outside the general fills (simplifies
Tony Cook authored
162 points => [
163 translate(150,150,
164 scale(70,70,
165 get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
166 ],
1c5252e merge the thickline branch polygon fix
Tony Cook authored
167 ), "poly filled with hatch")
168 or diag $img->errstr();
169 $img->write(file=>"testout/t75wave_fill.ppm") or die $img->errstr;
170 }
43c5dac move the combining function call outside the general fills (simplifies
Tony Cook authored
171
1c5252e merge the thickline branch polygon fix
Tony Cook authored
172 {
173 my $img = Imager->new(xsize=>300, ysize=>300, bits=>16);
174 ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF' },
43c5dac move the combining function call outside the general fills (simplifies
Tony Cook authored
175 points => [
176 translate(150,150,
177 scale(70,70,
178 get_polygon('wavycircle', 32*8, sub { 1+1*cos(5*$_) })))
179 ],
1c5252e merge the thickline branch polygon fix
Tony Cook authored
180 ), "hatched to 16-bit image")
181 or diag $img->errstr();
182 $img->write(file=>"testout/t75wave_fill16.ppm") or die $img->errstr;
183 }
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
184
1c5252e merge the thickline branch polygon fix
Tony Cook authored
185 Imager::malloc_state();
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
186
187
1c5252e merge the thickline branch polygon fix
Tony Cook authored
188 #initialized in a BEGIN, later
189 my %primitives;
190 my %polygens;
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
191
192 sub get_polygon {
193 my $name = shift;
194 if (exists $primitives{$name}) {
195 return @{$primitives{$name}};
196 }
197
198 if (exists $polygens{$name}) {
199 return $polygens{$name}->(@_);
200 }
201
202 die "polygon spec: $name unknown\n";
203 }
204
205
206 sub make_zoom {
207 my ($img, $sc, $polydata, $linecolor) = @_;
208
209 # scale with nearest neighboor sampling
210 my $timg = $img->scale(scalefactor=>$sc, qtype=>'preview');
211
212 # draw the grid
1c5252e merge the thickline branch polygon fix
Tony Cook authored
213 for(my $lx=0; $lx<$timg->getwidth(); $lx+=$sc) {
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
214 $timg->line(color=>$green, x1=>$lx, x2=>$lx, y1=>0, y2=>$timg->getheight(), antialias=>0);
215 }
216
1c5252e merge the thickline branch polygon fix
Tony Cook authored
217 for(my $ly=0; $ly<$timg->getheight(); $ly+=$sc) {
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
218 $timg->line(color=>$green, y1=>$ly, y2=>$ly, x1=>0, x2=>$timg->getwidth(), antialias=>0);
219 }
220 my @data = scale($sc, $sc, @$polydata);
221 push(@data, $data[0]);
222 my ($x, $y) = array_to_refpair(@data);
223
224 $timg->polyline(color=>$linecolor, 'x'=>$x, 'y'=>$y, antialias=>0);
225 return $timg;
226 }
227
228 # utility functions to manipulate point data
229
230 sub scale {
231 my ($x, $y, @data) = @_;
232 return map { [ $_->[0]*$x , $_->[1]*$y ] } @data;
233 }
234
235 sub translate {
236 my ($x, $y, @data) = @_;
237 map { [ $_->[0]+$x , $_->[1]+$y ] } @data;
238 }
239
240 sub rotate {
241 my ($rad, @data) = @_;
242 map { [ $_->[0]*cos($rad)+$_->[1]*sin($rad) , $_->[1]*cos($rad)-$_->[0]*sin($rad) ] } @data;
243 }
244
245 sub array_to_refpair {
246 my (@x, @y);
247 for (@_) {
248 push(@x, $_->[0]);
249 push(@y, $_->[1]);
250 }
251 return \@x, \@y;
252 }
253
254
255
256 BEGIN {
257 %primitives = (
258 box => [ [-0.5,-0.5], [0.5,-0.5], [0.5,0.5], [-0.5,0.5] ],
259 triangle => [ [0,0], [1,0], [1,1] ],
260 );
02d1d62 Initial revision
Arnar Mar Hrafnkelsson authored
261
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
262 %polygens = (
263 wavycircle => sub {
264 my $numv = shift;
265 my $radfunc = shift;
266 my @radians = map { $_*2*PI/$numv } 0..$numv-1;
267 my @radius = map { $radfunc->($_) } @radians;
268 map {
d0e7bfe A segfault bug fixed in polygon.c where it would crash when invalid poly...
Arnar Mar Hrafnkelsson authored
269 [ $radius[$_] * cos($radians[$_]), $radius[$_] * sin($radians[$_]) ]
9982a30 Finished antialiased polygon drawing routines.
Arnar Mar Hrafnkelsson authored
270 } 0..$#radians;
271 },
272 n_gon => sub {
273 my $N = shift;
274 map {
275 [ cos($_*2*PI/$N), sin($_*2*PI/$N) ]
276 } 0..$N-1;
277 },
278 );
279 }
Something went wrong with that request. Please try again.