path: root/src/MTools.pm

package MTools;
#	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
#
##################################################################

# MTools exporte des fonctions destinees principalement a :
#	- activer des fonctions propres a la librairie mtools
#	- assurer la compatibilite entre la manipulation des objets mtools et des objets zincs
#
# Ainsi, d'une maniere generale, toutes fonctions exportees s'appliquent aussi bien a des objets 
# zinc qu'a des objets mtools. L'unique restriction est dans la methode d'appel :
#	- obligatoirement : fct ($obj, @parametres) pour un objet zinc
#	- indiferemment $obj -> fct (@parametres).
# L'avantage de la premiere methode est qu'elle s'applique aussi bien a un objet zinc qu'a un objet MTools. 
# L'inconvenient est que l'on perd la possibilite de profiter de l'heritage et de la redefinition eventuelle de la fonction.
#
# La fonction particuliere "new" :
#	La fonction "new" permet de generer une nouvelle frame encapsulant un canvas zinc. 
#	Une frame MTools est unique pour une application
#	Elle initialise par ailleurs les donnees generiques pour le fonctionnement de MTools
#
# Les callbacks dans MTools :
#	\&fct : execution de fct ()
#	[\&fct, @params] : execution de fct (@params)
#	['fct_name', $obj, @params] : execution de $obj -> fct_name (@params)
#	[$obj, 'fct_name', @params] : execution de $obj -> fct_name (@params)
#	[$obj, \&fct_name, @params] : execution de fct_name ($obj, @params)
#
# Fonctions :
#	- propertyExists : test si une propriete MTools a ete enregistree (par recordProperty) 
#	pour l'objet en question. S'il s'agit d'un objet zinc la valeur retournee est forcement 0.
#	- mconfigure : permet de configurer indifferement des proprietes zinc ou MTools d'un objet. 
#	Les parametres sont passes sous forme d'une table de hash.
#	Par habitude, les proprietes zinc ou definie pour assurer une compatibilite avec zinc (comme '-visible') 
#	on ete precedees d'un '-'.
#	- mget : $obj -> mget ('propriete') permet de recuperer la valeur d'une propriete
#	- plisten : $obj -> plisten ('property_name', callback) plisten permet d'ecouter les modifications 
#	des propriete mtools d'un objet => associe l'appel d'une fonction a la modification d'un objet MTools
#	- unplisten : $obj -> unplisten ('property_name', callback) supprime l'ecoute
#	- plink : plink ([$obj1, 'property_1'], [$obj2, 'property_2'], ...); Synchronise n proprietes. 
#	Si property_1 est modifiee, property_2 prendra la valeur de property_1 et reciproquement. A l'initialisation,
#	toutes les propriete prennent la valeur de property_1.
#	- executer : executer (callback); permet d'executer une callback du type predefini ci-dessus dans la section 
#	"Les callbacks dans MTools"
#	- binding : $obj -> binding ('evenement', callback) permet d'ecouter un evenement MTOOLS ou Tk survenant sur un objet.
#	binding peut aussi etre redefini pour ecouter de nouvelles sources d'evenements (par exemple MIvy ou WacomAdapter)
#	- unbinding : $obj -> unbinding ('evenement', callback) arrete l'ecoute d'un evenement
#	- minstanciate : minstanciate ('definition', $parent) permet de retourner un objet MTools à partir de la spec 'definition'
#	si 'definition' est un path svg, minstanciate instancie le svg et retourne un objet MTools encapsulant le contenu
#	si 'definition' est un objet zinc, minstanciate retourne un objet MTools encapsulant l'objet zinc
#	si 'definition' est deja un objet MTools, minstanciate retourne l'objet lui-meme.
#	minstanciate change egalement le groupe parent qui deviendra obligatoirement $parent
#	- minstance : minstance ($objet, $parent) est le cousin de minstanciate mais lui retourne obligatoirement un objet zinc
#	- mrun : lance l'execution de la main loop.
#	- mfind : $objet -> mfind ('tag') permet de chercher un fils de l'objet ayant le tag correspondant
#	- mplaying : permet de lire un fichier son
# Les fonctions suivantes encapsulent l'execution des fonction zinc associees voir la doc zinc.
# http://www.tkzinc.org/Documentation/refman-3.3.4/index.html
#	- raise
#	- scale
#	- translate
#	- rotate
#	- coords
#	- bbox
#	- width
#	- height
#	- type
#	- tset
#	- treset
#	- tget
#	- clone
#	- chggroup
#	




