t/t61filters.t

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