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