[imager.git] / t / t20fill.t

#!perl -w
use strict;
use Test::More tests => 121;

use Imager ':handy';
use Imager::Fill;
use Imager::Color::Float;
use Config;

Imager::init_log("testout/t20fill.log", 1);

my $blue = NC(0,0,255);
my $red = NC(255, 0, 0);
my $redf = Imager::Color::Float->new(1, 0, 0);
my $bluef = Imager::Color::Float->new(0, 0, 1);
my $rsolid = Imager::i_new_fill_solid($blue, 0);
ok($rsolid, "building solid fill");
my $raw1 = Imager::ImgRaw::new(100, 100, 3);
# use the normal filled box
Imager::i_box_filled($raw1, 0, 0, 99, 99, $blue);
my $raw2 = Imager::ImgRaw::new(100, 100, 3);
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid);
ok(1, "drawing with solid fill");
my $diff = Imager::i_img_diff($raw1, $raw2);
ok($diff == 0, "solid fill doesn't match");
Imager::i_box_filled($raw1, 0, 0, 99, 99, $red);
my $rsolid2 = Imager::i_new_fill_solidf($redf, 0);
ok($rsolid2, "creating float solid fill");
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid2);
$diff = Imager::i_img_diff($raw1, $raw2);
ok($diff == 0, "float solid fill doesn't match");

# ok solid still works, let's try a hatch
# hash1 is a 2x2 checkerboard
my $rhatcha = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 0, 0);
my $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 2, 0);
ok($rhatcha && $rhatchb, "can't build hatched fill");

# the offset should make these match
Imager::i_box_cfill($raw1, 0, 0, 99, 99, $rhatcha);
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
ok(1, "filling with hatch");
$diff = Imager::i_img_diff($raw1, $raw2);
ok($diff == 0, "hatch images different");
$rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 4, 6);
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
$diff = Imager::i_img_diff($raw1, $raw2);
ok($diff == 0, "hatch images different");

# I guess I was tired when I originally did this - make sure it keeps
# acting the way it's meant to
# I had originally expected these to match with the red and blue swapped
$rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 2, 2);
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
$diff = Imager::i_img_diff($raw1, $raw2);
ok($diff == 0, "hatch images different");

# this shouldn't match
$rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 1, 1);
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
$diff = Imager::i_img_diff($raw1, $raw2);
ok($diff, "hatch images the same!");

# custom hatch
# the inverse of the 2x2 checkerboard
my $hatch = pack("C8", 0x33, 0x33, 0xCC, 0xCC, 0x33, 0x33, 0xCC, 0xCC);
my $rcustom = Imager::i_new_fill_hatch($blue, $red, 0, 0, $hatch, 0, 0);
Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rcustom);
$diff = Imager::i_img_diff($raw1, $raw2);
ok(!$diff, "custom hatch mismatch");

{
  # basic test of floating color hatch fills
  # this will exercise the code that the gcc shipped with OS X 10.4
  # forgets to generate
  # the float version is called iff we're working with a non-8-bit image
  # i_new_fill_hatchf() makes the same object as i_new_fill_hatch() but
  # we test the other construction code path here
  my $fraw1 = Imager::i_img_double_new(100, 100, 3);
  my $fhatch1 = Imager::i_new_fill_hatchf($redf, $bluef, 0, 1, undef, 0, 0);
  ok($fraw1, "making double image 1");
  ok($fhatch1, "making float hatch 1");
  Imager::i_box_cfill($fraw1, 0, 0, 99, 99, $fhatch1);
  my $fraw2 = Imager::i_img_double_new(100, 100, 3);
  my $fhatch2 = Imager::i_new_fill_hatchf($bluef, $redf, 0, 1, undef, 0, 2);
  ok($fraw2, "making double image 2");
  ok($fhatch2, "making float hatch 2");
  Imager::i_box_cfill($fraw2, 0, 0, 99, 99, $fhatch2);

  $diff = Imager::i_img_diff($fraw1, $fraw2);
  ok(!$diff, "float custom hatch mismatch");
  save($fraw1, "testout/t20hatchf1.ppm");
  save($fraw2, "testout/t20hatchf2.ppm");
}

