t/t21draw.t

   1 #!perl -w
   2 # Before `make install' is performed this script should be runnable with
   3 # `make test'. After `make install' it should work as `perl test.pl'
   4
   5 ######################### We start with some black magic to print on failure.
   6
   7 # Change 1..1 below to 1..last_test_to_print .
   8 # (It may become useful if the test is moved to ./t subdirectory.)
   9 use strict;
  10 use Test::More tests => 43;
  11 my $loaded;
  12
  13 BEGIN { use_ok(Imager=>':all'); }
  14 init_log("testout/t21draw.log",1);
  15
  16 my $redobj = NC(255, 0, 0);
  17 my $red = 'FF0000';
  18 my $greenobj = NC(0, 255, 0);
  19 my $green = [ 0, 255, 0 ];
  20 my $blueobj = NC(0, 0, 255);
  21 my $blue = { hue=>240, saturation=>1, value=>1 };
  22 my $white = '#FFFFFF';
  23
  24 my $img = Imager->new(xsize=>100, ysize=>500);
  25
  26 ok($img->box(color=>$blueobj, xmin=>10, ymin=>10, xmax=>48, ymax=>18),
  27    "box with color obj");
  28 ok($img->box(color=>$blue, xmin=>10, ymin=>20, xmax=>48, ymax=>28),
  29    "box with color");
  30 ok($img->box(color=>$redobj, xmin=>10, ymin=>30, xmax=>28, ymax=>48, filled=>1),
  31    "filled box with color obj");
  32 ok($img->box(color=>$red, xmin=>30, ymin=>30, xmax=>48, ymax=>48, filled=>1),
  33    "filled box with color");
  34
  35 ok($img->arc('x'=>75, 'y'=>25, r=>24, color=>$redobj),
  36    "filled arc with colorobj");
  37
  38 ok($img->arc('x'=>75, 'y'=>25, r=>20, color=>$green),
  39    "filled arc with colorobj");
  40 ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$white, d1=>325, d2=>225),
  41    "filled arc with color");
  42
  43 ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$blue, d1=>225, d2=>325),
  44    "filled arc with color");
  45 ok($img->arc('x'=>75, 'y'=>25, r=>15, color=>$green, aa=>1),
  46    "filled arc with color");
  47
  48 ok($img->line(color=>$blueobj, x1=>5, y1=>55, x2=>35, y2=>95),
  49    "line with colorobj");
  50
  51 # FIXME - neither the start nor end-point is set for a non-aa line
  52 my $c = Imager::i_get_pixel($img->{IMG}, 5, 55);
  53 ok(color_cmp($c, $blueobj) == 0, "# TODO start point not set");
  54
  55 ok($img->line(color=>$red, x1=>10, y1=>55, x2=>40, y2=>95, aa=>1),
  56    "aa line with color");
  57 ok($img->line(color=>$green, x1=>15, y1=>55, x2=>45, y2=>95, antialias=>1),
  58    "antialias line with color");
  59
  60 ok($img->polyline(points=>[ [ 55, 55 ], [ 90, 60 ], [ 95, 95] ],
  61                   color=>$redobj),
  62    "polyline points with color obj");
  63 ok($img->polyline('x'=>[ 55, 85, 90 ], 'y'=>[60, 65, 95], color=>$green, aa=>1),
  64    "polyline xy with color aa");
  65 ok($img->polyline('x'=>[ 55, 80, 85 ], 'y'=>[65, 70, 95], color=>$green,
  66                   antialias=>1),
  67    "polyline xy with color antialias");
  68
  69 ok($img->setpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], color=>$red),
  70    "set array of pixels");
  71 ok($img->setpixel('x'=>39, 'y'=>55, color=>$green),
  72    "set single pixel");
  73 use Imager::Color::Float;
  74 my $flred = Imager::Color::Float->new(1, 0, 0, 0);
  75 my $flgreen = Imager::Color::Float->new(0, 1, 0, 0);
  76 ok($img->setpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59], color=>$flred),
  77    "set array of float pixels");
  78 ok($img->setpixel('x'=>45, 'y'=>55, color=>$flgreen),
  79    "set single float pixel");
  80 my @gp = $img->getpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59]);
  81 ok(grep($_->isa('Imager::Color'), @gp) == 3, "check getpixel result type");
  82 ok(grep(color_cmp($_, NC(255, 0, 0)) == 0, @gp) == 3,
  83    "check getpixel result colors");
  84 my $gp = $img->getpixel('x'=>45, 'y'=>55);
  85 ok($gp->isa('Imager::Color'), "check scalar getpixel type");
  86 ok(color_cmp($gp, NC(0, 255, 0)) == 0, "check scalar getpixel color");
  87 @gp = $img->getpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], type=>'float');
  88 ok(grep($_->isa('Imager::Color::Float'), @gp) == 3,
  89    "check getpixel float result type");
  90 ok(grep(color_cmp($_, $flred) == 0, @gp) == 3,
  91    "check getpixel float result type");
  92 $gp = $img->getpixel('x'=>39, 'y'=>55, type=>'float');
  93 ok($gp->isa('Imager::Color::Float'), "check scalar float getpixel type");
  94 ok(color_cmp($gp, $flgreen) == 0, "check scalar float getpixel color");
  95
  96 # more complete arc tests
  97 ok($img->arc(x=>25, 'y'=>125, r=>20, d1=>315, d2=>45, color=>$greenobj),
  98    "color arc through angle 0");
  99 # use diff combine here to make sure double writing is noticable
 100 ok($img->arc(x=>75, 'y'=>125, r=>20, d1=>315, d2=>45,
 101              fill => { solid=>$blueobj, combine => 'diff' }),
 102    "fill arc through angle 0");
 103 ok($img->arc(x=>25, 'y'=>175, r=>20, d1=>315, d2=>225, color=>$redobj),
 104    "concave color arc");
 105 angle_marker($img, 25, 175, 23, 315, 225);
 106 ok($img->arc(x=>75, 'y'=>175, r=>20, d1=>315, d2=>225,
 107              fill => { solid=>$greenobj, combine=>'diff' }),
 108    "concave fill arc");
 109 angle_marker($img, 75, 175, 23, 315, 225);
 110 ok($img->arc(x=>25, y=>225, r=>20, d1=>135, d2=>45, color=>$redobj),
 111    "another concave color arc");
 112 angle_marker($img, 25, 225, 23, 45, 135);
 113 ok($img->arc(x=>75, y=>225, r=>20, d1=>135, d2=>45,
 114              fill => { solid=>$blueobj, combine=>'diff' }),
 115    "another concave fillarc");
 116 angle_marker($img, 75, 225, 23, 45, 135);
 117 ok($img->arc(x=>25, y=>275, r=>20, d1=>135, d2=>45, color=>$redobj, aa=>1),
 118    "concave color arc aa");
 119 ok($img->arc(x=>75, y=>275, r=>20, d1=>135, d2=>45,
 120              fill => { solid=>$blueobj, combine=>'diff' }, aa=>1),
 121    "concave fill arc aa");
 122
 123 ok($img->circle(x=>25, y=>325, r=>20, color=>$redobj),
 124    "color circle no aa");
 125 ok($img->circle(x=>75, y=>325, r=>20, color=>$redobj, aa=>1),
 126    "color circle aa");
 127 ok($img->circle(x=>25, 'y'=>375, r=>20,
 128                 fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
 129    "fill circle no aa");
 130 ok($img->circle(x=>75, 'y'=>375, r=>20, aa=>1,
 131                 fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
 132    "fill circle aa");
 133
 134 ok($img->arc(x=>50, y=>450, r=>45, d1=>135, d2=>45,
 135              fill => { solid=>$blueobj, combine=>'diff' }),
 136    "another concave fillarc");
 137 angle_marker($img, 50, 450, 47, 45, 135);
 138
 139 ok($img->write(file=>'testout/t21draw.ppm'),
 140    "saving output");
 141
 142 malloc_state();
 143
 144 sub color_cmp {
 145   my ($l, $r) = @_;
 146   my @l = $l->rgba;
 147   my @r = $r->rgba;
 148   # print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
 149   return $l[0] <=> $r[0]
 150     || $l[1] <=> $r[1]
 151       || $l[2] <=> $r[2];
 152 }
 153
 154 use constant PI => 4 * atan2(1,1);
 155
 156 sub angle_marker {
 157   my ($img, $x, $y, $radius, @angles) = @_;
 158
 159   for my $angle (@angles) {
 160     my $x1 = int($x + $radius * cos($angle * PI / 180) + 0.5);
 161     my $y1 = int($y + $radius * sin($angle * PI / 180) + 0.5);
 162     my $x2 = int($x + (5+$radius) * cos($angle * PI / 180) + 0.5);
 163     my $y2 = int($y + (5+$radius) * sin($angle * PI / 180) + 0.5);
 164
 165     $img->line(x1=>$x1, y1=>$y1, x2=>$x2, y2=>$y2, color=>'#FFF');
 166   }
 167 }