path: root/src/SVG/SVG2zinc/Backend/TclScript.pm.k

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 <mertz at intuilab dot com>
#
#       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(
<<HEADER
set w .$svgfilename
## catch {destroy \$w}
toplevel \$w
wm title \$w $svgfilename
wm iconname \$w $svgfilename

###########################################
# Zinc
##########################################
zinc \$w.zinc -width 600 -height 600 -font 9x15 -borderwidth 0 -backcolor grey90 -render $render

pack \$w.zinc

set topGroup [\$w.zinc add group 1]


HEADER
    );
}


sub fileTail {
    my ($self) = @_;
    $self->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 <ButtonPress-1>  "press motion %x %y"
bind $w.zinc <ButtonRelease-1>  release
bind $w.zinc <ButtonPress-2>  "press zoom %x %y"
bind $w.zinc <ButtonRelease-2>  release
bind $w.zinc <ButtonPress-3>  "press mouseRotate %x %y"
bind $w.zinc <ButtonRelease-3>  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 <Motion> "$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 <Motion> {}
}
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 <mertz at intuilab dot com>

=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