# test the oo interface
my $im1 = Imager->new(xsize=>100, ysize=>100);
my $im2 = Imager->new(xsize=>100, ysize=>100);

my $solid = Imager::Fill->new(solid=>'#FF0000');
ok($solid, "creating oo solid fill");
ok($solid->{fill}, "bad oo solid fill");
$im1->box(fill=>$solid);
$im2->box(filled=>1, color=>$red);
$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
ok(!$diff, "oo solid fill");

my $hatcha = Imager::Fill->new(hatch=>'check2x2');
my $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2);
$im1->box(fill=>$hatcha);
$im2->box(fill=>$hatchb);
# should be different
$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
ok($diff, "offset checks the same!");
$hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2, dy=>2);
$im2->box(fill=>$hatchb);
$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
ok(!$diff, "offset into similar check should be the same");

# test dymanic build of fill
$im2->box(fill=>{hatch=>'check2x2', dx=>2, fg=>NC(255,255,255), 
                 bg=>NC(0,0,0)});
$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
ok(!$diff, "offset and flipped should be the same");

# a simple demo
my $im = Imager->new(xsize=>200, ysize=>200);

$im->box(xmin=>10, ymin=>10, xmax=>190, ymax=>190,
         fill=>{ hatch=>'check4x4',
                 fg=>NC(128, 0, 0),
                 bg=>NC(128, 64, 0) })
  or print "# ",$im->errstr,"\n";
$im->arc(r=>80, d1=>45, d2=>75, 
           fill=>{ hatch=>'stipple2',
                   combine=>1,
                   fg=>[ 0, 0, 0, 255 ],
                   bg=>{ rgba=>[255,255,255,160] } })
  or print "# ",$im->errstr,"\n";
$im->arc(r=>80, d1=>75, d2=>135,
         fill=>{ fountain=>'radial', xa=>100, ya=>100, xb=>20, yb=>100 })
  or print "# ",$im->errstr,"\n";
$im->write(file=>'testout/t20_sample.ppm');

# flood fill tests
my $rffimg = Imager::ImgRaw::new(100, 100, 3);
# build a H 
Imager::i_box_filled($rffimg, 10, 10, 20, 90, $blue);
Imager::i_box_filled($rffimg, 80, 10, 90, 90, $blue);
Imager::i_box_filled($rffimg, 20, 45, 80, 55, $blue);
my $black = Imager::Color->new(0, 0, 0);
Imager::i_flood_fill($rffimg, 15, 15, $red);
my $rffcmp = Imager::ImgRaw::new(100, 100, 3);
# build a H 
Imager::i_box_filled($rffcmp, 10, 10, 20, 90, $red);
Imager::i_box_filled($rffcmp, 80, 10, 90, 90, $red);
Imager::i_box_filled($rffcmp, 20, 45, 80, 55, $red);
$diff = Imager::i_img_diff($rffimg, $rffcmp);
ok(!$diff, "flood fill difference");

my $ffim = Imager->new(xsize=>100, ysize=>100);
my $yellow = Imager::Color->new(255, 255, 0);
$ffim->box(xmin=>10, ymin=>10, xmax=>20, ymax=>90, color=>$blue, filled=>1);
$ffim->box(xmin=>20, ymin=>45, xmax=>80, ymax=>55, color=>$blue, filled=>1);
$ffim->box(xmin=>80, ymin=>10, xmax=>90, ymax=>90, color=>$blue, filled=>1);
ok($ffim->flood_fill('x'=>50, 'y'=>50, color=>$red), "flood fill");
$diff = Imager::i_img_diff($rffcmp, $ffim->{IMG});
ok(!$diff, "oo flood fill difference");
$ffim->flood_fill('x'=>50, 'y'=>50,
                  fill=> {
                          hatch => 'check2x2',
			  fg => '0000FF',
                         });
#                  fill=>{
#                         fountain=>'radial',
#                         xa=>50, ya=>50,
#                         xb=>10, yb=>10,
#                        });
$ffim->write(file=>'testout/t20_ooflood.ppm');

