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, "", [\&__pressed, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($src, "", [\&__moved, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($src, "", [\&__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;