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 -> 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; 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;