my $copy = $ffim->copy;
ok($ffim->flood_fill('x' => 50, 'y' => 50,
		     color => $red, border => '000000'),
   "border solid flood fill");
is(Imager::i_img_diff($ffim->{IMG}, $rffcmp), 0, "compare");
ok($ffim->flood_fill('x' => 50, 'y' => 50,
		     fill => { hatch => 'check2x2', fg => '0000FF', },
		     border => '000000'),
   "border cfill fill");
is(Imager::i_img_diff($ffim->{IMG}, $copy->{IMG}), 0,
   "compare");

# test combining modes
my $fill = NC(192, 128, 128, 128);
my $target = NC(64, 32, 64);
my $trans_target = NC(64, 32, 64, 128);
my %comb_tests =
  (
   none=>
   { 
    opaque => $fill,
    trans => $fill,
   },
   normal=>
   { 
    opaque => NC(128, 80, 96),
    trans => NC(150, 96, 107, 191),
   },
   multiply => 
   { 
    opaque => NC(56, 24, 48),
    trans => NC(101, 58, 74, 192),
   },
   dissolve => 
   { 
    opaque => [ $target, NC(192, 128, 128, 255) ],
    trans => [ $trans_target, NC(192, 128, 128, 255) ],
   },
   add => 
   { 
    opaque => NC(159, 96, 128),
    trans => NC(128, 80, 96, 255),
   },
   subtract => 
   { 
    opaque => NC(0, 0, 0),
    trans => NC(0, 0, 0, 255),
   },
   diff => 
   { 
    opaque => NC(96, 64, 64),
    trans => NC(127, 85, 85, 192),
   },
   lighten => 
   { 
    opaque => NC(128, 80, 96), 
    trans => NC(149, 95, 106, 192), 
   },
   darken => 
   { 
    opaque => $target,
    trans => NC(106, 63, 85, 192),
   },
   # the following results are based on the results of the tests and
   # are suspect for that reason (and were broken at one point <sigh>)
   # but trying to work them out manually just makes my head hurt - TC
   hue => 
   { 
    opaque => NC(64, 32, 47),
    trans => NC(64, 32, 42, 128),
   },
   saturation => 
   { 
    opaque => NC(63, 37, 64),
    trans => NC(64, 39, 64, 128),
   },
   value => 
   { 
    opaque => NC(127, 64, 128),
    trans => NC(149, 75, 150, 128),
   },
   color => 
   { 
    opaque => NC(64, 37, 52),
    trans => NC(64, 39, 50, 128),
   },
  );

for my $comb (Imager::Fill->combines) {
  my $test = $comb_tests{$comb};
  my $fillobj = Imager::Fill->new(solid=>$fill, combine=>$comb);

  for my $bits (qw(8 double)) {
    {
      my $targim = Imager->new(xsize=>4, ysize=>4, bits => $bits);
      $targim->box(filled=>1, color=>$target);
      $targim->box(fill=>$fillobj);
      my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
      my $allowed = $test->{opaque};
      $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
      ok(scalar grep(color_close($_, $c), @$allowed), 
	 "opaque '$comb' $bits bits")
	or print "# got:",join(",", $c->rgba),"  allowed: ", 
	  join("|", map { join(",", $_->rgba) } @$allowed),"\n";
    }
    
    {
      # make sure the alpha path in the combine function produces the same
      # or at least as sane a result as the non-alpha path
      my $targim = Imager->new(xsize=>4, ysize=>4, channels => 4, bits => $bits);
      $targim->box(filled=>1, color=>$target);
      $targim->box(fill=>$fillobj);
      my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
      my $allowed = $test->{opaque};
      $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
      ok(scalar grep(color_close4($_, $c), @$allowed), 
	 "opaque '$comb' 4-channel $bits bits")
	or print "# got:",join(",", $c->rgba),"  allowed: ", 
	  join("|", map { join(",", $_->rgba) } @$allowed),"\n";
    }
    
    {
      my $transim = Imager->new(xsize => 4, ysize => 4, channels => 4, bits => $bits);
      $transim->box(filled=>1, color=>$trans_target);
      $transim->box(fill => $fillobj);
      my $c = $transim->getpixel(x => 1, 'y' => 1);
      my $allowed = $test->{trans};
      $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
      ok(scalar grep(color_close4($_, $c), @$allowed), 
	 "translucent '$comb' $bits bits")
	or print "# got:",join(",", $c->rgba),"  allowed: ", 
	  join("|", map { join(",", $_->rgba) } @$allowed),"\n";
    }
  }
}

