File Coverage

lib/Graphics/Fig/Spline.pm
Criterion Covered Total %
statement 232 286 81.1
branch 31 54 57.4
condition 28 62 45.1
subroutine 14 18 77.7
pod 0 11 0.0
total 305 431 70.7


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::Spline;
18             our $VERSION = 'v1.0.7';
19              
20 12     12   89 use strict;
  12         21  
  12         450  
21 12     12   56 use warnings;
  12         22  
  12         310  
22 12     12   55 use Carp;
  12         19  
  12         642  
23 12     12   61 use Math::Trig;
  12         20  
  12         2054  
24 12     12   82 use Image::Info qw(image_info);
  12         21  
  12         617  
25 12     12   91 use Graphics::Fig::Color;
  12         38  
  12         310  
26 12     12   66 use Graphics::Fig::Parameters;
  12         29  
  12         30202  
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             #
36             # Graphics::Fig::Spline::validateControlPoint
37             #
38             sub validateControlPoint {
39 11     11 0 14 my $prefix = shift;
40 11         13 my $value = shift;
41              
42 11 50       149 if (!($value =~ m/^\s*($RE_REAL)/)) {
43 0         0 croak("${prefix}: expected number");
44             }
45 11 50 33     50 if ($value < -1.0 || $value > 1.0) {
46 0         0 croak("${prefix}: control point must be in -1.0 .. +1.0");
47             }
48 11         18 return 1;
49             }
50              
51             #
52             # Graphics::Fig::Spline::convertShapeFactors
53             # $fig: fig object
54             # $prefix: error message prefix
55             # $value: control point array
56             #
57             sub convertShapeFactors {
58 8     8 0 12 my $fig = shift;
59 8         10 my $prefix = shift;
60 8         9 my $value = shift;
61 8         9 my $context = shift;
62              
63 8 100       17 if (ref($value) eq "") {
64 7         16 &validateControlPoint($prefix, $value);
65 7         16 return $value;
66             }
67 1 50       4 if (ref($value) ne "ARRAY") {
68 0         0 croak("${prefix}: error: expected number or array");
69             }
70 1         3 foreach my $element (@{$value}) {
  1         2  
71 4         8 &validateControlPoint($prefix, $element);
72             }
73 1         3 return $value;
74             }
75              
76             my @SplineCommonParameters = (
77             \%Graphics::Fig::Parameters::UnitsParameter, # must be first
78             \%Graphics::Fig::Parameters::PositionParameter, # must be second
79             \%Graphics::Fig::Parameters::ColorParameter,
80             \%Graphics::Fig::Parameters::DepthParameter,
81             @Graphics::Fig::Parameters::LineParameters,
82             @Graphics::Fig::Parameters::FillParameters,
83             \%Graphics::Fig::Parameters::CapStyleParameter,
84             @Graphics::Fig::Parameters::ArrowParameters,
85             \%Graphics::Fig::Parameters::PointsParameter,
86             {
87             name => "splineSubtype",
88             convert => \&Graphics::Fig::Parameters::convertSplineSubtype,
89             aliases => [ "subtype" ],
90             },
91             {
92             name => "shapeFactors",
93             convert => \&convertShapeFactors,
94             aliases => [ "shapeFactor" ],
95             },
96             );
97              
98             #
99             # Spline Parameters
100             #
101             my %SplineParameterTemplate = (
102             positional => {
103             "@" => [ "points" ],
104             },
105             named => [
106             @SplineCommonParameters,
107             ],
108             );
109              
110             #
111             # Splineto Parameters
112             #
113             my %SplinetoParameterTemplate = (
114             positional => {
115             ".." => [ "distance", "heading" ],
116             "@" => [ "points" ],
117             },
118             named => [
119             @SplineCommonParameters,
120             {
121             name => "distance",
122             convert => \&Graphics::Fig::Parameters::convertLength,
123             },
124             {
125             name => "heading",
126             convert => \&Graphics::Fig::Parameters::convertAngle,
127             },
128             {
129             name => "new",
130             convert => \&Graphics::Fig::Parameters::convertBool,
131             }
132             ],
133             );
134              
135             #
136             # Graphics::Fig::Spline::new: base constructor
137             # $proto: prototype
138             # $parameters: ref to parameter hash
139             #
140             sub new {
141 16     16 0 24 my $proto = shift;
142 16         18 my $parameters = shift;
143              
144             my $self = {
145 16         20 subtype => ${$parameters}{"splineSubtype"},
146 16         20 lineStyle => ${$parameters}{"lineStyle"},
147 16         21 lineThickness => ${$parameters}{"lineThickness"},
148 16         20 penColor => ${$parameters}{"penColor"},
149 16         20 fillColor => ${$parameters}{"fillColor"},
150 16         17 depth => ${$parameters}{"depth"},
151 16         17 areaFill => ${$parameters}{"areaFill"},
152 16         19 styleVal => ${$parameters}{"styleVal"},
  16         111  
153             capStyle => 0,
154             fArrow => undef,
155             bArrow => undef,
156             points => [],
157             shapeFactors => [],
158             };
159              
160 16   33     55 my $class = ref($proto) || $proto;
161 16         22 bless($self, $class);
162 16         29 return $self;
163             }
164              
165             #
166             # Graphics::Fig::Spline::addPoints: add points and shapeFactors
167             # $self: object
168             # $parameters: reference to parameter hash
169             # $newPoints: reference to array of points to add
170             #
171             sub addPoints {
172 19     19 0 23 my $self = shift;
173 19         22 my $prefix = shift;
174 19         24 my $parameters = shift;
175 19         22 my $newPoints = shift;
176              
177             #
178             # Add the new points.
179             #
180 19         19 push(@{${$self}{"points"}}, @{$newPoints});
  19         19  
  19         30  
  19         32  
181              
182             #
183             # Add the new shape factors.
184             #
185 19         20 my $subtype = ${$self}{"subtype"};
  19         25  
186 19 100       21 if (defined(my $shapeFactors = ${$parameters}{"shapeFactors"})) {
  19         42  
187 8 50 66     21 if ($subtype != 4 && $subtype != 5) {
188 0         0 croak("${prefix}: shapeFactors may be given only with xspline");
189             }
190 8         9 my $m = scalar(@{$newPoints});
  8         11  
191              
192             #
193             # If the shapeFactor(s) parameter is a scalar, apply it to
194             # each point.
195             #
196 8 100       17 if (ref($shapeFactors) eq "") {
197 7         16 for (my $i = 0; $i < $m; ++$i) {
198 28         28 push(@{${$self}{"shapeFactors"}}, $shapeFactors);
  28         26  
  28         59  
199             }
200             #
201             # Otherwise, the length of the shapeFactor vector must be the
202             # same as length of the new point vector.
203             #
204             } else {
205 1         2 my $n = scalar(@{$shapeFactors});
  1         2  
206 1 50       3 if ($n != $m) {
207 0         0 croak("${prefix}: expected ${m} control points; found ${n}");
208             }
209 1         1 push(@{${$self}{"shapeFactors"}}, @{$shapeFactors});
  1         2  
  1         2  
  1         2  
210             }
211              
212             #
213             # For approximated and interpolated splines, set the shape
214             # factors to 1 and -1, respectively.
215             #
216             } else {
217 11 50 33     36 if ($subtype == 4 || $subtype == 5) {
218 0         0 croak("${prefix}: xspline requires shapeFactors parameter");
219             }
220 11         17 for (my $i = 0; $i < scalar(@{$newPoints}); ++$i) {
  39         74  
221 28 100       29 push(@{${$self}{"shapeFactors"}}, $subtype < 2 ? 1.0 : -1.0);
  28         26  
  28         58  
222             }
223             }
224             }
225              
226             #
227             # Graphics::Fig::Spline::spline constructor
228             # $proto: prototype
229             # $fig: parent object
230             # @parameters: spline parameters
231             #
232             sub spline {
233 13     13 0 18 my $proto = shift;
234 13         14 my $fig = shift;
235              
236             #
237             # Parse parameters.
238             #
239 13         15 my %parameters;
240 13         14 my $stack = ${$fig}{"stack"};
  13         19  
241 13         14 my $tos = ${$stack}[$#{$stack}];
  13         18  
  13         15  
242 13         18 eval {
243             Graphics::Fig::Parameters::parse($fig, "spline",
244             \%SplineParameterTemplate,
245 13         15 ${$tos}{"options"}, \%parameters, @_);
  13         29  
246             };
247 13 50       24 if ($@) {
248 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
249 0         0 croak("$@");
250             }
251              
252             #
253             # Make sure that at least three points were given.
254             #
255 13         19 my $temp;
256 13 50 50     28 if (!defined($temp = $parameters{"points"}) || scalar(@{$temp} < 3)) {
  13         30  
257 0         0 croak("spline: error: at least three points must be given");
258             }
259 13         15 my @newPoints = @{$temp};
  13         23  
260              
261             #
262             # Build object.
263             #
264 13         34 my $self = $proto->new(\%parameters);
265 13         26 ${$self}{"capStyle"} = $parameters{"capStyle"};
  13         32  
266 13         35 &addPoints($self, "spline", \%parameters, \@newPoints);
267 13         35 Graphics::Fig::Parameters::copyArrowParameters($self, \%parameters);
268              
269 13         15 push(@{${$tos}{"objects"}}, $self);
  13         12  
  13         33  
270 13         59 return $self;
271             }
272              
273             #
274             # Graphics::Fig::Spline::splineto
275             # $proto: prototype
276             # $fig: parent object
277             # @parameters: polygon parameters
278             #
279             sub splineto {
280 6     6 0 10 my $proto = shift;
281 6         7 my $fig = shift;
282 6         55 my $self;
283              
284             #
285             # Parse parameters.
286             #
287             my %parameters;
288 6         37 my $stack = ${$fig}{"stack"};
  6         12  
289 6         8 my $tos = ${$stack}[$#{$stack}];
  6         7  
  6         7  
290 6         8 eval {
291             Graphics::Fig::Parameters::parse($fig, "splineto",
292             \%SplinetoParameterTemplate,
293 6         10 ${$tos}{"options"}, \%parameters, @_);
  6         16  
294             };
295 6 50       13 if ($@) {
296 0         0 $@ =~ s/ at [^\s]* line \d+\.\n//;
297 0         0 croak("$@");
298             }
299              
300             #
301             # Check parameters and get the new points.
302             #
303 6         8 my @newPoints;
304 6 50       15 if (!defined($parameters{"points"})) {
305 0 0       0 if (!defined($parameters{"distance"})) {
306 0         0 croak("splineto error: expected distance and heading, or points");
307             }
308 0 0       0 if (!defined($parameters{"heading"})) {
309 0         0 croak("splineto error: expected distance and heading, or points");
310             }
311             push(@newPoints, [
312             $parameters{"position"}[0] +
313             $parameters{"distance"} * cos($parameters{"heading"}),
314             $parameters{"position"}[1] -
315 0         0 $parameters{"distance"} * sin($parameters{"heading"})
316             ]);
317              
318             } else {
319 6 50       10 if (defined($parameters{"distance"})) {
320 0         0 croak("splineto error: distance cannot be given with points");
321             }
322 6 50       11 if (defined($parameters{"heading"})) {
323 0         0 croak("splineto error: heading cannot be given with points");
324             }
325 6 50       7 if (scalar(@{$parameters{"points"}}) == 0) {
  6         14  
326 0         0 croak("splineto error: expected at least one point");
327             }
328 6         6 @newPoints = @{$parameters{"points"}};
  6         13  
329             }
330              
331             #
332             # If we have an open splineto object, get the object, curPoints and
333             # finalPoint.
334             #
335 6         13 my $curPoints;
336             my $curShapeFactors;
337 6         0 my $finalPoint;
338 6 100       6 if (defined($self = ${$tos}{"openSplineto"})) {
  6         13  
339 5         6 $curPoints = ${$self}{"points"};
  5         7  
340 5         7 $curShapeFactors = ${$self}{"shapeFactors"};
  5         8  
341 5         6 $finalPoint = ${$curPoints}[$#{$curPoints}];
  5         8  
  5         6  
342             }
343              
344             #
345             # If we don't have an open splineto object, or if any parameter has
346             # changed relative to the existing object, construct a new object.
347             #
348 6         10 my $position = $parameters{"position"};
349 6 50 66     30 if (!defined($self) || !defined($finalPoint) ||
      100        
      66        
      66        
      66        
      66        
      66        
      33        
      33        
      33        
      33        
      33        
      33        
      33        
350             $parameters{"new"} ||
351 4         6 ${$position}[0] != ${$finalPoint}[0] ||
  4         11  
352 4         19 ${$position}[1] != ${$finalPoint}[1] ||
  4         14  
353 4         13 ${$self}{"subtype"} != $parameters{"splineSubtype"} ||
354 3         19 ${$self}{"lineStyle"} != $parameters{"lineStyle"} ||
355 3         10 ${$self}{"lineThickness"} != $parameters{"lineThickness"} ||
356 3         9 ${$self}{"penColor"} != $parameters{"penColor"} ||
357 3         14 ${$self}{"fillColor"} != $parameters{"fillColor"} ||
358 3         11 ${$self}{"depth"} != $parameters{"depth"} ||
359 3         8 ${$self}{"areaFill"} != $parameters{"areaFill"} ||
360 3         8 ${$self}{"styleVal"} != $parameters{"styleVal"} ||
361 3         14 ${$self}{"capStyle"} != $parameters{"capStyle"} ||
362             Graphics::Fig::Parameters::compareArrowParameters($self,
363             \%parameters) != 0) {
364              
365 3         18 $self = $proto->new(\%parameters);
366 3         5 ${$self}{"capStyle"} = $parameters{"capStyle"};
  3         9  
367 3         4 ${$self}{"points"} = $parameters{"points"};
  3         5  
368 3         11 Graphics::Fig::Parameters::copyArrowParameters($self, \%parameters);
369 3         4 $curPoints = [];
370 3         13 $curShapeFactors = [];
371 3         4 ${$self}{"points"} = $curPoints;
  3         4  
372 3         4 ${$self}{"shapeFactors"} = $curShapeFactors;
  3         4  
373 3         4 push(@{${$tos}{"objects"}}, $self);
  3         5  
  3         6  
374 3         3 ${$tos}{"openSplineto"} = $self;
  3         4  
375 3         6 unshift(@newPoints, $position);
376             }
377              
378             #
379             # Add the new points and set position to the final point.
380             #
381 6         17 &addPoints($self, "splineto", \%parameters, \@newPoints);
382 6         10 ${$tos}{"options"}{"position"} = $newPoints[$#newPoints];
  6         14  
383              
384 6         32 return $self;
385             }
386              
387             #
388             # Graphics::Fig::Spline::translate
389             # $self: object
390             # $parameters: reference to parameter hash
391             #
392             sub translate {
393 0     0 0 0 my $self = shift;
394 0         0 my $parameters = shift;
395              
396 0         0 @{${$self}{"points"}} = Graphics::Fig::Parameters::translatePoints(
  0         0  
397 0         0 $parameters, @{${$self}{"points"}});
  0         0  
  0         0  
398              
399 0         0 return 1;
400             }
401              
402             #
403             # Graphics::Fig::Spline::rotate
404             # $self: object
405             # $parameters: reference to parameter hash
406             #
407             sub rotate {
408 0     0 0 0 my $self = shift;
409 0         0 my $parameters = shift;
410 0         0 my $rotation = ${$parameters}{"rotation"};
  0         0  
411              
412 0         0 @{${$self}{"points"}} = Graphics::Fig::Parameters::rotatePoints(
  0         0  
413 0         0 $parameters, @{${$self}{"points"}});
  0         0  
  0         0  
414              
415             # Change box and arc-box to polygon if rotated to a non right angle.
416 0         0 my $subtype = ${$self}{"subtype"};
  0         0  
417 0 0 0     0 if (sin($rotation) * cos($rotation) != 0 &&
      0        
418             ($subtype == 2 || $subtype == 4)) {
419 0         0 ${$self}{"subtype"} = 3;
  0         0  
420             }
421              
422 0         0 return 1;
423             }
424              
425             #
426             # Graphics::Fig::Spline::scale
427             # $self: object
428             # $parameters: reference to parameter hash
429             #
430             sub scale {
431 0     0 0 0 my $self = shift;
432 0         0 my $parameters = shift;
433              
434 0         0 @{${$self}{"points"}} = Graphics::Fig::Parameters::scalePoints(
  0         0  
435 0         0 $parameters, @{${$self}{"points"}});
  0         0  
  0         0  
436             }
437              
438             #
439             # Graphics::Fig::Spline::getbox: return [[xmin, ymin], [xmax, ymax]]
440             # $self: object
441             # $parameters: getbbox parameters
442             #
443             sub getbbox {
444 0     0 0 0 my $self = shift;
445 0         0 my $parameters = shift;
446              
447 0         0 return Graphics::Fig::Parameters::getbboxFromPoints(@{${$self}{"points"}});
  0         0  
  0         0  
448             }
449              
450             #
451             # Graphics::Fig::Spline::print
452             # $self: object
453             # $fh: reference to output file handle
454             # $parameters: save parameters
455             #
456             sub print {
457 16     16 0 19 my $self = shift;
458 16         19 my $fh = shift;
459 16         18 my $parameters = shift;
460              
461 16         27 my $figPerInch = Graphics::Fig::_figPerInch($parameters);
462 16         15 my $subtype = ${$self}{"subtype"};
  16         24  
463              
464             #
465             # If only two points were given, format as a polyline.
466             #
467 16 100       17 if (@{${$self}{"points"}} == 2) {
  16         16  
  16         29  
468             printf $fh ("2 1 %d %.0f %d %d %d -1 %d %.3f 0 %d 0 %d %d %d\n",
469 1         2 ${$self}{"lineStyle"},
470 1         3 ${$self}{"lineThickness"} * 80.0,
471 1         1 ${$self}{"penColor"},
472 1         2 ${$self}{"fillColor"},
473 1         2 ${$self}{"depth"},
474 1         1 ${$self}{"areaFill"},
475 1         3 ${$self}{"styleVal"} * 80.0,
476 1         11 ${$self}{"capStyle"},
477 1         10 defined(${$self}{"fArrow"}) ? 1 : 0,
478 1         6 defined(${$self}{"bArrow"}) ? 1 : 0,
479 1 50       2 scalar(@{${$self}{"points"}}));
  1 50       2  
  1         8  
480 1         5 Graphics::Fig::Parameters::printArrowParameters($self, $fh,
481             $parameters);
482 1         1 foreach my $point (@{${$self}{"points"}}) {
  1         2  
  1         3  
483             printf $fh ("\t%.0f %.0f\n",
484 2         3 ${$point}[0] * $figPerInch,
485 2         3 ${$point}[1] * $figPerInch);
  2         9  
486             }
487              
488             #
489             # Otherwise, format as spline.
490             #
491             } else {
492             printf $fh ("3 %d %d %.0f %d %d %d -1 %d %.3f %d %d %d %d\n",
493             $subtype,
494 15         19 ${$self}{"lineStyle"},
495 15         20 ${$self}{"lineThickness"} * 80.0,
496 15         17 ${$self}{"penColor"},
497 15         27 ${$self}{"fillColor"},
498 15         17 ${$self}{"depth"},
499 15         17 ${$self}{"areaFill"},
500 15         20 ${$self}{"styleVal"} * 80.0,
501 15         17 ${$self}{"capStyle"},
502 15         24 defined(${$self}{"fArrow"}) ? 1 : 0,
503 15         23 defined(${$self}{"bArrow"}) ? 1 : 0,
504 15 100       22 scalar(@{${$self}{"points"}}));
  15 50       25  
  15         92  
505 15         60 Graphics::Fig::Parameters::printArrowParameters($self, $fh,
506             $parameters);
507 15         17 foreach my $point (@{${$self}{"points"}}) {
  15         15  
  15         25  
508             printf $fh ("\t%.0f %.0f\n",
509 58         73 ${$point}[0] * $figPerInch,
510 58         67 ${$point}[1] * $figPerInch);
  58         154  
511             }
512 15         18 foreach my $shapeFactors (@{${$self}{"shapeFactors"}}) {
  15         15  
  15         26  
513 58         191 printf $fh ("\t%f\n", $shapeFactors);
514             }
515             }
516             }
517              
518             1;