require Exporter;

BEGIN 
{
	@ISA = qw / Exporter/;
	@EXPORT = qw / %fonts $zinc $pathForAutogen translate rotate executer mconfigure binding unbinding raise mget 
		scale getGradient chggroup plink plisten mplaying minstance mrun minstanciate 
		propertyExists bbox width height mdelete mfind coords type tset treset tget clone unplisten/;
}

use strict;
use Tk::Zinc;
use Ivy;

use MTools::MObjet;
use MTools::SVG::SVGLoader;

our $zinc;
our %fonts;
our $pathForAutogen;

my %gradients;

sub new {
	my ($class, $width, $height, $title, $Zinc, $screen, $geometry, $PathForAutogen) = @_;

	my $self = {};
	bless $self, $class;

	if (!defined $Zinc)
	{
	$screen = ":0.0" if (!defined $screen);
	$self -> {window} = my $mw = MainWindow -> new ('-screen' =>$screen);
	$mw -> title($title);

	$mw->geometry ($geometry) if (defined $geometry);
	$self -> {zinc} = $zinc = $mw -> Zinc (
					       -width => $width,
					       -height => $height,
					       -borderwidth => 0,
					       -backcolor => 'white',
					       -render => 1,
					       ) -> pack (qw/-expand yes -fill both/);
	}
	else
	{
	  $self -> {zinc}   = $zinc;
	  $zinc = $Zinc;
	  $self -> {window} = $zinc->toplevel ;
	}

	# Path for AUTOGEN: format the path
	if(defined $PathForAutogen){
		$PathForAutogen =~ s/^\///g ;
		$PathForAutogen = "$PathForAutogen/" if not $PathForAutogen =~ /\/$/;
		$PathForAutogen =~ s/\//::/g;
		$pathForAutogen = $PathForAutogen;
	}

	return $self;
}

my $link_token = 0;

sub __configure {
	my ($obj, $sender, $key, $value) = @_;
	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
	if ($obj_instance ne $obj)
	{
		my $oldvalue = $obj -> {__properties} -> {$key} -> {val};
		$obj -> {__properties} -> {$key} -> {val} = $value;
		if (defined $obj -> {__properties} -> {$key} -> {listeners})
		{
			my @listeners = @{$obj -> {__properties} -> {$key} -> {listeners}};
			for (my $i = 0; $i < @listeners; $i++)
			{
				executer ($listeners [$i], $sender, $key, $value, $oldvalue);
			}
		}
	}
	else
	{
		eval 
		{
			$zinc -> itemconfigure ($obj_instance, $key => $value);
		};
		if ($@) 
		{
			die "##### Error MTools::__confproplink : property $key not defined for $obj\n";
		}	
	}
}

sub __confproplink {
	my ($sender, $obj, $key, $val) = @_;
	
	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
	if ($obj_instance ne $obj)
	{
		if ($obj -> {__properties} -> {$key} -> {link_token} != $link_token)
		{
			$obj -> {__properties} -> {$key} -> {link_token} = $link_token;
			if (defined $obj -> {__properties} -> {$key} -> {links})
			{
				my @links = @{$obj -> {__properties} -> {$key} -> {links}};
				for (my $i = 0; $i < @links; $i ++)
				{
					__confproplink ($obj, $links [$i] -> [0], $links [$i] -> [1], $val);
				}
			}
			__configure ($obj, $sender, $key, $val);
		}
	}
	else
	{
		eval 
		{
			$zinc -> itemconfigure($obj_instance, $key => $val);
		};
		if ($@) 
		{
			die "##### Error MTools::__confproplink : property $key not defined for $obj\n";
		}			
	}
}