ok($ffim->arc(r=>45, color=>$blue, aa=>1), "aa circle");
$ffim->write(file=>"testout/t20_aacircle.ppm");

# image based fills
my $green = NC(0, 255, 0);
my $fillim = Imager->new(xsize=>40, ysize=>40, channels=>4);
$fillim->box(filled=>1, xmin=>5, ymin=>5, xmax=>35, ymax=>35, 
             color=>NC(0, 0, 255, 128));
$fillim->arc(filled=>1, r=>10, color=>$green, aa=>1);
my $ooim = Imager->new(xsize=>150, ysize=>150);
$ooim->box(filled=>1, color=>$green, xmin=>70, ymin=>25, xmax=>130, ymax=>125);
$ooim->box(filled=>1, color=>$blue, xmin=>20, ymin=>25, xmax=>80, ymax=>125);
$ooim->arc(r=>30, color=>$red, aa=>1);

my $oocopy = $ooim->copy();
ok($oocopy->arc(fill=>{image=>$fillim, 
                       combine=>'normal',
                       xoff=>5}, r=>40),
   "image based fill");
$oocopy->write(file=>'testout/t20_image.ppm');

# a more complex version
use Imager::Matrix2d ':handy';
$oocopy = $ooim->copy;
ok($oocopy->arc(fill=>{
                       image=>$fillim,
                       combine=>'normal',
                       matrix=>m2d_rotate(degrees=>30),
                       xoff=>5
                       }, r=>40),
   "transformed image based fill");
$oocopy->write(file=>'testout/t20_image_xform.ppm');

ok(!$oocopy->arc(fill=>{ hatch=>"not really a hatch" }, r=>20),
   "error handling of automatic fill conversion");
ok($oocopy->errstr =~ /Unknown hatch type/,
   "error message for automatic fill conversion");

# previous box fills to float images, or using the fountain fill
# got into a loop here

SKIP:
{
  skip("can't test without alarm()", 1) unless $Config{d_alarm};
  local $SIG{ALRM} = sub { die; };

  eval {
    alarm(2);
    ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
                  fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80, 
                          yb=>20 }), "linear box fill");
    alarm 0;
  };
  $@ and ok(0, "linear box fill $@");
}

# test that passing in a non-array ref returns an error
{
  my $fill = Imager::Fill->new(fountain=>'linear',
                               xa => 20, ya=>20, xb=>20, yb=>40,
                               segments=>"invalid");
  ok(!$fill, "passing invalid segments produces an error");
  cmp_ok(Imager->errstr, '=~', 'array reference',
         "check the error message");
}

