Import initial

1 files changed, 221 insertions, 0 deletions

diff --git a/src/MTools/Comp/MMover.pm b/src/MTools/Comp/MMover.pm
new file mode 100644
index 0000000..8282943
--- /dev/null
+++ b/src/MTools/Comp/MMover.pm
@@ -0,0 +1,221 @@
+package MTools::Comp::MMover;
+#	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
+#
+##################################################################
+
+# Le composant MMover permet de donner un comportement prehensible a un objet zinc. Les deplacements peuvent etre contraints a un espace defin
+#
+# Parametres :
+#	* src : objet source des evenements de deplacement
+#	* targets : objets deplaces
+#	* button : bouton de la souris utilise pour genere le deplacement
+# Proprietes :
+#	* x_min, y_min, x_max, y_max : contraintes de l'espace dans lequel peut se deplacer le strip
+#	* allower : fonction permettre d'appliquer une contrainte plus complexe sur l'objet
+#	* x, y : position de l'objet modifiee par le MMover
+#	* targets : objets deplaces
+#	* -visible : active ou desactive le comportement prehensible
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN 
+{
+	@ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+	my ($class, $src, $targets, $button, %options) = @_;
+	my $self = {};
+	bless $self, $class;
+
+	$self -> recordProperty ('x_min', -10000);
+	$self -> recordProperty ('y_min', -10000);
+	$self -> recordProperty ('x_max', 10000);
+	$self -> recordProperty ('y_max', 10000);
+	$self -> recordProperty ('-visible', 1);
+	$self -> recordProperty ('x', 0);
+	$self -> recordProperty ('y', 0);
+	$self -> recordProperty ('targets', $targets);
+	$self -> recordProperty ('allower', undef);
+	
+	$self -> mconfigure (%options);
+	
+	$self -> recordEvent ('PRESSED');
+	$self -> recordEvent ('MOVED');
+	$self -> recordEvent ('RELEASED');
+		
+	$button = 1 if ! defined $button;
+	binding ($src, "<Button-$button>", [\&__pressed, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, "<Button$button-Motion>", [\&__moved, $self, Ev('x'), Ev('y'), Ev('t')]);
+	binding ($src, "<ButtonRelease-$button>", [\&__released, $self, Ev('x'), Ev('y'), Ev('t')]);
+		
+	$self -> {__last_mouse_x} = 0;
+	$self -> {__last_mouse_y} = 0;
+
+	return $self;
+}
+
+sub setPos {
+	my ($self, $x, $y) = @_;
+	my $dx = $x - $self -> mget ('x');
+	my $dy = $y - $self -> mget ('y');
+	my $tgs = $self -> mget ('targets');
+	my @targets;
+	if (ref ($tgs) eq 'ARRAY')
+	{
+		@targets = @{$tgs};
+		for (my $i = 0; $i < @targets; $i++)
+		{
+			$targets [$i] -> translate ($dx, $dy);
+		}
+	}
+	else
+	{
+		$tgs -> translate ($dx, $dy);
+	}
+	$self -> mconfigure ('x', $x);
+	$self -> mconfigure ('y', $y);
+}
+
+sub __pressed {
+	my ($self, $x, $y, $t) = @_;
+	if(!$self -> mget('-visible')) {return;}
+	$self -> {__started} = 1;
+	$self -> {__last_mouse_x} = $x;
+	$self -> {__last_mouse_y} = $y;
+	$self -> notify ('PRESSED', $self -> {__last_mouse_x}, $self -> {__last_mouse_y}, $t);
+}
+
+sub __moved {
+	my ($self, $x, $y, $t) = @_;
+	if (!$self -> {__started}) {return;}
+	if(!$self -> mget('-visible')) {return;}
+	
+	my $dx = $x - $self -> {__last_mouse_x};
+	my $dy = $y - $self -> {__last_mouse_y};
+
+	my $x_min = $self -> mget('x_min');
+	my $y_min = $self -> mget('y_min');
+	my $x_max = $self -> mget('x_max');
+	my $y_max = $self -> mget('y_max');
+	my $current_x = $self -> mget ('x');
+	my $current_y = $self -> mget ('y');
+	if($current_x + $dx > $x_max)
+	{
+		$x -= $current_x + $dx - $x_max;	
+		$dx -= $current_x + $dx - $x_max;
+	}
+	if($current_y + $dy > $y_max)
+	{
+		$y -= $current_y + $dy - $y_max;	
+		$dy -= $current_y + $dy - $y_max;
+	}
+	if($current_x + $dx < $x_min)
+	{
+	
+		$x -= $current_x + $dx - $x_min;	
+		$dx -= $current_x + $dx - $x_min;
+	}
+	if($current_y + $dy < $y_min)
+	{
+		$y -= $current_y + $dy - $y_min;	
+		$dy -= $current_y + $dy - $y_min;
+	}
+	if( $dx == 0 && $dy == 0 )
+	{
+		return;
+	}
+	my $allower = $self -> mget ('allower');
+	if ($allower)
+	{
+		my ($ddx, $ddy) = executer ($allower, $current_x, $current_y, $dx, $dy);
+		$x -= $ddx;
+		$dx -= $ddx;
+		$y -= $ddy;
+		$dy -= $ddy;
+		if( $dx == 0 && $dy == 0 )
+		{
+			return;
+		}
+	}
+	$self -> {__last_mouse_x} = $x;
+	$self -> {__last_mouse_y} = $y;
+	$current_x += $dx;
+	$current_y += $dy;
+	$self -> notify ('MOVED', $current_x, $current_y, $t);	
+	$self -> setPos ($current_x, $current_y);
+}
+
+sub __released {
+	my ($self, $x, $y, $t) = @_;
+	$self -> {__started} = 0;
+	if(!$self -> mget('-visible')) {return;}
+	$self -> notify ('RELEASED', $self -> {__last_mouse_x}, $self -> {__last_mouse_y}, $t);
+}
+
+sub translate {
+	my ($self, $dx, $dy, $t) = @_;
+	my $x_min = $self -> mget('x_min');
+	my $y_min = $self -> mget('y_min');
+	my $x_max = $self -> mget('x_max');
+	my $y_max = $self -> mget('y_max');
+	my $current_x = $self -> mget ('x');
+	my $current_y = $self -> mget ('y');
+	if($current_x + $dx > $x_max)
+	{
+		$dx -= $current_x + $dx - $x_max;
+	}
+	if($current_y + $dy > $y_max)
+	{
+		$dy -= $current_y + $dy - $y_max;
+	}
+	if($current_x + $dx < $x_min)
+	{
+	
+		$dx -= $current_x + $dx - $x_min;
+	}
+	if($current_y + $dy < $y_min)
+	{
+		$dy -= $current_y + $dy - $y_min;
+	}
+	if( $dx == 0 && $dy == 0 )
+	{
+		return;
+	}
+	my $allower = $self -> mget ('allower');
+	if ($allower)
+	{
+		my ($ddx, $ddy) = executer ($allower, $current_x, $current_y, $dx, $dy);
+		$dx -= $ddx;
+		$dy -= $ddy;
+		if( $dx == 0 && $dy == 0 )
+		{
+			return;
+		}
+	}
+	$current_x += $dx;
+	$current_y += $dy;
+	$self -> setPos ($current_x, $current_y);
+	$self -> notify ('MOVED', $current_x, $current_y, $t);
+}
+
+1;