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 permettant 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 vars qw /@ISA/;

BEGIN 
{
	@ISA = qw /MTools::MObjet/;
}

use Tk;

sub new {
	my ($class, $src, $targets, $button, %options) = @_;
	my $self = new MTools::MObjet ();
	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 -> recordProperty ('magnetic', 10);
	$self -> recordProperty ('translate', 'translate');
	
	$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;
	my $translate_cbk = $self -> mget ('translate');
	if (ref ($tgs) eq 'ARRAY')
	{
		@targets = @{$tgs};
		for (my $i = 0; $i < @targets; $i++)
		{
			$targets [$i] -> $translate_cbk ($dx, $dy);
		}
	}
	else
	{
		$tgs -> $translate_cbk ($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');
	
	my ($cor_x, $cor_y) = $self -> checkMagneticConstraints ($current_x + $dx, $current_y + $dy);
	$dx += $cor_x;
	$dy += $cor_y;
	$x += $cor_x;
	$y += $cor_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);
}

sub addMagneticConstraints {
	my ($self, $type, $value) = @_;
	push (@{$self -> {magnetic_contraints}}, [$type, $value]);
} 

sub checkMagneticConstraints {
	my ($self, $x, $y) = @_;
	if ($self -> {magnetic_contraints}) {
		my $magnetic_step = $self -> mget ('magnetic');
		my $cx = undef;
		my $cy = undef;
		my @constraints = @{$self -> {magnetic_contraints}};
		for (my $i = 0; $i < @constraints; $i ++) {
			my $ct = $constraints [$i];
			if ($ct -> [0] eq 'x') {
				if (abs ($ct -> [1] - $x) < $magnetic_step) {
					if (defined $cx) {
						if (abs ($ct -> [1] - $x) < $cx) {
							$cx = $ct -> [1] - $x;
						}
					}
					else {
						$cx = $ct -> [1] - $x;
					}
				}
			}
			if ($ct -> [0] eq 'y') {
				if (abs ($ct -> [1] - $y) < $magnetic_step) {
					if (defined $cy) {
						if (abs ($ct -> [1] - $y) < $cy) {
							$cy = $ct -> [1] - $y;
						}
					}
					else {
						$cy = $ct -> [1] - $y;
					}
				}
			}
		}
		if (!defined $cx) {$cx = 0;}
		if (!defined $cy) {$cy = 0;}
		return ($cx, $cy);
	}
	return (0, 0);
}

1;