File Coverage

blib/lib/Algorithm/Line/Bresenham.pm
Criterion Covered Total %
statement 249 374 66.5
branch 53 108 49.0
condition 8 21 38.1
subroutine 18 20 90.0
pod 8 12 66.6
total 336 535 62.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Algorithm::Line::Bresenham - simple pixellated line-drawing algorithm
4              
5             =head1 SYNOPSIS
6              
7             use Algorithm::Line::Bresenham qw/line/;
8             my @points = line(3,3 => 5,0);
9             # returns the list: [3,3], [4,2], [4,1], [5,0]
10             my @points = circle(30,30,5);
11             # returns the points to draw a circle centered at 30,30, radius 5
12              
13             =head1 DESCRIPTION
14              
15             Bresenham is one of the canonical line drawing algorithms for pixellated grids.
16             Given a start and an end-point, Bresenham calculates which points on the grid
17             need to be filled to generate the line between them. This module has been extended
18             to include cureves crcles ellipses and thick licnes, variable thickness lines.
19              
20              
21             =cut
22              
23              
24             package Algorithm::Line::Bresenham;
25 1     1   54184 use strict; use warnings;
  1     1   3  
  1         23  
  1         4  
  1         1  
  1         33  
26             our $VERSION = 0.151;
27 1     1   4 use base 'Exporter';
  1         2  
  1         150  