sub propertyExists {
	my ($obj, $key) = @_;
	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
	if ($obj_instance ne $obj)
	{
		if (exists $obj -> {__properties} -> {$key})
		{
			return 1;
		}
	}
	return 0;
}

sub mconfigure {
	my ($obj, %options) = @_;
	my $obj_instance = ref ($obj) eq '' ? $obj : $obj -> {instance};
	my %zinc_props = ();
	if ($obj_instance ne $obj)
	{
 		while ( my ($key, $val) = each (%options) )
		{
			my $oldval;
			if (exists $obj -> {__properties} -> {$key})
			{
				if (defined $obj -> {__properties} -> {$key} -> {links})
				{
					$link_token ++;
					$obj -> {__properties} -> {$key} -> {link_token} = $link_token;
					my @links = @{$obj -> {__properties} -> {$key} -> {links}};
					for (my $i = 0; $i < @links; $i ++)
					{
						 __confproplink ($obj, $links [$i] -> [0], $links [$i] -> [1], $val);
					}
				}
				__configure ($obj, $obj, $key, $val);
			}
			else
			{
				$zinc_props {$key} = $val;
			}
		}
 	}
 	else
 	{
	 	%zinc_props = %options;
 	}

 	if (%zinc_props)
 	{
 		eval 
		{
			$zinc -> itemconfigure ($obj_instance, %zinc_props);
		};
		if ($@) 
		{
			my $prop = "";
			while (my ($k, $val) = each (%zinc_props))
			{
				$prop .= " '$k'";
			}
			die "##### Error MTools::mconfigure : one of the following properties :$prop, is not defined for $obj\n";
		}
	}
}

# WARNING 
# Les modification effectuees directement sur les objets zinc ne sont pas propagees
# En revanche, une modification effectuee sur un autre objet peut entrainer la modification 
# d'un objets zinc.
sub plink {
	my (@objets) = @_;

	if (! @objets) {return;}
	
	for (my $i = 0; $i < @objets; $i ++)
	{
		my $obj = $objets [$i] -> [0];
		my $key = $objets [$i] -> [1];
		# La propriete est une propriete zinc, 
		if(ref ($obj) ne '')
		{
			# On la transforme en propriete MTools si ce n'est pas deja fait
			if ( !defined $obj -> {__properties} -> {$key} )
			{
				$obj -> {__properties} -> {$key} -> {val} = $obj -> mget ($key);
				push (@{$obj -> {__properties} -> {$key} -> {links}}, [$obj -> {instance}, $key]);
				$obj -> {__properties} -> {$key} -> {link_token} = 0;
				# et on associe la modification de la propriete zinc avec la modification propriete MTools
			}
		}
	}
	my $val = ($objets [0] -> [0]) -> mget ($objets [0] -> [1]);
	# Normalement, tous les objets non zinc doivent donc avoir une propriete MTools
	$link_token ++;
	for (my $i = 0; $i < @objets; $i ++)
	{
		my $obj = $objets [$i] -> [0];
		my $key = $objets [$i] -> [1];
		# Si l'objet n'est pas un objet zinc, on associe a sa propriete tous ses liens
		if(ref ($obj) ne '')
		{
			for (my $j = 0; $j < @objets; $j ++)
			{
				if ($i != $j)
				{
					# Enregistre
					push (@{$obj -> {__properties} -> {$key} -> {links}}, $objets [$j]);
					__confproplink ($objets [0], $obj, $key, $val);
				}			
			}
		}
		else
		{
			eval 
			{
				$zinc -> itemconfigure ($obj, $key => $val);
			};
			if ($@) 
			{
				die "##### Error MTools::plink : property $key not defined for $obj\n";
			}
		}
	}
}

