From c5866f304210618979d03c561b1e3f6f83200bce Mon Sep 17 00:00:00 2001 From: ribet Date: Wed, 21 Mar 2007 10:19:39 +0000 Subject: Import initial --- src/SVG/SVG2zinc/Backend.pm | 293 ++++++++++ src/SVG/SVG2zinc/Backend/Display.pm.k | 257 +++++++++ src/SVG/SVG2zinc/Backend/Image.pm.k | 201 +++++++ src/SVG/SVG2zinc/Backend/PerlClass.pm | 203 +++++++ src/SVG/SVG2zinc/Backend/PerlScript.pm.k | 275 ++++++++++ src/SVG/SVG2zinc/Backend/Print.pm.k | 61 +++ src/SVG/SVG2zinc/Backend/Tcl.pm.k | 96 ++++ src/SVG/SVG2zinc/Backend/TclScript.pm.k | 275 ++++++++++ src/SVG/SVG2zinc/Conversions.pm | 909 +++++++++++++++++++++++++++++++ 9 files changed, 2570 insertions(+) create mode 100644 src/SVG/SVG2zinc/Backend.pm create mode 100644 src/SVG/SVG2zinc/Backend/Display.pm.k create mode 100644 src/SVG/SVG2zinc/Backend/Image.pm.k create mode 100644 src/SVG/SVG2zinc/Backend/PerlClass.pm create mode 100644 src/SVG/SVG2zinc/Backend/PerlScript.pm.k create mode 100644 src/SVG/SVG2zinc/Backend/Print.pm.k create mode 100644 src/SVG/SVG2zinc/Backend/Tcl.pm.k create mode 100644 src/SVG/SVG2zinc/Backend/TclScript.pm.k create mode 100644 src/SVG/SVG2zinc/Conversions.pm (limited to 'src/SVG/SVG2zinc') diff --git a/src/SVG/SVG2zinc/Backend.pm b/src/SVG/SVG2zinc/Backend.pm new file mode 100644 index 0000000..badee67 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend.pm @@ -0,0 +1,293 @@ +package SVG::SVG2zinc::Backend; +# 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 +# +################################################################## + +# Backend for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'?tudes de la Navigation A?rienne +# +# Author: Christophe Mertz +# +# An abstract class for code generation +# Concrete sub-classes can generate code for perl (script / module), tcl, +# printing, or direct execution +# +# $Id: Backend.pm,v 1.1.1.2 2006-11-16 14:51:45 merlin Exp $ +############################################################################# + +use strict; +use Carp; +use FileHandle; + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.2 $ =~ /(\d+)\.(\d+)/); + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->_initialize(%passed_options); + return $self; +} + +my %new_options = ( + -render => 1, + -out => 1, + -in => 1, + -verbose => 1, +); + +sub _initialize { + my ($self, %passed_options) = @_; + foreach my $opt (keys (%passed_options)) + { + if (defined ($new_options{$opt})) + { + $self->{$opt} = $passed_options{$opt}; + } + else + { + carp ("Warning: option $opt unknown for a ".ref($self)."\n"); + } + } + $self -> {-render} = 1 unless defined $self -> {-render}; + croak("undefined mandatory -in options") unless defined $self -> {-in}; + if (defined $self -> {-out} and $self -> {-out}) + { + my $out = $self->{-out}; + if (ref($out) eq 'GLOB') + { + ## nothing to do, the $out is supposed to be open!? + } + else + { + my @reps = split ('::', $out); + my $file = $reps [0]; + for (my $i = 0; $i < @reps - 1; $i++) + { + if(not -d $file) + { + if(!mkdir ($file)) + { + print STDERR "##### Error creating directory: $file\n"; + } + } + $file .= '/'.$reps [$i + 1]; + } + print STDERR "writing $file...\n"; + my $fh = FileHandle -> new("> " . $file); + if ($fh) + { + $self->{-filehandle} = $fh; + } + else + { + carp ("unable to open " . $out); + } + } + } + return $self; +} + +# used by SVG2zinc to know the zinc group in which the svg topgroup +# by default: 1 +# currently default need be overriden by PerlClass only, as far as I now!? +sub _topgroup { + my ($self) = @_; + if ($self->{-topgroup}) { + return $self->{-topgroup}; + } else { + return 1; + } +} + +# returns true if code is put in a file +sub inFile { + my ($self) = @_; + return (defined $self->{-filehandle}); +} + +sub printLines { + my ($self, @lines) = @_; + if ($self->inFile) { + my $fh = $self->{-filehandle}; + foreach my $l (@lines) { + print $fh "$l\n"; + } + } else { + carp "printLines cannot print if no outfile has been given\n"; + } +} + +sub treatLines { + my ($self, @lines) = @_; + if ($self->inFile) { + $self->printLines(@lines); + } +} + + +## in case of file generation, should print a comment +## the default is to print comment starting with # +sub comment { + my ($self, @lines) = @_; + if ($self->inFile) { + foreach my $l (@lines) { + $self->printLines("## $l"); + } + } +} + +sub close { + my ($self) = @_; + if ($self->inFile) { + $self->{-filehandle}->close; + } +} + +sub fileHeader { + my ($self) = @_; + $self->comment ("", "default Header of SVG::SVG2zinc::Backend", ""); +} + + +sub fileTail { + my ($self) = @_; + $self->comment ("", "default Tail of SVG::SVG2zinc::Backend", ""); + $self->close; +} + + + +1; + + +__END__ + +=head1 NAME + +SVG::SVG2zinc::Backend - a virtual class SVG::SVG2zinc svg reader. Sub-class are specialized for different type of generation + +=head1 SYNOPSIS + +package SVG::SVG2zinc::Backend::SubClass + +use SVG::SVG2zinc::Backend; + +## some methods definition + +.... + + ## when using a specialized backend: + + use SVG::SVG2zinc::Backend::SubClass; + + $backend = SVG::SVG2zinc::Backend::SubClass->new( + -out => filename_or_handle, + -in => svgfilename, + -verbose => 0|1, + [otheroptions], + ); + + $backend->fileHeader(); + + $backend->treatLines("lineOfCode1", "lineOfCode2",...); + + $backend->comment("comment1", "comment2", ...); + + $backend->printLines("comment1", "comment2", ...); + + $backend->fileTail(); + +=head1 DESCRIPTION + +SVG::SVG2zinc::Backend is a perl virtual class which should be specialized in sub-classes. It defines +a common interface ot classes which can for example generate perl code with Tk::Zinc, display +SVG file in a Tk::Zinc widget, convert svg file in image files (e.g. png) or generate tcl code +to be used with TkZinc etc... + +A backend should provide the following methods: + +=over + +=item B + +This creation class method should accept pairs of (-option => value) as well as the following arguments: + +=over + +=item B<-out> + +A filename or a filehandle ready for writing the output. In same rare cases +(e.g. the Display backend which only displays the SVG file on the screen, +this option will not be used) + +=item B<-in> + +The svg filename. It should be used in comments only in the generated file + +=item B<-verbose> + +It will be used for letting the backend being verbose + +=back + +=item B + +Generates the header in the out file, if needed. This method should be called just after creating a backend and prior any treatLines or comment method call. + +=item B + +Processes the given arguments as lines of code. The arguments are very close to Tk::Zinc perl code. When creating a new backend, using the B backend can help understanding what are exactly these arguments. + +=item B + +Processes the given arguments as comments. Depending on the backend, this method must be redefined so that arguments are treated as comments, or just skipped. + +=item B + +Print in an outfile the given arguments as lines of text. This method should not be re-defined, but used by any Backend which generates code. + +=item B + +Generate the tail in the out file if needed and closes the out file. This must be the last call. + +=back + +A backend can use the printLines method to print lines in the generated file. + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend::Display(3pm), SVG::SVG2zinc::Backend::PerlScript(3pm), +SVG::SVG2zinc::Backend::TclScript(3pm), SVG::SVG2zinc::Backend::PerlClass(3pm) code +as examples of SVG::SVG2zinc::Backend subclasses. + +SVG::SVG2zinc(3pm) + +=head1 AUTHORS + +Christophe Mertz with some help from Daniel Etienne + +=head1 COPYRIGHT + +CENA (C) 2003-2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/Display.pm.k b/src/SVG/SVG2zinc/Backend/Display.pm.k new file mode 100644 index 0000000..8da4b9b --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Display.pm.k @@ -0,0 +1,257 @@ +package SVG::SVG2zinc::Backend::Display; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc to display a svg file in a Tk::Zinc canvas +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz +# +# $Id: Display.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; +use Tk::Zinc::SVGExtension; + +eval (require Tk::Zinc); +if ($@) { + die "$@\nSVG::SVG2zinc::Backend requires Tk::Zinc to be installed\n"; +} elsif (eval ('$Tk::Zinc::VERSION !~ /^\d\.\d+$/ or $Tk::Zinc::VERSION < 3.295') ) { + die "Tk::Zinc must be at least 3.295"; +} + + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->_initialize(%passed_options); + return $self; +} + +my $zinc; +my ($WIDTH, $HEIGHT); +my $top_group; +sub _initialize { + my ($self, %passed_options) = @_; + $WIDTH = delete $passed_options{-width}; + $WIDTH = 600 unless defined $WIDTH; + $HEIGHT = delete $passed_options{-height}; + $HEIGHT = 600 unless defined $HEIGHT; + + $self->SUPER::_initialize(%passed_options); + + require Tk::Zinc::Debug; # usefull for browsing items herarchy + my $mw = MainWindow->new(); + my $svgfile = $self->{-in}; + $mw->title($svgfile); + $zinc = $mw->Zinc(-width => $WIDTH, -height => $HEIGHT, + -borderwidth => 0, + -render => $self->{-render}, + -backcolor => "white", ## why white? + )->pack(qw/-expand yes -fill both/); + + if (Tk::Zinc::Debug->can('init')) { + # for TkZinc >= 3.2.96 + &Tk::Zinc::Debug::init($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); + } else { + # for TkZinc <= 3.2.95 + &Tk::Zinc::Debug::finditems($zinc); + &Tk::Zinc::Debug::tree($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); + } +} + + +sub treatLines { + my ($self,@lines) = @_; + my $verbose = $self->{-verbose}; + foreach my $l (@lines) { + my $expr = $l; + $expr =~ s/->/\$zinc->/g; + my $unused = $zinc; ## due to a perl bug, this is needed so that $zinc will be known in $expr + my $r = eval ($expr); + if ($@) { +# &myWarn ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + print ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + } elsif ($verbose) { + if ($l =~ /^->add/) { + print "$r == $expr\n" if $verbose; + } else { + print "$expr\n" if $verbose; + } + } + } +} + + +sub fileHeader { +# my ($self) = @_; +} + + +my $zoom; +sub fileTail { + # resizing to make them all visible + $top_group = $zinc->find ('withtag', ".1"); + my @bbox = $zinc->bbox($top_group); + $zinc->translate($top_group, -$bbox[0], -$bbox[1]) if defined $bbox[0] and $bbox[1]; + @bbox = $zinc->bbox($top_group); + my $ratio = 1; + $ratio = $WIDTH / $bbox[2] if ($bbox[2] and $bbox[2] > $WIDTH); + $ratio = $HEIGHT/ $bbox[3] if ($bbox[3] and $HEIGHT/$bbox[3] lt $ratio); + + $zoom=1; + $zinc->scale($top_group, $ratio, $ratio); + + # adding some usefull callbacks + $zinc->Tk::bind('', [\&press, \&motion]); + $zinc->Tk::bind('', [\&release]); + + $zinc->Tk::bind('', [\&press, \&zoom]); + $zinc->Tk::bind('', [\&release]); + + $zinc->Tk::bind('', [\&press, \&mouseRotate]); + $zinc->Tk::bind('', [\&release]); + $zinc->bind('all', '', + [ sub { my ($z)=@_; my $i=$z->find('withtag', 'current'); + my @tags = $z->gettags($i); + pop @tags; # to remove the tag 'current' + print "$i (", $z->type($i), ") [@tags]\n";}] ); + + Tk::MainLoop; +} + +##### bindings for moving, rotating, scaling the displayed items +my ($cur_x, $cur_y, $cur_angle); +sub press { + my ($zinc, $action) = @_; + my $ev = $zinc->XEvent(); + $cur_x = $ev->x; + $cur_y = $ev->y; + $cur_angle = atan2($cur_y, $cur_x); + $zinc->Tk::bind('', [$action]); +} + +sub motion { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + + my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]); + $zinc->translate($top_group, ($res[0] - $res[2])*$zoom, ($res[1] - $res[3])*$zoom); + $cur_x = $lx; + $cur_y = $ly; +} + +sub zoom { + my ($zinc, $self) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my ($maxx, $maxy); + + if ($lx > $cur_x) { + $maxx = $lx; + } else { + $maxx = $cur_x; + } + if ($ly > $cur_y) { + $maxy = $ly + } else { + $maxy = $cur_y; + } + return if ($maxx == 0 || $maxy == 0); + my $sx = 1.0 + ($lx - $cur_x)/$maxx; + my $sy = 1.0 + ($ly - $cur_y)/$maxy; + $cur_x = $lx; + $cur_y = $ly; + $zoom = $zoom * $sx; + $zinc->scale($top_group, $sx, $sx); #$sy); +} + +sub mouseRotate { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $langle = atan2($ev->y, $ev->x); + $zinc->rotate($top_group, -($langle - $cur_angle), $cur_x, $cur_y); + $cur_angle = $langle; +} + +sub release { + my ($zinc) = @_; + $zinc->Tk::bind('', ''); +} + + +sub displayVersion { + print $0, " : Version $VERSION\n\tSVG::SVG2zinc.pm Version : $SVG::SVG2zinc::VERSION\n"; + exit; +} + + +1; + + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::Display - a backend class for displaying SVG file + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::Display is a class for displaying SVG files. + +For more information, you should look at SVG:SVG2zinc::Backend(3pm). + +The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters: + +=over + +=item B<-render> + +The render value of the Tk::Zinc widget. 0 means no openGL, 1 or 2 for openGL. Defaults to 1. + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm) + +=head1 AUTHORS + +Christophe Mertz + +=head1 COPYRIGHT + +CENA (C) 2003-2004 IntuiLab 2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/Image.pm.k b/src/SVG/SVG2zinc/Backend/Image.pm.k new file mode 100644 index 0000000..bfd7851 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Image.pm.k @@ -0,0 +1,201 @@ +package SVG::SVG2zinc::Backend::Image; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc to generate image files +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz +# +# $Id: Image.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; +use Tk::Zinc::SVGExtension; + +eval (require Tk::Zinc); +if ($@) { + print "$@\nSVG::SVG2zinc::Backend requires Tk::Zinc to be installed\n"; +} + +sub new { + # testing that 'import' is available + # is this test portable? + my $ret = `which import`; + croak ("## You need the 'import' command from 'imagemagic' package to use the Image backend.\n") + if !$ret; + + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->_initialize(%passed_options); + return $self; +} + +my $zinc; +sub _initialize { + my ($self, %passed_options) = @_; + if (defined $passed_options{-ratio}) { + if ($passed_options{-ratio} !~ /^\d+%$/) { + croak ("## -ratio should look like nn%"); + } else { + $self->{-ratio} = delete $passed_options{-ratio}; + } + } + if (defined $passed_options{-width}) { + $self->{-width} = delete $passed_options{-width}; + } + if (defined $passed_options{-height}) { + $self->{-height} = delete $passed_options{-height}; + } + + $self->SUPER::_initialize(%passed_options); + + my $mw = MainWindow->new(); + my $svgfile = $self->{-in}; + $mw->title($svgfile); + my $render = (defined $self->{-render}) ? $self->{-render} : 1; + $zinc = $mw->Zinc(-borderwidth => 0, + -render => $render, + -backcolor => "white", ## why white? + )->pack(qw/-expand yes -fill both/); +} + + +sub treatLines { + my ($self,@lines) = @_; + my $verbose = $self->{-verbose}; + foreach my $l (@lines) { + my $expr = $l; + $expr =~ s/->/\$zinc->/g; + my $unused = $zinc; ## due to a perl bug, this is needed so that $zinc will be known in $expr + my $r = eval ($expr); + if ($@) { +# &myWarn ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + print ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + } elsif ($verbose) { + if ($l =~ /^->add/) { + print "$r == $expr\n" if $verbose; + } else { + print "$expr\n" if $verbose; + } + } + } +} + + +sub fileHeader { +# my ($self) = @_; +} + + +sub fileTail { + my ($self) = @_; + my $outfile = $self->{-out}; + + # to find the top group containing width and height + my $svgGroup = $zinc->find('withtag', 'svg_top') ; + + my $tags = join " ", $zinc->gettags($svgGroup); +# print "svgGroup=$svgGroup => $tags\n"; + my ($width) = $tags =~ /width=(\d+)/ ; + my ($height) = $tags =~ /height=(\d+)/ ; +# print "height => $height width => $width\n"; + + $zinc->configure (-width => $width, -height => $height); + $zinc->update; + + my $requiredWidth = $self->{-width}; + my $requiredHeigth = $self->{-height}; + my $importParams=""; + if (defined $requiredWidth and defined $requiredHeigth) { + $importParams=" -resize $requiredWidth"."x$requiredHeigth"; + } elsif (defined $self->{-ratio}) { + $importParams=" -resize ".$self->{-ratio}; + } +# print "importParams=$importParams\n"; + + ## following are for comments: + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + my $svgfile = $self->{-in}; + + my $command = "import -window " . $zinc->id . $importParams ." -comment 'created with SVG::SVG2zinc from $svgfile v$VERSION (c) CENA 2003 C.Mertz.' $outfile"; +# print "command=$command\n"; + my $return = system ($command); + + if ($return) { + ## -1 when import is not available + print "## To use the Image Backend you need the 'import' command\n"; + print "## from the 'imagemagick' package on your system\n"; + } +} + + +1; + + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::Image - a backend class for generating image file from SVG file + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::Image is a backend class for generating image file from SVG files. It uses the 'import' command included in the ImageMagick package. + +For more information, you should look at SVG:SVG2zinc::Backend(3pm). + +The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters: + +=over + +=item B + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm) + +=head1 BUGS and LIMITATIONS + +This backend generates images files from the content of a displayed Tk::Zinc window. The size (in pixels) of the generated image is thus limited to the maximal size of a window on your system. + +=head1 AUTHORS + +Christophe Mertz + +=head1 COPYRIGHT + +CENA (C) 2003-2004 IntuiLab 2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/PerlClass.pm b/src/SVG/SVG2zinc/Backend/PerlClass.pm new file mode 100644 index 0000000..9b47ee7 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/PerlClass.pm @@ -0,0 +1,203 @@ +package SVG::SVG2zinc::Backend::PerlClass; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'?tudes de la Navigation A?rienne +# +# Author: Christophe Mertz +# +# An concrete class for code generation for Perl Class +# +# $Id: PerlClass.pm,v 1.4 2007-03-12 10:25:18 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; +use File::Basename; + +use Tk::Zinc; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; + +our $current_package_name = ''; + +sub _initialize { + my ($self, %passed_options) = @_; + $self->{-topgroup} = '$self->{-topgroup}'; # this code is used by SVG2zinc + $self->SUPER::_initialize(%passed_options); + $self -> {delayed_lines} = (); + $self -> {gradient} = {}; + $self -> {gradient_id} = 0; + return $self; +} + +sub recordGradient { + my ($self, $name, $def) = @_; + $self -> {gradient} -> {$name} = $def; +} + +sub getGradient { + my ($self, $name) = @_; + return $self -> {gradient} -> {$name} -> {stops}; +} + +sub applyGradient { + my ($self, $name, $prop) = @_; + my $grad = $self -> {gradient} -> {$name}; + my $id = $self -> {gradient_id} ++; + my %hash = %{$grad}; + my @lignes = 'my ($x1, $y1, $x2, $y2) = $_zinc -> bbox ($previous);'; +# push (@lignes, 'my ($parent) = $_zinc -> find(\'ancestors\', $previous);'); + push (@lignes, '($x1, $y1, $x2, $y2) = $_zinc -> transform(\'device\', $parent, [$x1+1, $y1+1, $x2-2, $y2-2]);'); + push (@lignes, "my \$grad = getGradient ("); + push (@lignes, "\t'$current_package_name',"); + push (@lignes, "\t'$id',"); + push (@lignes, "\t'".$hash {type}."',"); + push (@lignes, "\t'".$hash {gradientUnits}."',"); + push (@lignes, "\t".join (',' , @{$hash{coords}}).","); + push (@lignes, "\t'".join ('|' , @{$hash{stops}})."',"); + push (@lignes, "\t".join (',' , @{$hash{transform}}).","); + push (@lignes, "\t\$x1, \$y1, \$x2, \$y2"); + push (@lignes, ");"); + push (@lignes, "mconfigure (\$previous, $prop => \$grad);"); + + $self -> {current_gradient} = \@lignes; +} + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) + { + $l =~ s/^(\s*)->/$1\$_zinc->/g; + $l =~ s/(\W)->/$1\$_zinc->/g; + $self -> printLines($l); + } +} + +sub dtreatLines { + my ($self, @lines) = @_; + foreach my $l (@lines) + { + $l =~ s/^(\s*)->add/$1\$previous = \$_zinc-> add/g; + $l =~ s/(\W)->add/$1\$previous = \$_zinc-> add/g; + + $l =~ s/^(\s*)->/$1\$_zinc-> /g; + $l =~ s/(\W)->/$1\$_zinc-> /g; + + } + if (defined @lines) + { + my $rule = shift (@lines); + push (@{$self -> {delayed_lines}}, $rule); + } + if (defined $self -> {current_gradient}) + { + my @grad = @{$self -> {current_gradient}}; + foreach my $l (@grad) + { + push (@{$self -> {delayed_lines}}, $l); + } + $self -> {current_gradient} = undef; + } + foreach my $l (@lines) + { + push (@{$self -> {delayed_lines}}, $l); + } +} + +sub fileHeader { + my ($self) = @_; + my $file = $self -> {-in}; # print "file=$file\n"; + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + my ($package_name) = $self -> {-out} =~ /(.*)\.pm$/ ; + $current_package_name = $package_name; + $self -> printLines("package $package_name; + +####### This file has been generated from $file by SVG::SVG2zinc.pm Version: $VERSION + +"); + $self->printLines( +<<'HEADER' + +use strict; +use MTools; +use MTools::MGroup; +use vars qw /@ISA @EXPORT @EXPORT_OK/; +use Tk::PNG; + +BEGIN +{ + @ISA = qw /MTools::MGroup/; +} + + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + + my $_zinc = $passed_options {-zinc}; + croak ("-zinc option is mandatory at instanciation") unless defined $_zinc; + + if (defined $passed_options {-topgroup}) + { + $self -> {-topgroup} = $passed_options {-topgroup}; + } + else + { + $self -> {-topgroup} = 1; + } + + my $parent = $self -> {-topgroup}; + my @parents = (); + my $previous = (); + push (@parents, $parent); + +# on now items creation! +HEADER +); +} + + +sub fileTail { + my ($self) = @_; + $self->comment ("", "Tail of SVG2zinc::Backend::PerlScript", ""); + unshift (@{$self -> {delayed_lines}}, '$self -> {instance} = $previous = '); + $self -> printLines(@{$self -> {delayed_lines}}); + $self -> printLines( +<<'TAIL' +return $self; +} + +1; +TAIL +); + $self->close; +} + + +1; + diff --git a/src/SVG/SVG2zinc/Backend/PerlScript.pm.k b/src/SVG/SVG2zinc/Backend/PerlScript.pm.k new file mode 100644 index 0000000..b3b453c --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/PerlScript.pm.k @@ -0,0 +1,275 @@ +package SVG::SVG2zinc::Backend::PerlScript; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz +# +# A concrete class for code generation for Perl Scripts +# +# $Id: PerlScript.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use strict; +use Carp; + +use SVG::SVG2zinc::Backend; +use File::Basename; + +use vars qw( $VERSION @ISA ); +@ISA = qw( SVG::SVG2zinc::Backend ); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) { + $l =~ s/->/\$_zinc->/g; + $self->printLines($l); + } +} + +sub fileHeader { + my ($self) = @_; + my $svgfile = $self->{-in}; + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + $self->printLines("#!/usr/bin/perl -w + +####### This file has been generated from $svgfile by SVG::SVG2zinc.pm Version: $VERSION +"); + + + $self->printLines( +<<'HEADER' +use Tk::Zinc 3.295; +use Tk::Zinc::Debug; +use Tk::PNG; # only usefull if loading png file +use Tk::JPEG; # only usefull if loading png file + +use Tk::Zinc::SVGExtension; + +my $mw = MainWindow->new(); +HEADER + ); + my $svgfilename = basename($svgfile); + $self->printLines(" +\$mw->title('$svgfile'); +my (\$WIDTH, \$HEIGHT) = (800, 600); +" ); + my $render = $self->{-render}; + $self->printLines(" +my \$zinc = \$mw->Zinc(-width => \$WIDTH, -height => \$HEIGHT, + -borderwidth => 0, + -backcolor => 'white', # why white? + -render => $render, + )->pack(qw/-expand yes -fill both/);; +"); + + $self->printLines( +<<'HEADER' +if (Tk::Zinc::Debug->can('init')) { + # for TkZinc >= 3.2.96 + &Tk::Zinc::Debug::init($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); +} else { + # for TkZinc <= 3.2.95 + &Tk::Zinc::Debug::finditems($zinc); + &Tk::Zinc::Debug::tree($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); +} + +my $top_group = 1; ###$zinc->add('group', 1); + +my $_zinc=$zinc; + +{ ### + +HEADER + ); +} + + +sub fileTail { + my ($self) = @_; + $self->printLines( +<<'TAIL' + } + +### on va retailler et translater les objets créés! + +my @bbox = $_zinc->bbox($top_group); +$_zinc->translate($top_group, -$bbox[0], -$bbox[1]); +@bbox = $_zinc->bbox($top_group); +my $ratio = 1; +$ratio = $WIDTH / $bbox[2] if ($bbox[2] > $WIDTH); +$ratio = $HEIGHT/$bbox[3] if ($HEIGHT/$bbox[3] lt $ratio); +$zinc->scale($top_group, $ratio, $ratio); + +### on ajoute quelques binding bien pratiques pour la mise au point + +$_zinc->Tk::bind('', [\&press, \&motion]); +$_zinc->Tk::bind('', [\&release]); +$_zinc->Tk::bind('', [\&press, \&zoom]); +$_zinc->Tk::bind('', [\&release]); + +# $_zinc->Tk::bind('', [\&press, \&mouseRotate]); +# $_zinc->Tk::bind('', [\&release]); +$_zinc->bind('all', '', + [ sub { my ($z)=@_; my $i=$z->find('withtag', 'current'); + my @tags = $z->gettags($i); + pop @tags; # pour enlever 'current' + print "$i (", $z->type($i), ") [@tags]\n";}] ); + +&Tk::MainLoop; + + +##### bindings for moving, rotating, scaling the items +my ($cur_x, $cur_y, $cur_angle); +sub press { + my ($zinc, $action) = @_; + my $ev = $zinc->XEvent(); + $cur_x = $ev->x; + $cur_y = $ev->y; + $cur_angle = atan2($cur_y, $cur_x); + $zinc->Tk::bind('', [$action]); +} + +sub motion { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]); + $zinc->translate($top_group, $res[0] - $res[2], $res[1] - $res[3]); + $cur_x = $lx; + $cur_y = $ly; +} + +sub zoom { + my ($zinc, $self) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my $maxx; + my $maxy; + my $sx; + my $sy; + + if ($lx > $cur_x) { + $maxx = $lx; + } else { + $maxx = $cur_x; + } + if ($ly > $cur_y) { + $maxy = $ly + } else { + $maxy = $cur_y; + } + return if ($maxx == 0 || $maxy == 0); + $sx = 1.0 + ($lx - $cur_x)/$maxx; + $sy = 1.0 + ($ly - $cur_y)/$maxy; + $cur_x = $lx; + $cur_y = $ly; + $zinc->scale($top_group, $sx, $sx); #$sy); +} + +sub mouseRotate { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my $langle = atan2($ly, $lx); + $zinc->rotate($top_group, -($langle - $cur_angle)); + $cur_angle = $langle; +} + +sub release { + my ($zinc) = @_; + $zinc->Tk::bind('', ''); +} +TAIL +); + $self->close; +} + + +1; + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::PerlScript - a backend class generating Perl script displaying the content of a SVG file + +=head1 SYNOPSIS + + use SVG:SVG2zinc::Backend::PerlScript; + + $backend = SVG:SVG2zinc::Backend::PerlScript->new( + -out => filename_or_handle, + -in => svgfilename, + -verbose => 0|1, + -render => 0|1|2, + ); + + $backend->fileHeader(); + + $backend->treatLines("lineOfCode1", "lineOfCode2",...); + + $backend->comment("comment1", "comment2", ...); + + $backend->printLines("comment1", "comment2", ...); + + $backend->fileTail(); + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::PerlScript is a class for generating perl script which displays the content of a SVG file. The generated script requires Tk::Zinc. + +For more information, you should look at SVG::SVG2zinc::Backend(3pm). + +The generated perl script uses the Tk::Zinc::Debug tool, so it is easy to inspect items created in Tk::Zinc. Use the key to get some help when the cursor is in the Tk::Zinc window. + +The B method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameter: + +=over + +=item B<-render> + +The render option of the Tk::Zinc widget. A value of 0 means no openGL, 1 or 2 for openGL. Defaults to 1. + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm) + +=head1 AUTHORS + +Christophe Mertz + +=head1 COPYRIGHT + +CENA (C) 2003-2004 IntuiLab (C) 2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/Print.pm.k b/src/SVG/SVG2zinc/Backend/Print.pm.k new file mode 100644 index 0000000..8e533ac --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Print.pm.k @@ -0,0 +1,61 @@ +package SVG::SVG2zinc::Backend::Print; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz +# +# An concrete class for code printing for Perl Scripts/Modules +# This Backend is for svg2zinc debug purpose mainly +# +# $Id: Print.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) { + print "$l\n"; + } +} + + +sub fileHeader { +# my ($self) = @_; +} + + +sub fileTail { +# my ($self) = @_; +} + + +1; + diff --git a/src/SVG/SVG2zinc/Backend/Tcl.pm.k b/src/SVG/SVG2zinc/Backend/Tcl.pm.k new file mode 100644 index 0000000..3149ef6 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Tcl.pm.k @@ -0,0 +1,96 @@ +package SVG::SVG2zinc::Backend::Tcl; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz +# +# A module for code translation from perl to tcl generation +# +# $Id: Tcl.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +@ISA = qw( Exporter ); +@EXPORT = qw( perl2tcl ); + +use strict; +use Carp; + + +sub perl2tcl { + my (@lines) = @_; + my @res; + foreach my $l (@lines) { + + $l =~ s/->(\w*)\((.*)\)/\$w\.zinc $1 $2/g; # ->add(....) => $w.zinc add ... + + $l =~ s/\s*,\s*/ /g; # replacing commas by spaces + $l =~ s/\s*=>\s*/ /g; # replacing => by spaces + + $l =~ s/\s*\'([^\s;]+)\'\s*/ $1 /g ; # removing single-quotes around string without spaces + $l =~ s/\s*\"([^\s;]+)\"\s*/ $1 /g ; # removing double-quotes around string without spaces + $l =~ s/([\"\s])\#/$1\\\#/g ; # prefixing # by a slash + + $l =~ s/\[/\{/g; # replacing [ by } + $l =~ s/\]/\}/g; # replacing ] by } + $l =~ s/\{\s+/\{/g; # removing spaces after { + $l =~ s/\s+\}/\}/g; # removing spaces before } + + $l =~ s/-tags \{(\S+)\}/-tags $1/g; # -tags {toto} ==>> -tags toto + $l =~ s/\'/\"/g; # replacing all single quotes by double quotes + + $l = &hack($l); + + $l =~ s/\s+/ /g; # dangerous: removing multiple occurences of blanks + + $l =~ s/^\s+//; # removing blanks at the beginning + $l =~ s/\s+$//; # removing trailing blanks + $l =~ s/\s*;$//; # removing trailing ; + push @res, $l; + } + return (@res); +} + + +# this routine is used to do some special code transformation, +# due to soem discrepancies between tcl/tk and perl/tk +# the following code is more or less dependant from the generated +# code by SVG2zinc.pm +# +# We assume is code has already been tcl-ised +sub hack { + my ($l) = @_; + + if ($l =~ /^\$w\.zinc fontCreate/) { + # this works because I know how fontCreate is used in SVG2zinc + $l =~ s/\$w\.zinc fontCreate/font create/; + $l =~ s/-weight medium/-weight normal/; + } + + return $l; +} + +1; + diff --git a/src/SVG/SVG2zinc/Backend/TclScript.pm.k b/src/SVG/SVG2zinc/Backend/TclScript.pm.k new file mode 100644 index 0000000..90ecf4b --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/TclScript.pm.k @@ -0,0 +1,275 @@ +package SVG::SVG2zinc::Backend::TclScript; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz +# +# A concrete class for code generation for Tcl Scripts +# +# $Id: TclScript.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use strict; +use Carp; + +use SVG::SVG2zinc::Backend; +use SVG::SVG2zinc::Backend::Tcl; +use File::Basename; + +use vars qw( $VERSION @ISA ); +@ISA = qw( SVG::SVG2zinc::Backend ); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->{-render} = defined $passed_options{-render} ? delete $passed_options{-render} : 1; + $self->_initialize(%passed_options); + return $self; +} + + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) { + $self->printLines( &perl2tcl($l) ); + } +} + +sub fileHeader { + my ($self) = @_; + my $svgfile = $self->{-in}; + my $svgfilename = basename($svgfile); + $svgfilename =~ s/\./_/g; + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + $self->printLines('#!/bin/sh +# the next line restarts using wish \ + exec wish "$0" "$@" +'); + + $self->printLines(" + +####### This Tcl script file has been generated +####### from $svgfile +####### by SVG::SVG2zinc.pm Version: $VERSION + +"); + + $self->printLines(' +# +# Locate the zinc top level directory. +# +set zincRoot [file join [file dirname [info script]] ..] + +# +# And adjust the paths accordingly. +# +lappend auto_path $zincRoot +set zinc_library $zincRoot + +package require Tkzinc 3.2 + +## here we should import img for reading jpeg, png, gif files + +'); + + my $render = $self->{-render}; + $self->printLines( +<
printLines( +<<'TAIL' +### translating ojects for making them all visibles + +#set bbox [$w.zinc bbox $topGroup] + +$w.zinc translate $topGroup 200 150 + + +##### bindings for moving rotating scaling the items + +bind $w.zinc "press motion %x %y" +bind $w.zinc release +bind $w.zinc "press zoom %x %y" +bind $w.zinc release +bind $w.zinc "press mouseRotate %x %y" +bind $w.zinc release + + +set curX 0 +set curY 0 +set curAngle 0 + +proc press {action x y} { + global w curAngle curX curY + + set curX $x + set curY $y + set curAngle [expr atan2($y, $x)] + bind $w.zinc "$action %x %y" +} + +proc motion {x y} { + global w topGroup curX curY + + foreach {x1 y1 x2 y2} [$w.zinc transform $topGroup \ + [list $x $y $curX $curY]] break + $w.zinc translate $topGroup [expr $x1 - $x2] [expr $y1 - $y2] + set curX $x + set curY $y +} + +proc zoom {x y} { + global w curX curY + + if {$x > $curX} { + set maxX $x + } else { + set maxX $curX + } + if {$y > $curY} { + set maxY $y + } else { + set maxY $curY + } + if {($maxX == 0) || ($maxY == 0)} { + return; + } + set sx [expr 1.0 + (double($x - $curX) / $maxX)] + set sy [expr 1.0 + (double($y - $curY) / $maxY)] + $w.zinc scale __svg__1 $sx $sx + set curX $x + set curY $y +} + +proc mouseRotate {x y} { + global w curAngle + + set lAngle [expr atan2($y, $x)] + $w.zinc rotate __svg__1 [expr $lAngle - $curAngle] + set curAngle $lAngle +} + +proc release {} { + global w + + bind $w.zinc {} +} +TAIL +); + + $self->close; +} + + +1; + + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::TclScript - a backend class for generating Tcl script + +=head1 SYNOPSIS + + use SVG:SVG2zinc::Backend::TclScript; + + $backend = SVG:SVG2zinc::Backend::TclScript->new( + -out => filename_or_handle, + -in => svgfilename, + -verbose => 0|1, + -render => 0|1|2, + ); + + $backend->fileHeader(); + + $backend->treatLines("lineOfCode1", "lineOfCode2",...); + + $backend->comment("comment1", "comment2", ...); + + $backend->printLines("comment1", "comment2", ...); + + $backend->fileTail(); + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::TclScript is a class for generating Tcl script to display SVG files. The generated script is based on TkZinc. + +For more information, you should look at SVG:SVG2zinc::Backend(3pm). + +The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters: + +=over + +=item B<-render> + +The render value of the TkZinc widget. 0 means no openGL, 1 or 2 for openGL. Defaults to 1. + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend and SVG::SVG2zinc(3pm) + +=head1 BUGS and LIMITATIONS + +This is higly experimental. Only few tests... The author is not a Tcl coder! + +The Tk::Zinc::SVGExtension perl module provided with SVG::SVG2zinc should be converted in Tcl and imported by (or included in) the generated Tcl script. + +=head1 AUTHORS + +Christophe Mertz + +=head1 COPYRIGHT + +CENA (C) 2003-2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + 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(); +## this func assumes that 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; -- cgit v1.1