# test that colors in segments are converted
{
  my @segs =
    (
     [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
    );
  my $fill = Imager::Fill->new(fountain=>'linear',
                               xa => 0, ya=>20, xb=>49, yb=>20,
                               segments=>\@segs);
  ok($fill, "check that color names are converted")
    or print "# ",Imager->errstr,"\n";
  my $im = Imager->new(xsize=>50, ysize=>50);
  $im->box(fill=>$fill);
  my $left = $im->getpixel('x'=>0, 'y'=>20);
  ok(color_close($left, Imager::Color->new(0,0,0)),
     "check black converted correctly");
  my $right = $im->getpixel('x'=>49, 'y'=>20);
  ok(color_close($right, Imager::Color->new(255,255,255)),
     "check white converted correctly");

  # check that invalid colors handled correctly
  
  my @segs2 =
    (
     [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
    );
  my $fill2 = Imager::Fill->new(fountain=>'linear',
                               xa => 0, ya=>20, xb=>49, yb=>20,
                               segments=>\@segs2);
  ok(!$fill2, "check handling of invalid color names");
  cmp_ok(Imager->errstr, '=~', 'No color named', "check error message");
}

sub color_close {
  my ($c1, $c2) = @_;

  my @c1 = $c1->rgba;
  my @c2 = $c2->rgba;

  for my $i (0..2) {
    if (abs($c1[$i]-$c2[$i]) > 2) {
      return 0;
    }
  }
  return 1;
}

sub color_close4 {
  my ($c1, $c2) = @_;

  my @c1 = $c1->rgba;
  my @c2 = $c2->rgba;

  for my $i (0..3) {
    if (abs($c1[$i]-$c2[$i]) > 2) {
      return 0;
    }
  }
  return 1;
}

# for use during testing
sub save {
  my ($im, $name) = @_;

  open FH, "> $name" or die "Cannot create $name: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  Imager::i_writeppm_wiol($im, $io) or die "Cannot save to $name";
  undef $io;
  close FH;
}
Commit	Line	Data
f1ac5027 TC	1	#!perl -w
f1ac5027 TC	2	use strict;
9b1ec2b8	3	use Test::More tests => 121;
efdc2568	4
f1ac5027 TC	5	use Imager ':handy';
	6	use Imager::Fill;
	7	use Imager::Color::Float;
f3b59de8	8	use Config;
f1ac5027	9
efdc2568	10	Imager::init_log("testout/t20fill.log", 1);
f1ac5027 TC	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);
e2d5ca90	15	my $bluef = Imager::Color::Float->new(0, 0, 1);
f1ac5027	16	my $rsolid = Imager::i_new_fill_solid($blue, 0);
109bec2d	17	ok($rsolid, "building solid fill");
f1ac5027 TC	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);
109bec2d	23	ok(1, "drawing with solid fill");
f1ac5027	24	my $diff = Imager::i_img_diff($raw1, $raw2);
109bec2d	25	ok($diff == 0, "solid fill doesn't match");
f1ac5027 TC	26	Imager::i_box_filled($raw1, 0, 0, 99, 99, $red);
f1ac5027 TC	27	my $rsolid2 = Imager::i_new_fill_solidf($redf, 0);
109bec2d	28	ok($rsolid2, "creating float solid fill");
f1ac5027 TC	29	Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid2);
f1ac5027 TC	30	$diff = Imager::i_img_diff($raw1, $raw2);
109bec2d	31	ok($diff == 0, "float solid fill doesn't match");
f1ac5027 TC	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);
109bec2d	37	ok($rhatcha && $rhatchb, "can't build hatched fill");
f1ac5027 TC	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);
109bec2d	42	ok(1, "filling with hatch");
f1ac5027	43	$diff = Imager::i_img_diff($raw1, $raw2);
109bec2d	44	ok($diff == 0, "hatch images different");
f1ac5027 TC	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);
109bec2d	48	ok($diff == 0, "hatch images different");
f1ac5027 TC	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);
109bec2d	56	ok($diff == 0, "hatch images different");
f1ac5027 TC	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);
109bec2d	62	ok($diff, "hatch images the same!");
f1ac5027 TC	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);
109bec2d	70	ok(!$diff, "custom hatch mismatch");
f1ac5027	71
e2d5ca90 TC	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
f1ac5027 TC	96	# test the oo interface
	97	my $im1 = Imager->new(xsize=>100, ysize=>100);
	98	my $im2 = Imager->new(xsize=>100, ysize=>100);
	99
efdc2568	100	my $solid = Imager::Fill->new(solid=>'#FF0000');
109bec2d TC	101	ok($solid, "creating oo solid fill");
109bec2d TC	102	ok($solid->{fill}, "bad oo solid fill");
f1ac5027 TC	103	$im1->box(fill=>$solid);
	104	$im2->box(filled=>1, color=>$red);
	105	$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
