t/t61filters.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:handy);
   4 use Test::More tests => 69;
   5 Imager::init_log("testout/t61filters.log", 1);
   6 use Imager::Test qw(is_image_similar);
   7 # meant for testing the filters themselves
   8 my $imbase = Imager->new;
   9 $imbase->open(file=>'testout/t104.ppm') or die;
  10 my $im_other = Imager->new(xsize=>150, ysize=>150);
  11 $im_other->box(xmin=>30, ymin=>60, xmax=>120, ymax=>90, filled=>1);
  12
  13 test($imbase, {type=>'autolevels'}, 'testout/t61_autolev.ppm');
  14
  15 test($imbase, {type=>'contrast', intensity=>0.5},
  16      'testout/t61_contrast.ppm');
  17
  18 # this one's kind of cool
  19 test($imbase, {type=>'conv', coef=>[ -0.5, 1, -0.5, ], },
  20      'testout/t61_conv.ppm');
  21
  22 {
  23   my $gauss = test($imbase, {type=>'gaussian', stddev=>5 },
  24                    'testout/t61_gaussian.ppm');
  25
  26   my $imbase16 = $imbase->to_rgb16;
  27   my $gauss16 = test($imbase16,  {type=>'gaussian', stddev=>5 },
  28                      'testout/t61_gaussian16.ppm');
  29   is_image_similar($gauss, $gauss16, 200000, "8 and 16 gaussian match");
  30 }
  31
  32
  33 test($imbase, { type=>'gradgen', dist=>1,
  34                    xo=>[ 10,  10, 120 ],
  35                    yo=>[ 10, 140,  60 ],
  36                    colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
  37      'testout/t61_gradgen.ppm');
  38
  39 test($imbase, {type=>'mosaic', size=>8}, 'testout/t61_mosaic.ppm');
  40
  41 test($imbase, {type=>'hardinvert'}, 'testout/t61_hardinvert.ppm');
  42
  43 test($imbase, {type=>'noise'}, 'testout/t61_noise.ppm');
  44
  45 test($imbase, {type=>'radnoise'}, 'testout/t61_radnoise.ppm');
  46
  47 test($imbase, {type=>'turbnoise'}, 'testout/t61_turbnoise.ppm');
  48
  49 test($imbase, {type=>'bumpmap', bump=>$im_other, lightx=>30, lighty=>30},
  50      'testout/t61_bumpmap.ppm');
  51
  52 test($imbase, {type=>'bumpmap_complex', bump=>$im_other}, 'testout/t61_bumpmap_complex.ppm');
  53
  54 test($imbase, {type=>'postlevels', levels=>3}, 'testout/t61_postlevels.ppm');
  55
  56 test($imbase, {type=>'watermark', wmark=>$im_other },
  57      'testout/t61_watermark.ppm');
  58
  59 test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>85, yb=>30,
  60                repeat=>'triangle', #ftype=>'radial',
  61                super_sample=>'circle', ssample_param => 16,
  62               },
  63      'testout/t61_fountain.ppm');
  64 use Imager::Fountain;
  65
  66 my $f1 = Imager::Fountain->new;
  67 $f1->add(end=>0.2, c0=>NC(255, 0,0), c1=>NC(255, 255,0));
  68 $f1->add(start=>0.2, c0=>NC(255,255,0), c1=>NC(0,0,255,0));
  69 test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
  70                 #repeat=>'triangle',
  71                 segments=>$f1
  72               },
  73      'testout/t61_fountain2.ppm');
  74 my $f2 = Imager::Fountain->new
  75   ->add(end=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'hueup')
  76   ->add(start=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'huedown');
  77 #use Data::Dumper;
  78 #print Dumper($f2);
  79 test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
  80                     segments=>$f2 },
  81      'testout/t61_fount_hsv.ppm');
  82 my $f3 = Imager::Fountain->read(gimp=>'testimg/gimpgrad');
  83 ok($f3, "read gimpgrad");
  84 test($imbase, { type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
  85                     segments=>$f3, super_sample=>'grid',
  86                     ftype=>'radial_square', combine=>'color' },
  87      'testout/t61_fount_gimp.ppm');
  88 test($imbase, { type=>'unsharpmask', stddev=>2.0 },
  89      'testout/t61_unsharp.ppm');
  90 test($imbase, {type=>'conv', coef=>[ -1, 3, -1, ], },
  91      'testout/t61_conv_sharp.ppm');
  92
  93 test($imbase, { type=>'nearest_color', dist=>1,
  94                    xo=>[ 10,  10, 120 ],
  95                    yo=>[ 10, 140,  60 ],
  96                    colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
  97      'testout/t61_nearest.ppm');
  98
  99 # Regression test: the checking of the segment type was incorrect
 100 # (the comparison was checking the wrong variable against the wrong value)
 101 my $f4 = [ [ 0, 0.5, 1, NC(0,0,0), NC(255,255,255), 5, 0 ] ];
 102 test($imbase, {type=>'fountain',  xa=>75, ya=>75, xb=>90, yb=>15,
 103                segments=>$f4, super_sample=>'grid',
 104                ftype=>'linear', combine=>'color' },
 105      'testout/t61_regress_fount.ppm');
 106 my $im2 = $imbase->copy;
 107 $im2->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
 108 $im2->write(file=>'testout/t61_diff_base.ppm');
 109 my $im3 = Imager->new(xsize=>150, ysize=>150, channels=>3);
 110 $im3->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
 111 my $diff = $imbase->difference(other=>$im2);
 112 ok($diff, "got difference image");
 113 SKIP:
 114 {
 115   skip(1, "missing comp or diff image") unless $im3 && $diff;
 116
 117   is(Imager::i_img_diff($im3->{IMG}, $diff->{IMG}), 0,
 118      "compare test image and diff image");
 119 }
 120
 121 # newer versions of gimp add a line to the gradient file
 122 my $name;
 123 my $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr',
 124                                 name => \$name);
 125 ok($f5, "read newer gimp gradient")
 126   or print "# ",Imager->errstr,"\n";
 127 is($name, "imager test gradient", "check name read correctly");
 128 $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr');
 129 ok($f5, "check we handle case of no name reference correctly")
 130   or print "# ",Imager->errstr,"\n";
 131
 132 # test writing of gradients
 133 ok($f2->write(gimp=>'testout/t61grad1.ggr'), "save a gradient")
 134   or print "# ",Imager->errstr,"\n";
 135 undef $name;
 136 my $f6 = Imager::Fountain->read(gimp=>'testout/t61grad1.ggr',
 137                                 name=>\$name);
 138 ok($f6, "read what we wrote")
 139   or print "# ",Imager->errstr,"\n";
 140 ok(!defined $name, "we didn't set the name, so shouldn't get one");
 141
 142 # try with a name
 143 ok($f2->write(gimp=>'testout/t61grad2.ggr', name=>'test gradient'),
 144    "write gradient with a name")
 145   or print "# ",Imager->errstr,"\n";
 146 undef $name;
 147 my $f7 = Imager::Fountain->read(gimp=>'testout/t61grad2.ggr', name=>\$name);
 148 ok($f7, "read what we wrote")
 149   or print "# ",Imager->errstr,"\n";
 150 is($name, "test gradient", "check the name matches");
 151
 152 # we attempt to convert color names in segments to segments now
 153 {
 154   my @segs =
 155     (
 156      [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
 157     );
 158   my $im = Imager->new(xsize=>50, ysize=>50);
 159   ok($im->filter(type=>'fountain', segments => \@segs,
 160                  xa=>0, ya=>30, xb=>49, yb=>30),
 161      "fountain with color names instead of objects in segments");
 162   my $left = $im->getpixel('x'=>0, 'y'=>20);
 163   ok(color_close($left, Imager::Color->new(0,0,0)),
 164      "check black converted correctly");
 165   my $right = $im->getpixel('x'=>49, 'y'=>20);
 166   ok(color_close($right, Imager::Color->new(255,255,255)),
 167      "check white converted correctly");
 168
 169   # check that invalid color names are handled correctly
 170   my @segs2 =
 171     (
 172      [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
 173     );
 174   ok(!$im->filter(type=>'fountain', segments => \@segs2,
 175                   xa=>0, ya=>30, xb=>49, yb=>30),
 176      "fountain with invalid color name");
 177   cmp_ok($im->errstr, '=~', 'No color named', "check error message");
 178 }
 179
 180 {
 181   my $im = Imager->new(xsize=>100, ysize=>100);
 182   # build the gradient the hard way - linear from black to white,
 183   # then back again
 184   my @simple =
 185    (
 186      [   0, 0.25, 0.5, 'black', 'white', 0, 0 ],
 187      [ 0.5. 0.75, 1.0, 'white', 'black', 0, 0 ],
 188    );
 189   # across
 190   my $linear = $im->filter(type   => "fountain",
 191                            ftype  => 'linear',
 192                            repeat => 'sawtooth',
 193                            xa     => 0,
 194                            ya     => $im->getheight / 2,
 195                            xb     => $im->getwidth - 1,
 196                            yb     => $im->getheight / 2);
 197   ok($linear, "linear fountain sample");
 198   # around
 199   my $revolution = $im->filter(type   => "fountain",
 200                                ftype  => 'revolution',
 201                                xa     => $im->getwidth / 2,
 202                                ya     => $im->getheight / 2,
 203                                xb     => $im->getwidth / 2,
 204                                yb     => 0);
 205   ok($revolution, "revolution fountain sample");
 206   # out from the middle
 207   my $radial = $im->filter(type   => "fountain",
 208                            ftype  => 'radial',
 209                            xa     => $im->getwidth / 2,
 210                            ya     => $im->getheight / 2,
 211                            xb     => $im->getwidth / 2,
 212                            yb     => 0);
 213   ok($radial, "radial fountain sample");
 214 }
 215
 216 {
 217   # try a simple custom filter that uses the Perl image interface
 218   sub perl_filt {
 219     my %args = @_;
 220
 221     my $im = $args{imager};
 222
 223     my $channels = $args{channels};
 224     unless (@$channels) {
 225       $channels = [ reverse(0 .. $im->getchannels-1) ];
 226     }
 227     my @chans = @$channels;
 228     push @chans, 0 while @chans < 4;
 229
 230     for my $y (0 .. $im->getheight-1) {
 231       my $row = $im->getsamples(y => $y, channels => \@chans);
 232       $im->setscanline(y => $y, pixels => $row);
 233     }
 234   }
 235   Imager->register_filter(type => 'perl_test',
 236                           callsub => \&perl_filt,
 237                           defaults => { channels => [] },
 238                           callseq => [ qw/imager channels/ ]);
 239   test($imbase, { type => 'perl_test' }, 'testout/t61perl.ppm');
 240 }
 241
 242 sub test {
 243   my ($in, $params, $out) = @_;
 244
 245   my $copy = $in->copy;
 246   if (ok($copy->filter(%$params), $params->{type})) {
 247     ok($copy->write(file=>$out), "write $params->{type}")
 248       or print "# ",$copy->errstr,"\n";
 249   }
 250   else {
 251   SKIP:
 252     {
 253       skip("couldn't filter", 1);
 254     }
 255   }
 256   $copy;
 257 }
 258
 259 sub color_close {
 260   my ($c1, $c2) = @_;
 261
 262   my @c1 = $c1->rgba;
 263   my @c2 = $c2->rgba;
 264
 265   for my $i (0..2) {
 266     if (abs($c1[$i]-$c2[$i]) > 2) {
 267       return 0;
 268     }
 269   }
 270   return 1;
 271 }