t/t61filters.t

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