aboutsummaryrefslogtreecommitdiff
path: root/src/SVG/SVG2zinc/Conversions.pm
diff options
context:
space:
mode:
Diffstat (limited to 'src/SVG/SVG2zinc/Conversions.pm')
-rw-r--r--src/SVG/SVG2zinc/Conversions.pm909
1 files changed, 909 insertions, 0 deletions
diff --git a/src/SVG/SVG2zinc/Conversions.pm b/src/SVG/SVG2zinc/Conversions.pm
new file mode 100644
index 0000000..9a8ccb9
--- /dev/null
+++ b/src/SVG/SVG2zinc/Conversions.pm
@@ -0,0 +1,909 @@
+package SVG::SVG2zinc::Conversions;
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU LGPL Libray General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA,
+# or refer to http://www.gnu.org/copyleft/lgpl.html
+#
+##################################################################
+
+use Math::Trig;
+use Math::Bezier::Convert;
+use strict;
+use Carp;
+
+use vars qw( $VERSION @ISA @EXPORT );
+
+($VERSION) = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);
+
+@ISA = qw( Exporter );
+
+@EXPORT = qw( InitConv
+ removeComment convertOpacity
+ createNamedFont
+ defineNamedGradient namedGradient namedGradientDef existsGradient
+ extractGradientTypeAndStops addTransparencyToGradient
+ colorConvert
+ pathPoints points
+ cleanName
+ float2int sizesConvert sizeConvert
+ transform
+ );
+
+# some variables to be initialized at the beginning
+
+my ($warnProc, $lineNumProc); # two proc
+my %fonts; # a hashtable to identify all used fonts
+my %gradients;
+
+sub InitConv {
+ ($warnProc, $lineNumProc) = @_;
+ %fonts = ();
+ %gradients = ();
+ return 1;
+}
+
+sub myWarn{
+ &{$warnProc}(@_);
+}
+
+### remove SVG comments in the form /* */ in $str
+### returns the string without these comments
+sub removeComment {
+ my ($str) = @_;
+# my $strOrig = $str;
+ return "" unless defined $str;
+
+ while ($str =~ s|(.*)(/\*.*\*/){1}?|$1|) {
+# print "begin='$str'\n";
+ }
+# print "'$strOrig' => '$str'\n";
+ $str =~ s/^\s*// ;
+ return $str;
+}
+
+## returns an opacity value between 0 and 1
+## returns 1 if the argument is undefined
+sub convertOpacity {
+ my ($opacity) = @_;
+ $opacity = 1 unless defined $opacity;
+ $opacity = 0 if $opacity<0;
+ $opacity = 1 if $opacity>1;
+ return $opacity;
+}
+
+
+######################################################################################
+# fontes management
+######################################################################################
+
+# the following hashtable is used to maps SVG font names to X font names
+# BUG: obvioulsy this hashtable should be defined in the system or at
+# least as a configuration file or in the SVG2zinc parser parameters
+
+my %fontsMapping = (
+ 'comicsansms' => "comic sans ms",
+ 'arialmt' => "arial",
+ 'arial black' => "arial-bold",
+ 'bleriottextmono-roman' => 'bleriot-radar',
+ 'bleriottext-roman' => 'bleriot',
+ 'cityd' => 'city d',
+ 'cityd-medi' => 'city d',
+);
+
+my $last_key = "verdana";
+
+sub createNamedFont {
+ my ($fullFamily, $size, $weight) = @_;
+ if ($fullFamily eq "")
+ {
+ $fullFamily = $last_key if $fullFamily eq "";
+ }
+ else
+ {
+ $last_key = $fullFamily;
+ }
+ my $family = lc($fullFamily);
+
+ $weight = "normal" unless $weight;
+ if ( $size =~ /(.*)pt/ )
+ {
+ $size = -$1;
+ }
+ elsif ( $size =~ /(.*)px/ )
+ {
+ $size = -$1;
+ }
+ elsif ( $size =~ /(\d*(.\d*)?)\s*$/ )
+ {
+ $size = -$1;
+ }
+# $size = &float2int($size); # I round the font size, at least until we have vectorial font in Tk::Zinc
+
+ $family = $fontsMapping{$family} if defined $fontsMapping{$family};
+ if ( $family =~ /(\w*)-bold/ )
+ {
+ $family = $1;
+ $weight = "bold";
+ }
+ else
+ {
+ $weight = "medium";
+ }
+
+ my $fontKey = join "_", ($family, $size, $weight);
+ if (!defined $fonts{$fontKey})
+ {
+ $fonts{$fontKey} = $fontKey;
+ return ($fontKey, "->fontCreate('$fontKey', -family => \"$family\", -size => $size, -weight => \"$weight\") if ! \$fonts {\"$fontKey\"};");
+ }
+ else
+ {
+ return ($fontKey,"");
+ }
+
+} # end of createNamedFont
+
+######################################################################################
+# gradients management
+######################################################################################
+# my %gradients;
+
+## Check if the new gradient does not already exists (with another name)
+## In this case, the hash is extended with an "auto-reference"
+## $gradients{newName} = "oldName"
+## and the function returns 0
+## Otherwise, add an entry in the hastable
+## $gradients{newName} = "newDefinition"
+## and returns 1
+sub defineNamedGradient {
+ my ($newGname, $newGradDef) = @_;
+ my $prevEqGrad;
+ $newGradDef =~ s/^\s*(.*\S)\s*$/$1/ ; # removing trailing/leading blank
+ $newGradDef =~ s/\s*\|\s*/ \| /g ; # inserting blanks around the |
+ $newGradDef =~ s/\s\s+/ /g; # removing multiple occurence of blanks
+# print "CLEANED grad='$newGradDef'\n";
+ foreach my $gname (keys %gradients) {
+ if ($gradients{$gname} eq $newGradDef) {
+ ## such a gradient already exist with another name
+ $gradients{$newGname} = $gname;
+# print "GRADIENT: $newGname == $gname\n";
+
+# $res .= "\n###### $newGname => $gname"; ###
+
+ return 0;
+ }
+ }
+ ## there is no identical gradient with another name
+ ## we add the definition in the hashtable
+ $gradients{$newGname} = $newGradDef;
+ return $newGradDef;
+}
+
+## returns the name of a gradient, by following if necessary
+## "auto-references" in the hashtable
+sub namedGradient {
+ my ($gname) = @_;
+ my $def = $gradients{$gname};
+ return $gname unless defined $def;
+ ## to avoid looping if the hashtable is buggy:
+ return $gname if !defined $gradients{$def} or $def eq $gradients{$def};
+ return &namedGradient($gradients{$gname});
+}
+
+## returns the definition associated to a named gradient, following if necessary
+## "auto-references" in the hashtable
+sub namedGradientDef {
+ my ($gname) = @_;
+ my $def = $gradients{$gname};
+ return "" unless defined $def;
+ ## to avoid looping if the hashtable is buggy:
+ return $def if !defined $gradients{$def} or $def eq $gradients{$def};
+ return $gradients{&namedGradient($gradients{$gname})};
+}
+
+# returns 1 if the named has an associated gradient
+sub existsGradient {
+ my ($gname) = @_;
+ if (defined $gradients{$gname}) {return 1} else {return 0};
+}
+
+## this function returns both the radial type with its parameters AND
+## a list of stops characteristics as defined in TkZinc
+## usage: ($radialType, @stops) = &extractGradientTypeAndStops(<namedGradient>);
+## this func assumes that <namedGradient> DOES exist
+sub extractGradientTypeAndStops {
+ my ($namedGradient) = @_;
+ my $gradDef = &namedGradientDef($namedGradient);
+ my @defElements = split (/\s*\|\s*/ , $gradDef);
+ my $gradientType;
+ $gradientType = shift @defElements;
+ return ($gradientType, @defElements);
+}
+
+## combines the opacity to every parts of a named gradient
+## if some parts of the gradients are themselves partly transparent, they are combined
+## if $opacity is 1, returns directly $gname
+## else returns a new definition of a gradient
+sub addTransparencyToGradient {
+ my ($gname,$opacity) = @_;
+ return $gname if $opacity == 100;
+ &myWarn ("ATTG: ERROR $gname\n"), return $gname if !&namedGradientDef($gname); ## this cas is certainly an error in the SVG source file!
+ my ($gradientType, @stops) = &extractGradientTypeAndStops($gname);
+
+ my @newStops;
+ foreach my $stop (@stops) {
+ my $newStop="";
+ if ($stop =~ /^([^\s;]+)\s*;\s*(\d+)\s*(\d*)\s*$/ # red;45 50 or red;45
+ ) {
+ my ($color,$trans,$pos) = ($1,$2,$3);
+# print "$stop => '$color','$trans','$pos'\n";
+ my $newtransp = &float2int($trans*$opacity/100);
+ if ($pos) {
+ $newStop="$color;$newtransp $pos";
+ } else {
+ $newStop="$color;$newtransp";
+ }
+ } elsif ($stop =~ /^(\S+)\s+(\d+)$/) { # red 50
+ my ($color,$pos) = ($1,$2);
+# print "$stop => '$color','$pos'\n";
+ my $newtransp = &float2int($opacity);
+ $newStop="$color;$newtransp $pos";
+ } elsif ($stop =~ /^(\S+)$/) {
+ my ($color) = ($1);
+# print "$stop => '$color'\n";
+ my $newtransp = &float2int($opacity);
+ $newStop="$color;$newtransp";
+ } else {
+ &myWarn ("In addTransparencyToGradient: bad gradient Elements: '$stop'\n");
+ }
+ push @newStops, $newStop;
+ }
+ return ( $gradientType . " | " . join (" | ", @newStops));
+} # end of addTransparencyToGradient
+
+
+######################################################################################
+# color conversion
+######################################################################################
+# a hash table to define non-X SVG colors
+# THX to Lemort for bug report and correction!
+my %color2color = ('lime' => 'green',
+ 'Lime' => 'green',
+ 'crimson' => '#DC143C',
+ 'Crimson' => '#DC143C',
+ 'aqua' => '#00ffff',
+ 'Aqua' => '#00ffff',
+ 'fuschia' => '#ff00ff',
+ 'Fuschia' => '#ff00ff',
+ 'fuchsia' => '#ff00ff',
+ 'Fuchsia' => '#ff00ff',
+ 'indigo' => '#4b0082',
+ 'Indigo' => '#4b0082',
+ 'olive' => '#808000',
+ 'Olive' => '#808000',
+ 'silver' => '#c0c0c0',
+ 'Silver' => '#c0c0c0',
+ 'teal' => '#008080',
+ 'Teal' => '#008080',
+ 'green' => '#008000',
+ 'Green' => '#008000',
+ 'grey' => '#808080',
+ 'Grey' => '#808080',
+ 'gray' => '#808080',
+ 'Gray' => '#808080',
+ 'maroon' => '#800000',
+ 'Maroon' => '#800000',
+ 'purple' => '#800080',
+ 'Purple' => '#800080',
+ );
+
+#### BUG: this is certainly only a partial implementation!!
+sub colorConvert {
+ my ($color) = @_;
+
+ if ($color =~ /^\s*none/m)
+ {
+ return ('none', 0);
+ }
+ elsif ($color =~ /rgb\(\s*(.+)\s*\)/ )
+ {
+ ## color like "rgb(...)"
+ my $rgbs = $1;
+ if ($rgbs =~ /([\d.]*)%\s*,\s*([\d.]*)%\s*,\s*([\d.]*)%/ )
+ {
+ ## color like "rgb(1.2% , 45%,67.%)"
+ my ($r,$g,$b) = ($1,$2,$3);
+ $color = sprintf ("#%02x%02x%02x",
+ sprintf ("%.0f",2.55*$r),
+ sprintf ("%.0f",2.55*$g),
+ sprintf ("%.0f",2.55*$b));
+ return ($color, 0);
+ }
+ elsif ($rgbs =~ /(\d*)\s*,\s*(\d*)\s*,\s*(\d*)/ )
+ {
+ ## color like "rgb(255, 45,67)"
+ my ($r,$g,$b) = ($1,$2,$3);
+ $color = sprintf "#%02x%02x%02x", $r,$g,$b;
+ return ($color, 0);
+ }
+ else
+ {
+ &myWarn ("Unknown rgb color coding: $color\n");
+ }
+ }
+ elsif ($color =~ /^url\(\#(.+)\)/ )
+ {
+ ## color like "url(#monGradient)"
+# $color = $1;
+# my $res = &namedGradient($color);
+ return ($1, 1); #&namedGradient($1);
+ }
+ elsif ( $color =~ /\#([0-9a-fA-F]{3}?)$/ )
+ {
+ ## color like #fc1 => #ffcc11
+ $color =~ s/([0-9a-fA-F])/$1$1/g ;
+ # on doubling the digiys, because Tk does not do it properly
+ return ($color, 0);
+ }
+ elsif ( $color =~ /\#([0-9a-fA-F]{6}?)$/ )
+ {
+ return ($color, 0);
+ }
+ else
+ {
+ ## named colors!
+ ## except those in the %color2color, all other should be defined in the
+ ## standard rgb.txt file
+# my $converted = $color2color{lc($color)}; # THX to Lemort for bug report!
+# if (defined $converted) {
+# return $converted;
+# } else {
+ return ($color, 0);
+# }
+ }
+} # end of colorConvert
+
+######################################################################################
+# path points commands conversion
+######################################################################################
+
+
+# &pathPoints (\%attrs)
+# returns a boolean and a list of table references
+# - the boolean is true is the path has more than one contour or if it must be closed
+# - every table referecne pints to a table of strings, each string describing coordinates
+# possible BUG: in Tk::Zinc when a curve has more than one contour, they are all closed
+# how is it in SVG?
+sub pathPoints {
+ my ($ref_attrs) = @_;
+ my $str = $ref_attrs->{d};
+# print "#### In PathPoints : $str\n";
+ my ($x,$y) = (0,0); # current values
+ my $closed = 1;
+ my $atLeastOneZ=0; # true if at least one z/Z command. The curve must then be closed
+ my @fullRes;
+ my @res ;
+ my ($firstX, $firstY); # for memorizing the first point for a 'm' command after a 'z'!
+ my ($prevContrlx,$prevContrly); # useful for the s/S commande
+
+ # I use now a repetitive search on the same string, without allocating
+ # a $last string for the string end; with very long list of points, such
+ # as iceland.svg, we can gain 30% in this function and about 3s over 30s
+ while ( $str =~ m/\s*([aAmMzZvVhHlLcCsSqQtT])\s*([^aAmMzZvVhHlLcCsSqQtT]*)\s*/g ) {
+ my ($command, $args)=($1,$2);
+ &myWarn ("!!!! Ill-formed path command: '", substr($str,pos($str), 40), "...'\n") unless defined $command ;
+# print "Command=$command args=$args x=$x y=$y\n";
+ if ($command eq "M") { ## moveto absolute
+ if (!$closed) {
+ ## creating a new contour
+ push @fullRes, [ @res ];
+ $atLeastOneZ = 1;
+ @res = ();
+ }
+ my @points = &splitPoints($args);
+ ($prevContrlx,$prevContrly) = (undef,undef);
+ $firstX = $points[0];
+ $firstY = $points[1];
+ while (@points) {
+ $x = shift @points;
+ $y = shift @points;
+ push @res , "[$x, $y]";
+ }
+ next;
+ } elsif ($command eq "m") { ## moveto relative
+ if (!$closed) {
+ ## creating a new contour
+ push @fullRes, [ @res ];
+ $atLeastOneZ = 1;
+ @res = ();
+ }
+ my @dxy = &splitPoints($args);
+ $firstX = $x+$dxy[0];
+ $firstY = $y+$dxy[1];
+# print "m command: $args => @dxy ,$x,$y\n";
+ while (@dxy) {
+ ## trying to minimize the number of operation
+ ## to speed a bit this loop
+ $x += shift @dxy;
+ $y += shift @dxy;
+ push @res, "[$x, $y]";
+ }
+ next;
+ } elsif ($command eq 'z' or $command eq 'Z') {
+ push @fullRes, [ @res ];
+ $closed = 1;
+ $atLeastOneZ = 1;
+ @res = ();
+ $x=$firstX;
+ $y=$firstY;
+ next;
+ }
+ # as a command will/should follow, the curve is no more closed
+ $closed = 0;
+ if ($command eq "V") { ## vertival lineto absolute
+ ($y) = $args =~ /(\S+)/m ; ## XXXX what about multiple y !?
+ push @res , "[$x, $y]";
+ } elsif ($command eq "v") { ## vertical lineto relative
+ my ($dy) = $args =~ /(\S+)/m ; ## XXXX what about multiple dy !?
+ $y += $dy;
+ push @res , "[$x, $y]";
+ } elsif ($command eq "H") { ## horizontal lineto absolute
+ ($x) = $args =~ /(\S+)/m ; ## XXXX what about multiple x !?
+ push @res , "[$x, $y]";
+ } elsif ($command eq "h") { ## horizontal lineto relative
+ my ($dx) = $args =~ /(\S+)/m ; ## XXXX what about multiple dx !?
+ $x += $dx;
+ push @res , "[$x, $y]";
+ } elsif ($command eq "L") { ## lineto absolute
+ my @points = &splitPoints($args);
+ while (@points) {
+ $x = shift @points;
+ $y = shift @points;
+ push @res , "[$x, $y]";
+ }
+ } elsif ($command eq "l") { ## lineto relative
+ ### thioscommand can have more than one point as arguments
+ my @points = &splitPoints($args);
+ # for (my $i = 0; $i < $#points; $i+=2)
+ # is not quicker than the following while
+ while (@points) {
+ ## trying to minimize the number of operation
+ ## to speed a bit this loop
+ $x += shift @points;
+ $y += shift @points;
+ push @res , "[$x, $y]";
+ }
+ } elsif ($command eq "C" or $command eq "c") { ## cubic bezier
+ &myWarn ("$command command in a path must not be the first one") ,last
+ if (scalar @res < 1);
+ my @points = &splitPoints($args);
+ while (@points) {
+ &myWarn ("$command command must have 6 coordinates x N times") ,last
+ if (scalar @points < 6);
+ my $x1 = shift @points;
+ my $y1 = shift @points;
+ $prevContrlx = shift @points;
+ $prevContrly = shift @points;
+ my $xf = shift @points;
+ my $yf = shift @points;
+ if ($command eq "c") { $x1+=$x; $y1+=$y; $prevContrlx+=$x; $prevContrly+=$y; $xf+=$x; $yf+=$y}
+ push @res, ( "[$x1, $y1, 'c'], [$prevContrlx, $prevContrly, 'c'], [$xf, $yf]");
+ $x=$xf;
+ $y=$yf;
+ }
+ } elsif ($command eq "S" or $command eq "s") { ## cubic bezier with opposite last control point
+ &myWarn ("$command command in a path must not be the first one") ,last
+ if (scalar @res < 1);
+# print "$command command : $args\n";
+ my @points = &splitPoints($args);
+ if ($command eq "s") {
+ for (my $i=0; $i <= $#points; $i += 2) {
+ $points[$i] += $x;
+ }
+ for (my $i=1; $i <= $#points; $i += 2) {
+ $points[$i] += $y;
+ }
+ }
+ while (@points) {
+ &myWarn ("$command command must have 4 coordinates x N times; skipping @points") ,last
+ if (scalar @points < 4);
+ my $x1 = (defined $prevContrlx) ? $prevContrlx : $x;
+ $x1 = 2*$x-$x1;
+ my $y1 = (defined $prevContrly) ? $prevContrly : $y;
+ $y1 = 2*$y-$y1;
+ $prevContrlx = shift @points;
+ $prevContrly = shift @points;
+ $x = shift @points;
+ $y = shift @points;
+ push @res, ( "[$x1, $y1, 'c'], [$prevContrlx, $prevContrly, 'c'], [$x, $y]");
+ }
+
+
+ } elsif ($command eq "Q" or $command eq "q") { ## quadratic bezier
+ &myWarn ("$command command in a path must not be the first one") ,last
+ if (scalar @res < 1);
+ my @points = &splitPoints($args);
+ if ($command eq "q") {
+ for (my $i=0; $i <= $#points; $i += 2) {
+ $points[$i] += $x;
+ }
+ for (my $i=1; $i <= $#points; $i += 2) {
+ $points[$i] += $y;
+ }
+ }
+ while (@points) {
+ &myWarn ("$command command must have 4 coordinates x N times") ,last
+ if (scalar @points < 4);
+ $prevContrlx = shift @points;
+ $prevContrly = shift @points;
+
+ my $last_x = $x;
+ my $last_y = $y;
+
+ $x = shift @points;
+ $y = shift @points;
+
+ # the following code has been provided by Lemort@intuilab.com
+ my @coordsToConvert = ($last_x,$last_y, $prevContrlx, $prevContrly,$x,$y);
+ my @convertCoords = Math::Bezier::Convert::quadratic_to_cubic(@coordsToConvert);
+ # removing the first point, already present
+ splice(@convertCoords, 0, 2);
+
+ while (@convertCoords) {
+ my ($ctrl1_x, $ctrl1_y) = splice(@convertCoords, 0, 2);
+ my ($ctrl2_x, $ctrl2_y) = splice(@convertCoords, 0, 2);
+ my ($pt_x, $pt_y) = splice(@convertCoords, 0, 2);
+
+ push @res, ("[$ctrl1_x, $ctrl1_y, 'c'], [$ctrl2_x, $ctrl2_y, 'c'], [$pt_x, $pt_y]");
+ }
+
+ }
+
+ } elsif ($command eq "T" or $command eq "t") { ## quadratic bezier with opposite last control point?!
+ &myWarn ("$command command in a path must not be the first one") ,last
+ if (scalar @res < 1);
+ my @points = &splitPoints($args);
+
+ if ($command eq "t") {
+ for (my $i=0; $i <= $#points; $i += 2) {
+ $points[$i] += $x;
+ }
+ for (my $i=1; $i <= $#points; $i += 2) {
+ $points[$i] += $y;
+ }
+ }
+ while (@points) {
+ &myWarn ("$command command must have 2 coordinates x N times") ,last
+ if (scalar @points < 2);
+ my $x1 = (defined $prevContrlx) ? $prevContrlx : $x;
+ $prevContrlx = 2*$x-$x1;
+ my $y1 = (defined $prevContrly) ? $prevContrly : $y;
+ $prevContrly = 2*$y-$y1;
+
+ my $last_x = $x;
+ my $last_y = $y;
+
+ $x = shift @points;
+ $y = shift @points;
+
+ # the following code has been provided by Lemort@intuilab.com
+ my @coordsToConvert = ($last_x,$last_y, $prevContrlx, $prevContrly,$x,$y);
+ my @convertCoords = Math::Bezier::Convert::quadratic_to_cubic(@coordsToConvert);
+ # removing the first point, already present
+ splice(@convertCoords, 0, 2);
+
+ while (@convertCoords) {
+ my ($ctrl1_x, $ctrl1_y) = splice(@convertCoords, 0, 2);
+ my ($ctrl2_x, $ctrl2_y) = splice(@convertCoords, 0, 2);
+ my ($pt_x, $pt_y) = splice(@convertCoords, 0, 2);
+
+ push @res, ("[$ctrl1_x, $ctrl1_y, 'c'], [$ctrl2_x, $ctrl2_y, 'c'], [$pt_x, $pt_y]");
+ }
+
+ }
+ } elsif ($command eq 'a' or $command eq 'A') {
+ my @points = &splitPoints($args);
+ while (@points) {
+ &myWarn ("bad $command command parameters: @points\n") if (scalar @points < 7);
+# print "($x,$y) $command command: @points\n";
+ if ($command eq 'a') {
+ $points[5] += $x;
+ $points[6] += $y;
+ }
+# print "($x,$y) $command command: @points\n";
+ my @coords = &arcPathCommand ( $x,$y, @points[0..6] );
+ push @res, @coords;
+ $x = $points[5];
+ $y = $points[6];
+ last if (scalar @points == 7);
+ @points = @points[7..$#points]; ### XXX ? tester!
+ }
+ } else {
+ &myWarn ("!!! bad path command: $command\n");
+ }
+ }
+ if (@res) {
+ return ( $atLeastOneZ, [@res], @fullRes);
+ } else { return ( $atLeastOneZ, @fullRes) }
+} # end of pathPoints
+
+
+
+
+# this function can be called many many times; so it has been "optimized"
+# even if a bit less readable
+sub splitPoints {
+ $_ = shift;
+ ### adding a space before every dash (-) when the dash preceeds by a digit
+ s/(\d)-/$1 -/g;
+ ### adding a space before ? dot (.) when more than one real are not separated;
+ ### e.g.: '2.3.45.6.' becomes '2.3 .45 .5'
+ while ( scalar s/\.(\d+)\.(\d+)/\.$1 \.$2/) {
+ }
+ return split ( /[\s,]+/ );
+}
+
+
+
+sub arcPathCommand {
+ my ($x1,$y1, $rx,$ry, $x_rot, $large_arc_flag,$sweep_flag, $x2,$y2) = @_;
+ return ($x2,$y2) if ($rx == 0 and $ry == 0);
+ $rx = -$rx if $rx < 0;
+ $ry = -$ry if $ry < 0;
+
+ # computing the center
+ my $phi = deg2rad($x_rot);
+
+ # compute x1' and y1' (formula F.6.5.1)
+ my $deltaX = ($x1-$x2)/2;
+ my $deltaY = ($y1-$y2)/2;
+ my $xp1 = cos($phi)*$deltaX + sin($phi)*$deltaY;
+ my $yp1 = -sin($phi)*$deltaX + cos($phi)*$deltaY;
+# print "xp1,yp1= $xp1 , $yp1\n";
+
+ # the radius_check has been suggested by lemort@intuilab.com
+ # checking that radius are correct
+ my $radius_check = ($xp1/$rx)**2 + ($yp1/$ry)**2;
+
+ if ($radius_check > 1) {
+ $rx *= sqrt($radius_check);
+ $ry *= sqrt($radius_check);
+ }
+
+ # compute the sign: (formula F.6.5.2)
+ my $sign = 1;
+ $sign = -1 if $large_arc_flag eq $sweep_flag;
+ # compute the big square root (formula F.6.5.2)
+# print "denominator: ", ( ($rx*$ry)**2 - ($rx*$yp1)**2 - ($ry*$xp1)**2 ),"\n";
+ my $bigsqroot = (
+ abs( ($rx*$ry)**2 - ($rx*$yp1)**2 - ($ry*$xp1)**2 ) ### ABS ?!?!
+ /
+ ( ($rx*$yp1)**2 + ($ry*$xp1)**2 )
+ );
+ # computing c'x and c'y (formula F.6.5.2)
+ $bigsqroot = $sign * sqrt ($bigsqroot);
+ my $cpx = $bigsqroot * ($rx*$yp1/$ry);
+ my $cpy = $bigsqroot * (- $ry*$xp1/$rx);
+
+ # compute cx and cy (formula F.6.5.3)
+ my $middleX = ($x1+$x2)/2;
+ my $middleY = ($y1+$y2)/2;
+ my $cx = cos($phi)*$cpx - sin($phi)*$cpy + $middleX;
+ my $cy = sin($phi)*$cpx + cos($phi)*$cpy + $middleY;
+
+ # computing theta1 (formula F.6.5.5)
+ my $XX = ($xp1-$cpx)/$rx;
+ my $YY = ($yp1-$cpy)/$ry;
+ my $theta1 = rad2deg (&vectorProduct ( 1,0, $XX,$YY));
+ # computing dTheta (formula F.6.5.6)
+ my $dTheta = rad2deg (&vectorProduct ( $XX,$YY, (-$xp1-$cpx)/$rx,(-$yp1-$cpy)/$ry ));
+
+ if (!$sweep_flag and $dTheta>0) {
+ $dTheta-=360;
+ }
+ if ($sweep_flag and $dTheta<0) {
+ $dTheta+=360;
+ }
+ return join (",", &computeArcPoints($cx,$cy,$rx,$ry,
+ $phi,deg2rad($theta1),deg2rad($dTheta))), "\n";
+}
+
+sub computeArcPoints {
+ my ($cx,$cy,$rx,$ry,$phi,$theta1,$dTheta) = @_;
+ my $Nrad = 3.14/18;
+ my $N = &float2int(abs($dTheta/$Nrad));
+ my $cosPhi = cos($phi);
+ my $sinPhi = sin($phi);
+ my $dd = $dTheta/$N;
+ my @res;
+ for (my $i=0; $i<=$N; $i++)
+ {
+ my $a = $theta1 + $dd*$i;
+ my $xp = $rx*cos($a);
+ my $yp = $ry*sin($a);
+ my $x1 = $cosPhi*$xp - $sinPhi*$yp + $cx;
+ my $y1 = $sinPhi*$xp + $cosPhi*$yp + $cy;
+ push @res, "[$x1, $y1]";
+ }
+ return @res;
+}
+
+## vectorial product
+sub vectorProduct {
+ my ($x1,$y1, $x2,$y2) = @_;
+ my $sign = 1;
+ $sign = -1 if ($x1*$y2 - $y1*$x2) < 0;
+
+ return $sign * acos ( ($x1*$x2 + $y1*$y2)
+ /
+ sqrt ( ($x1**2 + $y1**2) * ($x2**2 + $y2**2) )
+ );
+}
+
+######################################################################################
+# points conversions for polygone / polyline
+######################################################################################
+
+# &points (\%attrs)
+# converts the string, value of an attribute points
+# to a string of coordinate list for Tk::Zinc
+sub points {
+ my ($ref_attrs) = @_;
+ my $str = $ref_attrs->{points};
+ # suppressing leading and trailing blanks:
+ ($str) = $str =~ /^\s* # leading blanks
+ (.*\S) #
+ \s*$ # trailing blanks
+ /x;
+
+ $str =~ s/([^,])[\s]+([^,])/$1,$2/g ; # replacing blanks separators by a comma
+ return $str;
+}
+
+######################################################################################
+# cleaning an id to make it usable as a TkZinc Tag
+######################################################################################
+
+## the following function cleans an id, ie modifies it so that it
+## follows the TkZinc tag conventions.
+## BUG: the cleanning is far from being complete
+sub cleanName {
+ my $id = shift;
+ # to avoid numeric ids
+ if ($id =~ /^\d+$/) {
+# &myWarn ("id: $id start with digits\n");
+ $id = "id_".$id;
+ }
+ # to avoid any dots in a tag
+ if ($id =~ /\./) {
+# &myWarn ("id: $id contains dots\n");
+ $id =~ s/\./_/g ;
+ }
+ return $id;
+}
+
+################################################################################
+# size conversions
+################################################################################
+
+## get a list of "size" attributes as listed in @attrs (e.g.: x y width height...)
+## - convert all in pixel
+## - return 0 for attributes listed in @attrs and not available in %{$ref_attrs}
+sub sizesConvert {
+ my ($ref_attrs,@attrs) = @_;
+ my %attrs = %{$ref_attrs};
+ my @res;
+ foreach my $attr (@attrs)
+ {
+ my $value;
+ if (!defined ($value = $attrs{$attr}) )
+ {
+ if ($attr eq 'x2')
+ {
+ push (@res, 1);
+ }
+ else
+ {
+ push (@res, 0);
+ }
+ }
+ else
+ {
+ push @res,&sizeConvert ($value);
+ }
+ }
+ return @res;
+} # end of sizesConvert
+
+# currently, to simplify this code, I suppose the screen is 100dpi!
+# at least the generated code is currently independant from the host
+# where is is supposed to run
+# maybe this should be enhanced
+sub sizeConvert {
+ my ($value) = @_;
+ if ($value =~ /(.*)cm/) {
+ return $1 * 40; ## approximative pixel / cm
+ } elsif ($value =~ /(.*)mm/) {
+ return $1 * 4; ## approximative pixel / mm
+ } elsif ($value =~ /(.*)px/) {
+ return $1; ## exact! pixel / pixel
+ } elsif ($value =~ /(.*)in/) {
+ return &float2int($1 * 100); ## approximative pixel / inch
+ } elsif ($value =~ /(.*)pt/) {
+ return &float2int($1 * 100 / 72); ## approximative pixel / pt (a pt = 1in/72)
+ } elsif ($value =~ /(.*)pc/) {
+ return &float2int($1 * 100 / 6); ## (a pica = 1in/6)
+ } elsif ($value =~ /(.*)%/) {
+ return $1/100; ## useful for coordinates using %
+ ## in lienar gradient (x1,x2,y2,y2)
+ } elsif ($value =~ /(.*)em/) { # not yet implemented
+ &myWarn ("em unit not yet implemented in sizes");
+ return $value;
+ } elsif ($value =~ /(.*)ex/) { # not yet implemented
+ &myWarn ("ex unit not yet implemented in sizes");
+ return $value;
+ } else {
+ return $value;
+ }
+} # end of sizeConvert
+
+
+sub float2int {
+ return sprintf ("%.0f",$_[0]);
+}
+
+
+# process a string describing transformations
+# returns a list of string describing transformations
+# to be applied to Tk::Zinc item Id
+sub transform {
+ my ($id, $str) = @_;
+ return () if !defined $str;
+ &myWarn ("!!! Need an Id for applying a transformation\n"), return () if !defined $id;
+ my @fullTrans;
+ while ($str =~ m/\s*(\w+)\s*\(([^\)]*)\)\s*/g) {
+ my ($trans, $params) = ($1,$2);
+ my @params = split (/[\s,]+/, $params);
+ if ($trans eq 'translate') {
+ $params[1] = 0 if scalar @params == 1; ## the 2nd paramter defaults to 0
+ my $translation = "-> translate ($id," . join (",",@params) . ");" ;
+ push @fullTrans, $translation;
+ } elsif ($trans eq 'rotate') {
+ $params[0] = deg2rad($params[0]);
+ my $rotation = "-> rotate ($id," . join (",",@params) . ");";
+ push @fullTrans, $rotation;
+ } elsif ($trans eq 'scale') {
+ $params[1] = $params[0] if scalar @params == 1; ## the 2nd scale parameter defaults to the 1st
+ my $scale = "-> scale ($id," . join (",",@params) . ");";
+ push @fullTrans,$scale;
+ } elsif ($trans eq 'matrix') {
+ my $matrixParams = join ',',@params;
+ my $matrix = "-> tset ($id, $matrixParams);";
+ push @fullTrans, $matrix;
+ } elsif ($trans eq 'skewX'){
+ my $skewX = "-> skew ($id, " . deg2rad($params[0]) . ",0);";
+# print "skewX=$skewX\n";
+ push @fullTrans, $skewX;
+ } elsif ($trans eq 'skewY'){
+ my $skewY = "-> skew ($id, 0," . deg2rad($params[0]) . ");";
+# print "skewY=$skewY\n";
+ push @fullTrans, $skewY;
+ } else {
+ &myWarn ("!!! Unknown transformation '$trans'\n");
+ }
+# $str = $rest;
+ }
+ return reverse @fullTrans;
+} # end of transform
+
+1;
generated by cgit v1.1 at 2024-09-21 06:27:14 +0000