t/400-filter/010-filters.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:handy);
   4 use Test::More tests => 136;
   5
   6 -d "testout" or mkdir "testout";
   7
   8 Imager::init_log("testout/t61filters.log", 1);
   9 use Imager::Test qw(is_image_similar test_image is_image is_color4 is_fcolor4);
  10 # meant for testing the filters themselves
  11
  12 my $imbase = test_image();
  13
  14 my $im_other = Imager->new(xsize=>150, ysize=>150);
  15 $im_other->box(xmin=>30, ymin=>60, xmax=>120, ymax=>90, filled=>1);
  16
  17 test($imbase, {type=>'autolevels'}, 'testout/t61_autolev.ppm');
  18
  19 test($imbase, {type=>'autolevels_skew'}, 'testout/t61_autoskew.ppm');
  20
  21 test($imbase, {type=>'contrast', intensity=>0.5},
  22      'testout/t61_contrast.ppm');
  23
  24 # this one's kind of cool
  25 test($imbase, {type=>'conv', coef=>[ 0.3, 1, 0.3, ], },
  26      'testout/t61_conv_blur.ppm');
  27
  28 {
  29   my $work = $imbase->copy;
  30   ok(!Imager::i_conv($work->{IMG}, []), "conv should fail with empty array");
  31   ok(!$work->filter(type => 'conv', coef => []),
  32      "check the conv OO intergave too");
  33   is($work->errstr, "there must be at least one coefficient",
  34      "check conv error message");
  35 }
  36
  37 {
  38   my $work8 = $imbase->copy;
  39   ok(!$work8->filter(type => "conv", coef => "ABC"),
  40      "coef not an array");
  41 }
  42 {
  43   my $work8 = $imbase->copy;
  44   ok(!$work8->filter(type => "conv", coef => [ -1, 2, -1 ]),
  45      "should fail if sum of coef is 0");
  46   is($work8->errstr, "sum of coefficients is zero", "check message");
  47 }
  48
  49 {
  50   my $work8 = $imbase->copy;
  51   my $work16 = $imbase->to_rgb16;
  52   my $coef = [ -0.2, 1, -0.2 ];
  53   ok($work8->filter(type => "conv", coef => $coef),
  54      "filter 8 bit image");
  55   ok($work16->filter(type => "conv", , coef => $coef),
  56      "filter 16 bit image");
  57   is_image_similar($work8, $work16, 80000, "8 and 16 bit conv match");
  58 }
  59
  60 {
  61   my $gauss = test($imbase, {type=>'gaussian', stddev=>5 },
  62                    'testout/t61_gaussian.ppm');
  63
  64   my $imbase16 = $imbase->to_rgb16;
  65   my $gauss16 = test($imbase16,  {type=>'gaussian', stddev=>5 },
  66                      'testout/t61_gaussian16.ppm');
  67   is_image_similar($gauss, $gauss16, 250000, "8 and 16 gaussian match");
  68 }
  69
  70 {
  71   my $imbase = Imager->new( xsize=>150, ysize=>150 );
  72   $imbase->box( filled=>1, color=>'white', box=>[ 70, 24, 80, 124 ] );
  73   $imbase->box( filled=>1, color=>'red', box=>[ 70, 24, 124, 30 ] );
  74   $imbase->write( file=>"testout/t61_gaussian2-base.ppm" );
  75
  76   my $gauss = test($imbase, {type=>'gaussian2', stddevY=>5, stddevX=>0 },
  77                    'testout/t61_gaussianY.ppm');
  78
  79   my $imbase16 = $imbase->to_rgb16;
  80   my $gauss16 = test($imbase16,  {type=>'gaussian2', stddevY=>5, stddevX=>0.1 },
  81                      'testout/t61_gaussianY-16.ppm');
  82   is_image_similar($gauss, $gauss16, 250000, "8 and 16 gaussian match");
  83
  84
  85   test($imbase, {type=>'gaussian2', stddevX=>5, stddevY=>5 },
  86                    'testout/t61_gaussian_both.ppm');
  87
  88
  89   $gauss = test($imbase, {type=>'gaussian2', stddevX=>5, stddevY=>0 },
  90                    'testout/t61_gaussianX.ppm');
  91
  92   $imbase16 = $imbase->to_rgb16;
  93   $gauss16 = test($imbase16,  {type=>'gaussian2', stddevX=>5, stddevY=>0.1 },
  94                      'testout/t61_gaussianX-16.ppm');
  95   is_image_similar($gauss, $gauss16, 250000, "8 and 16 gaussian match");
  96 }
  97
  98
  99 test($imbase, { type=>'gradgen', dist=>1,
 100                    xo=>[ 10,  10, 120 ],
 101                    yo=>[ 10, 140,  60 ],
 102                    colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
 103      'testout/t61_gradgen.ppm');
 104
 105 test($imbase, {type=>'mosaic', size=>8}, 'testout/t61_mosaic.ppm');
 106
 107 test($imbase, {type=>'hardinvert'}, 'testout/t61_hardinvert.ppm');
 108
 109 { # invert - 8 bit
 110   my $im = Imager->new(xsize => 1, ysize => 1, channels => 4);
 111   ok($im, "make test image for invert test");
 112   ok($im->setpixel(x => 0, y => 0, color => "000010C0"),
 113      "set a test pixel");
 114   my $copy = $im->copy;
 115   ok($im->filter(type => "hardinvert"), "hardinvert it");
 116   is_color4($im->getpixel(x => 0, y => 0), 255, 255, 0xEF, 0xC0,
 117             "check only colour inverted");
 118   ok($copy->filter(type => "hardinvertall"), "hardinvertall copy");
 119   is_color4($copy->getpixel(x => 0, y => 0), 255, 255, 0xEF, 0x3f,
 120             "check all inverted");
 121 }
 122
 123 { # invert - double image
 124   my $im = Imager->new(xsize => 1, ysize => 1, channels => 4, bits => "double");
 125   ok($im, "make double test image for invert test");
 126   ok($im->setpixel(x => 0, y => 0, color => Imager::Color::Float->new(0, 0, 0.125, 0.75)),
 127      "set a test pixel");
 128   my $copy = $im->copy;
 129   ok($im->filter(type => "hardinvert"), "hardinvert it");
 130   is_fcolor4($im->getpixel(x => 0, y => 0, type => "double"),
 131              1.0, 1.0, 0.875, 0.75, 1e-5,
 132              "check only colour inverted");
 133   ok($copy->filter(type => "hardinvertall"), "hardinvertall copy");
 134   is_fcolor4($copy->getpixel(x => 0, y => 0, type =>"double"),
 135              1.0, 1.0, 0.875, 0.25, 1e-5,
 136              "check all inverted");
 137 }
 138
 139 test($imbase, {type=>'noise'}, 'testout/t61_noise.ppm');
 140
 141 test($imbase, {type=>'radnoise'}, 'testout/t61_radnoise.ppm');
 142
 143 test($imbase, {type=>'turbnoise'}, 'testout/t61_turbnoise.ppm');
 144
 145 test($imbase, {type=>'bumpmap', bump=>$im_other, lightx=>30, lighty=>30},
 146      'testout/t61_bumpmap.ppm');
 147
 148 test($imbase, {type=>'bumpmap_complex', bump=>$im_other}, 'testout/t61_bumpmap_complex.ppm');
 149
 150 test($imbase, {type=>'postlevels', levels=>3}, 'testout/t61_postlevels.ppm');
 151
 152 test($imbase, {type=>'watermark', wmark=>$im_other },
 153      'testout/t61_watermark.ppm');
 154
 155 test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>85, yb=>30,
 156                repeat=>'triangle', #ftype=>'radial',
 157                super_sample=>'circle', ssample_param => 16,
 158               },
 159      'testout/t61_fountain.ppm');
 160 use Imager::Fountain;
 161
 162 my $f1 = Imager::Fountain->new;
 163 $f1->add(end=>0.2, c0=>NC(255, 0,0), c1=>NC(255, 255,0));
 164 $f1->add(start=>0.2, c0=>NC(255,255,0), c1=>NC(0,0,255,0));
 165 test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
 166                 #repeat=>'triangle',
 167                 segments=>$f1
 168               },
 169      'testout/t61_fountain2.ppm');
 170 my $f2 = Imager::Fountain->new
 171   ->add(end=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'hueup')
 172   ->add(start=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'huedown');
 173 #use Data::Dumper;
 174 #print Dumper($f2);
 175 test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
 176                     segments=>$f2 },
 177      'testout/t61_fount_hsv.ppm');
 178 my $f3 = Imager::Fountain->read(gimp=>'testimg/gimpgrad');
 179 ok($f3, "read gimpgrad");
 180 test($imbase, { type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
 181                     segments=>$f3, super_sample=>'grid',
 182                     ftype=>'radial_square', combine=>'color' },
 183      'testout/t61_fount_gimp.ppm');
 184 { # test new fountain with no parameters
 185   my $warn = '';
 186   local $SIG{__WARN__} = sub { $warn .= "@_" };
 187   my $f4 = Imager::Fountain->read();
 188   ok(!$f4, "read with no parameters does nothing");
 189   like($warn, qr/Nothing to do!/, "check the warning");
 190 }
 191 { # test with missing file
 192   my $warn = '';
 193   local $SIG{__WARN__} = sub { $warn .= "@_" };
 194   my $f = Imager::Fountain->read(gimp => "no-such-file");
 195   ok(!$f, "try to read a fountain defintion that doesn't exist");
 196   is($warn, "", "should be no warning");
 197   like(Imager->errstr, qr/^Cannot open no-such-file: /, "check message");
 198 }
 199 SKIP:
 200 {
 201   my $fh = IO::File->new("testimg/gimpgrad", "r");
 202   ok($fh, "opened gradient")
 203     or skip "Couldn't open gradient: $!", 1;
 204   my $f = Imager::Fountain->read(gimp => $fh);
 205   ok($f, "read gradient from file handle");
 206 }
 207 {
 208   # not a gradient
 209   my $f = Imager::Fountain->read(gimp => "t/400-filter/010-filters.t");
 210   ok(!$f, "fail to read non-gradient");
 211   is(Imager->errstr, "t/400-filter/010-filters.t is not a GIMP gradient file",
 212      "check error message");
 213 }
 214 { # an invalid gradient file
 215   my $f = Imager::Fountain->read(gimp => "testimg/gradbad.ggr");
 216   ok(!$f, "fail to read bad gradient (bad seg count)");
 217   is(Imager->errstr, "testimg/gradbad.ggr is missing the segment count",
 218      "check error message");
 219 }
 220 { # an invalid gradient file
 221   my $f = Imager::Fountain->read(gimp => "testimg/gradbad2.ggr");
 222   ok(!$f, "fail to read bad gradient (bad segment)");
 223   is(Imager->errstr, "Bad segment definition",
 224      "check error message");
 225 }
 226 test($imbase, { type=>'unsharpmask', stddev=>2.0 },
 227      'testout/t61_unsharp.ppm');
 228 test($imbase, {type=>'conv', coef=>[ -1, 3, -1, ], },
 229      'testout/t61_conv_sharp.ppm');
 230
 231 test($imbase, { type=>'nearest_color', dist=>1,
 232                    xo=>[ 10,  10, 120 ],
 233                    yo=>[ 10, 140,  60 ],
 234                    colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
 235      'testout/t61_nearest.ppm');
 236
 237 # Regression test: the checking of the segment type was incorrect
 238 # (the comparison was checking the wrong variable against the wrong value)
 239 my $f4 = [ [ 0, 0.5, 1, NC(0,0,0), NC(255,255,255), 5, 0 ] ];
 240 test($imbase, {type=>'fountain',  xa=>75, ya=>75, xb=>90, yb=>15,
 241                segments=>$f4, super_sample=>'grid',
 242                ftype=>'linear', combine=>'color' },
 243      'testout/t61_regress_fount.ppm');
 244 my $im2 = $imbase->copy;
 245 $im2->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
 246 $im2->write(file=>'testout/t61_diff_base.ppm');
 247 my $im3 = Imager->new(xsize=>150, ysize=>150, channels=>3);
 248 $im3->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
 249 my $diff = $imbase->difference(other=>$im2);
 250 ok($diff, "got difference image");
 251 SKIP:
 252 {
 253   skip(1, "missing comp or diff image") unless $im3 && $diff;
 254
 255   is(Imager::i_img_diff($im3->{IMG}, $diff->{IMG}), 0,
 256      "compare test image and diff image");
 257 }
 258
 259 # newer versions of gimp add a line to the gradient file
 260 my $name;
 261 my $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr',
 262                                 name => \$name);
 263 ok($f5, "read newer gimp gradient")
 264   or print "# ",Imager->errstr,"\n";
 265 is($name, "imager test gradient", "check name read correctly");
 266 $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr');
 267 ok($f5, "check we handle case of no name reference correctly")
 268   or print "# ",Imager->errstr,"\n";
 269
 270 # test writing of gradients
 271 ok($f2->write(gimp=>'testout/t61grad1.ggr'), "save a gradient")
 272   or print "# ",Imager->errstr,"\n";
 273 undef $name;
 274 my $f6 = Imager::Fountain->read(gimp=>'testout/t61grad1.ggr',
 275                                 name=>\$name);
 276 ok($f6, "read what we wrote")
 277   or print "# ",Imager->errstr,"\n";
 278 ok(!defined $name, "we didn't set the name, so shouldn't get one");
 279
 280 # try with a name
 281 ok($f2->write(gimp=>'testout/t61grad2.ggr', name=>'test gradient'),
 282    "write gradient with a name")
 283   or print "# ",Imager->errstr,"\n";
 284 undef $name;
 285 my $f7 = Imager::Fountain->read(gimp=>'testout/t61grad2.ggr', name=>\$name);
 286 ok($f7, "read what we wrote")
 287   or print "# ",Imager->errstr,"\n";
 288 is($name, "test gradient", "check the name matches");
 289
 290 # we attempt to convert color names in segments to segments now
 291 {
 292   my @segs =
 293     (
 294      [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
 295     );
 296   my $im = Imager->new(xsize=>50, ysize=>50);
 297   ok($im->filter(type=>'fountain', segments => \@segs,
 298                  xa=>0, ya=>30, xb=>49, yb=>30),
 299      "fountain with color names instead of objects in segments");
 300   my $left = $im->getpixel('x'=>0, 'y'=>20);
 301   ok(color_close($left, Imager::Color->new(0,0,0)),
 302      "check black converted correctly");
 303   my $right = $im->getpixel('x'=>49, 'y'=>20);
 304   ok(color_close($right, Imager::Color->new(255,255,255)),
 305      "check white converted correctly");
 306
 307   # check that invalid color names are handled correctly
 308   my @segs2 =
 309     (
 310      [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
 311     );
 312   ok(!$im->filter(type=>'fountain', segments => \@segs2,
 313                   xa=>0, ya=>30, xb=>49, yb=>30),
 314      "fountain with invalid color name");
 315   cmp_ok($im->errstr, '=~', 'No color named', "check error message");
 316 }
 317
 318 {
 319   # test simple gradient creation
 320   my @colors = map Imager::Color->new($_), qw/white blue red/;
 321   my $s = Imager::Fountain->simple(positions => [ 0, 0.3, 1.0 ],
 322                                    colors => \@colors);
 323   ok($s, "made simple gradient");
 324   my $start = $s->[0];
 325   is($start->[0], 0, "check start of first correct");
 326   is_color4($start->[3], 255, 255, 255, 255, "check color at start");
 327 }
 328 {
 329   # simple gradient error modes
 330   {
 331     my $warn = '';
 332     local $SIG{__WARN__} = sub { $warn .= "@_" };
 333     my $s = Imager::Fountain->simple();
 334     ok(!$s, "no parameters to simple()");
 335     like($warn, qr/Nothing to do/);
 336   }
 337   {
 338     my $s = Imager::Fountain->simple(positions => [ 0, 1 ],
 339                                      colors => [ NC(0, 0, 0) ]);
 340     ok(!$s, "mismatch of positions and colors fails");
 341     is(Imager->errstr, "positions and colors must be the same size",
 342        "check message");
 343   }
 344   {
 345     my $s = Imager::Fountain->simple(positions => [ 0 ],
 346                                      colors => [ NC(0, 0, 0) ]);
 347     ok(!$s, "not enough positions");
 348     is(Imager->errstr, "not enough segments");
 349   }
 350 }
 351
 352 {
 353   my $im = Imager->new(xsize=>100, ysize=>100);
 354   # build the gradient the hard way - linear from black to white,
 355   # then back again
 356   my @simple =
 357    (
 358      [   0, 0.25, 0.5, 'black', 'white', 0, 0 ],
 359      [ 0.5. 0.75, 1.0, 'white', 'black', 0, 0 ],
 360    );
 361   # across
 362   my $linear = $im->filter(type   => "fountain",
 363                            ftype  => 'linear',
 364                            repeat => 'sawtooth',
 365                            xa     => 0,
 366                            ya     => $im->getheight / 2,
 367                            xb     => $im->getwidth - 1,
 368                            yb     => $im->getheight / 2);
 369   ok($linear, "linear fountain sample");
 370   # around
 371   my $revolution = $im->filter(type   => "fountain",
 372                                ftype  => 'revolution',
 373                                xa     => $im->getwidth / 2,
 374                                ya     => $im->getheight / 2,
 375                                xb     => $im->getwidth / 2,
 376                                yb     => 0);
 377   ok($revolution, "revolution fountain sample");
 378   # out from the middle
 379   my $radial = $im->filter(type   => "fountain",
 380                            ftype  => 'radial',
 381                            xa     => $im->getwidth / 2,
 382                            ya     => $im->getheight / 2,
 383                            xb     => $im->getwidth / 2,
 384                            yb     => 0);
 385   ok($radial, "radial fountain sample");
 386 }
 387
 388 {
 389   # try a simple custom filter that uses the Perl image interface
 390   sub perl_filt {
 391     my %args = @_;
 392
 393     my $im = $args{imager};
 394
 395     my $channels = $args{channels};
 396     unless (@$channels) {
 397       $channels = [ reverse(0 .. $im->getchannels-1) ];
 398     }
 399     my @chans = @$channels;
 400     push @chans, 0 while @chans < 4;
 401
 402     for my $y (0 .. $im->getheight-1) {
 403       my $row = $im->getsamples(y => $y, channels => \@chans);
 404       $im->setscanline(y => $y, pixels => $row);
 405     }
 406   }
 407   Imager->register_filter(type => 'perl_test',
 408                           callsub => \&perl_filt,
 409                           defaults => { channels => [] },
 410                           callseq => [ qw/imager channels/ ]);
 411   test($imbase, { type => 'perl_test' }, 'testout/t61perl.ppm');
 412 }
 413
 414 { # check the difference method out
 415   my $im1 = Imager->new(xsize => 3, ysize => 2);
 416   $im1->box(filled => 1, color => '#FF0000');
 417   my $im2 = $im1->copy;
 418   $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
 419   $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
 420   $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
 421   $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
 422
 423   my $diff1 = $im1->difference(other => $im2);
 424   my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
 425   $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
 426   $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
 427   is_image($diff1, $cmp1, "difference() - check image with mindist 0");
 428
 429   my $diff2 = $im1->difference(other => $im2, mindist => 1);
 430   my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
 431   $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
 432   is_image($diff2, $cmp2, "difference() - check image with mindist 1");
 433 }
 434
 435 {
 436   # and again with large samples
 437   my $im1 = Imager->new(xsize => 3, ysize => 2, bits => 'double');
 438   $im1->box(filled => 1, color => '#FF0000');
 439   my $im2 = $im1->copy;
 440   $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
 441   $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
 442   $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
 443   $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
 444
 445   my $diff1 = $im1->difference(other => $im2);
 446   my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
 447   $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
 448   $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
 449   is_image($diff1, $cmp1, "difference() - check image with mindist 0 - large samples");
 450
 451   my $diff2 = $im1->difference(other => $im2, mindist => 1.1);
 452   my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
 453   $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
 454   is_image($diff2, $cmp2, "difference() - check image with mindist 1.1 - large samples");
 455 }
 456
 457 {
 458   my $empty = Imager->new;
 459   ok(!$empty->filter(type => "hardinvert"), "can't filter an empty image");
 460   is($empty->errstr, "filter: empty input image",
 461      "check error message");
 462   ok(!$empty->difference(other => $imbase), "can't difference empty image");
 463   is($empty->errstr, "difference: empty input image",
 464      "check error message");
 465   ok(!$imbase->difference(other => $empty),
 466      "can't difference against empty image");
 467   is($imbase->errstr, "difference: empty input image (other image)",
 468      "check error message");
 469 }
 470
 471 sub test {
 472   my ($in, $params, $out) = @_;
 473
 474   my $copy = $in->copy;
 475   if (ok($copy->filter(%$params), $params->{type})) {
 476     ok($copy->write(file=>$out), "write $params->{type}")
 477       or print "# ",$copy->errstr,"\n";
 478   }
 479   else {
 480     diag($copy->errstr);
 481   SKIP:
 482     {
 483       skip("couldn't filter", 1);
 484     }
 485   }
 486   $copy;
 487 }
 488
 489 sub color_close {
 490   my ($c1, $c2) = @_;
 491
 492   my @c1 = $c1->rgba;
 493   my @c2 = $c2->rgba;
 494
 495   for my $i (0..2) {
 496     if (abs($c1[$i]-$c2[$i]) > 2) {
 497       return 0;
 498     }
 499   }
 500   return 1;
 501 }