28             our @EXPORT_OK = qw/line circle ellipse_rect quad_bezier polyline varthick_line thick_line/;
29              
30              
31             =head2 C
32              
33             line ($from_x, $from_y => $to_x, $to_y);
34              
35             Generates a list of all the intermediate points. This is returned as a list
36             of array references. Previous versions used to include a callback parameter
37             as a CODE ref to act on each point in turn. This version omits that for
38             performance reasons
39              
40             =cut
41              
42             sub line { # ported from https://gist.github.com/bert/1085538
43 1     1   424 use integer;
  1         12  
  1         3  
44 6     6 1 90 my ($x0, $y0, $x1, $y1,$callback,$cbArgs)=@_;
45 1     1   38 use integer;
  1         2  
  1         3  
46 6         8 my $dx = abs ($x1 - $x0);
47 6 100       13 my $sx = $x0 < $x1 ? 1 : -1;
48 6         10 my $dy = -abs ($y1 - $y0);
49 6 100       8 my $sy = $y0 < $y1 ? 1 : -1;
50 6         10 my $err = $dx + $dy;
51 6         8 my $e2; #/* error value e_xy */
52             my @points;
53            
54 6         6 while(1){ #/* loop */
55 21 50       31 if ($callback){
56 0         0 $callback->($x0,$y0,$cbArgs);
57             }
58             else{
59 21         29 push @points,[$x0,$y0];
60             }
61            
62 21 100 100     49 last if ($x0 == $x1 && $y0 == $y1);
63 15         19 $e2 = 2 * $err;
64 15 100       21 if ($e2 >= $dy) { $err += $dy; $x0 += $sx; } #/* e_xy+e_x > 0 */
  13         14  
  13         17  
65 15 100       21 if ($e2 <= $dx) { $err += $dx; $y0 += $sy; } #/* e_xy+e_y < 0 */
  10         12  
  10         12  
66             }
67 6         22 return @points;
68             }
69              
70              
71             =head2 C
72              
73             my @points = circle ($x, $y, $radius)
74              
75             Returns the points to draw a circle centered on C<$x,$y> with
76             radius C<$radius>
77              
78             =cut
79              
80             sub circle { # ported from https://gist.github.com/bert/1085538
81 1     1 1 4 my ($xm, $ym, $r)=@_;
82 1     1   144 use integer;
  1         2  
  1         4  
83 1         2 my $x = -$r;
84 1         2 my $y = 0;
85 1         2 my $err = 2-2*$r; #/* II. Quadrant */
86 1         1 my @points;
87 1         2 do {
88 1         3 push @points,[$xm-$x, $ym+$y];# /* I. Quadrant */
89 1         2 push @points,[$xm-$y, $ym-$x];# /* II. Quadrant */
90 1         2 push @points,[$xm+$x, $ym-$y];# /* III. Quadrant */
91 1         2 push @points,[$xm+$y, $ym+$x];# /* IV. Quadrant */
92 1         10 $r = $err;
93 1 50       5 $err += ++$x*2+1 if ($r > $x); #/* e_xy+e_x > 0 */
94 1 50       4 $err += ++$y*2+1 if ($r <= $y); #/* e_xy+e_y < 0 */
95             } while ($x < 0);
96 1         5 return @points;
97             }
98              
99             =head2 C
100              
101             my @points = ellipse_rect ($x0, $y0, $x1, $y1)
102              
103             Returns the points to an ellipse bound within a rectangle defined by
104             the two coordinate pairs passed.
105              
106             =cut
107              
108              
109             sub ellipse_rect{ # ported from https://gist.github.com/bert/1085538
110 1     1   117 use integer;
  1         1  
  1         3  
111 1     1 1 3 my ($x0, $y0, $x1, $y1)=@_;
112 1         2 my $a = abs ($x1 - $x0);
113 1         2 my $b = abs ($y1 - $y0);
114 1         2 my $b1 = $b & 1; #/* values of diameter */
115 1         2 my $dx = 4 * (1 - $a) * $b * $b;
116 1         9 my $dy = 4 * ($b1 + 1) * $a * $a; #/* error increment */
117 1         3 my $err = $dx + $dy + $b1 * $a * $a;
118 1         1 my $e2; #/* error of 1.step */
119              
120 1 50       4 if ($x0 > $x1) { $x0 = $x1; $x1 += $a; } #/* if called with swapped points */
  0         0  
  0         0  
121 1 50       2 $y0 = $y1 if ($y0 >$y1);# /* .. exchange them */
122 1         2 $y0 += ($b + 1) / 2;
123 1         1 $y1 = $y0-$b1; #/* starting pixel */
124 1         2 $a *= 8 * $a; $b1 = 8 * $b * $b;
  1         2  
125 1         1 my @points;
126             do
127 1         2 {
128 3         5 push @points,[$x1, $y0];# /* I. Quadrant */
129 3         5 push @points,[$x0, $y0];# /* II. Quadrant */
130 3         6 push @points,[$x0, $y1];# /* III. Quadrant */
131 3         4 push @points,[$x1, $y1];# /* IV. Quadrant */
132 3         4 $e2 = 2 * $err;
133 3 50       5 if ($e2 >= $dx)
134             {
135 3         4 $x0++;
136 3         3 $x1--;
137 3         3 $err += $dx += $b1; # does this translate into perl
138             } #/* x step */
139 3 50       10 if ($e2 <= $dy)
140             {
141 0         0 $y0++;
142 0         0 $y1--;
143 0         0 $err += $dy += $a;
144             } #/* y step */
145             } while ($x0 <= $x1);
146 1         3 while ($y0-$y1 < $b)
147             { #/* too early stop of flat ellipses a=1 */
148 0         0 push @points,[$x0-1, $y0]; #/* -> finish tip of ellipse */
149 0         0 push @points,[$x1+1, $y0++];
150 0         0 push @points,[$x0-1, $y1];
151 0         0 push @points,[$x1+1, $y1--];
152             }
153            
154 1         10 return @points;
155             }
156              
157             =head2 C
158              
159             my @points = basic_bezier ($x0, $y0, $x1, $y1, $x2, $y2)
160              
161             This is not usefull on its own. Iteturns the points to segment of a
162             bezier curve without a gradient sign change. It is a companion to
163             the C function that splits a bezier into segments
164             with each gradient direction and these segments are computed in
165             C
166              
167             =cut
168              
169              
170             sub basic_bezier{ # without gradient changes adapted from https://gist.github.com/bert/1085538
171 2     2 1 4 my ($x0, $y0, $x1, $y1, $x2, $y2)=@_;
172 2 50       6 my $sx = $x0 < $x2 ? 1 : -1;
173 2 100       5 my $sy = $y0 < $y2 ? 1 : -1; #/* step direction */
174 2         3 my $cur = $sx * $sy *(($x0 - $x1) * ($y2 - $y1) - ($x2 - $x1) * ($y0 - $y1)); #/* curvature */
175 2         3 my $x = $x0 - 2 * $x1 + $x2;
176 2         4 my $y = $y0 - 2 * $y1 +$y2;
177 2         3 my $xy = 2 * $x * $y * $sx * $sy;
178             # /* compute error increments of P0 */
179 2         6 my $dx = (1 - 2 * abs ($x0 - $x1)) * $y * $y + abs ($y0 - $y1) * $xy - 2 * $cur * abs ($y0 - $y2);
180 2         4 my $dy = (1 - 2 * abs ($y0 - $y1)) * $x * $x + abs ($x0 - $x1) * $xy + 2 * $cur * abs ($x0 - $x2);
181             #/* compute error increments of P2 */
182 2         5 my $ex = (1 - 2 * abs ($x2 - $x1)) * $y * $y + abs ($y2 - $y1) * $xy + 2 * $cur * abs ($y0 - $y2);
183 2         5 my $ey = (1 - 2 * abs ($y2 - $y1)) * $x * $x + abs ($x2 - $x1) * $xy - 2 * $cur * abs ($x0 - $x2);
184             # /* sign of gradient must not change */
185 2 50 33     17 warn "gradient change detected" unless (($x0 - $x1) * ($x2 - $x1) <= 0 && ($y0 - $y1) * ($y2 - $y1) <= 0);
186 2 50       5 if ($cur == 0)
187             { #/* straight line */
188 0         0 return line ($x0, $y0, $x2, $y2);
189            
190             }
191 2         3 $x *= 2 * $x;
192 2         3 $y *= 2 * $y;
193 2 100       5 if ($cur < 0)
194             { #/* negated curvature */
195 1         1 $x = -$x;
196 1         1 $dx = -$dx;
197 1         2 $ex = -$ex;
198 1         1 $xy = -$xy;
199 1         2 $y = -$y;
200 1         1 $dy = -$dy;
201 1         1 $ey = -$ey;
202             }
203             #/* algorithm fails for almost straight line, check error values */
204 2 50 33     20 if ($dx >= -$y || $dy <= -$x || $ex <= -$y || $ey >= -$x)
      33        
      33        
205             {
206 0         0 return (line ($x0, $y0, $x1, $y1), line ($x1, $y1, $x2, $y2)); #/* simple approximation */
207             }
208 2         3 $dx -= $xy;
209 2         3 $ex = $dx + $dy;
210 2         2 $dy -= $xy; #/* error of 1.step */
211 2         3 my @points;
212 2         4 while(1)
213             { #/* plot curve */
214 7         10 push @points,[$x0, $y0];
215 7         10 $ey = 2 * $ex - $dy; #/* save value for test of y step */
216 7 50       9 if (2 * $ex >= $dx)
217             { #/* x step */
218 7 100       14 last if ($x0 == $x2);
219 5         6 $x0 += $sx;
220 5         5 $dy -= $xy;
221 5         6 $ex += $dx += $y;
222             }
223 5 100       8 if ($ey <= 0)
224             { #/* y step */
225 2 50       4 last if ($y0 == $y2);
226 2         3 $y0 += $sy;
227 2         2 $dx -= $xy;
228 2         3 $ex += $dy += $x;
229             }
230             }
231 2         6 return @points;
232             }
233              
234              
235             =head2 C
236              
237             my @points = quad_bezier ($x0, $y0, $x1, $y1, $x2, $y2)
238              
239             Draws a Bezier curve from C<($x0,$y0)> to C<($x2,$y2)> using control
240             point C<($x1,$y1)>
241              
242             =cut
243              
244              
245             sub quad_bezier{ # adapted from http://members.chello.at/easyfilter/bresenham.html
246 1     1 1 3 my ($x0, $y0, $x1, $y1, $x2, $y2)=@_;# /* plot any quadratic Bezier curve */
247 1         2 my $x = $x0-$x1;
248 1         2 my $y = $y0-$y1;
249 1         3 my $t = $x0-2*$x1+$x2;
250 1         2 my $r;
251             my @points;
252 1 50       4 if ($x*($x2-$x1) > 0) { #/* horizontal cut at P4? */
253 0 0       0 if ($y*($y2-$y1) > 0){ #/* vertical cut at P6 too? */
254 0 0       0 if (abs(($y0-2*$y1+$y2)/$t*$x) > abs($y)) { #/* which first? */
255 0         0 $x0 = $x2; $x2 = $x+$x1; $y0 = $y2; $y2 = $y+$y1;# /* swap points */
  0         0  
  0         0  
  0         0  
256             } #/* now horizontal cut at P4 comes first */
257             }
258 0         0 $t = ($x0-$x1)/$t;
259 0         0 $r = (1-$t)*((1-$t)*$y0+2.0*$t*$y1)+$t*$t*$y2;# /* By(t=P4) */
260 0         0 $t = ($x0*$x2-$x1*$x1)*$t/($x0-$x1); #/* gradient dP4/dx=0 */
261 0         0 $x = int($t+0.5); $y = int($r+0.5);
  0         0  
262 0         0 $r = ($y1-$y0)*($t-$x0)/($x1-$x0)+$y0; #/* intersect P3 | P0 P1 */
263 0         0 push @points, basic_bezier($x0,$y0, $x,int($r+0.5), $x,$y);
264 0         0 $r = ($y1-$y2)*($t-$x2)/($x1-$x2)+$y2; #/* intersect P4 | P1 P2 */
265 0         0 $x0 = $x1 = $x; $y0 = $y; $y1 = int($r+0.5);# /* P0 = P4, P1 = P8 */
  0         0  
  0         0  
266             }
267 1 50       4 if (($y0-$y1)*($y2-$y1) > 0) { #/* vertical cut at P6? */
268 1         3 $t = $y0-2*$y1+$y2; $t = ($y0-$y1)/$t;
  1         2  
269 1         5 $r = (1-$t)*((1-$t)*$x0+2.0*$t*$x1)+$t*$t*$x2; # /* Bx(t=P6) */
270 1         3 $t = ($y0*$y2-$y1*$y1)*$t/($y0-$y1); #/* gradient dP6/dy=0 */
271 1         2 $x = int($r+0.5); $y = int($t+0.5);
  1         2  
272 1         3 $r = ($x1-$x0)*($t-$y0)/($y1-$y0)+$x0; #/* intersect P6 | P0 P1 */
273 1         4 push @points, basic_bezier($x0,$y0, int($r+0.5),$y, $x,$y);
274 1         8 $r = ($x1-$x2)*($t-$y2)/($y1-$y2)+$x2; #/* intersect P7 | P1 P2 */
275 1         2 $x0 = $x; $x1 = int($r+0.5); $y0 = $y1 = $y;# /* P0 = P6, P1 = P7 */
  1         2  
  1         2  
276             }
277 1         3 push @points, basic_bezier($x0,$y0, $x1,$y1, $x2,$y2); #/* remaining part */
278 1         4 return @points;
279             }
280              
281             =head2 C
282              
283             my @points = polyline ($x0, $y0, $x1, $y1, $x2, $y2)
284              
285             Draws a polyline between points served as a list of x,y pairs
286              
287             =cut
288              
289             sub polyline{
290 1     1 1 2 my @vertices;
291 1         7 push @vertices,[shift,shift] while (@_>1);
292 1         2 my @points;
293 1         3 foreach my $vertex(0..(@vertices-2)){
294 2         3 push @points,line(@{$vertices[$vertex]},@{$vertices[$vertex+1]});
  2         3  
  2         5  
295 2 100       6 pop @points if ($vertex < (@vertices-2)); # remove duplicated points
296             }
297 1         4 return @points;
298             }
299              
300             =head2 C
301              
302             my @points = thick_line ($x0, $y0, $x1, $y1,$thickness)
303              
304             Draws a line thickened using Murphy's modication of Bresenham'salgorithm
305             between two points of x,y pairs. This routine was further enahnced to
306             provide variable thickness lines and uses multiple helper subroutines.
307              
308             =head2 C
309            
310             my @points= varthick_line($x0,$y0,$x1,$y1,$leftFn,$argL,$rightFn,$argR)
311              
312             Variable thickness lines are implemented as described in
313             http://kt8216.unixcab.org/murphy/index.html ; This allows passing of
314             two subroutine references (so the left side and the right sides of the
315             line can have differently varying thicknesses) along with a
316             user originated parameter. The subroutine reference example is shown below:
317              
318             my $leftFn=sub{
319             my ($arg,$p,$l)=@_;
320             # C<$arg> is passed by calling routine,
321             # C<$p> is point on line
322             # C<$l> is length of line
323             return $p % $arg;
324             };
325              
326             =cut
327              
328             ## Variable thickness lines using Murphy's Modification of Bresenham Line Algorithm**
329             ## Codes ported from C in http://kt8216.unixcab.org/murphy/index.html
330              
331             #* X BASED LINES *
332            
333             sub x_perpendicular{
334 0     0 0 0 my ($x0,$y0,$dx,$dy,$xstep,$ystep,$einit,$w_left,$w_right,$winit)=@_;
335            
336 0         0 my @pts;
337              
338 0         0 my $threshold = $dx - 2*$dy;
339 0         0 my $E_diag= -2*$dx;
340 0         0 my $E_square= 2*$dy;
341 0         0 my $p=my $q=0;
342              
343 0         0 my $y= $y0;
344 0         0 my $x= $x0;
345 0         0 my $error= $einit;
346 0         0 my $tk= $dx+$dy-$winit;
347              
348 0         0 while($tk<=$w_left)
349             {
350 0         0 push (@pts,[$x,$y]);
351 0 0       0 if ($error>=$threshold)
352             {
353 0         0 $x= $x + $xstep;
354 0         0 $error = $error + $E_diag;
355 0         0 $tk= $tk + 2*$dy;
356             }
357 0         0 $error = $error + $E_square;
358 0         0 $y= $y + $ystep;
359 0         0 $tk= $tk + 2*$dx;
360 0         0 $q++;
361             }
362              
363 0         0 $y= $y0;
364 0         0 $x= $x0;
365 0         0 $error= -$einit;
366 0         0 $tk= $dx+$dy+$winit;
367              
368 0         0 while($tk<=$w_right)
369             {
370 0 0       0 push (@pts,[$x,$y]) if ($p);
371 0 0       0 if ($error>$threshold)
372             {
373 0         0 $x= $x - $xstep;
374 0         0 $error = $error + $E_diag;
375 0         0 $tk= $tk + 2*$dy;
376             }
377 0         0 $error = $error + $E_square;
378 0         0 $y= $y - $ystep;
379 0         0 $tk= $tk + 2*$dx;
380 0         0 $p++;
381             }
382              
383 0 0 0     0 push (@pts,[$x,$y]) if ($q==0 && $p<2); # we need this for very thin lines
384            
385 0         0 return @pts;
386             }
387              
388              
389             sub x_varthick_line{
390 0     0 0 0 my ($x0,$y0,$dx,$dy,$xstep,$ystep,
391             $left, $argL, #left thickness function
392             $right,$argR, #right thickness function
393             $pxstep,$pystep)=@_;
394            
395 0         0 my @xPoints;
396            
397 0         0 my $p_error= 0;
398 0         0 my $error= 0;
399 0         0 my $y= $y0;
400 0         0 my $x= $x0;
401 0         0 my $threshold = $dx - 2*$dy;
402 0         0 my $E_diag= -2*$dx;
403 0         0 my $E_square= 2*$dy;
404 0         0 my $length = $dx+1;
405 0         0 my $D= sqrt($dx*$dx+$dy*$dy);
406              
407 0         0 for(my $p=0;$p<$length;$p++)
408             {
409 0         0 my $w_left= $left->($argL, $p, $length)*2*$D;
410 0         0 my $w_right= $right->($argR,$p, $length)*2*$D;
411 0         0 push @xPoints,x_perpendicular($x,$y, $dx, $dy, $pxstep, $pystep,
412             $p_error,$w_left,$w_right,$error);
413 0 0       0 if ($error>=$threshold)
414             {
415 0         0 $y= $y + $ystep;
416 0         0 $error = $error + $E_diag;
417 0 0       0 if ($p_error>=$threshold)
418             {
419 0         0 push @xPoints,x_perpendicular($x,$y, $dx, $dy, $pxstep, $pystep,
420             ($p_error+$E_diag+$E_square),
421             $w_left,$w_right,$error);
422 0         0 $p_error= $p_error + $E_diag;
423             }
424 0         0 $p_error= $p_error + $E_square;
425             }
426 0         0 $error = $error + $E_square;
427 0         0 $x= $x + $xstep;
428             }
429 0         0 return @xPoints;
430             }
431              
432             #* Y BASED LINES *
433              
434             sub y_perpendicular{
435 23     23 0 35 my ($x0,$y0,$dx,$dy,$xstep,$ystep,
436             $einit,$w_left, $w_right,$winit)=@_;
437              
438 23         26 my @pts;
439              
440 23         30 my $threshold = $dy - 2*$dx;
441 23         46 my $E_diag= -2*$dy;
442 23         27 my $E_square= 2*$dx;
443 23         24 my $p=my $q=0;
444              
445 23         24 my $y= $y0;
446 23         24 my $x= $x0;
447 23         25 my $error= -$einit;
448 23         28 my $tk= $dx+$dy+$winit;
449              
450              
451 23         39 while($tk<=$w_left)
452             {
453 31         43 push @pts,[$x,$y];
454 31 100       49 if ($error>$threshold)
455             {
456 16         19 $y= $y + $ystep;
457 16         16 $error = $error + $E_diag;
458 16         20 $tk= $tk + 2*$dx;
459             }
460 31         34 $error = $error + $E_square;
461 31         33 $x= $x + $xstep;
462 31         32 $tk= $tk + 2*$dy;
463 31         44 $q++;
464             }
465              
466              
467 23         34 $y= $y0;
468 23         25 $x= $x0;
469 23         24 $error= $einit;
470 23         26 $tk= $dx+$dy-$winit;
471              
472 23         34 while($tk<=$w_right)
473             {
474 27 100       43 push (@pts,[$x,$y]) if ($p);
475 27 100       42 if ($error>=$threshold)
476             {
477 12         13 $y= $y - $ystep;
478 12         13 $error = $error + $E_diag;
479 12         13 $tk= $tk + 2*$dx;
480             }
481 27         30 $error = $error + $E_square;
482 27         30 $x= $x - $xstep;
483 27         28 $tk= $tk + 2*$dy;
484 27         38 $p++;
485             }
486              
487 23 50 33     37 push (@pts,[$x,$y]) if ($q==0 && $p<2); # we need this for very thin lines
488 23         38 return @pts;
489             }
490              
491              
492             sub y_varthick_line {
493 1     1 0 4 my ($x0,$y0,$dx,$dy,$xstep,$ystep,
494             $left, $argL, #left thickness function
495             $right,$argR, #right thickness function
496             $pxstep,$pystep)=@_;
497            
498 1         1 my @yPoints;
499 1         2 my $p_error= 0;
500 1         1 my $error= 0;
501 1         2 my $y= $y0;
502 1         1 my $x= $x0;
503 1         2 my $threshold = $dy - 2*$dx;
504 1         2 my $E_diag= -2*$dy;
505 1         2 my $E_square= 2*$dx;
506 1         1 my $length = $dy+1;
507 1         3 my $D= sqrt($dx*$dx+$dy*$dy);
508              
509 1         3 for(my $p=0;$p<$length;$p++)
510             {
511 19         27 my $w_left= $left->($argL, $p, $length)*2*$D;
512 19         26 my $w_right= $right->($argR,$p, $length)*2*$D;
513 19         26 push @yPoints,y_perpendicular($x,$y, $dx, $dy, $pxstep, $pystep,
514             $p_error,$w_left,$w_right,$error);
515 19 100       30 if ($error>=$threshold)
516             {
517 8         8 $x= $x + $xstep;
518 8         9 $error = $error + $E_diag;
519 8 100       12 if ($p_error>=$threshold)
520             {
521 4         14 push @yPoints,y_perpendicular($x,$y, $dx, $dy, $pxstep, $pystep,
522             ($p_error+$E_diag+$E_square),$w_left,$w_right,$error);
523 4         4 $p_error= $p_error + $E_diag;
524             }
525 8         9 $p_error= $p_error + $E_square;
526             }
527 19         21 $error = $error + $E_square;
528 19         31 $y= $y + $ystep;
529             }
530 1         14 return @yPoints;
531             }
532              
533             #* ENTRY *
534              
535             sub thick_line{
536 1     1 1 3 my ($x0,$y0,$x1,$y1,$thickness)=@_;
537 19     19   28 return varthick_line($x0,$y0,$x1,$y1,sub{return (1+$thickness)/2},undef,sub{return (1+$thickness)/2},undef)
  19         28  
538 1         7 };
539             sub varthick_line{
540 1     1 1 3 my ($x0,$y0,$x1,$y1,
541             $left,$argL,
542             $right,$argR)=@_;
543              
544 1         2 my $dx= $x1-$x0;
545 1         2 my $dy= $y1-$y0;
546 1         2 my $xstep= my $ystep= 1;
547              
548 1 50       3 if ($dx<0) { $dx= -$dx; $xstep= -1; }
  1         2  
  1         9  
549 1 50       27 if ($dy<0) { $dy= -$dy; $ystep= -1; }
  1         4  
  1         1  
550              
551 1 50       4 $xstep= 0 if ($dx==0);
552 1 50       2 $ystep= 0 if ($dy==0);
553 1         2 my $pxstep; my $pystep;
554              
555 1         1 my $xch= 0;
556 1         4 for($xstep + $ystep*4){
557 1 50       3 ($_==-1 + -1*4) && do {$pystep= -1; $pxstep= 1; $xch= 1; last;}; # -5
  1         1  
  1         1  
  1         2  
  1         2  
558 0 0       0 ($_==-1 + 0*4) && do {$pystep= -1; $pxstep= 0; $xch= 1; last;}; # -1
  0         0  
  0         0  
  0         0  
  0         0  
559 0 0       0 ($_==-1 + 1*4) && do {$pystep= 1; $pxstep= 1; last;}; # 3
  0         0  
  0         0  
  0         0  
560 0 0       0 ($_== 0 + -1*4) && do {$pystep= 0; $pxstep= -1; last;}; # -4
  0         0  
  0         0  
  0         0  
561 0 0       0 ($_== 0 + 0*4) && do {$pystep= 0; $pxstep= 0; last;}; # 0
  0         0  
  0         0  
  0         0  
562 0 0       0 ($_== 0 + 1*4) && do {$pystep= 0; $pxstep= 1; last;}; # 4
  0         0  
  0         0  
  0         0  
563 0 0       0 ($_== 1 + -1*4) && do {$pystep= -1; $pxstep= -1; last;}; # -3
  0         0  
  0         0  
  0         0  
564 0 0       0 ($_== 1 + 0*4) && do {$pystep= -1; $pxstep= 0; last;}; # 1
  0         0  
  0         0  
  0         0  
565 0 0       0 ($_== 1 + 1*4) && do {$pystep= 1; $pxstep= -1; $xch=1; last;}; # 5
  0         0  
  0         0  
  0         0  
  0         0  
566             }
567              
568 1 50       2 if ($xch){
569 1         1 my $K;
570 1         2 $K= $argL; $argL= $argR; $argR= $K;
  1         1  
  1         2  
571 1         1 $K= $left; $left= $right; $right= $K; }
  1         7  
  1         2  
572              
573 1 50       8 if ($dx>$dy){
574 0         0 return x_varthick_line($x0,$y0,$dx,$dy,$xstep,$ystep,
575             $left,$argL,$right,$argR,
576             $pxstep,$pystep);
577             }
578             else{
579 1         3 return y_varthick_line($x0,$y0,$dx,$dy,$xstep,$ystep,
580             $left,$argL,$right,$argR,
581             $pxstep,$pystep);
582             }
583             }
584              
585              
586              
587              
588             1;
589             __END__