t/t20fill.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 121;
   4
   5 use Imager ':handy';
   6 use Imager::Fill;
   7 use Imager::Color::Float;
   8 use Config;
   9
  10 Imager::init_log("testout/t20fill.log", 1);
  11
  12 my $blue = NC(0,0,255);
  13 my $red = NC(255, 0, 0);
  14 my $redf = Imager::Color::Float->new(1, 0, 0);
  15 my $bluef = Imager::Color::Float->new(0, 0, 1);
  16 my $rsolid = Imager::i_new_fill_solid($blue, 0);
  17 ok($rsolid, "building solid fill");
  18 my $raw1 = Imager::ImgRaw::new(100, 100, 3);
  19 # use the normal filled box
  20 Imager::i_box_filled($raw1, 0, 0, 99, 99, $blue);
  21 my $raw2 = Imager::ImgRaw::new(100, 100, 3);
  22 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid);
  23 ok(1, "drawing with solid fill");
  24 my $diff = Imager::i_img_diff($raw1, $raw2);
  25 ok($diff == 0, "solid fill doesn't match");
  26 Imager::i_box_filled($raw1, 0, 0, 99, 99, $red);
  27 my $rsolid2 = Imager::i_new_fill_solidf($redf, 0);
  28 ok($rsolid2, "creating float solid fill");
  29 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid2);
  30 $diff = Imager::i_img_diff($raw1, $raw2);
  31 ok($diff == 0, "float solid fill doesn't match");
  32
  33 # ok solid still works, let's try a hatch
  34 # hash1 is a 2x2 checkerboard
  35 my $rhatcha = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 0, 0);
  36 my $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 2, 0);
  37 ok($rhatcha && $rhatchb, "can't build hatched fill");
  38
  39 # the offset should make these match
  40 Imager::i_box_cfill($raw1, 0, 0, 99, 99, $rhatcha);
  41 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  42 ok(1, "filling with hatch");
  43 $diff = Imager::i_img_diff($raw1, $raw2);
  44 ok($diff == 0, "hatch images different");
  45 $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 4, 6);
  46 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  47 $diff = Imager::i_img_diff($raw1, $raw2);
  48 ok($diff == 0, "hatch images different");
  49
  50 # I guess I was tired when I originally did this - make sure it keeps
  51 # acting the way it's meant to
  52 # I had originally expected these to match with the red and blue swapped
  53 $rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 2, 2);
  54 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  55 $diff = Imager::i_img_diff($raw1, $raw2);
  56 ok($diff == 0, "hatch images different");
  57
  58 # this shouldn't match
  59 $rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 1, 1);
  60 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
  61 $diff = Imager::i_img_diff($raw1, $raw2);
  62 ok($diff, "hatch images the same!");
  63
  64 # custom hatch
  65 # the inverse of the 2x2 checkerboard
  66 my $hatch = pack("C8", 0x33, 0x33, 0xCC, 0xCC, 0x33, 0x33, 0xCC, 0xCC);
  67 my $rcustom = Imager::i_new_fill_hatch($blue, $red, 0, 0, $hatch, 0, 0);
  68 Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rcustom);
  69 $diff = Imager::i_img_diff($raw1, $raw2);
  70 ok(!$diff, "custom hatch mismatch");
  71
  72 {
  73   # basic test of floating color hatch fills
  74   # this will exercise the code that the gcc shipped with OS X 10.4
  75   # forgets to generate
  76   # the float version is called iff we're working with a non-8-bit image
  77   # i_new_fill_hatchf() makes the same object as i_new_fill_hatch() but
  78   # we test the other construction code path here
  79   my $fraw1 = Imager::i_img_double_new(100, 100, 3);
  80   my $fhatch1 = Imager::i_new_fill_hatchf($redf, $bluef, 0, 1, undef, 0, 0);
  81   ok($fraw1, "making double image 1");
  82   ok($fhatch1, "making float hatch 1");
  83   Imager::i_box_cfill($fraw1, 0, 0, 99, 99, $fhatch1);
  84   my $fraw2 = Imager::i_img_double_new(100, 100, 3);
  85   my $fhatch2 = Imager::i_new_fill_hatchf($bluef, $redf, 0, 1, undef, 0, 2);
  86   ok($fraw2, "making double image 2");
  87   ok($fhatch2, "making float hatch 2");
  88   Imager::i_box_cfill($fraw2, 0, 0, 99, 99, $fhatch2);
  89
  90   $diff = Imager::i_img_diff($fraw1, $fraw2);
  91   ok(!$diff, "float custom hatch mismatch");
  92   save($fraw1, "testout/t20hatchf1.ppm");
  93   save($fraw2, "testout/t20hatchf2.ppm");
  94 }
  95
  96 # test the oo interface
  97 my $im1 = Imager->new(xsize=>100, ysize=>100);
  98 my $im2 = Imager->new(xsize=>100, ysize=>100);
  99
 100 my $solid = Imager::Fill->new(solid=>'#FF0000');
 101 ok($solid, "creating oo solid fill");
 102 ok($solid->{fill}, "bad oo solid fill");
 103 $im1->box(fill=>$solid);
 104 $im2->box(filled=>1, color=>$red);
 105 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 106 ok(!$diff, "oo solid fill");
 107
 108 my $hatcha = Imager::Fill->new(hatch=>'check2x2');
 109 my $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2);
 110 $im1->box(fill=>$hatcha);
 111 $im2->box(fill=>$hatchb);
 112 # should be different
 113 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 114 ok($diff, "offset checks the same!");
 115 $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2, dy=>2);
 116 $im2->box(fill=>$hatchb);
 117 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 118 ok(!$diff, "offset into similar check should be the same");
 119
 120 # test dymanic build of fill
 121 $im2->box(fill=>{hatch=>'check2x2', dx=>2, fg=>NC(255,255,255),
 122                  bg=>NC(0,0,0)});
 123 $diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
 124 ok(!$diff, "offset and flipped should be the same");
 125
 126 # a simple demo
 127 my $im = Imager->new(xsize=>200, ysize=>200);
 128
 129 $im->box(xmin=>10, ymin=>10, xmax=>190, ymax=>190,
 130          fill=>{ hatch=>'check4x4',
 131                  fg=>NC(128, 0, 0),
 132                  bg=>NC(128, 64, 0) })
 133   or print "# ",$im->errstr,"\n";
 134 $im->arc(r=>80, d1=>45, d2=>75,
 135            fill=>{ hatch=>'stipple2',
 136                    combine=>1,
 137                    fg=>[ 0, 0, 0, 255 ],
 138                    bg=>{ rgba=>[255,255,255,160] } })
 139   or print "# ",$im->errstr,"\n";
 140 $im->arc(r=>80, d1=>75, d2=>135,
 141          fill=>{ fountain=>'radial', xa=>100, ya=>100, xb=>20, yb=>100 })
 142   or print "# ",$im->errstr,"\n";
 143 $im->write(file=>'testout/t20_sample.ppm');
 144
 145 # flood fill tests
 146 my $rffimg = Imager::ImgRaw::new(100, 100, 3);
 147 # build a H
 148 Imager::i_box_filled($rffimg, 10, 10, 20, 90, $blue);
 149 Imager::i_box_filled($rffimg, 80, 10, 90, 90, $blue);
 150 Imager::i_box_filled($rffimg, 20, 45, 80, 55, $blue);
 151 my $black = Imager::Color->new(0, 0, 0);
 152 Imager::i_flood_fill($rffimg, 15, 15, $red);
 153 my $rffcmp = Imager::ImgRaw::new(100, 100, 3);
 154 # build a H
 155 Imager::i_box_filled($rffcmp, 10, 10, 20, 90, $red);
 156 Imager::i_box_filled($rffcmp, 80, 10, 90, 90, $red);
 157 Imager::i_box_filled($rffcmp, 20, 45, 80, 55, $red);
 158 $diff = Imager::i_img_diff($rffimg, $rffcmp);
 159 ok(!$diff, "flood fill difference");
 160
 161 my $ffim = Imager->new(xsize=>100, ysize=>100);
 162 my $yellow = Imager::Color->new(255, 255, 0);
 163 $ffim->box(xmin=>10, ymin=>10, xmax=>20, ymax=>90, color=>$blue, filled=>1);
 164 $ffim->box(xmin=>20, ymin=>45, xmax=>80, ymax=>55, color=>$blue, filled=>1);
 165 $ffim->box(xmin=>80, ymin=>10, xmax=>90, ymax=>90, color=>$blue, filled=>1);
 166 ok($ffim->flood_fill('x'=>50, 'y'=>50, color=>$red), "flood fill");
 167 $diff = Imager::i_img_diff($rffcmp, $ffim->{IMG});
 168 ok(!$diff, "oo flood fill difference");
 169 $ffim->flood_fill('x'=>50, 'y'=>50,
 170                   fill=> {
 171                           hatch => 'check2x2',
 172                           fg => '0000FF',
 173                          });
 174 #                  fill=>{
 175 #                         fountain=>'radial',
 176 #                         xa=>50, ya=>50,
 177 #                         xb=>10, yb=>10,
 178 #                        });
 179 $ffim->write(file=>'testout/t20_ooflood.ppm');
 180
 181 my $copy = $ffim->copy;
 182 ok($ffim->flood_fill('x' => 50, 'y' => 50,
 183                      color => $red, border => '000000'),
 184    "border solid flood fill");
 185 is(Imager::i_img_diff($ffim->{IMG}, $rffcmp), 0, "compare");
 186 ok($ffim->flood_fill('x' => 50, 'y' => 50,
 187                      fill => { hatch => 'check2x2', fg => '0000FF', },
 188                      border => '000000'),
 189    "border cfill fill");
 190 is(Imager::i_img_diff($ffim->{IMG}, $copy->{IMG}), 0,
 191    "compare");
 192
 193 # test combining modes
 194 my $fill = NC(192, 128, 128, 128);
 195 my $target = NC(64, 32, 64);
 196 my $trans_target = NC(64, 32, 64, 128);
 197 my %comb_tests =
 198   (
 199    none=>
 200    {
 201     opaque => $fill,
 202     trans => $fill,
 203    },
 204    normal=>
 205    {
 206     opaque => NC(128, 80, 96),
 207     trans => NC(150, 96, 107, 191),
 208    },
 209    multiply =>
 210    {
 211     opaque => NC(56, 24, 48),
 212     trans => NC(101, 58, 74, 192),
 213    },
 214    dissolve =>
 215    {
 216     opaque => [ $target, NC(192, 128, 128, 255) ],
 217     trans => [ $trans_target, NC(192, 128, 128, 255) ],
 218    },
 219    add =>
 220    {
 221     opaque => NC(159, 96, 128),
 222     trans => NC(128, 80, 96, 255),
 223    },
 224    subtract =>
 225    {
 226     opaque => NC(0, 0, 0),
 227     trans => NC(0, 0, 0, 255),
 228    },
 229    diff =>
 230    {
 231     opaque => NC(96, 64, 64),
 232     trans => NC(127, 85, 85, 192),
 233    },
 234    lighten =>
 235    {
 236     opaque => NC(128, 80, 96),
 237     trans => NC(149, 95, 106, 192),
 238    },
 239    darken =>
 240    {
 241     opaque => $target,
 242     trans => NC(106, 63, 85, 192),
 243    },
 244    # the following results are based on the results of the tests and
 245    # are suspect for that reason (and were broken at one point <sigh>)
 246    # but trying to work them out manually just makes my head hurt - TC
 247    hue =>
 248    {
 249     opaque => NC(64, 32, 47),
 250     trans => NC(64, 32, 42, 128),
 251    },
 252    saturation =>
 253    {
 254     opaque => NC(63, 37, 64),
 255     trans => NC(64, 39, 64, 128),
 256    },
 257    value =>
 258    {
 259     opaque => NC(127, 64, 128),
 260     trans => NC(149, 75, 150, 128),
 261    },
 262    color =>
 263    {
 264     opaque => NC(64, 37, 52),
 265     trans => NC(64, 39, 50, 128),
 266    },
 267   );
 268
 269 for my $comb (Imager::Fill->combines) {
 270   my $test = $comb_tests{$comb};
 271   my $fillobj = Imager::Fill->new(solid=>$fill, combine=>$comb);
 272
 273   for my $bits (qw(8 double)) {
 274     {
 275       my $targim = Imager->new(xsize=>4, ysize=>4, bits => $bits);
 276       $targim->box(filled=>1, color=>$target);
 277       $targim->box(fill=>$fillobj);
 278       my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
 279       my $allowed = $test->{opaque};
 280       $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
 281       ok(scalar grep(color_close($_, $c), @$allowed),
 282          "opaque '$comb' $bits bits")
 283         or print "# got:",join(",", $c->rgba),"  allowed: ",
 284           join("|", map { join(",", $_->rgba) } @$allowed),"\n";
 285     }
 286
 287     {
 288       # make sure the alpha path in the combine function produces the same
 289       # or at least as sane a result as the non-alpha path
 290       my $targim = Imager->new(xsize=>4, ysize=>4, channels => 4, bits => $bits);
 291       $targim->box(filled=>1, color=>$target);
 292       $targim->box(fill=>$fillobj);
 293       my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
 294       my $allowed = $test->{opaque};
 295       $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
 296       ok(scalar grep(color_close4($_, $c), @$allowed),
 297          "opaque '$comb' 4-channel $bits bits")
 298         or print "# got:",join(",", $c->rgba),"  allowed: ",
 299           join("|", map { join(",", $_->rgba) } @$allowed),"\n";
 300     }
 301
 302     {
 303       my $transim = Imager->new(xsize => 4, ysize => 4, channels => 4, bits => $bits);
 304       $transim->box(filled=>1, color=>$trans_target);
 305       $transim->box(fill => $fillobj);
 306       my $c = $transim->getpixel(x => 1, 'y' => 1);
 307       my $allowed = $test->{trans};
 308       $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
 309       ok(scalar grep(color_close4($_, $c), @$allowed),
 310          "translucent '$comb' $bits bits")
 311         or print "# got:",join(",", $c->rgba),"  allowed: ",
 312           join("|", map { join(",", $_->rgba) } @$allowed),"\n";
 313     }
 314   }
 315 }
 316
 317 ok($ffim->arc(r=>45, color=>$blue, aa=>1), "aa circle");
 318 $ffim->write(file=>"testout/t20_aacircle.ppm");
 319
 320 # image based fills
 321 my $green = NC(0, 255, 0);
 322 my $fillim = Imager->new(xsize=>40, ysize=>40, channels=>4);
 323 $fillim->box(filled=>1, xmin=>5, ymin=>5, xmax=>35, ymax=>35,
 324              color=>NC(0, 0, 255, 128));
 325 $fillim->arc(filled=>1, r=>10, color=>$green, aa=>1);
 326 my $ooim = Imager->new(xsize=>150, ysize=>150);
 327 $ooim->box(filled=>1, color=>$green, xmin=>70, ymin=>25, xmax=>130, ymax=>125);
 328 $ooim->box(filled=>1, color=>$blue, xmin=>20, ymin=>25, xmax=>80, ymax=>125);
 329 $ooim->arc(r=>30, color=>$red, aa=>1);
 330
 331 my $oocopy = $ooim->copy();
 332 ok($oocopy->arc(fill=>{image=>$fillim,
 333                        combine=>'normal',
 334                        xoff=>5}, r=>40),
 335    "image based fill");
 336 $oocopy->write(file=>'testout/t20_image.ppm');
 337
 338 # a more complex version
 339 use Imager::Matrix2d ':handy';
 340 $oocopy = $ooim->copy;
 341 ok($oocopy->arc(fill=>{
 342                        image=>$fillim,
 343                        combine=>'normal',
 344                        matrix=>m2d_rotate(degrees=>30),
 345                        xoff=>5
 346                        }, r=>40),
 347    "transformed image based fill");
 348 $oocopy->write(file=>'testout/t20_image_xform.ppm');
 349
 350 ok(!$oocopy->arc(fill=>{ hatch=>"not really a hatch" }, r=>20),
 351    "error handling of automatic fill conversion");
 352 ok($oocopy->errstr =~ /Unknown hatch type/,
 353    "error message for automatic fill conversion");
 354
 355 # previous box fills to float images, or using the fountain fill
 356 # got into a loop here
 357
 358 SKIP:
 359 {
 360   skip("can't test without alarm()", 1) unless $Config{d_alarm};
 361   local $SIG{ALRM} = sub { die; };
 362
 363   eval {
 364     alarm(2);
 365     ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
 366                   fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80,
 367                           yb=>20 }), "linear box fill");
 368     alarm 0;
 369   };
 370   $@ and ok(0, "linear box fill $@");
 371 }
 372
 373 # test that passing in a non-array ref returns an error
 374 {
 375   my $fill = Imager::Fill->new(fountain=>'linear',
 376                                xa => 20, ya=>20, xb=>20, yb=>40,
 377                                segments=>"invalid");
 378   ok(!$fill, "passing invalid segments produces an error");
 379   cmp_ok(Imager->errstr, '=~', 'array reference',
 380          "check the error message");
 381 }
 382
 383 # test that colors in segments are converted
 384 {
 385   my @segs =
 386     (
 387      [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
 388     );
 389   my $fill = Imager::Fill->new(fountain=>'linear',
 390                                xa => 0, ya=>20, xb=>49, yb=>20,
 391                                segments=>\@segs);
 392   ok($fill, "check that color names are converted")
 393     or print "# ",Imager->errstr,"\n";
 394   my $im = Imager->new(xsize=>50, ysize=>50);
 395   $im->box(fill=>$fill);
 396   my $left = $im->getpixel('x'=>0, 'y'=>20);
 397   ok(color_close($left, Imager::Color->new(0,0,0)),
 398      "check black converted correctly");
 399   my $right = $im->getpixel('x'=>49, 'y'=>20);
 400   ok(color_close($right, Imager::Color->new(255,255,255)),
 401      "check white converted correctly");
 402
 403   # check that invalid colors handled correctly
 404
 405   my @segs2 =
 406     (
 407      [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
 408     );
 409   my $fill2 = Imager::Fill->new(fountain=>'linear',
 410                                xa => 0, ya=>20, xb=>49, yb=>20,
 411                                segments=>\@segs2);
 412   ok(!$fill2, "check handling of invalid color names");
 413   cmp_ok(Imager->errstr, '=~', 'No color named', "check error message");
 414 }
 415
 416 sub color_close {
 417   my ($c1, $c2) = @_;
 418
 419   my @c1 = $c1->rgba;
 420   my @c2 = $c2->rgba;
 421
 422   for my $i (0..2) {
 423     if (abs($c1[$i]-$c2[$i]) > 2) {
 424       return 0;
 425     }
 426   }
 427   return 1;
 428 }
 429
 430 sub color_close4 {
 431   my ($c1, $c2) = @_;
 432
 433   my @c1 = $c1->rgba;
 434   my @c2 = $c2->rgba;
 435
 436   for my $i (0..3) {
 437     if (abs($c1[$i]-$c2[$i]) > 2) {
 438       return 0;
 439     }
 440   }
 441   return 1;
 442 }
 443
 444 # for use during testing
 445 sub save {
 446   my ($im, $name) = @_;
 447
 448   open FH, "> $name" or die "Cannot create $name: $!";
 449   binmode FH;
 450   my $io = Imager::io_new_fd(fileno(FH));
 451   Imager::i_writeppm_wiol($im, $io) or die "Cannot save to $name";
 452   undef $io;
 453   close FH;
 454 }