t/250-draw/050-polyaa.t

   1 #!perl -w
   2
   3 use strict;
   4 use Test::More tests => 28;
   5
   6 use Imager qw/NC/;
   7 use Imager::Test qw(is_image is_color3);
   8
   9 sub PI () { 3.14159265358979323846 }
  10
  11 -d "testout" or mkdir "testout";
  12
  13 my @out_files;
  14
  15 END {
  16   unless ($ENV{IMAGER_KEEP_FILES}) {
  17     unlink @out_files;
  18     rmdir "testout";
  19   }
  20 }
  21
  22 Imager->open_log(log => "testout/250-polyaa.log");
  23 push @out_files, "testout/250-polyaa.log";
  24
  25 my $red   = Imager::Color->new(255,0,0);
  26 my $green = Imager::Color->new(0,255,0);
  27 my $blue  = Imager::Color->new(0,0,255);
  28 my $white = Imager::Color->new(255,255,255);
  29 my $black = Imager::Color->new(0, 0, 0);
  30
  31 { # artifacts with multiple vertical lobes
  32   # https://rt.cpan.org/Ticket/Display.html?id=43518
  33   # previously this would have a full coverage pixel at (0,0) caused
  34   # by the (20,0.5) point in the right lobe
  35
  36   my @pts =
  37     (
  38      [ 0.5, -9 ],
  39      [ 10, -9 ],
  40      [ 10, 11 ],
  41      [ 15, 11 ],
  42      [ 15, -9 ],
  43      [ 17, -9 ],
  44      [ 20, 0.5 ],
  45      [ 17, 11 ],
  46      [ 0.5, 11 ],
  47     );
  48   my $im = Imager->new(xsize => 10, ysize => 2);
  49   ok($im->polygon(points => \@pts,
  50                   color => $white),
  51      "draw with inside point");
  52   ok($im->write(file => "testout/250-poly-inside.ppm"), "save to file");
  53   push @out_files, "testout/250-poly-inside.ppm";
  54   # both scanlines should be the same
  55   my $line0 = $im->crop(top => 0, height => 1);
  56   my $line1 = $im->crop(top => 1, height => 1);
  57   is_image($line0, $line1, "both scanlines should be the same");
  58 }
  59
  60 { # check vertical edges are consistent
  61   my $im = Imager->new(xsize => 10, ysize => 10);
  62   ok($im->polygon(points => [ [ 0.5, 0 ], [ 9.25, 0 ],
  63                               [ 9.25, 10 ], [ 0.5, 10 ] ],
  64                   color => $white,
  65                   aa => 1),
  66      "draw polygon with mid pixel vertical edges")
  67     or diag $im->errstr;
  68   my @line0 = $im->getscanline(y => 0);
  69   my $im2 = Imager->new(xsize => 10, ysize => 10);
  70   for my $y (0..9) {
  71     $im2->setscanline(y => $y, pixels => \@line0);
  72   }
  73   is_image($im, $im2, "all scan lines should be the same");
  74   is_color3($line0[0], 128, 128, 128, "(0,0) should be 50% coverage");
  75   is_color3($line0[9], 64, 64, 64, "(9,0) should be 25% coverage");
  76 }
  77
  78 { # check horizontal edges are consistent
  79   my $im = Imager->new(xsize => 10, ysize => 10);
  80   ok($im->polygon(points => [ [ 0, 0.5 ], [ 0, 9.25 ],
  81                               [ 10, 9.25 ], [ 10, 0.5 ] ],
  82                   color => $white,
  83                   aa => 1),
  84      "draw polygon with mid-pixel horizontal edges");
  85   is_deeply([ $im->getsamples(y => 0, channels => [ 0 ]) ],
  86             [ (128) x 10 ],
  87             "all of line 0 should be 50% coverage");
  88   is_deeply([ $im->getsamples(y => 9, channels => [ 0 ]) ],
  89             [ (64) x 10 ],
  90             "all of line 9 should be 25% coverage");
  91 }
  92
  93 {
  94   my $img = Imager->new(xsize=>20, ysize=>10);
  95   my @data = translate(5.5,5,
  96                        rotate(0,
  97                               scale(5, 5,
  98                                     get_polygon(n_gon => 5)
  99                                    )
 100                              )
 101                       );
 102
 103
 104   my ($x, $y) = array_to_refpair(@data);
 105   ok(Imager::i_poly_aa_m($img->{IMG}, $x, $y, 0, $white), "primitive poly");
 106
 107   ok($img->write(file=>"testout/250-poly.ppm"), "write to file")
 108     or diag $img->errstr;
 109   push @out_files, "testout/250-poly.ppm";
 110
 111   my $zoom = make_zoom($img, 8, \@data, $red);
 112   ok($zoom, "make zoom of primitive");
 113   $zoom->write(file=>"testout/250-poly-zoom.ppm") or die $zoom->errstr;
 114   push @out_files, "testout/250-poly-zoom.ppm";
 115 }
 116
 117 {
 118   my $img = Imager->new(xsize=>300, ysize=>100);
 119
 120   my $good = 1;
 121   for my $n (0..55) {
 122     my @data = translate(20+20*($n%14),18+20*int($n/14),
 123                          rotate(15*$n/PI,
 124                                 scale(15, 15,
 125                                       get_polygon('box')
 126                                      )
 127                                )
 128                         );
 129     my ($x, $y) = array_to_refpair(@data);
 130     Imager::i_poly_aa_m($img->{IMG}, $x, $y, 0, NC(rand(255), rand(255), rand(255)))
 131         or $good = 0;
 132   }
 133
 134   $img->write(file=>"testout/250-poly-big.ppm") or die $img->errstr;
 135
 136   ok($good, "primitive squares");
 137   push @out_files, "testout/250-poly-big.ppm";
 138 }
 139
 140 {
 141   my $img = Imager->new(xsize => 300, ysize => 300);
 142   ok($img -> polygon(color=>$white,
 143                   points => [
 144                              translate(150,150,
 145                                        rotate(45*PI/180,
 146                                               scale(70,70,
 147                                                     get_polygon('wavycircle', 32*8, sub { 1.2+1*cos(4*$_) }))))
 148                             ],
 149                  ), "method call")
 150     or diag $img->errstr();
 151
 152   $img->write(file=>"testout/250-poly-wave.ppm") or die $img->errstr;
 153   push @out_files, "testout/250-poly-wave.ppm";
 154 }
 155
 156 {
 157   my $img = Imager->new(xsize=>10,ysize=>6);
 158   my @data = translate(165,5,
 159                        scale(80,80,
 160                              get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })));
 161
 162   ok($img -> polygon(color=>$white,
 163                 points => [
 164                            translate(165,5,
 165                                      scale(80,80,
 166                                            get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
 167                           ],
 168                  ), "bug check")
 169     or diag $img->errstr();
 170
 171   make_zoom($img,20,\@data, $blue)->write(file=>"testout/250-poly-wavebug.ppm") or die $img->errstr;
 172
 173   push @out_files, "testout/250-poly-wavebug.ppm";
 174 }
 175
 176 {
 177   my $img = Imager->new(xsize=>300, ysize=>300);
 178   ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF', dx=>3 },
 179               points => [
 180                          translate(150,150,
 181                                    scale(70,70,
 182                                          get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
 183                         ],
 184              ), "poly filled with hatch")
 185     or diag $img->errstr();
 186   $img->write(file=>"testout/250-poly-wave_fill.ppm") or die $img->errstr;
 187   push @out_files, "testout/250-poly-wave_fill.ppm";
 188 }
 189
 190 {
 191   my $img = Imager->new(xsize=>300, ysize=>300, bits=>16);
 192   ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF' },
 193               points => [
 194                          translate(150,150,
 195                                    scale(70,70,
 196                                          get_polygon('wavycircle', 32*8, sub { 1+1*cos(5*$_) })))
 197                         ],
 198              ), "hatched to 16-bit image")
 199     or diag $img->errstr();
 200   $img->write(file=>"testout/250-poly-wave_fill16.ppm") or die $img->errstr;
 201   push @out_files, "testout/250-poly-wave_fill16.ppm";
 202 }
 203
 204 {
 205   my $img = Imager->new(xsize => 100, ysize => 100);
 206   my $poly =
 207     [
 208      [
 209       [ 10, 90, 90, 10 ],
 210       [ 10, 10, 90, 90 ],
 211      ],
 212      [
 213       [ 20, 45, 45, 20 ],
 214       [ 20, 20, 80, 80 ],
 215      ],
 216      [
 217       [ 55, 55, 80, 80 ],
 218       [ 20, 80, 80, 20 ],
 219      ],
 220     ];
 221   ok($img->polypolygon
 222      (
 223       points => $poly,
 224       filled => 1,
 225       color => $white,
 226      ), "default polypolygon");
 227   push @out_files, "testout/250-poly-ppeo.ppm";
 228   ok($img->write(file => "testout/250-poly-ppeo.ppm"),
 229      "save to file");
 230   my $cmp_eo = Imager->new(xsize => 100, ysize => 100);
 231   $cmp_eo->box(filled => 1, color => $white, box => [ 10, 10, 89, 89 ]);
 232   $cmp_eo->box(filled => 1, color => $black, box => [ 20, 20, 44, 79 ]);
 233   $cmp_eo->box(filled => 1, color => $black, box => [ 55, 20, 79, 79 ]);
 234   is_image($img, $cmp_eo, "check even/odd matches");
 235   $img = Imager->new(xsize => 100, ysize => 100);
 236   ok($img->polypolygon
 237      (
 238       points => $poly,
 239       filled => 1,
 240       color => $white,
 241       mode => "nonzero",
 242      ), "default polypolygon");
 243   my $cmp_nz = Imager->new(xsize => 100, ysize => 100);
 244   $cmp_nz->box(filled => 1, color => $white, box => [ 10, 10, 89, 89 ]);
 245   $cmp_nz->box(filled => 1, color => $black, box => [ 55, 20, 79, 79 ]);
 246   is_image($img, $cmp_nz, "check non-zero matches");
 247   push @out_files, "testout/250-poly-ppnz.ppm";
 248   ok($img->write(file => "testout/250-poly-ppnz.ppm"),
 249      "save to file");
 250 }
 251
 252 {
 253   # fail 2 point polygon
 254   my $im = Imager->new(xsize => 10, ysize => 10);
 255   ok(!$im->polygon(x => [ 0, 5 ], y => [ 0, 5 ]),
 256      "fail to draw poly with only two points");
 257   like($im->errstr, qr/polygons must have at least 3 points/,
 258        "check error message");
 259   my $im2 = Imager->new(xsize => 10, ysize => 10);
 260   ok(!$im2->polygon(x => [ 0, 5 ], y => [ 0, 5 ], fill => { solid => "#FFFFFF" }),
 261      "fail to draw poly with only two points (fill)");
 262   like($im2->errstr, qr/polygons must have at least 3 points/,
 263        "check error message");
 264 }
 265
 266 Imager->close_log;
 267
 268 Imager::malloc_state();
 269
 270 #initialized in a BEGIN, later
 271 my %primitives;
 272 my %polygens;
 273
 274 sub get_polygon {
 275   my $name = shift;
 276   if (exists $primitives{$name}) {
 277     return @{$primitives{$name}};
 278   }
 279
 280   if (exists $polygens{$name}) {
 281     return $polygens{$name}->(@_);
 282   }
 283
 284   die "polygon spec: $name unknown\n";
 285 }
 286
 287
 288 sub make_zoom {
 289   my ($img, $sc, $polydata, $linecolor) = @_;
 290
 291   # scale with nearest neighboor sampling
 292   my $timg = $img->scale(scalefactor=>$sc, qtype=>'preview');
 293
 294   # draw the grid
 295   for(my $lx=0; $lx<$timg->getwidth(); $lx+=$sc) {
 296     $timg->line(color=>$green, x1=>$lx, x2=>$lx, y1=>0, y2=>$timg->getheight(), antialias=>0);
 297   }
 298
 299   for(my $ly=0; $ly<$timg->getheight(); $ly+=$sc) {
 300     $timg->line(color=>$green, y1=>$ly, y2=>$ly, x1=>0, x2=>$timg->getwidth(), antialias=>0);
 301   }
 302   my @data = scale($sc, $sc, @$polydata);
 303   push(@data, $data[0]);
 304   my ($x, $y) = array_to_refpair(@data);
 305
 306   $timg->polyline(color=>$linecolor, 'x'=>$x, 'y'=>$y, antialias=>0);
 307   return $timg;
 308 }
 309
 310 # utility functions to manipulate point data
 311
 312 sub scale {
 313   my ($x, $y, @data) = @_;
 314   return map { [ $_->[0]*$x , $_->[1]*$y ] } @data;
 315 }
 316
 317 sub translate {
 318   my ($x, $y, @data) = @_;
 319   map { [ $_->[0]+$x , $_->[1]+$y ] } @data;
 320 }
 321
 322 sub rotate {
 323   my ($rad, @data) = @_;
 324   map { [ $_->[0]*cos($rad)+$_->[1]*sin($rad) , $_->[1]*cos($rad)-$_->[0]*sin($rad) ] } @data;
 325 }
 326
 327 sub array_to_refpair {
 328   my (@x, @y);
 329   for (@_) {
 330     push(@x, $_->[0]);
 331     push(@y, $_->[1]);
 332   }
 333   return \@x, \@y;
 334 }
 335
 336
 337
 338 BEGIN {
 339 %primitives = (
 340                box => [ [-0.5,-0.5], [0.5,-0.5], [0.5,0.5], [-0.5,0.5] ],
 341                triangle => [ [0,0], [1,0], [1,1] ],
 342               );
 343
 344 %polygens = (
 345              wavycircle => sub {
 346                my $numv = shift;
 347                my $radfunc = shift;
 348                my @radians = map { $_*2*PI/$numv } 0..$numv-1;
 349                my @radius  = map { $radfunc->($_) } @radians;
 350                map {
 351                  [ $radius[$_] * cos($radians[$_]), $radius[$_] * sin($radians[$_]) ]
 352                } 0..$#radians;
 353              },
 354              n_gon => sub {
 355                my $N = shift;
 356                map {
 357                  [ cos($_*2*PI/$N), sin($_*2*PI/$N) ]
 358                } 0..$N-1;
 359              },
 360 );
 361 }