t/t61filters.t

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