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