sub plisten {
	my ($obj, $key, $methode) = @_;
	
	# Si la propriete est une propriete zinc, on la transforme en propriete MTools 
	# et on lie la modification de la propriete MTools a la propriete zinc
	if ( !defined $obj -> {__properties} -> {$key} )
	{
		$obj -> {__properties} -> {$key} -> {val} = $obj -> mget ($key);
		plink ([$obj, $key], [$obj -> {instance}, $key]);
	}
	push (@{$obj -> {__properties} -> {$key} -> {listeners}}, $methode);
	mconfigure ($obj, $key => mget ($obj, $key));
	return $methode;
}

sub unplisten {
	my ($obj, $key, $methode) = @_;
	if (defined $obj -> {__properties} -> {$key} -> {listeners})
	{
		for (my $i = @{$obj -> {__properties} -> {$key} -> {listeners}} - 1; $i >=  0; $i --) 
		{
			if (@{$obj -> {__properties} -> {$key} -> {listeners}} [$i] eq $methode) 
			{
				splice (@{$obj -> {__properties} -> {$key} -> {listeners}}, $i, 1);
			}
		}
	 }
}

sub mget {
	my ($obj, $key) = @_;
	if (ref ($obj) ne '')
	{
		if (defined $obj -> {__properties} -> {$key})
		{
			return $obj -> {__properties} -> {$key} -> {val};
		}
		else
		{
			my $retour;
			eval 
			{
				$retour = $zinc -> itemcget (minstance ($obj), $key);
			};
			if ($@) 
			{
				die "##### Error MTools::mget : property $key not defined for $obj\n";
			}
			return $retour;
		}
	}
	else
	{
		my $retour;
		eval 
		{
			$retour = $zinc -> itemcget ($obj, $key);
		};
		if ($@) 
		{
			die "##### Error MTools::mget : property $key not defined for $obj\n";
		}
		return $retour;
	}
}

sub mdelete {
	my ($obj) = @_;
	if (ref ($obj) ne '')
	{
		$zinc -> remove ($obj -> {instance});
		$obj -> {__events} = {};
		$obj -> {__properties} = {};
		undef $obj;
	}
	else
	{
		$zinc -> remove ($obj);
	}
}

sub binding {
	my ($obj, $spec, $sub) = @_;
	if ($spec =~ /\<(.*)\>/)
	{
		$obj = ref ($obj) eq ''?$obj:$obj -> {instance};
		if (type ($obj) eq 'group')
		{
			mconfigure ($obj, '-atomic' => 1);
		}
		if (ref ($sub) eq 'ARRAY')
		{
			$zinc -> bind ($obj, $spec, [\&__callback_binding, @{$sub}]);
		}
		else
		{
			$zinc -> bind ($obj, $spec, [\&__callback_binding, $sub]);
		}
		return $sub;
	}
	else
	{
		$obj -> __addListener ($spec, $sub);
		return $sub;
	}
}

sub __callback_binding {
	my ($tk, @cbk) = @_;
	executer (\@cbk);
}

sub unbinding {
	my ($obj, $spec, $sub) = @_;
	if ($spec =~ /\<(.*)\>/)
	{
		$zinc -> bind ( ref ($obj) eq '' ? $obj : $obj -> {instance}, $spec, undef);
	}
	else
	{
		$obj -> __removeListener ($spec, $sub);
	}
}

sub tset {
	my ($obj, @args) = @_;
	return $zinc -> tset (ref ($obj) eq '' ? $obj : $obj -> {instance}, @args);
}

sub tget {
	my ($obj) = @_;
	return $zinc -> tget (ref ($obj) eq '' ? $obj : $obj -> {instance});
}

sub treset {
	my ($obj) = @_;
	return $zinc -> treset (ref ($obj) eq '' ? $obj : $obj -> {instance});
}

sub bbox {
  my ($obj) = @_;
  return $zinc -> bbox (ref ($obj) eq '' ? $obj : $obj -> {instance});
}

