File Coverage

lib/Graphics/Fig/Polyline.pm
Criterion Covered Total %
statement 449 503 89.2
branch 93 138 67.3
condition 43 89 48.3
subroutine 21 21 100.0
pod 0 12 0.0
total 606 763 79.4


line stmt bran cond sub pod time code
1             #
2             # XFig Drawing Library
3             #
4             # Copyright (c) 2017 D Scott Guthridge
5             #
6             # This program is free software: you can redistribute it and/or modify it under
7             # the terms of the Artistic License as published by the Perl Foundation, either
8             # version 2.0 of the License, or (at your option) any later version.
9             #
10             # This program is distributed in the hope that it will be useful, but WITHOUT
11             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12             # FOR A PARTICULAR PURPOSE. See the Artistic License for more details.
13             #
14             # You should have received a copy of the Artistic License along with this
15             # program. If not, see .
16             #
17             package Graphics::Fig::Polyline;
18             our $VERSION = 'v1.0.7';
19              
20 12     12   85 use strict;
  12         27  
  12         366  
21 12     12   66 use warnings;
  12         18  
  12         651  
22 12     12   72 use Carp;
  12         21  
  12         629  
23 12     12   64 use Math::Trig;
  12         21  
  12         2181  
24 12     12   6595 use Image::Info qw(image_info);
  12         21228  
  12         710  
25 12     12   84 use Graphics::Fig::Color;
  12         24  
  12         308  
26 12     12   61 use Graphics::Fig::Parameters;
  12         19  
  12         54124  
