Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 279 lines (231 sloc) 7.432 kb
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
1 #!perl -w
02d1d628 » Arnar Mar Hrafnkelsson
2001-03-25 Initial revision
2
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
3 use strict;
4 use Test::More tests => 18;
02d1d628 » Arnar Mar Hrafnkelsson
2001-03-25 Initial revision
5
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
6 use Imager qw/NC/;
7 use Imager::Test qw(is_image is_color3);
02d1d628 » Arnar Mar Hrafnkelsson
2001-03-25 Initial revision
8
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
9 sub PI () { 3.14159265358979323846 }
02d1d628 » Arnar Mar Hrafnkelsson
2001-03-25 Initial revision
10
40e78f96 »
2011-02-03 RT#65088 make sure each test script that needs testout/ creates it
11 -d "testout" or mkdir "testout";
12
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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 }
02d1d628 » Arnar Mar Hrafnkelsson
2001-03-25 Initial revision
47
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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");
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
64 }
65
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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 }
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
80
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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");
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
94
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
95 ok($img->write(file=>"testout/t75.ppm"), "write to file")
96 or diag $img->errstr;
d0e7bfee » Arnar Mar Hrafnkelsson
2001-11-12 A segfault bug fixed in polygon.c where it would crash when invalid p…
97
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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 }
d0e7bfee » Arnar Mar Hrafnkelsson
2001-11-12 A segfault bug fixed in polygon.c where it would crash when invalid p…
102
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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;
d0e7bfee » Arnar Mar Hrafnkelsson
2001-11-12 A segfault bug fixed in polygon.c where it would crash when invalid p…
121
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
122 ok($good, "primitive squares");
123 }
fe24d684 » Arnar Mar Hrafnkelsson
2001-11-12 Bug fixes for the polygon rendering code where naming the same pixel …
124
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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 }
fe24d684 » Arnar Mar Hrafnkelsson
2001-11-12 Bug fixes for the polygon rendering code where naming the same pixel …
139
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
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,
fe24d684 » Arnar Mar Hrafnkelsson
2001-11-12 Bug fixes for the polygon rendering code where naming the same pixel …
147 points => [
148 translate(165,5,
149 scale(80,80,
150 get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
151 ],
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
152 ), "bug check")
153 or diag $img->errstr();
fe24d684 » Arnar Mar Hrafnkelsson
2001-11-12 Bug fixes for the polygon rendering code where naming the same pixel …
154
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
155 make_zoom($img,20,\@data, $blue)->write(file=>"testout/t75wavebug.ppm") or die $img->errstr;
fe24d684 » Arnar Mar Hrafnkelsson
2001-11-12 Bug fixes for the polygon rendering code where naming the same pixel …
156
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
157 }
fe24d684 » Arnar Mar Hrafnkelsson
2001-11-12 Bug fixes for the polygon rendering code where naming the same pixel …
158
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
159 {
160 my $img = Imager->new(xsize=>300, ysize=>300);
161 ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF', dx=>3 },
43c5dacb » Tony Cook
2001-11-19 move the combining function call outside the general fills (simplifies
162 points => [
163 translate(150,150,
164 scale(70,70,
165 get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
166 ],
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
167 ), "poly filled with hatch")
168 or diag $img->errstr();
169 $img->write(file=>"testout/t75wave_fill.ppm") or die $img->errstr;
170 }
43c5dacb » Tony Cook
2001-11-19 move the combining function call outside the general fills (simplifies
171
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
172 {
173 my $img = Imager->new(xsize=>300, ysize=>300, bits=>16);
174 ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF' },
43c5dacb » Tony Cook
2001-11-19 move the combining function call outside the general fills (simplifies
175 points => [
176 translate(150,150,
177 scale(70,70,
178 get_polygon('wavycircle', 32*8, sub { 1+1*cos(5*$_) })))
179 ],
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
180 ), "hatched to 16-bit image")
181 or diag $img->errstr();
182 $img->write(file=>"testout/t75wave_fill16.ppm") or die $img->errstr;
183 }
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
184
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
185 Imager::malloc_state();
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
186
187
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
188 #initialized in a BEGIN, later
189 my %primitives;
190 my %polygens;
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
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
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
213 for(my $lx=0; $lx<$timg->getwidth(); $lx+=$sc) {
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
214 $timg->line(color=>$green, x1=>$lx, x2=>$lx, y1=>0, y2=>$timg->getheight(), antialias=>0);
215 }
216
1c5252ed » Tony Cook
2010-06-20 merge the thickline branch polygon fix
217 for(my $ly=0; $ly<$timg->getheight(); $ly+=$sc) {
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
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 );
02d1d628 » Arnar Mar Hrafnkelsson
2001-03-25 Initial revision
261
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
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 {
d0e7bfee » Arnar Mar Hrafnkelsson
2001-11-12 A segfault bug fixed in polygon.c where it would crash when invalid p…
269 [ $radius[$_] * cos($radians[$_]), $radius[$_] * sin($radians[$_]) ]
9982a307 » Arnar Mar Hrafnkelsson
2001-11-12 Finished antialiased polygon drawing routines.
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.