Leolo's guassian2 patch
[imager.git] / t / 400-filter / 010-filters.t
CommitLineData
d08b8f85
TC
1#!perl -w
2use strict;
3use Imager qw(:handy);
3d3b6bed 4use Test::More tests => 136;
40e78f96
TC
5
6-d "testout" or mkdir "testout";
7
f1ac5027 8Imager::init_log("testout/t61filters.log", 1);
5558f899 9use Imager::Test qw(is_image_similar test_image is_image is_color4 is_fcolor4);
d08b8f85 10# meant for testing the filters themselves
01b84320
TC
11
12my $imbase = test_image();
13
d08b8f85
TC
14my $im_other = Imager->new(xsize=>150, ysize=>150);
15$im_other->box(xmin=>30, ymin=>60, xmax=>120, ymax=>90, filled=>1);
16
8c3ff7d9 17test($imbase, {type=>'autolevels'}, 'testout/t61_autolev.ppm');
d08b8f85 18
ac00f58d
TC
19test($imbase, {type=>'autolevels_skew'}, 'testout/t61_autoskew.ppm');
20
8c3ff7d9 21test($imbase, {type=>'contrast', intensity=>0.5},
d08b8f85
TC
22 'testout/t61_contrast.ppm');
23
24# this one's kind of cool
6a3cbaef
TC
25test($imbase, {type=>'conv', coef=>[ 0.3, 1, 0.3, ], },
26 'testout/t61_conv_blur.ppm');
27
1e0418f1
TC
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
6a3cbaef
TC
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}
d08b8f85 59
73962964
TC
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');
bd8052a6 67 is_image_similar($gauss, $gauss16, 250000, "8 and 16 gaussian match");
73962964
TC
68}
69
3d3b6bed
TC
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
d08b8f85 98
8c3ff7d9 99test($imbase, { type=>'gradgen', dist=>1,
d08b8f85
TC
100 xo=>[ 10, 10, 120 ],
101 yo=>[ 10, 140, 60 ],
102 colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
103 'testout/t61_gradgen.ppm');
104
8c3ff7d9 105test($imbase, {type=>'mosaic', size=>8}, 'testout/t61_mosaic.ppm');
d08b8f85 106
8c3ff7d9 107test($imbase, {type=>'hardinvert'}, 'testout/t61_hardinvert.ppm');
d08b8f85 108
5558f899
TC
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
8c3ff7d9 139test($imbase, {type=>'noise'}, 'testout/t61_noise.ppm');
d08b8f85 140
8c3ff7d9 141test($imbase, {type=>'radnoise'}, 'testout/t61_radnoise.ppm');
d08b8f85 142
8c3ff7d9 143test($imbase, {type=>'turbnoise'}, 'testout/t61_turbnoise.ppm');
d08b8f85 144
8c3ff7d9 145test($imbase, {type=>'bumpmap', bump=>$im_other, lightx=>30, lighty=>30},
d08b8f85
TC
146 'testout/t61_bumpmap.ppm');
147
8c3ff7d9 148test($imbase, {type=>'bumpmap_complex', bump=>$im_other}, 'testout/t61_bumpmap_complex.ppm');
d08b8f85 149
8c3ff7d9 150test($imbase, {type=>'postlevels', levels=>3}, 'testout/t61_postlevels.ppm');
b2778574 151
8c3ff7d9 152test($imbase, {type=>'watermark', wmark=>$im_other },
d08b8f85
TC
153 'testout/t61_watermark.ppm');
154
8c3ff7d9
TC
155test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>85, yb=>30,
156 repeat=>'triangle', #ftype=>'radial',
157 super_sample=>'circle', ssample_param => 16,
158 },
6607600c
TC
159 'testout/t61_fountain.ppm');
160use Imager::Fountain;
161
162my $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));
8c3ff7d9
TC
165test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
166 #repeat=>'triangle',
167 segments=>$f1
168 },
6607600c
TC
169 'testout/t61_fountain2.ppm');
170my $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);
8c3ff7d9 175test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
6607600c
TC
176 segments=>$f2 },
177 'testout/t61_fount_hsv.ppm');
8c3ff7d9
TC
178my $f3 = Imager::Fountain->read(gimp=>'testimg/gimpgrad');
179ok($f3, "read gimpgrad");
180test($imbase, { type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
6607600c 181 segments=>$f3, super_sample=>'grid',
efdc2568 182 ftype=>'radial_square', combine=>'color' },
6607600c 183 'testout/t61_fount_gimp.ppm');
0ae3d953
TC
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}
199SKIP:
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
5664d5c8 209 my $f = Imager::Fountain->read(gimp => "t/400-filter/010-filters.t");
0ae3d953 210 ok(!$f, "fail to read non-gradient");
5664d5c8 211 is(Imager->errstr, "t/400-filter/010-filters.t is not a GIMP gradient file",
0ae3d953
TC
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}
8c3ff7d9 226test($imbase, { type=>'unsharpmask', stddev=>2.0 },
b6381851 227 'testout/t61_unsharp.ppm');
8c3ff7d9 228test($imbase, {type=>'conv', coef=>[ -1, 3, -1, ], },
0958329a
TC
229 'testout/t61_conv_sharp.ppm');
230
9cef8440
TC
231test($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
4c033fd4
TC
237# Regression test: the checking of the segment type was incorrect
238# (the comparison was checking the wrong variable against the wrong value)
239my $f4 = [ [ 0, 0.5, 1, NC(0,0,0), NC(255,255,255), 5, 0 ] ];
8c3ff7d9
TC
240test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
241 segments=>$f4, super_sample=>'grid',
242 ftype=>'linear', combine=>'color' },
4c033fd4 243 'testout/t61_regress_fount.ppm');
dff75dee
TC
244my $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');
247my $im3 = Imager->new(xsize=>150, ysize=>150, channels=>3);
248$im3->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
249my $diff = $imbase->difference(other=>$im2);
8c3ff7d9
TC
250ok($diff, "got difference image");
251SKIP:
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");
dff75dee 257}
6607600c 258
817ba871
TC
259# newer versions of gimp add a line to the gradient file
260my $name;
261my $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr',
262 name => \$name);
263ok($f5, "read newer gimp gradient")
264 or print "# ",Imager->errstr,"\n";
265is($name, "imager test gradient", "check name read correctly");
266$f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr');
267ok($f5, "check we handle case of no name reference correctly")
268 or print "# ",Imager->errstr,"\n";
269
270# test writing of gradients
271ok($f2->write(gimp=>'testout/t61grad1.ggr'), "save a gradient")
272 or print "# ",Imager->errstr,"\n";
273undef $name;
274my $f6 = Imager::Fountain->read(gimp=>'testout/t61grad1.ggr',
275 name=>\$name);
276ok($f6, "read what we wrote")
277 or print "# ",Imager->errstr,"\n";
278ok(!defined $name, "we didn't set the name, so shouldn't get one");
279
280# try with a name
281ok($f2->write(gimp=>'testout/t61grad2.ggr', name=>'test gradient'),
282 "write gradient with a name")
283 or print "# ",Imager->errstr,"\n";
284undef $name;
285my $f7 = Imager::Fountain->read(gimp=>'testout/t61grad2.ggr', name=>\$name);
286ok($f7, "read what we wrote")
287 or print "# ",Imager->errstr,"\n";
288is($name, "test gradient", "check the name matches");
289
109bec2d
TC
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
0ae3d953
TC
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
b692658a
TC
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
7327d4b0
TC
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
01b84320
TC
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);
01b84320
TC
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
435{
436 # and again with large samples
437 my $im1 = Imager->new(xsize => 3, ysize => 2, bits => 'double');
438 $im1->box(filled => 1, color => '#FF0000');
439 my $im2 = $im1->copy;
440 $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
441 $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
442 $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
443 $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
444
445 my $diff1 = $im1->difference(other => $im2);
446 my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
447 $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
448 $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
449 is_image($diff1, $cmp1, "difference() - check image with mindist 0 - large samples");
450
451 my $diff2 = $im1->difference(other => $im2, mindist => 1.1);
01b84320
TC
452 my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
453 $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
454 is_image($diff2, $cmp2, "difference() - check image with mindist 1.1 - large samples");
455}
456
1136f089
TC
457{
458 my $empty = Imager->new;
459 ok(!$empty->filter(type => "hardinvert"), "can't filter an empty image");
460 is($empty->errstr, "filter: empty input image",
461 "check error message");
462 ok(!$empty->difference(other => $imbase), "can't difference empty image");
463 is($empty->errstr, "difference: empty input image",
464 "check error message");
465 ok(!$imbase->difference(other => $empty),
466 "can't difference against empty image");
467 is($imbase->errstr, "difference: empty input image (other image)",
468 "check error message");
469}
470
d08b8f85 471sub test {
8c3ff7d9 472 my ($in, $params, $out) = @_;
b2778574 473
d08b8f85 474 my $copy = $in->copy;
8c3ff7d9
TC
475 if (ok($copy->filter(%$params), $params->{type})) {
476 ok($copy->write(file=>$out), "write $params->{type}")
477 or print "# ",$copy->errstr,"\n";
d08b8f85
TC
478 }
479 else {
6a3cbaef 480 diag($copy->errstr);
8c3ff7d9
TC
481 SKIP:
482 {
483 skip("couldn't filter", 1);
484 }
d08b8f85 485 }
73962964 486 $copy;
d08b8f85 487}
109bec2d
TC
488
489sub color_close {
490 my ($c1, $c2) = @_;
491
492 my @c1 = $c1->rgba;
493 my @c2 = $c2->rgba;
494
495 for my $i (0..2) {
496 if (abs($c1[$i]-$c2[$i]) > 2) {
497 return 0;
498 }
499 }
500 return 1;
501}