aboutsummaryrefslogtreecommitdiff
path: root/src/MTools/Comp/MMover.pm
diff options
context:
space:
mode:
Diffstat (limited to 'src/MTools/Comp/MMover.pm')
-rw-r--r--src/MTools/Comp/MMover.pm221
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;
generated by cgit v1.1 at 2024-09-21 09:39:42 +0000