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