t/400-filter/010-filters.t

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