27              
28             #
29             # RE_REAL regular expression matching a floating point number
30             #
31             my $RE_REAL = "(?:(?i)(?:[-+]?)(?:(?=[.]?[0123456789])(?:[0123456789]*)" .
32             "(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[-+]?)" .
33             "(?:[0123456789]+))|))";
34              
35             my $DEFAULT_RESOLUTION = 100.0; # dpi
36              
37             #
38             # _parseResolution: parse resolution string
39             # $value: resolution
40             # $state: state structure
41             #
42             # Input may be any of (in increasing preference):
43             # xres / yres (form 1)
44             # xyres unit (form 2)
45             # xres / yres unit (form 3)
46             #
47             # Return:
48             # If the input string is valid, this function updates the
49             # state structure and returns 1. On error, it returns undef.
50             #
51             sub _parseResolution {
52 8     8   12 my $value = shift;
53 8         8 my $state = shift;
54              
55             #
56             # Match against pattern.
57             #
58 8         28 my $pattern = "\\s*($RE_REAL)" .
59             "(\\s*[/xX,]?\\s*($RE_REAL))?" .
60             "(\\s*(dpi|dpcm|dpm))?\\s*";
61 8 50 33     244 if (defined($value) && $value =~ m/^${pattern}$/) {
62 8         21 my $x = $1;
63 8         10 my $y = $3;
64 8         10 my $dpi;
65              
66             #
67             # If unit given, convert to dpi.
68             #
69 8 100       16 if (defined($5)) {
70 4 50       19 if ($5 eq "dpcm") {
    50          
71 0         0 $dpi = 2.54;
72             } elsif ($5 eq "dpm") {
73 0         0 $dpi = 0.0254;
74             } else { # "dpi"
75 4         4 $dpi = 1.0;
76             }
77             }
78             #
79             # Form 1
80             #
81 8 100 66     27 if (!defined($dpi) && defined($y)) {
82 4 100       10 if ($state->{"best_form"} < 1) {
83 1         4 $state->{"x_resolution"} = $x * $DEFAULT_RESOLUTION;
84 1         2 $state->{"y_resolution"} = $y * $DEFAULT_RESOLUTION;
85 1         2 $state->{"best_form"} = 1;
86             }
87 4         10 return 1;
88             }
89             #
90             # Form 2
91             #
92 4 100 66     15 if (defined($dpi) && !defined($y)) {
93 3 50       7 if ($state->{"best_form"} < 2) {
94 3         10 $state->{"x_resolution"} = $x * $dpi;
95 3         6 $state->{"y_resolution"} = $x * $dpi; # y same as x
96 3         4 $state->{"best_form"} = 2;
97             }
98 3         13 return 1;
99             }
100             #
101             # Form 3
102             #
103 1 50 33     8 if (defined($dpi) && defined($y)) {
104 1 50       4 if ($state->{"best_form"} < 3) {
105 1         4 $state->{"x_resolution"} = $x * $dpi;
106 1         3 $state->{"y_resolution"} = $y * $dpi;
107 1         2 $state->{"best_form"} = 3;
108             }
109 1         5 return 1
110             }
111             }
112 0         0 return undef;
113             }
114              
115             #
116             # _convertResolution: convert image resolution
117             # $value: resolution
118             # $fromImage: true if parsing from Image::Info; false if parameter
119             #
120             sub _convertResolution {
121 5     5   7 my $value = shift;
122 5         6 my $fromImage = shift;
123              
124             #
125             # Init state
126             #
127 5         18 my $state = {
128             x_resolution => $DEFAULT_RESOLUTION,
129             y_resolution => $DEFAULT_RESOLUTION,
130             best_form => 0,
131             };
132              
133             #
134             # Resolution returned from image_info can either be a string or
135             # a reference to an array of strings, each in one of the forms
136             # described above in _parseResolution. For example, the resolution
137             # may be returned as: [ "300 dpi", "1/1" ]. We take the best form
138             # offered. If the resolution was given explicitly as a parameter
139             # to Graphics::Fig, it must be a single valid string.
140             #
141 5 100 66     23 if ($fromImage && ref($value) eq "ARRAY") {
142 3         4 foreach my $temp (@{$value}) {
  3         7  
143 6         12 &_parseResolution($temp, $state);
144             }
145             } else {
146 2 0 33     6 if (!&_parseResolution($value, $state) && !$fromImage) {
147 0         0 croak("picture: error: ${value}: invalid resolution");
148             }
149             }
150 5         21 return [ $state->{"x_resolution"}, $state->{"y_resolution"} ];
151             }
152              
153             #
154             # Graphics::Fig::Polyline::convertResolution
155             # $fig: Fig instance
156             # $prefix: error message prefix
157             # $value: angle (degrees)
158             # $context: parameter context
159             #
160             sub convertResolution {
161 2     2 0 3 my $fig = shift;
162 2         4 my $prefix = shift;
163 2         2 my $value = shift;
164 2         3 my $context = shift;
165              
166 2         5 return &_convertResolution($value, 0);
167             }
168              
169             my @PolylineCommonParameters = (
170             \%Graphics::Fig::Parameters::UnitsParameter, # must be first
171             \%Graphics::Fig::Parameters::PositionParameter, # must be second
172             \%Graphics::Fig::Parameters::ColorParameter,
173             \%Graphics::Fig::Parameters::DepthParameter,
174             @Graphics::Fig::Parameters::FillParameters,
175             \%Graphics::Fig::Parameters::JoinStyleParameter,
176             @Graphics::Fig::Parameters::LineParameters,
177             \%Graphics::Fig::Parameters::PointsParameter,
178             );
179              
180             #
181             # Polyline Parameters
182             #
183             my %PolylineParameterTemplate = (
184             positional => {
185             "@" => [ "points" ],
186             },
187             named => [
188             @PolylineCommonParameters,
189             @Graphics::Fig::Parameters::ArrowParameters,
190             \%Graphics::Fig::Parameters::CapStyleParameter,
191             ],
192             );
193              
194             #
195             # Lineto Parameters
196             #
197             my %LinetoParameterTemplate = (
198             positional => {
199             ".." => [ "distance", "heading" ],
200             "@" => [ "points" ],
201             },
202             named => [
203             @PolylineCommonParameters,
204             @Graphics::Fig::Parameters::ArrowParameters,
205             \%Graphics::Fig::Parameters::CapStyleParameter,
206             {
207             name => "distance",
208             convert => \&Graphics::Fig::Parameters::convertLength,
209             },
210             {
211             name => "heading",
212             convert => \&Graphics::Fig::Parameters::convertAngle,
213             },
214             {
215             name => "detachedLineto",
216             convert => \&Graphics::Fig::Parameters::convertBool,
217             aliases => [ "new" ],
218             }
219             ],
220             );
221              
222             #
223             # Box Parameters
224             #
225             my %BoxParameterTemplate = (
226             positional => {
227             ".." => [ "width", "height" ],
228             "@" => [ "points" ],
229             },
230             named => [
231             @PolylineCommonParameters,
232             \%Graphics::Fig::Parameters::CenterParameter,
233             \%Graphics::Fig::Parameters::CornerRadiusParameter,
234             {
235             name => "width",
236             convert => \&Graphics::Fig::Parameters::convertLength,
237             },
238             {
239             name => "height",
240             convert => \&Graphics::Fig::Parameters::convertLength,
241             },
242             ],
243             );
244              
245             #
246             # Polygon Parameters
247             #
248             my %PolygonParameterTemplate = (
249             positional => {
250             ".." => [ "n", "r" ],
251             "@" => [ "points" ],
252             },
253             named => [
254             @PolylineCommonParameters,
255             \%Graphics::Fig::Parameters::CenterParameter,
256             \%Graphics::Fig::Parameters::RotationParameter,
257             {
258             name => "n",
259             convert => \&Graphics::Fig::Parameters::convertInt,
260             },
261             {
262             name => "r",
263             convert => \&Graphics::Fig::Parameters::convertLength,
264             aliases => [ "radius" ],
265             },
266             ],
267             );
268              
269             #
270             # Picture Parameters
271             #
272             my %PictureParameterTemplate = (
273             positional => {
274             "" => [ ],
275             "." => [ "filename" ],
276             ".." => [ "filename", "width" ],
277             "..." => [ "filename", "width", "height" ],
278             ".@" => [ "filename", "points" ],
279             },
280             named => [
281             @PolylineCommonParameters,
282             \%Graphics::Fig::Parameters::CenterParameter,
283             {
284             name => "filename",
285             },
286             {
287             name => "width",
288             convert => \&Graphics::Fig::Parameters::convertLength,
289             },
290             {
291             name => "height",
292             convert => \&Graphics::Fig::Parameters::convertLength,
293             },
294             {
295             name => "resolution",
296             convert => \&convertResolution,
297             },
298             ],
299             );
300              
301             #
302             # Graphics::Fig::Polyline::new: base constructor
303             # $proto: prototype
304             # $parameters: ref to parameter hash
305             #
306             sub new {
307 71     71 0 104 my $proto = shift;
308 71         81 my $subtype = shift;
309 71         89 my $parameters = shift;
310              
311             my $self = {
312             subtype => $subtype,
313 71         114 lineStyle => ${$parameters}{"lineStyle"},
314 71         105 lineThickness => ${$parameters}{"lineThickness"},
315 71         99 penColor => ${$parameters}{"penColor"},
316 71         88 fillColor => ${$parameters}{"fillColor"},
317 71         95 depth => ${$parameters}{"depth"},
318 71         91 areaFill => ${$parameters}{"areaFill"},
319 71         86 styleVal => ${$parameters}{"styleVal"},
320 71         97 joinStyle => ${$parameters}{"joinStyle"},
  71         619  
321             capStyle => 0,
322             cornerRadius => 0,
323             fArrow => undef,
324             bArrow => undef,
325             points => [],
326             };
327              
328 71   33     275 my $class = ref($proto) || $proto;
329 71         121 bless($self, $class);
330 71         136 return $self;
331             }
332              
333             #
334             # Graphics::Fig::Polyline::polyline constructor
335             # $proto: prototype
336             # $fig: parent object
337             # @parameters: polyline parameters
338             #
339             sub polyline {
340 11     11 0 16 my $proto = shift;
341 11         13 my $fig = shift;
342              
343             #
344             # Parse parameters.
345             #
346 11         14 my %parameters;
347 11         13 my $stack = ${$fig}{"stack"};
  11         19  
348 11         14 my $tos = ${$stack}[$#{$stack}];
  11         16  
  11         15  
349 11         15 eval {
350             Graphics::Fig::Parameters::parse($fig, "polyline",
351             \%PolylineParameterTemplate,
352 11         18 ${$tos}{"options"}, \%parameters, @_);
  11         27  
353             };
354 11 50       23 if ($@) {
355 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
356 0         0 croak("$@");
357             }
358              
359             #
360             # Make sure that at least two points were given.
361             #
362 11         14 my $temp;
363 11 50 50     30 if (!defined($temp = $parameters{"points"}) || scalar(@{$temp} < 2)) {
  11         31  
364 0         0 croak("polyline: error: at least two points must be given");
365             }
366              
367             #
368             # Set remaining parameters.
369             #
370 11         35 my $self = $proto->new(1, \%parameters);
371 11         16 ${$self}{"capStyle"} = $parameters{"capStyle"};
  11         30  
372 11         14 ${$self}{"points"} = $parameters{"points"};
  11         16  
373 11         46 Graphics::Fig::Parameters::copyArrowParameters($self, \%parameters);
374              
375 11         14 push(@{${$tos}{"objects"}}, $self);
  11         13  
  11         22  
376 11         45 return $self;
377             }
378              
379             #
380             # Graphics::Fig::Polyline::lineto
381             # $proto: prototype
382             # $fig: parent object
383             # @parameters: polygon parameters
384             #
385             sub lineto {
386 29     29 0 37 my $proto = shift;
387 29         45 my $fig = shift;
388 29         91 my $self;
389              
390             #
391             # Parse parameters.
392             #
393             my %parameters;
394 29         65 my $stack = ${$fig}{"stack"};
  29         44  
395 29         31 my $tos = ${$stack}[$#{$stack}];
  29         40  
  29         38  
396 29         36 eval {
397             Graphics::Fig::Parameters::parse($fig, "lineto",
398             \%LinetoParameterTemplate,
399 29         37 ${$tos}{"options"}, \%parameters, @_);
  29         69  
400             };
401 29 50       62 if ($@) {
402 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
403 0         0 croak("$@");
404             }
405              
406             #
407             # Check parameters and get the new points.
408             #
409 29         41 my $newPoints = $parameters{"points"};
410 29 100       63 if (!defined($newPoints)) {
411 18 50       36 if (!defined($parameters{"distance"})) {
412 0         0 croak("lineto error: expected distance and heading, or points");
413             }
414 18 50       31 if (!defined($parameters{"heading"})) {
415 0         0 croak("lineto error: expected distance and heading, or points");
416             }
417             $newPoints = [[
418             $parameters{"position"}[0] +
419             $parameters{"distance"} * cos($parameters{"heading"}),
420             $parameters{"position"}[1] -
421 18         187 $parameters{"distance"} * sin($parameters{"heading"})
422             ]];
423              
424             } else {
425 11 50       33 if (defined($parameters{"distance"})) {
426 0         0 croak("lineto error: distance cannot be given with points");
427             }
428 11 50       20 if (defined($parameters{"heading"})) {
429 0         0 croak("lineto error: heading cannot be given with points");
430             }
431 11 50       11 if (scalar(@{$newPoints}) == 0) {
  11         25  
432 0         0 croak("lineto error: expected at least one point");
433             }
434             }
435              
436             #
437             # If we have an open lineto object, get the object, curPoints and
438             # finalPoint.
439             #
440 29         48 my $curPoints;
441             my $finalPoint;
442 29 100       29 if (defined($self = ${$tos}{"openLineto"})) {
  29         64  
443 20         25 $curPoints = ${$self}{"points"};
  20         28  
444 20         26 $finalPoint = ${$curPoints}[$#{$curPoints}];
  20         38  
  20         25  
445             }
446              
447             #
448             # If we don't have an open lineto object, or if any parameter has
449             # changed from the existing object, construct a new object.
450             #
451 29         41 my $position = $parameters{"position"};
452 29 50 66     124 if (!defined($self) || !defined($finalPoint) ||
      100        
      100        
      66        
      66        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
453             $parameters{"detachedLineto"} ||
454 16         22 ${$position}[0] != ${$finalPoint}[0] ||
  16         53  
455 12         25 ${$position}[1] != ${$finalPoint}[1] ||
  12         35  
456 12         31 ${$self}{"lineStyle"} != $parameters{"lineStyle"} ||
457 12         37 ${$self}{"lineThickness"} != $parameters{"lineThickness"} ||
458 12         37 ${$self}{"penColor"} != $parameters{"penColor"} ||
459 12         29 ${$self}{"fillColor"} != $parameters{"fillColor"} ||
460 12         29 ${$self}{"depth"} != $parameters{"depth"} ||
461 12         34 ${$self}{"areaFill"} != $parameters{"areaFill"} ||
462 12         47 ${$self}{"styleVal"} != $parameters{"styleVal"} ||
463 12         41 ${$self}{"joinStyle"} != $parameters{"joinStyle"} ||
464 12         58 ${$self}{"capStyle"} != $parameters{"capStyle"} ||
465             Graphics::Fig::Parameters::compareArrowParameters($self,
466             \%parameters) != 0) {
467              
468 17         53 $self = $proto->new(1, \%parameters);
469 17         26 ${$self}{"capStyle"} = $parameters{"capStyle"};
  17         33  
470 17         22 ${$self}{"points"} = $parameters{"points"};
  17         22  
471 17         52 Graphics::Fig::Parameters::copyArrowParameters($self, \%parameters);
472 17         26 $curPoints = [ $position ];
473 17         22 ${$self}{"points"} = $curPoints;
  17         25  
474 17         24 push(@{${$tos}{"objects"}}, $self);
  17         17  
  17         31  
475 17         27 ${$tos}{"openLineto"} = $self;
  17         23  
476             }
477              
478             #
479             # Add the new points and set position to the final point.
480             #
481 29         42 push(@{$curPoints}, @{$newPoints});
  29         38  
  29         53  
482 29         34 ${$tos}{"options"}{"position"} = ${$newPoints}[$#{$newPoints}];
  29         50  
  29         37  
  29         33  
483              
484 29         133 return $self;
485             }
486              
487             #
488             # Graphics::Fig::Polyline::box constructor
489             # $proto: prototype
490             # $fig: parent object
491             # @parameters: box parameters
492             #
493             sub box {
494 17     17 0 42 my $proto = shift;
495 17         23 my $fig = shift;
496              
497             #
498             # Parse parameters.
499             #
500 17         24 my %parameters;
501 17         54 my $stack = ${$fig}{"stack"};
  17         34  
502 17         23 my $tos = ${$stack}[$#{$stack}];
  17         30  
  17         36  
503 17         25 eval {
504             Graphics::Fig::Parameters::parse($fig, "box",
505             \%BoxParameterTemplate,
506 17         78 ${$tos}{"options"}, \%parameters, @_);
  17         126  
507             };
508 17 50       44 if ($@) {
509 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
510 0         0 croak("$@");
511             }
512              
513             #
514             # Construct the object.
515             #
516 17         22 my $self;
517 17         28 my $cornerRadius = $parameters{"cornerRadius"};
518 17 50 33     48 if (defined($cornerRadius) && $cornerRadius != 0) {
519 0         0 $self = $proto->new(4, \%parameters);
520 0         0 ${$self}{"cornerRadius"} = $cornerRadius;
  0         0  
521             } else {
522 17         66 $self = $proto->new(2, \%parameters);
523             }
524              
525             #
526             # Construct the box from two corners.
527             #
528 17         26 my $temp;
529 17 100 33     74 if (defined($temp = $parameters{"points"})) {
    50          
530 9         24 my ($x1, $y1, $x2, $y2);
531              
532 9 50       27 if (defined($parameters{"width"})) {
533 0         0 croak("box: error: width not allowed with points");
534             }
535 9 50       22 if (defined($parameters{"height"})) {
536 0         0 croak("box: error: height not allowed with points");
537             }
538 9 50       23 if (defined($parameters{"center"})) {
539 0         0 croak("box: error: center not allowed with points");
540             }
541 9 50       10 if (scalar(@{$temp}) == 1) {
  9 50       27  
542 0         0 ($x1, $y1) = @{$parameters{"position"}};
  0         0  
543 0         0 ($x2, $y2) = @{${$temp}[0]};
  0         0  
  0         0  
544 9         40 } elsif (scalar(@{$temp}) == 2) {
545 9         14 ($x1, $y1) = @{${$temp}[0]};
  9         12  
  9         24  
546 9         13 ($x2, $y2) = @{${$temp}[1]};
  9         11  
  9         1567  
547             } else {
548 0         0 croak("box: error: expected 1 or 2 points");
549             }
550 9         62 ${$self}{"points"} = [
  9         35  
551             [ $x1, $y1 ], [ $x2, $y1 ], [ $x2, $y2 ], [ $x1, $y2 ], [ $x1, $y1 ]
552             ];
553              
554             } elsif (defined(my $width = $parameters{"width"}) &&
555             defined(my $height = $parameters{"height"})) {
556 8         11 my ($xc, $yc);
557 8 100       19 if (defined($parameters{"center"})) {
558 3         11 ($xc, $yc) = @{$parameters{"center"}};
  3         8  
559             } else {
560 5         8 ($xc, $yc) = @{$parameters{"position"}};
  5         12  
561             }
562 8         15 my $dx = $width / 2.0;
563 8         13 my $dy = $height / 2.0;
564 8         44 ${$self}{"points"} = [
  8         21  
565             [ $xc - $dx, $yc - $dy ],
566             [ $xc + $dx, $yc - $dy ],
567             [ $xc + $dx, $yc + $dy ],
568             [ $xc - $dx, $yc + $dy ],
569             [ $xc - $dx, $yc - $dy ]
570             ];
571              
572             } else {
573 0         0 croak("box: error: expected width and height or 1 or 2 points");
574             }
575 17         45 push(@{${$tos}{"objects"}}, $self);
  17         32  
  17         45  
576 17         83 return $self;
577             }
578              
579             #
580             # Graphics::Fig::Polyline::polygon constructor
581             # $proto: prototype
582             # $fig: parent object
583             # @parameters: polygon parameters
584             #
585             sub polygon {
586 7     7 0 24 my $proto = shift;
587 7         9 my $fig = shift;
588              
589             #
590             # Parse parameters.
591             #
592 7         8 my %parameters;
593 7         8 my $stack = ${$fig}{"stack"};
  7         14  
594 7         7 my $tos = ${$stack}[$#{$stack}];
  7         10  
  7         10  
595 7         12 eval {
596             Graphics::Fig::Parameters::parse($fig, "polygon",
597             \%PolygonParameterTemplate,
598 7         57 ${$tos}{"options"}, \%parameters, @_);
  7         90  
599             };
600 7 50       22 if ($@) {
601 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
602 0         0 croak("$@");
603             }
604              
605             #
606             # Construct the object.
607             #
608 7         22 my $self = $proto->new(3, \%parameters);
609              
610             #
611             # Regular Polygon
612             #
613 7         9 my $n;
614 7 100       18 if (defined($n = $parameters{"n"})) {
615 5         7 my $center;
616 5         6 my $rotation = 0.0;
617 5         8 my $firstPoint;
618             my $basePoint; # first with center at origin
619              
620             #
621             # Minimum n is 3.
622             #
623 5 50       7 if ($n < 3) {
624 0         0 croak("polygon: error: n must be at least 3");
625             }
626              
627             #
628             # Find the center.
629             #
630 5 100       10 if (defined($parameters{"center"})) {
631 1         2 $center = $parameters{"center"};
632             } else {
633 4         5 $center = $parameters{"position"};
634             }
635              
636             #
637             # Get the first point.
638             #
639 5 100       9 if (defined($parameters{"points"})) {
640 1         2 my $points = $parameters{"points"};
641 1 50       1 if (scalar(@{$points}) != 1) {
  1         4  
642 0         0 croak("polygon: error: only one point allowed with n");
643             }
644 1         1 $firstPoint = ${$points}[0];
  1         3  
645 1         2 $basePoint = [ ${$firstPoint}[0] - ${$center}[0],
  1         3  
646 1         1 ${$firstPoint}[1] - ${$center}[1] ];
  1         2  
  1         2  
647 1 50       3 if (defined($parameters{"r"})) {
648 0         0 croak("polygon: error: r not allowed with points");
649             }
650 1 50       3 if (defined($parameters{"rotation"})) {
651 0         0 croak("polygon: error: rotation not allowed with points");
652             }
653             } else {
654 4         4 my $r;
655 4 50       9 if (!defined($r = $parameters{"r"})) {
656 0         0 croak("polygon: error: r parameter required");
657             }
658 4 100       8 if (defined($parameters{"rotation"})) {
659 2         3 $rotation = $parameters{"rotation"};
660             }
661 4         19 $basePoint = [ $r * cos($rotation), -$r * sin($rotation) ];
662 4         4 $firstPoint = [ ${$basePoint}[0] + ${$center}[0],
  4         8  
663 4         7 ${$basePoint}[1] + ${$center}[1] ];
  4         4  
  4         8  
664             }
665 5         7 push(@{${$self}{"points"}}, $firstPoint);
  5         6  
  5         14  
666 5         11 for (my $i = 1; $i < $n; ++$i) {
667 13         53 my $c = cos(2 * pi * $i / $n);
668 13         24 my $s = sin(2 * pi * $i / $n);
669             my $point = [
670 13         21 $c * ${$basePoint}[0] + $s * ${$basePoint}[1] + ${$center}[0],
  13         16  
  13         18  
671 13         14 -$s * ${$basePoint}[0] + $c * ${$basePoint}[1] + ${$center}[1]
  13         16  
  13         14  
  13         24  
672             ];
673 13         18 push(@{${$self}{"points"}}, $point);
  13         11  
  13         37  
674             }
675              
676             #
677             # Polygon from Points
678             #
679             } else {
680 2         4 my $points = $parameters{"points"};
681 2 50       4 if (scalar(@{$points}) < 3) {
  2         6  
682 0         0 croak("polygon: error: expected n or at least 3 points");
683             }
684 2 50       9 if (defined($parameters{"r"})) {
685 0         0 croak("polygon: error: r not allowed with points");
686             }
687 2 50       6 if (defined($parameters{"rotation"})) {
688 0         0 croak("polygon: error: rotation not allowed with points");
689             }
690 2         3 @{${$self}{"points"}} = @{$points};
  2         3  
  2         14  
  2         4  
691             }
692              
693             #
694             # Duplicate the first point.
695             #
696             {
697 7         12 my $points = ${$self}{"points"};
  7         8  
  7         10  
698 7         10 push(@{$points}, ${$points}[0]);
  7         7  
  7         16  
699             }
700 7         22 push(@{${$tos}{"objects"}}, $self);
  7         9  
  7         15  
701 7         31 return $self;
702             }
703              
704             #
705             # Graphics::Fig::Polyline::picture constructor
706             # $proto: prototype
707             # $fig: parent object
708             # @parameters: picture parameters
709             #
710             sub picture {
711 19     19 0 27 my $proto = shift;
712 19         24 my $fig = shift;
713              
714             #
715             # Parse parameters.
716             #
717 19         20 my %parameters;
718 19         22 my $stack = ${$fig}{"stack"};
  19         32  
719 19         20 my $tos = ${$stack}[$#{$stack}];
  19         26  
  19         24  
720 19         40 eval {
721             Graphics::Fig::Parameters::parse($fig, "pictures",
722             \%PictureParameterTemplate,
723 19         95 ${$tos}{"options"}, \%parameters, @_);
  19         114  
724             };
725 19 50       36 if ($@) {
726 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
727 0         0 croak("$@");
728             }
729              
730             #
731             # Make sure the filename was given.
732             #
733 19         23 my $filename = $parameters{"filename"};
734 19 50       41 if (!defined($filename)) {
735 0         0 croak("picture: error: filename must be given");
736             }
737 19 50       66 if ($filename =~ m/\n/) {
738 0         0 croak("picture: error: invalid filename");
739             }
740              
741             #
742             # Construct the object.
743             #
744 19         61 my $self = $proto->new(5, \%parameters);
745 19         23 ${$self}{"filename"} = $filename;
  19         43  
746 19         24 ${$self}{"flipped"} = 0;
  19         46  
747              
748             #
749             # Construct the bounding box from two corners.
750             #
751 19         20 my $temp;
752 19 100       40 if (defined($temp = $parameters{"points"})) {
753 13         17 my ($x1, $y1, $x2, $y2);
754              
755 13 50       40 if (defined($parameters{"width"})) {
756 0         0 croak("picture: error: width not allowed with points");
757             }
758 13 50       23 if (defined($parameters{"height"})) {
759 0         0 croak("picture: error: height not allowed with points");
760             }
761 13 50       24 if (defined($parameters{"center"})) {
762 0         0 croak("picture: error: center not allowed with points");
763             }
764 13 50       13 if (scalar(@{$temp}) == 1) {
  13 50       23  
765 0         0 ($x1, $y1) = @{$parameters{"position"}};
  0         0  
766 0         0 ($x2, $y2) = @{${$temp}[0]};
  0         0  
  0         0  
767 13         21 } elsif (scalar(@{$temp}) == 2) {
768 13         14 ($x1, $y1) = @{${$temp}[0]};
  13         14  
  13         26  
769 13         16 ($x2, $y2) = @{${$temp}[1]};
  13         14  
  13         21  
770             } else {
771 0         0 croak("picture: error: expected 1 or 2 points");
772             }
773 13         43 ${$self}{"points"} = [
  13         23  
774             [ $x1, $y1 ], [ $x2, $y1 ], [ $x2, $y2 ], [ $x1, $y2 ], [ $x1, $y1 ]
775             ];
776              
777             } else {
778             #
779             # Find the center.
780             #
781 6         7 my ($xc, $yc);
782 6 100       10 if (defined($parameters{"center"})) {
783 1         2 ( $xc, $yc ) = @{$parameters{"center"}};
  1         2  
784             } else {
785 5         6 ( $xc, $yc ) = @{$parameters{"position"}};
  5         11  
786             }
787              
788             #
789             # Find width and height. If the size is not completely specified,
790             # compute the missing width and height from the image properties.
791             #
792 6         10 my $width = $parameters{"width"};
793 6         8 my $height = $parameters{"height"};
794 6         8 my $resolution = $parameters{"resolution"};
795 6 100 100     17 if (!defined($width) || !defined($height)) {
796 5         16 my $info = image_info($filename);
797 5 50       17023 if (my $error = ${$info}{"error"}) {
  5         23  
798 0         0 croak("picture: error: ${error}");
799             }
800 5 100       12 if (!defined($resolution)) {
801 3         4 $resolution = &_convertResolution(${$info}{"resolution"}, 1);
  3         8  
802             }
803 5 50       14 die "picture: internal error" unless ref($resolution) eq "ARRAY";
804 5         8 my $nWidth = ${$info}{"width"};
  5         8  
805 5         6 my $nHeight = ${$info}{"height"};
  5         6  
806 5 50 33     33 if (!defined($nWidth) || $nWidth <= 0.0 ||
      33        
      33        
807             !defined($nHeight) || $nHeight <= 0.0) {
808 0         0 croak("picture: error: cannot determine image size");
809             }
810 5         9 $nWidth /= ${$resolution}[0];
  5         9  
811 5         8 $nHeight /= ${$resolution}[1];
  5         7  
812 5 100       10 if (defined($width)) {
    100          
813 1         11 $height = $nHeight * $width / $nWidth;
814             } elsif (defined($height)) {
815 1         14 $width = $nWidth * $height / $nHeight;
816             } else {
817 3         5 $width = $nWidth;
818 3         34 $height = $nHeight;
819             }
820             }
821 6         11 my $dx = $width / 2.0;
822 6         9 my $dy = $height / 2.0;
823 6         28 ${$self}{"points"} = [
  6         13  
824             [ $xc - $dx, $yc - $dy ],
825             [ $xc + $dx, $yc - $dy ],
826             [ $xc + $dx, $yc + $dy ],
827             [ $xc - $dx, $yc + $dy ],
828             [ $xc - $dx, $yc - $dy ]
829             ];
830             }
831              
832 19         24 push(@{${$tos}{"objects"}}, $self);
  19         23  
  19         38  
833 19         88 return $self;
834             }
835              
836             #
837             # Graphics::Fig::Polyline::translate
838             # $self: object
839             # $parameters: reference to parameter hash
840             #
841             sub translate {
842 17     17 0 24 my $self = shift;
843 17         21 my $parameters = shift;
844              
845 17         21 @{${$self}{"points"}} = Graphics::Fig::Parameters::translatePoints(
  17         40  
846 17         30 $parameters, @{${$self}{"points"}});
  17         27  
  17         45  
847              
848 17         61 return 1;
849             }
850              
851             #
852             # Graphics::Fig::Polyline::rotate
853             # $self: object
854             # $parameters: reference to parameter hash
855             #
856             sub rotate {
857 17     17 0 25 my $self = shift;
858 17         21 my $parameters = shift;
859 17         21 my $rotation = ${$parameters}{"rotation"};
  17         24  
860              
861 17         21 @{${$self}{"points"}} = Graphics::Fig::Parameters::rotatePoints(
  17         44  
862 17         23 $parameters, @{${$self}{"points"}});
  17         18  
  17         59  
863              
864             # Change box and arc-box to polygon if rotated to a non right angle.
865 17         24 my $subtype = ${$self}{"subtype"};
  17         25  
866 17 100 66     102 if (sin($rotation) * cos($rotation) != 0 &&
      33        
867             ($subtype == 2 || $subtype == 4)) {
868 3         5 ${$self}{"subtype"} = 3;
  3         5  
869             }
870              
871 17         52 return 1;
872             }
873              
874             #
875             # Graphics::Fig::Polyline::scale
876             # $self: object
877             # $parameters: reference to parameter hash
878             #
879             sub scale {
880 6     6 0 13 my $self = shift;
881 6         6 my $parameters = shift;
882              
883 6         8 @{${$self}{"points"}} = Graphics::Fig::Parameters::scalePoints(
  6         20  
884 6         12 $parameters, @{${$self}{"points"}});
  6         8  
  6         18  
885              
886 6         9 my $subtype = ${$self}{"subtype"};
  6         12  
887 6 100       23 if ($subtype == 5) {
888 4         5 my $scale = ${$parameters}{"scale"};
  4         9  
889 4 100       5 if (${$scale}[0] * ${$scale}[1] < 0) {
  4         5  
  4         17  
890 2         3 ${$self}{"flipped"} ^= 1;
  2         13  
891             }
892             }
893             }
894              
895             #
896             # Graphics::Fig::Polyline return [[xmin, ymin], [xmax, ymax]]
897             # $self: object
898             # $parameters: getbbox parameters
899             #
900             sub getbbox {
901 19     19 0 27 my $self = shift;
902 19         21 my $parameters = shift;
903              
904 19         20 return Graphics::Fig::Parameters::getbboxFromPoints(@{${$self}{"points"}});
  19         21  
  19         49  
905             }
906              
907             #
908             # Graphics::Fig::Polyline::print
909             # $self: object
910             # $fh: reference to output file handle
911             # $parameters: save parameters
912             #
913             sub print {
914 71     71 0 98 my $self = shift;
915 71         81 my $fh = shift;
916 71         81 my $parameters = shift;
917              
918 71         117 my $figPerInch = Graphics::Fig::_figPerInch($parameters);
919 71         84 my $subtype = ${$self}{"subtype"};
  71         124  
920              
921             #
922             # Print
923             #
924             printf $fh ("2 %d %d %.0f %d %d %d -1 %d %.3f %d %d %.0f %d %d %d\n",
925             $subtype,
926 71         94 ${$self}{"lineStyle"},
927 71         106 ${$self}{"lineThickness"} * 80.0,
928 71         99 ${$self}{"penColor"},
929 71         88 ${$self}{"fillColor"},
930 71         80 ${$self}{"depth"},
931 71         84 ${$self}{"areaFill"},
932 71         98 ${$self}{"styleVal"} * 80.0,
933 71         84 ${$self}{"joinStyle"},
934 71         83 ${$self}{"capStyle"},
935 71         100 ${$self}{"cornerRadius"} * 80.0,
936 71         125 defined(${$self}{"fArrow"}) ? 1 : 0,
937 71         127 defined(${$self}{"bArrow"}) ? 1 : 0,
938 71 100       102 scalar(@{${$self}{"points"}}));
  71 100       75  
  71         500  
939 71         259 Graphics::Fig::Parameters::printArrowParameters($self, $fh, $parameters);
940 71 100       149 if ($subtype == 5) {
941 19         23 printf $fh (" %d %s\n", ${$self}{"flipped"}, ${$self}{"filename"});
  19         20  
  19         56  
942             }
943 71         96 foreach my $point (@{${$self}{"points"}}) {
  71         94  
  71         188  
944             printf $fh ("\t%.0f %.0f\n",
945 290         359 ${$point}[0] * $figPerInch,
946 290         337 ${$point}[1] * $figPerInch);
  290         837  
947             }
948             }
949              
950             1;