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
#	- indefiremment $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 nouvelle source d'evenement (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
#	- type
#	- tset
#	- treset
#	- tget
#	- clone
#	- chggroup
#	




require Exporter;

BEGIN 
{
	@ISA = qw / Exporter/;
	@EXPORT = qw / %fonts $zinc translate rotate executer mconfigure binding unbinding raise mget 
		scale getGradient chggroup plink plisten mplaying minstance mrun minstanciate 
		propertyExists bbox 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;

my %gradients;

sub new {
	my ($class, $width, $height, $title) = @_;
	my $self = {};
	bless $self, $class;

	$self -> {window} = my $mw = MainWindow -> new ();
	$mw -> title($title);
	
	$self -> {zinc} = $zinc = $mw -> Zinc (
		-width => $width,
		-height => $height,
		-borderwidth => 0,
		-backcolor => 'white',
		-render => 1,
	) -> pack (qw/-expand yes -fill both/);

	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 (defined %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 (!defined @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, $ref) = @_;
	return $zinc -> tget (ref ($obj) eq '' ? $obj : $obj -> {instance}, $ref);
}

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 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) = @_;
	$zinc -> chggroup (ref ($obj) eq '' ? $obj : $obj -> {instance}, ref ($parent) eq '' ? $parent : $parent -> {instance});
}

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;