t/t61filters.t

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