t/t75polyaa.t

   1 #!perl -w
   2
   3 use strict;
   4 use Test::More tests => 18;
   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 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 }
  47
  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");
  64 }
  65
  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 }
  80
  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");
  94
  95   ok($img->write(file=>"testout/t75.ppm"), "write to file")
  96     or diag $img->errstr;
  97
  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 }
 102
 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;
 121
 122   ok($good, "primitive squares");
 123 }
 124
 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 }
 139
 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,
 147                 points => [
 148                            translate(165,5,
 149                                      scale(80,80,
 150                                            get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
 151                           ],
 152                  ), "bug check")
 153     or diag $img->errstr();
 154
 155   make_zoom($img,20,\@data, $blue)->write(file=>"testout/t75wavebug.ppm") or die $img->errstr;
 156
 157 }
 158
 159 {
 160   my $img = Imager->new(xsize=>300, ysize=>300);
 161   ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF', dx=>3 },
 162               points => [
 163                          translate(150,150,
 164                                    scale(70,70,
 165                                          get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
 166                         ],
 167              ), "poly filled with hatch")
 168     or diag $img->errstr();
 169   $img->write(file=>"testout/t75wave_fill.ppm") or die $img->errstr;
 170 }
 171
 172 {
 173   my $img = Imager->new(xsize=>300, ysize=>300, bits=>16);
 174   ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF' },
 175               points => [
 176                          translate(150,150,
 177                                    scale(70,70,
 178                                          get_polygon('wavycircle', 32*8, sub { 1+1*cos(5*$_) })))
 179                         ],
 180              ), "hatched to 16-bit image")
 181     or diag $img->errstr();
 182   $img->write(file=>"testout/t75wave_fill16.ppm") or die $img->errstr;
 183 }
 184
 185 Imager::malloc_state();
 186
 187
 188 #initialized in a BEGIN, later
 189 my %primitives;
 190 my %polygens;
 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
 213   for(my $lx=0; $lx<$timg->getwidth(); $lx+=$sc) {
 214     $timg->line(color=>$green, x1=>$lx, x2=>$lx, y1=>0, y2=>$timg->getheight(), antialias=>0);
 215   }
 216
 217   for(my $ly=0; $ly<$timg->getheight(); $ly+=$sc) {
 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               );
 261
 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 {
 269                  [ $radius[$_] * cos($radians[$_]), $radius[$_] * sin($radians[$_]) ]
 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 }