109bec2d	106	ok(!$diff, "oo solid fill");
f1ac5027 TC	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});
109bec2d	114	ok($diff, "offset checks the same!");
f1ac5027 TC	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});
109bec2d	118	ok(!$diff, "offset into similar check should be the same");
f1ac5027 TC	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});
109bec2d	124	ok(!$diff, "offset and flipped should be the same");
f1ac5027 TC	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),
569795e8 TC	132	bg=>NC(128, 64, 0) })
569795e8 TC	133	or print "# ",$im->errstr,"\n";
f1ac5027 TC	134	$im->arc(r=>80, d1=>45, d2=>75,
	135	fill=>{ hatch=>'stipple2',
	136	combine=>1,
efdc2568	137	fg=>[ 0, 0, 0, 255 ],
569795e8 TC	138	bg=>{ rgba=>[255,255,255,160] } })
569795e8 TC	139	or print "# ",$im->errstr,"\n";
f1ac5027	140	$im->arc(r=>80, d1=>75, d2=>135,
569795e8 TC	141	fill=>{ fountain=>'radial', xa=>100, ya=>100, xb=>20, yb=>100 })
569795e8 TC	142	or print "# ",$im->errstr,"\n";
f1ac5027 TC	143	$im->write(file=>'testout/t20_sample.ppm');
f1ac5027 TC	144
cc6483e0 TC	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);
109bec2d	159	ok(!$diff, "flood fill difference");
cc6483e0 TC	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);
109bec2d	166	ok($ffim->flood_fill('x'=>50, 'y'=>50, color=>$red), "flood fill");
cc6483e0	167	$diff = Imager::i_img_diff($rffcmp, $ffim->{IMG});
109bec2d	168	ok(!$diff, "oo flood fill difference");
9d540150	169	$ffim->flood_fill('x'=>50, 'y'=>50,
cc6483e0	170	fill=> {
3efb0915 TC	171	hatch => 'check2x2',
3efb0915 TC	172	fg => '0000FF',
cc6483e0 TC	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
3efb0915 TC	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
efdc2568 TC	193	# test combining modes
	194	my $fill = NC(192, 128, 128, 128);
	195	my $target = NC(64, 32, 64);
9b1ec2b8	196	my $trans_target = NC(64, 32, 64, 128);
efdc2568 TC	197	my %comb_tests =
efdc2568 TC	198	(
9b1ec2b8 TC	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	},
efdc2568 TC	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
9b1ec2b8 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	},
efdc2568 TC	267	);
efdc2568 TC	268
efdc2568 TC	269	for my $comb (Imager::Fill->combines) {
efdc2568 TC	270	my $test = $comb_tests{$comb};
efdc2568	271	my $fillobj = Imager::Fill->new(solid=>$fill, combine=>$comb);
9b1ec2b8 TC	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	}
efdc2568 TC	314	}
	315	}
	316
109bec2d	317	ok($ffim->arc(r=>45, color=>$blue, aa=>1), "aa circle");
0d321238 TC	318	$ffim->write(file=>"testout/t20_aacircle.ppm");
0d321238 TC	319
f576ce7e TC	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();
109bec2d	332	ok($oocopy->arc(fill=>{image=>$fillim,
f576ce7e TC	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;
109bec2d	341	ok($oocopy->arc(fill=>{
f576ce7e TC	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
109bec2d	350	ok(!$oocopy->arc(fill=>{ hatch=>"not really a hatch" }, r=>20),
569795e8	351	"error handling of automatic fill conversion");
109bec2d	352	ok($oocopy->errstr =~ /Unknown hatch type/,
569795e8 TC	353	"error message for automatic fill conversion");
569795e8 TC	354
2de568dc TC	355	# previous box fills to float images, or using the fountain fill
2de568dc TC	356	# got into a loop here
f3b59de8	357
109bec2d TC	358	SKIP:
	359	{
	360	skip("can't test without alarm()", 1) unless $Config{d_alarm};
2de568dc TC	361	local $SIG{ALRM} = sub { die; };
	362
	363	eval {
	364	alarm(2);
109bec2d	365	ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
2de568dc TC	366	fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80,
2de568dc TC	367	yb=>20 }), "linear box fill");
13b8afa0	368	alarm 0;
2de568dc	369	};
109bec2d	370	$@ and ok(0, "linear box fill $@");
f3b59de8	371	}
2de568dc	372
109bec2d TC	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	}
f1ac5027	382
109bec2d TC	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");
efdc2568 TC	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;
f1ac5027 TC	428	}
f1ac5027 TC	429
9b1ec2b8 TC	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
f1ac5027 TC	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	}