sub width {
  my ($obj) = @_;
  my ($x1,$y1,$x2,$y2) = bbox($obj);
  return ($x2 - $x1);
}

sub height {
  my ($obj) = @_;
  my ($x1,$y1,$x2,$y2) = bbox($obj);
  return ($y2 - $y1);
}

sub coords {
  my ($obj, @args) = @_;
  return $zinc -> coords (ref ($obj) eq '' ? $obj : $obj -> {instance}, @args);
}

sub type {
	my ($obj) = @_;
	$zinc -> type (ref ($obj) eq '' ? $obj : $obj -> {instance});
}


sub raise {
	my ($obj) = @_;
	$zinc -> raise (ref ($obj) eq '' ? $obj : $obj -> {instance});
}

sub chggroup {
	my ($obj, $parent, $adjust) = @_;
	$zinc -> chggroup (ref ($obj) eq '' ? $obj : $obj -> {instance}, ref ($parent) eq '' ? $parent : $parent -> {instance},$adjust);
}

sub clone {
	my ($obj, $parent) = @_;
	return $zinc -> clone (ref ($obj) eq '' ? $obj : $obj -> {instance});
}

sub scale {
	my ($obj, @params) = @_;
	$zinc -> scale (ref ($obj) eq '' ? $obj : $obj -> {instance}, @params);
}

sub translate {
	my ($obj, @params) = @_;
	$zinc -> translate (ref ($obj) eq '' ? $obj : $obj -> {instance}, @params);
}

sub rotate {
	my ($obj, @params) = @_;
	$zinc -> rotate (ref ($obj) eq '' ? $obj : $obj -> {instance}, @params);
}

sub mfind {
	my ($obj, @params) = @_;
	my @tagged = $zinc -> find ('withtag', @params);
	my $ref = ref ($obj) eq '' ? $obj : $obj -> {instance};
	if (@tagged)
	{
		for (my $i = 0; $i < @tagged; $i++)
		{
			my @ancestors = $zinc -> find ('ancestors', $tagged [$i]);
			for (my $j = 0; $j < @ancestors; $j ++)
			{
				if ($ancestors [$j] == $ref)
				{
					return $tagged [$i];
				}
			}
		}
		print "#### Warning : can't find any object matching with @params \n";
	}
	else
	{
		print "#### Warning : can't find any object matching with @params \n";
	}
	return undef;
}

sub executer {
	my ($tb, @params) = @_;
	if (ref ($tb) eq 'ARRAY')
	{
		my @fct = @{$tb};
		my $methode = shift @fct;
		if(ref ($methode) eq 'CODE')
		{
			&$methode (@fct, @params);
		}
		elsif (ref ($methode) eq '')
		{
			my $objet = shift @fct;
			$objet -> $methode (@fct, @params);
		}
		else
		{
			my $objet = shift @fct;
			$methode -> $objet (@fct, @params);
		}
	}
	else
	{
		&$tb(@params);
	}
}

sub getGradient {
	
	my $pack = shift (@_);
	my $id = shift (@_);
	my $type = shift (@_);
	my $unit = shift (@_);

	if (defined $gradients {"$pack#$id"})
	{
		return "$pack#$id";
	}
	if ($type eq 'axial')
	{
		my ($x1, $y1, $x2, $y2, $stops, $a00, $a01, $a10, $a11, $a20, $a21, $bb_x1, $bb_y1, $bb_x2, $bb_y2) = @_;

		if ($unit ne 'userSpaceOnUse')
		{
			$x1 = $x1 * 100 - 50;
			$x2 = $x2 * 100 - 50;
			$y1 = $y1 * 100 - 50;
			$y2 = $y2 * 100 - 50;
		}

	    $x1 = $a00 * $x1 + $a10 * $y1 + $a20;
	    $y1 = $a01 * $x1 + $a11 * $y1 + $a21;
    	$x2 = $a00 * $x2 + $a10 * $y2 + $a20;
	    $y2 = $a01 * $x2 + $a11 * $y2 + $a21;
	  
		my ($zx1, $zx2, $zy1, $zy2);
		if ($unit eq 'userSpaceOnUse')
		{
			my $cx = ($bb_x1 + $bb_x2) / 2;
			my $cy = ($bb_y1 + $bb_y2) / 2;
			my $w = ($bb_x2 - $bb_x1);
			my $h = ($bb_y2 - $bb_y1);
			
			$zx1 = $w ? 100 * ($x1 - $cx) / $w : 0;
			$zx2 = $w ? 100 * ($x2 - $cx) / $w : 0;
			$zy1 = $h ? 100 * ($y1 - $cy) / $h : 0;
			$zy2 = $h ? 100 * ($y2 - $cy) / $h : 0;
			
			$zx1 = $zx1 > 0 ? int ($zx1 + 0.5) : int ($zx1 - 0.5);
			$zx2 = $zx2 > 0 ? int ($zx2 + 0.5) : int ($zx2 - 0.5);
			$zy1 = $zy1 > 0 ? int ($zy1 + 0.5) : int ($zy1 - 0.5);
			$zy2 = $zy2 > 0 ? int ($zy2 + 0.5) : int ($zy2 - 0.5);
		}
		else
		{
			$zx1 = $x1;
			$zx2 = $x2;
			$zy1 = $y1;
			$zy2 = $y2;
		}
	    
		my $path = "=axial $zx1 $zy1 $zx2 $zy2 | $stops";
		$zinc -> gname ($path, "$pack#$id");
		$gradients {"$pack#$id"} = 1;
		return "$pack#$id";
	}
	
	if ($type eq 'radial')
	{
		my ($x1, $y1, $stops, $bb_x1, $bb_y1, $bb_x2, $bb_y2) = @_;
		if ($unit eq 'userSpaceOnUse')
		{
			$x1 = 0;
			$y1 = 0;
		}
		my $path = "=radial $x1 $y1 | $stops";
		$zinc -> gname ($path, "$pack#$id");
		$gradients {"$pack#$id"} = 1;
		return "$pack#$id";
	}
	
	return $type;
}

use IPC::Open2;

sub mplaying {
	my ($file) = @_;
	$file = Tk::findINC ($file);
#	my $player = Tk::findINC ("essai.pl");
#	my ($out,$in);
#	open2 ($out, $in, "perl $player $file");
	my $h1;
	my $h2;
	open2 ($h1, $h2, "play $file \&");
}

sub minstance {
	my ($obj, $parent) = @_;
	if ( ref ($obj) eq '')
	{
		if( $obj =~ /SVG\((.*)\)/)
		{
			my $tmp = MTools::SVG::SVGLoader::load ($1, $parent);
			return $tmp -> {instance};
		}
		else
		{
			if( $obj =~ /(.*)\.svg\#(.*)/)
			{
				my $tmp = MTools::SVG::SVGLoader::load ($obj, $parent);
				return $tmp -> {instance};
			}
			else
			{
				return $obj;
			}
		}
	}
	else
	{
		return $obj -> {instance};
	}
}

sub mrun {
	&Tk::MainLoop;
}

sub minstanciate {
	my ($path, $parent) = @_;
	if ( ref ($path) eq '')
	{
		if( $path =~ /SVG\((.*)\)/)
		{
			return MTools::SVG::SVGLoader::load ($1, $parent);
		}
		else
		{
			if( $path =~ /(.*)\.svg\#(.*)/)
			{
				return MTools::SVG::SVGLoader::load ($path, $parent);
			}
			elsif( $path =~ /(.*)\.svg/)
			{
				return MTools::SVG::SVGLoader::load ($path, $parent);
			}
			else
			{	
				my $obj = new MTools::MObjet ();
				$obj -> {instance} = $path;
				$obj -> chggroup ($parent);
				return $obj;
			}
		}
	}
	else
	{
		$path -> chggroup ($parent);
		return $path;
	}
}

1;