aboutsummaryrefslogtreecommitdiff
path: root/src/MTools/Comp
diff options
context:
space:
mode:
Diffstat (limited to 'src/MTools/Comp')
-rw-r--r--src/MTools/Comp/MAntiRecouvrement.pm240
-rw-r--r--src/MTools/Comp/MFlicker.pm79
-rw-r--r--src/MTools/Comp/MFocuser.pm89
-rw-r--r--src/MTools/Comp/MInertie.pm153
-rw-r--r--src/MTools/Comp/MMover.pm221
-rw-r--r--src/MTools/Comp/MMultiSelection.pm754
-rw-r--r--src/MTools/Comp/MReconizer.pm145
-rw-r--r--src/MTools/Comp/MTremor.pm121
-rw-r--r--src/MTools/Comp/MWritable.pm276
9 files changed, 2078 insertions, 0 deletions
diff --git a/src/MTools/Comp/MAntiRecouvrement.pm b/src/MTools/Comp/MAntiRecouvrement.pm
new file mode 100644
index 0000000..1e10edd
--- /dev/null
+++ b/src/MTools/Comp/MAntiRecouvrement.pm
@@ -0,0 +1,240 @@
+package MTools::Comp::MAntiRecouvrement;
+# 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
+#
+##################################################################
+
+# Encapsule l'algorithme d'anti-recouvrement des objets et gere les objets anti-recouvres
+# IMPORTANT : Les objets anti-recouvre doivent heriter de MTools::GUI::MAntiRecouvrementGroup
+#
+# BUG : La propriete '-visible' devrait permettre d'activer ou non l'anti-recouvrement global des objets.
+# Ce n'est pas le cas aujourd'hui, cette popriete est inactive
+#
+# Fonctions :
+# * addObject : permet d'inclure un objet heritant de MTools::GUI::MAntiRecouvrementGroup dans l'algorithme d'anti-recouvrement
+# * removeObjet : permet de sortir un objet de l'algorithme d'anti-recouvrement
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+ my ($class) = @_;
+ my $self = new MTools::MObjet ();
+ bless $self, $class;
+
+ $self -> recordProperty ('-visible', 1);
+ $self -> recordEvent ('ITEM_MOVED');
+ $self -> {__objects} = ();
+ $self -> {__known_objects} = ();
+ $self -> {__ask_move} = ();
+ $self -> {__ask_reaction} = ();
+
+ return $self;
+}
+
+sub addObject {
+ my ($self, $ob) = @_;
+ my $ever_known = 0;
+ if (defined $self -> {__known_objects})
+ {
+ my @known = @{$self -> {__known_objects}};
+ for (my $i = 0; $i < @known; $i ++)
+ {
+ if ($known [$i] eq $ob)
+ {
+ $ever_known = 1;
+ last;
+ }
+ }
+ }
+ if (!$ever_known)
+ {
+ binding ($ob, '__HANDLE_MOVING', [$self, \&__on_handle_moving_on_track]);
+ binding ($ob, '__PUSH_BACK', [$self, \&__on_push_back_on_track]);
+ binding ($ob, '__ENQUEUE_MOVING', [$self, \&__on_enqueue_moving_on_track]);
+ push (@{$self -> {__known_objects}}, $ob);
+ }
+ if (!defined $ob -> {__added} || $ob -> {__added} == 0)
+ {
+ push (@{$self -> {__objects}}, $ob);
+ }
+ $ob -> update_bbox ();
+ $ob -> {__added} = 1;
+ $ob -> translate (0, 0);
+}
+
+sub removeObject {
+ my ($self, $target) = @_;
+ for (my $i = @{$self -> {__objects}} - 1; $i >= 0; $i --)
+ {
+ if (@{$self -> {__objects}} [$i] eq $target)
+ {
+ @{$self -> {__objects}} [$i] -> {__added} = 0;
+ splice (@{$self -> {__objects}}, $i, 1);
+ }
+ }
+}
+
+sub __on_handle_moving_on_track {
+ my ($self) = @_;
+ my ($first_work, $first_track, $current_track, $intersection);
+ while (scalar @{$self -> {__ask_move}} > 0)
+ {
+ $first_work = $self -> {__ask_move} -> [0];
+ $first_track = $first_work -> [0];
+ my ($firstx, $firsty) = ($first_track -> mget ('x'), $first_track -> mget ('y'));
+ for (my $i = 0; $i < @{$self -> {__objects}}; $i++)
+ {
+ $current_track = @{$self -> {__objects}} [$i];
+ next if ($current_track eq $first_track);
+ my ($x, $y) = ($current_track -> mget ('x'), $current_track -> mget ('y'));
+ $intersection = __intersection (
+ $firstx, $firsty,
+ $first_track -> mget ('width'), $first_track -> mget ('height'),
+ $x, $y,
+ $current_track -> mget ('width'), $current_track-> mget ('height')
+ );
+ next if (($intersection -> [2] == 0) and ($intersection -> [3] == 0));
+ if ($intersection -> [2] < $intersection -> [3])
+ {
+ if ($firstx < $x)
+ {
+ $current_track -> __try_move ($intersection -> [2], 0, $first_work -> [3]);
+ }
+ else
+ {
+ $current_track -> __try_move(-$intersection -> [2], 0, $first_work -> [3]);
+ }
+ }
+ else
+ {
+ if ($firsty < $y)
+ {
+ $current_track -> __try_move (0, $intersection -> [3], $first_work -> [3]);
+ }
+ else
+ {
+ $current_track -> __try_move (0, -$intersection -> [3], $first_work -> [3]);
+ }
+ }
+ }
+ shift @{$self -> {__ask_move}};
+ }
+ $self -> notify ('ITEM_MOVED');
+}
+
+sub __on_push_back_on_track {
+ my ($self, $track, $delta_x, $delta_y, $path) = @_;
+ push @{$path}, $track;
+ my @other_path = @{$path};
+ $self -> __on_enqueue_moving_on_track ($track, $delta_x, $delta_y, [@other_path]);
+ $track -> __update_xy ($delta_x, $delta_y);
+ my ($current_track, $push_x, $push_y, $intersection);
+ my ($firstx, $firsty) = ($track -> mget ('x'), $track -> mget ('y'));
+
+ for (my $i = 0; $i < @{$self -> {__objects}}; $i++)
+ {
+ $current_track = @{$self -> {__objects}} [$i];
+ next if $current_track eq $track;
+ my ($x, $y) = ($current_track -> mget ('x'), $current_track -> mget ('y'));
+ $intersection = __intersection (
+ $firstx, $firsty,
+ $track -> mget ('width'), $track -> mget ('height'),
+ $x, $y,
+ $current_track -> mget ('width'), $current_track -> mget ('height')
+ );
+ $push_x = 0;
+ $push_y = 0;
+ $push_x = $intersection -> [2] if ($intersection -> [2] <= $delta_x);
+ $push_x = -$intersection -> [2] if ($intersection -> [2] <= -$delta_x);
+ $push_y = $intersection -> [3] if ($intersection -> [3] <= $delta_y);
+ $push_y = -$intersection -> [3] if ($intersection -> [3] <= -$delta_y);
+ $self -> __on_push_back_on_track ($current_track, $push_x, $push_y, $path)
+ if ((($push_x != 0) or ($push_y != 0)) and (__occurences ($current_track, @{$path}) < 3));
+ }
+ pop @{$path};
+}
+
+sub __intersection {
+ my ($x1, $y1, $w1, $h1, $x2, $y2, $w2, $h2) = @_;
+ my ($x, $y, $w, $h);
+ $x = &__max_of ($x1, $x2);
+ $w = &__min_of ($x1 + $w1, $x2 + $w2) - $x;
+ if ($w > 0)
+ {
+ $y = &__max_of ($y1, $y2);
+ $h = &__min_of ($y1 + $h1, $y2 + $h2) - $y;
+ if ($h > 0)
+ {
+ return [$x, $y, $w, $h];
+ }
+ }
+ return [0, 0, 0, 0];
+}
+
+sub __min_of {
+ my (@values) = @_;
+ my $res = $values [0];
+ foreach (@values)
+ {
+ $res = $_ if ($_ <= $res);
+ }
+ return $res;
+}
+
+sub __max_of {
+ my (@values) = @_;
+ my $res = $values [0];
+ foreach (@values)
+ {
+ $res = $_ if ($_ >= $res);
+ }
+ return $res;
+}
+
+sub __occurences {
+ my ($val,@tab) = @_;
+ my $result = 0;
+ if (($#tab != -1) and (defined $val))
+ {
+ foreach (@tab)
+ {
+ if (($_ eq $val) or ($_ =~ m/$val/))
+ {
+ $result++;
+ }
+ }
+ }
+ return $result;
+}
+
+sub __on_enqueue_moving_on_track {
+ my ($self, $track, $delta_x, $delta_y, $path) = @_;
+ push @{$self -> {__ask_move}}, [$track, $delta_x, $delta_y, $path];
+}
+
+
+
+1;
diff --git a/src/MTools/Comp/MFlicker.pm b/src/MTools/Comp/MFlicker.pm
new file mode 100644
index 0000000..fd622c8
--- /dev/null
+++ b/src/MTools/Comp/MFlicker.pm
@@ -0,0 +1,79 @@
+package MTools::Comp::MFlicker;
+# 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 permet d'ajouter un comportement de clignotement ? un objet cible
+#
+# Parametres :
+#
+# * target : objet cible du tremblement
+# * periode : periode du clignottement
+# Propriete :
+# * flick : demarre le clignottement
+# * show : rend l'objet cible toujours visible
+# * hide : rend l'objet cible toujours masque
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MSwitch/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, $target, $periode) = @_;
+ my $self = new MTools::MObjet ();
+ $self -> {__target} = $target;
+ $self -> {__target} -> mconfigure (-visible => 0);
+ bless $self, $class;
+
+ $self -> recordProperty ('periode', $periode);
+
+ $self -> {__timer} = new MTools::MTimer ($periode, 1, sub {
+ $self -> {__target} -> mconfigure (-visible => !$self -> {__target} -> mget (-visible));
+ });
+
+ plink ([$self, 'periode'], [$self -> {__timer}, 'timeout']);
+
+ return $self;
+}
+
+sub flick {
+ my ($self) = @_;
+ $self -> {__timer} -> start ();
+}
+
+sub show {
+ my ($self) = @_;
+ $self -> {__timer} -> stop ();
+ $self -> {__target} -> mconfigure (-visible => 1);
+}
+
+sub hide {
+ my ($self) = @_;
+ $self -> {__timer} -> stop ();
+ $self -> mconfigure ('state' => 'unvisible');
+}
+
+1;
diff --git a/src/MTools/Comp/MFocuser.pm b/src/MTools/Comp/MFocuser.pm
new file mode 100644
index 0000000..cb821ae
--- /dev/null
+++ b/src/MTools/Comp/MFocuser.pm
@@ -0,0 +1,89 @@
+package MTools::Comp::MFocuser;
+# 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
+#
+##################################################################
+
+# L'objet MFocuser permet de gerer le focus entre plusieurs objets
+#
+# Parametres :
+# * @targets : objets entre lesquels est gere le focus
+# Fonctions :
+# * add : permet de prendre en compte un nouvel objet
+# * setFocused : force le focus sur un objet
+
+use strict;
+use MTools;
+use MTools::MObjet;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, @targets) = @_;
+ my $self = {};
+ bless $self, $class;
+
+ $self -> recordEvent ('GET_FOCUS');
+ $self -> recordEvent ('SET_FOCUS');
+
+ $self -> {__targets} = \@targets;
+ for (my $i; $i < @targets; $i++)
+ {
+ $targets [$i] -> binding ('GET_FOCUS', ['setFocused', $self]);
+ }
+
+ $self -> binding ('SET_FOCUS', ['setFocused', $self]);
+
+ return $self;
+}
+
+sub add {
+ my ($self, $tg) = @_;
+ push (@{$self -> {__targets}}, $tg);
+ $tg -> binding ('GET_FOCUS', ['setFocused', $self]);
+}
+
+sub setFocused {
+ my ($self, $tg) = @_;
+ if (!defined $self -> {__targets}) {return;}
+ my @tgs = @{$self -> {__targets}};
+ my $from_children = 0;
+ for (my $i; $i < @tgs; $i++)
+ {
+ if ($tgs [$i] ne $tg)
+ {
+ $tgs [$i] -> notify ('SET_FOCUS');
+ }
+ else
+ {
+ $from_children = 1;
+ }
+ }
+ if ($from_children)
+ {
+ $self -> notify ('GET_FOCUS', $self);
+ }
+}
+
+1;
+
+
diff --git a/src/MTools/Comp/MInertie.pm b/src/MTools/Comp/MInertie.pm
new file mode 100644
index 0000000..9b820a0
--- /dev/null
+++ b/src/MTools/Comp/MInertie.pm
@@ -0,0 +1,153 @@
+package MTools::Comp::MInertie;
+# 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
+#
+##################################################################
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use Time::HiRes;
+
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, $target, %options) = @_;
+ my $self = new MTools::MObjet ();
+ bless $self, $class;
+
+ my $msg_pressed = defined $options {msg_pressed} ? $options {msg_pressed} : 'PRESSED';
+ my $msg_moved = defined $options {msg_moved} ? $options {msg_moved} : 'MOVED';
+ my $msg_released = defined $options {msg_released} ? $options {msg_released} : 'RELEASED';
+ my $msg_stopped = defined $options {msg_stopped} ? $options {msg_stopped} : 'INERTIE_STOPPED';
+
+ delete $options {msg_pressed};
+ delete $options {msg_moved};
+ delete $options {msg_released};
+ delete $options {msg_stopped};
+
+ $self -> recordProperty ('target', $target);
+ $self -> recordProperty ('-visible', 1);
+ $self -> recordProperty ('rate', 0.85);
+ $self -> recordProperty ('inertie_callback', 'translate');
+
+ $self -> recordEvent ($msg_stopped);
+ $self -> mconfigure (%options);
+
+ $self -> {__old_t} = 0;
+ $self -> {__old_x} = 0;
+ $self -> {__old_y} = 0;
+ $self -> {__x} = 0;
+ $self -> {__y} = 0;
+ $self -> {__t} = 0;
+ $self -> {__vx} = 0;
+ $self -> {__vy} = 0;
+
+ $self -> {__msg_stopped} = $msg_stopped;
+
+ $target -> binding ($msg_pressed, [$self, 'target_pressed']);
+ $target -> binding ($msg_moved, [$self, 'target_moved']);
+ $target -> binding ($msg_released, [$self, 'target_released']);
+
+ $self -> {timer_inertie} = new MTools::MTimer (1000/60, 1, [$self, 'inertie']);
+
+ return $self;
+}
+
+sub interrupt {
+ my ($self) = @_;
+ $self -> {timer_inertie} -> stop ();
+}
+
+sub target_pressed {
+ my ($self, $x, $y, $t) = @_;
+ $self -> interrupt ();
+ $self -> {__old_x} = 0;
+ $self -> {__old_y} = 0;
+ $self -> {__old_t} = 0;
+ $self -> {__x} = 0;
+ $self -> {__y} = 0;
+ $self -> {__t} = 0;
+}
+
+sub target_moved {
+ my ($self, $x, $y, $t) = @_;
+ if (!defined $t)
+ {
+ $t = Time::HiRes::gettimeofday();
+ }
+ $self -> {__old_x} = $self -> {__x};
+ $self -> {__old_y} = $self -> {__y};
+ $self -> {__old_t} = $self -> {__t};
+ $self -> {__x} = $x;
+ $self -> {__y} = $y;
+ $self -> {__t} = $t;
+}
+
+sub target_released {
+ my ($self, $x, $y, $t) = @_;
+ if (!defined $t)
+ {
+ $t = Time::HiRes::gettimeofday();
+ }
+ my $dt = $self -> {__t} - $self -> {__old_t};
+ my $dx = $self -> {__x} - $self -> {__old_x};
+ my $dy = $self -> {__y} - $self -> {__old_y};
+ if ($dt && $self -> mget ('-visible'))
+ {
+ $self -> {__vx} = ($dx * 1000) / ($dt * 60);
+ $self -> {__vy} = ($dy * 1000) / ($dt * 60);
+ $self -> {timer_inertie} -> start();
+ }
+ else
+ {
+ $self -> notify ($self -> {__msg_stopped});
+ }
+ $self -> {__old_x} = 0;
+ $self -> {__old_y} = 0;
+ $self -> {__old_t} = 0;
+ $self -> {__x} = 0;
+ $self -> {__y} = 0;
+ $self -> {__t} = 0;
+}
+
+sub inertie {
+ my ($self) = @_;
+ my $rate = $self -> mget ('rate');
+ $self -> {__vx} *= $rate;
+ $self -> {__vy} *= $rate;
+ if ((abs $self -> {__vx} <= 2) and (abs $self -> {__vy} <= 2))
+ {
+ $self -> notify ($self -> {__msg_stopped});
+ $self -> {timer_inertie} -> stop();
+ return;
+ }
+ my $dx = $self -> {__vx};
+ my $dy = $self -> {__vy};
+ my $target = $self -> mget ('target');
+ my $callback = $self -> mget ('inertie_callback');
+ $target -> $callback ($dx, $dy);
+}
+
+1;
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;
diff --git a/src/MTools/Comp/MMultiSelection.pm b/src/MTools/Comp/MMultiSelection.pm
new file mode 100644
index 0000000..f124720
--- /dev/null
+++ b/src/MTools/Comp/MMultiSelection.pm
@@ -0,0 +1,754 @@
+package MTools::Comp::MMultiSelection;
+# 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 MMultiSelection associe deux comportements :
+# 1. Selection multiple d'objets repartis eventuellement dans plusieurs plans.
+# La selection des objets est geree en les entourant et des-entourant.
+# Si un objet est selectionne dans le plan 1, les objets situes dans les plans 2, 3, etc. sont negliges.
+# De meme, si un objet est selectionne dans le plan, les objets situes dans les plans 3, 4, etc. sont negliges.
+# 2. Deux interactions peuvent-etre initiees depuis la zone de selection. Si l'interaction est demarree
+# au-dessus d'un objet, on deplace les objets selectionnes. Si on demarre un interaction au-dessus du fond,
+# on demarre une operation de designation de cibles.
+#
+# Les cibles et les objets selectionnables doivent declarer des proprietes particulieres. Il n'y a ce jour de
+# composant definissant ces interfaces, c'est un tord... Qui est volontaire :)
+#
+# Les source doivent definir les prorpiete
+# barycentre_x
+# barycentre_y
+# La position d'un objet est definie par
+# la valeur de barycentre_x plus optionnelement la valeur de la propriete x si celle-ci est definie
+# la valeur de barycentre_y plus optionnelement la valeur de la propriete y si celle-ci est definie
+# Les cibles doivent emettre les evenements
+# DRAGENTER
+# DRAGLEAVE
+# RELEASEDOVER
+#
+# NOTA : le deuxieme comportement devrait etre dissocie de l'objet multi-selection...
+# Cela reste a faire egalement
+#
+# Parametres :
+# * src : Objet sur lequel est effectue l'interaction de selection
+# * dessin : Group parent du dessin de la selection
+# * reference a la frame principale
+# Proprietes :
+# * delay : duree pendant laquelle le dessin de la selection s'estompe et pendant laquelle le demarrage de la
+# seconde interaction est possible
+# * inertie : coefficient d'inertie dqns le deplacement de la fleche
+# Evenements :
+# * PRESSED : Notifie lorsque l'on demarre la selection
+# * MOVED : Notifie lorsque la selection evolue
+# * RELEASED : Notifie lorsque la selection est terminee
+# * FLECHEPRESSED : Notifie lorsque une seconde interaction est demarree depuis la zone de selection
+# * FLECHEMOVED : Notifie lorsque la seconde interaction evolue
+# * FLECHERELEASED : Notifie lorsque la seconde interaction se termine
+# * SELECTION_CHANGED : Notifie lorsque le statut d'un objet a change
+# Fonctions :
+# * addObject : $multi -> addObject ($objet, $plan)
+# Ajoute l'objet $objet dans le plan de selection $plan
+# * removeObject : $multi -> removeObject ($objet, $plan)
+# Supprime l'objet $objet du plan de selection $plan
+# * addDropTarget : $multi -> addDropTarget ($target)
+# Ajoute la cible $target
+# * removeDropTarget : $multi -> removeDropTarget ($target)
+# Supprime la cible $target
+# * applySelection : $multi -> applySelection ($plan, $fonction, @parametres)
+# Applique la fonction $fonction (@parametres) ? tous les objets selectionnes dans le plan $plan
+# * applyAll : $multi -> applyAll ($plan, $fonction, @parametres)
+# Applique la fonction $fonction (@parametres) ? tous les objets du plan $plan
+# * getSelectedPlan : $multi -> getSelectedPlan ()
+# Retourne l'index du plan selectionne
+# * getSelection : $multi -> getSelection ($plan)
+# Retourne la liste des objets selectionnes dans le plan $plan si $plan est d?fini
+# sinon retourne $multi -> getSelection ($multi -> getSelectedPlan ())
+#
+
+
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use Math::Trig;
+use MTools::Anim::MOpacity;
+use MTools::Comp::MInertie;
+use MTools::MGroup;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, $src, $dessin, $frame, %options) = @_;
+ my $self = new MTools::MObjet ();
+ bless $self, $class;
+
+ $self -> recordProperty ('delay', 0);
+ $self -> recordProperty ('inertie', 0.6);
+ $self -> recordEvent ('PRESSED');
+ $self -> recordEvent ('MOVED');
+ $self -> recordEvent ('RELEASED');
+ $self -> recordEvent ('FLECHEPRESSED');
+ $self -> recordEvent ('FLECHEMOVED');
+ $self -> recordEvent ('FLECHERELEASED');
+ $self -> recordEvent ('SELECTION_CHANGED');
+ $self -> recordEvent ('DESELECT_ALL');
+ $self -> mconfigure (%options);
+
+ binding ($src, '<Button-1>', [\&__pressed, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($src, '<Button1-Motion>', [\&__moved, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($src, '<ButtonRelease-1>', [\&__released, $self, Ev('x'), Ev('y'), Ev('t')]);
+
+ $self -> {__inertie} = my $inertie = new MTools::Comp::MInertie(
+ $self,
+ 'rate' => $self -> mget ('inertie'),
+ );
+ binding ($inertie, 'INERTIE_STOPPED', [$self, \&__fin_moved]);
+
+ my $inertie = new MTools::Comp::MInertie(
+ $self,
+ 'rate' => 0.75,
+ 'msg_pressed' => 'FLECHEPRESSED',
+ 'msg_moved' => 'FLECHEMOVED',
+ 'msg_released' => 'FLECHERELEASED',
+ 'msg_stopped' => 'FLECHEINERTIE_STOPPED',
+ 'inertie_callback' => '__translate_fleche',
+ );
+ binding ($inertie, 'FLECHEINERTIE_STOPPED', [$self, \&__fin_fleche_moved]);
+
+ $self -> {__frame} = $frame;
+ $self -> {__drop_targets} = ();
+ $self -> {__objects} = ();
+ $self -> {__points} = ();
+ $self -> {__owns_data} = ();
+ $self -> {__source} = minstance ($src);
+
+ $self -> {__gp_anime} = my $group = new MTools::MGroup ($dessin);
+
+ push (@{$self -> {__owns_data}}, minstance ($src));
+ push (@{$self -> {__owns_data}}, minstance ($group));
+
+ $self -> {__anim__disparition} = new MTools::Anim::MOpacity (
+ duration => 0.8,
+ targets => $group,
+ from_opacity => 100,
+ to_opacity => 0,
+ );
+
+ binding ($self -> {__anim__disparition}, 'ANIMATION_END', [$self, \&__clear]);
+
+ $self -> {__curve_bck} = $zinc -> add ('curve', minstance($group), [[0,0],[0,0]],
+ -linecolor => "#888888;50",
+ -linewidth => 2,
+ -smoothrelief => 1,
+ -priority => 10,
+ -visible => 1,
+ -sensitive => 1,
+ -filled => 0,
+ );
+ $self -> {__curve} = $zinc -> add ('curve', minstance($group), [[0,0],[0,0]],
+ -linecolor => "#FFFFFF;90",
+ -linewidth => 1,
+ -smoothrelief => 1,
+ -priority => 10,
+ -visible => 1,
+ -sensitive => 1,
+ -fillcolor => "#FFFFFF;10",
+ -filled => 1,
+ );
+ push (@{$self -> {__owns_data}}, minstance ($self -> {__curve}));
+
+ $self -> {__fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+ -linecolor => "black",
+ -linewidth => 2,
+ -priority => 10,
+ -visible => 1,
+ -sensitive => 0,
+ );
+ push (@{$self -> {__owns_data}}, minstance ($self -> {__fleche}));
+
+ $self -> {__ph_fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+ -linecolor => "black",
+ -linewidth => 2,
+ -priority => 10,
+ -visible => 1,
+ -sensitive => 0,
+ );
+ push (@{$self -> {__owns_data}}, minstance ($self -> {__ph_fleche}));
+
+ $self -> {__pb_fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+ -linecolor => "black",
+ -linewidth => 2,
+ -priority => 10,
+ -visible => 1,
+ -sensitive => 0,
+ );
+ push (@{$self -> {__owns_data}}, minstance ($self -> {__pb_fleche}));
+
+ binding ($self -> {__curve}, '<Button-1>', [\&__fleche_pressed, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($self -> {__curve}, '<Button1-Motion>', [\&__fleche_moved, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($self -> {__curve}, '<ButtonRelease-1>', [\&__fleche_released, $self, Ev('x'), Ev('y'), Ev('t')]);
+ $self -> {__fleche_points} = ();
+ $self -> {__fleche_started} = 0;
+ $self -> {__drag_started} = 0;
+ return $self;
+}
+
+sub __hide_cursor {
+ my ($self) = @_;
+ my $frame = $self -> {__frame};
+ $frame -> {window} -> Tk::configure (
+ -cursor => [ '@'.Tk::findINC('emptycursor.xbm'),
+ Tk::findINC('emptycursor.mask'),
+ 'black', 'black'
+ ]
+ );
+}
+
+sub __show_cursor {
+ my ($self) = @_;
+ my $frame = $self -> {__frame};
+ $frame -> {window} -> Tk::configure (
+ -cursor => "",
+ );
+}
+
+sub addObject {
+ my ($self, $object, $plan) = @_;
+ if (!defined $plan) {$plan = 0;}
+ if (!$object -> propertyExists ('barycentre_x'))
+ {
+ print "MMultiSelection Error property barycentre_x isn't defined in $object\n";
+ return;
+ }
+ if (!$object -> propertyExists ('barycentre_y'))
+ {
+ print "MMultiSelection Error property barycentre_y isn't defined in $object\n";
+ return;
+ }
+ $object -> {__surround_angle} = 0;
+ push (@{$self -> {__objects} [$plan]}, $object);
+}
+
+sub removeObject {
+ my ($self, $target, $plan) = @_;
+ if (!defined $plan) {$plan = 0;}
+ for (my $i = @{$self -> {__objects} [$plan]} - 1; $i >= 0; $i --)
+ {
+ if (@{$self -> {__objects} [$plan]} [$i] eq $target)
+ {
+ splice (@{$self -> {__objects} [$plan]}, $i, 1);
+ last;
+ }
+ }
+}
+
+sub addDropTarget {
+ my ($self, $target) = @_;
+ push (@{$self -> {__drop_targets}}, $target);
+}
+
+sub removeDropTarget {
+ my ($self, $target) = @_;
+ if ($self -> {__last_notified} == $target)
+ {
+ $self -> {__last_notified} = undef;
+ }
+ for (my $i = @{$self -> {__drop_targets}} - 1; $i >= 0; $i--)
+ {
+ if (@{$self -> {__drop_targets}} [$i] eq $target)
+ {
+ splice (@{$self -> {__drop_targets}}, $i, 1);
+ last;
+ }
+ }
+}
+
+sub __clear {
+ my ($self) = @_;
+ $self -> {__anim__disparition} -> stop ();
+ $self -> {__inertie} -> interrupt ();
+ $self -> {__fleche_started} = 0;
+ $self -> {__drag_started} = 0;
+ $self -> {__points} = ();
+ $self -> {__fleche_points} = ();
+ $self -> __reset_surrounding ();
+ $zinc -> coords ($self -> {__ph_fleche}, 0, [[0,0],[0,0]]);
+ $zinc -> coords ($self -> {__pb_fleche}, 0, [[0,0],[0,0]]);
+ $zinc -> coords ($self -> {__fleche}, 0, [[0,0],[0,0]]);
+ $zinc -> coords ($self -> {__curve}, 0, [[0,0],[0,0]]);
+ $zinc -> coords ($self -> {__curve_bck}, 0, [[0,0],[0,0]]);
+ $self -> {__gp_anime} -> mconfigure (
+ -alpha => 100,
+ );
+}
+
+sub __pressed {
+ my ($self, $x, $y, $t) = @_;
+ $self -> __clear ();
+ push (@{$self -> {__points}}, [$x, $y]);
+ $self -> notify ('PRESSED', $x, $y, $t);
+ $self -> notify ('DESELECT_ALL');
+}
+
+sub __released {
+ my ($self, $x, $y, $t) = @_;
+ my $pt = $self -> {__points}[@{$self -> {__points}} - 2];
+ $self -> notify ('RELEASED', $x - $pt -> [0], $y - $pt -> [1], $t);
+}
+
+sub __fin_moved {
+ my ($self) = @_;
+ if (!$self -> {__fleche_started} && !$self -> {__drag_started})
+ {
+ $self -> {__anim__disparition} -> start ();
+ }
+}
+
+sub __moved {
+ my ($self, $x, $y, $t) = @_;
+ push (@{$self -> {__points}}, [$x, $y]);
+ my @pts = @{$self -> {__points}};
+ $zinc -> coords ($self -> {__curve}, 0, \@pts);
+ $zinc -> coords ($self -> {__curve_bck}, 0, \@pts);
+ my $pt = $self -> {__points}[@{$self -> {__points}} - 2];
+ $self -> notify ('MOVED', $x - $pt -> [0], $y - $pt -> [1], $t);
+ $self -> __update_all ();
+}
+
+sub translate {
+ my ($self, $dx, $dy) = @_;
+ my $pt = $self -> {__points}[@{$self -> {__points}} - 1];
+ push (@{$self -> {__points}}, [$pt -> [0] - $dx, $pt -> [1] - $dy]);
+ my @pts = @{$self -> {__points}};
+ $zinc -> coords ($self -> {__curve}, 0, \@pts);
+ $zinc -> coords ($self -> {__curve_bck}, 0, \@pts);
+ $self -> __update_all ();
+}
+
+sub __fleche_pressed {
+ my ($self, $x, $y, $t) = @_;
+ my @all = $zinc -> find ('overlapping', $x, $y, $x + 1, $y +1);
+ if ($all [1] == $self -> {__source})
+ {
+ $self -> {__fleche_points} = ();
+ push (@{$self -> {__fleche_points}}, [$x, $y]);
+ $self -> {__fleche_started} = 1;
+ $self -> __hide_cursor ();
+ $self -> notify ('FLECHEPRESSED', $x, $y, $t);
+ $self -> __stop_animation ();
+ }
+ else
+ {
+ $self -> {__drag_started} = 1;
+ $self -> {__lx} = $x;
+ $self -> {__ly} = $y;
+ $self -> notify ('FLECHEPRESSED', $x, $y, $t);
+ }
+}
+
+sub __stop_animation {
+ my ($self) = @_;
+ $self -> {__anim__disparition} -> stop ();
+ $self -> {__gp_anime} -> mconfigure (
+ -alpha => 100,
+ );
+}
+
+sub __fleche_released {
+ my ($self, $x, $y, $t) = @_;
+ if ($self -> {__fleche_started})
+ {
+ my $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 1];
+ $self -> notify ('FLECHERELEASED', $x - $pt -> [0], $y - $pt -> [1], $t);
+ }
+ else
+ {
+ $self -> notify ('FLECHERELEASED', $x - $self -> {__lx}, $y - $self -> {__ly}, $t);
+ $self -> {__lx} = $x;
+ $self -> {__ly} = $y;
+ }
+
+}
+
+sub __fin_fleche_moved {
+ my ($self) = @_;
+ if ($self -> {__fleche_started})
+ {
+ $self -> __clear ();
+ if (defined $self -> {__last_notified})
+ {
+ $self -> {__last_notified} -> notify ('RELEASEDOVER', $self);
+ $self -> {__last_notified} = undef;
+ }
+ elsif (defined $self -> {__secondary_last_notified})
+ {
+ $self -> {__secondary_last_notified} -> notify ('RELEASEDOVER', $self);
+ $self -> {__secondary_last_notified} = undef;
+ }
+ $self -> __show_cursor ();
+ }
+ else
+ {
+ }
+}
+
+sub __fleche_moved {
+ my ($self, $x, $y, $t) = @_;
+ if ($self -> {__fleche_started})
+ {
+ push (@{$self -> {__fleche_points}}, [$x, $y]);
+ my @pts = @{$self -> {__fleche_points}};
+ $zinc -> coords ($self -> {__fleche}, 0, \@pts);
+ my $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 2];
+ $self -> notify ('FLECHEMOVED', $x - $pt -> [0], $y - $pt -> [1], $t);
+ $self -> __update_fleche_moved ($x, $y);
+ }
+ else
+ {
+ $self -> notify ('FLECHEMOVED', $x - $self -> {__lx}, $y - $self -> {__ly}, $t);
+ $self -> __translate_selection ($x - $self -> {__lx}, $y - $self -> {__ly});
+ $self -> {__lx} = $x;
+ $self -> {__ly} = $y;
+ }
+}
+
+sub __translate_fleche {
+ my ($self, $dx, $dy) = @_;
+ if ($self -> {__fleche_started})
+ {
+ my $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 1];
+ push (@{$self -> {__fleche_points}}, [$pt -> [0] - $dx, $pt -> [1] - $dy]);
+ my @pts = @{$self -> {__fleche_points}};
+ $zinc -> coords ($self -> {__fleche}, 0, \@pts);
+ $self -> __update_fleche_moved ($pt -> [0] - $dx, $pt -> [1] - $dy);
+ }
+ else
+ {
+ $self -> __translate_selection (-$dx, -$dy);
+ }
+}
+
+sub __translate_selection {
+ my ($self, $dx, $dy) = @_;
+ my @oldy = $self -> applySelection (0, 'mget', 'y');
+ my @oldx = $self -> applySelection (0, 'mget', 'x');
+ my @selection = $self -> getSelection ();
+ for (my $i = 0; $i < @selection; $i ++)
+ {
+ my $x = $selection [$i] -> mget ('x');
+ my $pdx = $dx - ($x - $oldx [$i]);
+ my $y = $selection [$i] -> mget ('y');
+ my $pdy = $dy - ($y - $oldy [$i]);
+ $selection [$i] -> translate ($pdx, $pdy);
+ }
+}
+
+sub __update_fleche_moved {
+ my ($self, $x, $y) = @_;
+ my $pt;
+ if (@{$self -> {__fleche_points}} > 2)
+ {
+ $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 3];
+ }
+ else
+ {
+ $pt = $self -> {__fleche_points}[@{$self -> {__fleche_points}} - 2];
+ }
+ my $xa = $x - $pt -> [0];
+ my $ya = $y - $pt -> [1];
+ if ($xa + $ya == 0) {return;}
+
+ my $norme = sqrt ($xa * $xa + $ya * $ya);
+ $xa = $xa * 8 / $norme;
+ $ya = $ya * 8 / $norme;
+
+ if ( $xa != 0)
+ {
+ my $yb = sqrt ((10 * 10 - $xa * $xa - $ya * $ya) / (1 + $ya * $ya / ($xa * $xa)));
+ my $xb = -$yb * $ya / $xa;
+ $zinc -> coords ($self -> {__ph_fleche}, 0, [[$x, $y], [$x + $xb - $xa, $y + $yb - $ya]]);
+ $zinc -> coords ($self -> {__pb_fleche}, 0, [[$x, $y], [$x - $xb - $xa, $y - $yb - $ya]]);
+ }
+ else
+ {
+ my $xb = sqrt (10 * 10 - $ya * $ya);
+ my $yb = 0;
+ $zinc -> coords ($self -> {__ph_fleche}, 0, [[$x, $y], [$x + $xb - $xa, $y + $yb - $ya]]);
+ $zinc -> coords ($self -> {__pb_fleche}, 0, [[$x, $y], [$x - $xb - $xa, $y - $yb - $ya]]);
+ }
+ my @all = $zinc -> find ('overlapping', $x, $y, $x + 1, $y +1);
+
+ if (defined $self -> {__drop_targets})
+ {
+ my @selected;
+ my @owns = @{$self -> {__owns_data}};
+ for (my $i = 0; $i < @all; $i++)
+ {
+ my $find = 0;
+ for (my $j = 0; $j < @owns; $j ++)
+ {
+ if ($all [$i] == $owns [$j])
+ {
+ $find = 1;
+ }
+ }
+ if (!$find)
+ {
+ push (@selected, $all [$i]);
+ }
+ }
+ if (defined @selected)
+ {
+ my @targets = @{$self -> {__drop_targets}};
+ my $last_notified = $self -> {__last_notified};
+ $self -> {__last_notified} = undef;
+ for (my $i = 0; $i < @targets; $i ++)
+ {
+ if (minstance ($targets [$i]) == $selected [0] || minstance ($targets [$i]) == $selected [1])
+ {
+ if ($last_notified != $targets [$i])
+ {
+ $targets [$i] -> notify ('DRAGENTER');
+ }
+ $self -> {__last_notified} = $targets [$i];
+ }
+ else
+ {
+ if ($last_notified == $targets [$i])
+ {
+ $targets [$i] -> notify ('DRAGLEAVE');
+ }
+ }
+ }
+ }
+ }
+}
+
+sub getObjectBellow {
+ my ($self, $x, $y, @objects) = @_;
+ my @all = $zinc -> find ('overlapping', $x, $y, $x + 1, $y +1);
+ my @owns = @{$self -> {__owns_data}};
+ my @below;
+ for (my $i = 0; $i < @all; $i++)
+ {
+ my $find = 0;
+ for (my $j = 0; $j < @owns; $j ++)
+ {
+ if ($all [$i] == $owns [$j])
+ {
+ $find = 1;
+ }
+ }
+ if (!$find)
+ {
+ push (@below, $all [$i]);
+ }
+ }
+ my $nb = @below;
+ my @elements;
+ for (my $i = 0; $i < $nb; $i ++)
+ {
+ my @fils = $zinc -> find ('ancestors', $below [$i]);
+ push (@elements, '-'.$below [$i], @fils);
+ }
+ my $main;
+ for (my $j = 0; $j < @elements; $j ++)
+ {
+ if (index($elements [$j], '-') == 0)
+ {
+ $elements [$j] = substr ($elements [$j], 1, length ($elements [$j]));
+ $main = $elements [$j];
+ }
+ for (my $i = 0; $i < @objects; $i++)
+ {
+ if (minstance ($objects [$i]) == $elements [$j])
+ {
+ return ($objects [$i], $main);
+ }
+ }
+ }
+ return undef;
+}
+
+sub __update_all {
+ my ($self) = @_;
+ my $selection_changed = 0;
+ $self -> {_selected} = 0;
+ $self -> {__selected_plan} = -1;
+ if (defined $self -> {__objects})
+ {
+ my @object_plan = @{$self -> {__objects}};
+ for (my $j = 0; $j < @object_plan; $j ++)
+ {
+ if (defined $self -> {__objects} [$j])
+ {
+ my @items = @{$self -> {__objects} [$j]};
+ for (my $i = 0; $i < @items; $i++)
+ {
+ $selection_changed = $selection_changed || $self -> __update_surrouding ($items [$i], ($self -> {__selected_plan} != -1), $self -> {__points});
+ }
+ if ($self -> {_selected} && $self -> {__selected_plan} == -1)
+ {
+ $self -> {__selected_plan} = $j;
+ }
+ }
+ }
+ }
+ if ($selection_changed)
+ {
+ $self -> notify ('SELECTION_CHANGED', $self)
+ }
+}
+
+sub getSelectedPlan {
+ my ($self) = @_;
+ return $self -> {__selected_plan};
+}
+
+sub __update_surrouding {
+ my ($self, $item, $force_non_sel, $coords) = @_;
+ my $center_x = $item -> mget ('barycentre_x');
+ if ($item -> propertyExists ('x'))
+ {
+ $center_x += $item -> mget ('x');
+ }
+ my $center_y = $item -> mget ('barycentre_y');
+ if ($item -> propertyExists ('y'))
+ {
+ $center_y += $item -> mget ('y');
+ }
+ my ($tmp,$ref);
+ $ref = -$self -> __angle($coords, @{$coords} - 1, $center_x, $center_y, 0);
+ $tmp = -$self -> __angle($coords, @{$coords} - 2, $center_x, $center_y, $ref);
+ $item -> {__surround_angle} += $tmp;
+ $tmp = $self -> __angle($coords, 0, $center_x, $center_y, $ref);
+ if ($force_non_sel)
+ {
+ if ($item -> isSelected ())
+ {
+ $item -> setSelected (0);
+ }
+ }
+ else
+ {
+ if (abs ($item -> {__surround_angle} + $tmp) > 2)
+ {
+ $self -> {_selected} ++;
+ if (!$item -> isSelected ())
+ {
+ $item -> setSelected (1);
+ return 1;
+ }
+ }
+ else
+ {
+ if ($item -> isSelected ())
+ {
+ $item -> setSelected (0);
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+
+sub __angle {
+ my ($self, $coords, $index, $center_x, $center_y, $ref) = @_;
+ my $angle;
+ my $tab = $coords -> [$index];
+ $angle = atan2 ($tab -> [1] - $center_y, $tab -> [0] - $center_x) + $ref;
+ $angle -= 2*pi if ($angle > pi);
+ $angle += 2*pi if ($angle < - pi);
+ return $angle;
+}
+
+sub __reset_surrounding {
+ my ($self) = @_;
+ if (defined $self -> {__objects})
+ {
+ my @object_plan = @{$self -> {__objects}};
+ for (my $j = 0; $j < @object_plan; $j ++)
+ {
+ if (defined $self -> {__objects} [$j])
+ {
+ my @items = @{$self -> {__objects} [$j]};
+ for (my $i = 0; $i < @items; $i++)
+ {
+ $items [$i] -> {__surround_angle} = 0;
+ }
+ }
+ }
+ }
+}
+
+sub applySelection {
+ my ($self, $plan, $fct, @args) = @_;
+ my @retour;
+ if (defined $self -> {__objects} [$plan])
+ {
+ my @items = @{$self -> {__objects} [$plan]};
+ for (my $i = 0; $i < @items; $i++)
+ {
+ if ($items [$i] -> isSelected ())
+ {
+ push (@retour, $items [$i] -> $fct (@args));
+ }
+ }
+ }
+ return @retour;
+}
+
+sub applyAll {
+ my ($self, $plan, $fct, @args) = @_;
+ my @retour;
+ if (defined $self -> {__objects} [$plan])
+ {
+ my @items = @{$self -> {__objects} [$plan]};
+ for (my $i = 0; $i < @items; $i++)
+ {
+ push (@retour, $items [$i] -> $fct (@args));
+ }
+ }
+ return @retour;
+}
+
+sub getSelection {
+ my ($self, $plan) = @_;
+ if (!defined $plan) {$plan = $self -> getSelectedPlan ();}
+ my @selection;
+ if (defined $self -> {__objects} [$plan])
+ {
+ my @items = @{$self -> {__objects} [$plan]};
+ for (my $i = 0; $i < @items; $i++)
+ {
+ if ($items [$i] -> isSelected ())
+ {
+ push (@selection, $items [$i]);
+ }
+ }
+ }
+ return @selection;
+}
+
+1;
diff --git a/src/MTools/Comp/MReconizer.pm b/src/MTools/Comp/MReconizer.pm
new file mode 100644
index 0000000..9605eb9
--- /dev/null
+++ b/src/MTools/Comp/MReconizer.pm
@@ -0,0 +1,145 @@
+package MTools::Comp::MReconizer;
+# 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 permet de rendre un objet zinc sensible a la reco de geste
+#
+# Parametres :
+# * src : objet rendu sensible et donc source des evenements
+# * button : bouton de la souris utilise pour genere la reco de geste
+# * %options : table de hash permettant la configuration initiale des proprietes
+# Proprietes :
+# * animation_duration : duree de l'animation de disparition du feedback
+# * color : couleur du feedback
+# * callback : callback appelee sur reconnaissance
+# Evenements :
+# * START_GESTURE_RECO : evenement survenant lors du demarrage d'un geste
+# * RECONIZED : evenement survenant lorsque un geste est reconnu
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use Recogestures;
+
+use MTools::Anim::MOpacity;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, $src, $button, %options) = @_;
+ my $self = new MTools::MObjet ();
+ bless $self, $class;
+
+ $button = 1 if ! defined $button;
+
+ $self -> recordEvent ('RECONIZED');
+ $self -> recordEvent ('START_GESTURE_RECO');
+ $self -> recordProperty ('animation_duration', 0.5);
+ $self -> recordProperty ('color', 'blue');
+ $self -> recordProperty ('callback', undef);
+
+ $self -> mconfigure (%options);
+
+ binding ($src, "<Button-$button>", [\&__pressed, $self, Ev('x'), Ev('y')]);
+ binding ($src, "<Button$button-Motion>", [\&__moved, $self, Ev('x'), Ev('y')]);
+ binding ($src, "<ButtonRelease-$button>", [\&__released, $self, Ev('x'), Ev('y')]);
+
+ $self -> binding ('RECONIZED', sub {
+ my $methode = $self -> mget ('callback');
+ if (defined $methode)
+ {
+ executer ($methode, @_);
+ }
+ });
+ $self -> {__dessin} = undef;
+
+ $self -> {__dessin} = my $dessin = new MTools::MGroup (1);
+ $self -> {__fleche} = $zinc -> add ('curve', minstance($dessin), [[0,0],[0,0]],
+ -linecolor => 'blue',
+ -linewidth => 2,
+ -priority => 10,
+ -visible => 1,
+ -sensitive => 0,
+ );
+
+ $self -> {__anim__disparition} = new MTools::Anim::MOpacity (
+ duration => 0.8,
+ targets => $dessin,
+ from_opacity => 100,
+ to_opacity => 0,
+ );
+ binding ($self -> {__anim__disparition}, 'ANIMATION_END', [$self, \&__clear]);
+ plink ([$self, 'color'], [$self -> {__fleche}, '-linecolor']);
+ plink ([$self, 'animation_duration'], [$self -> {__anim__disparition}, 'duration']);
+
+ return $self;
+}
+
+sub __clear () {
+ my ($self, $x, $y) = @_;
+ $self -> {__points} = ();
+ $zinc -> coords ($self -> {__fleche}, 0, [[0,0],[0,0]]);
+ $self -> {__dessin} -> mconfigure (
+ -alpha => 100,
+ );
+}
+
+sub __pressed {
+ my ($self, $x, $y) = @_;
+ ($x, $y) = $zinc -> transform('device', minstance ($self -> {__dessin}), [$x, $y]);
+ if (defined $self -> {__dessin})
+ {
+ push (@{$self -> {__points}}, [$x, $y]);
+ }
+ $self -> notify ('START_GESTURE_RECO', $x, $y);
+}
+
+sub __moved {
+ my ($self, $x, $y) = @_;
+ ($x, $y) = $zinc -> transform('device', minstance ($self -> {__dessin}), [$x, $y]);
+ push (@{$self -> {trace}},$x,$y);
+
+ if (defined $self -> {__dessin})
+ {
+ push (@{$self -> {__points}}, [$x, $y]);
+ my @pts = @{$self -> {__points}};
+ $zinc -> coords ($self -> {__fleche}, 0, \@pts);
+ }
+}
+
+sub __released {
+ my ($self, $x, $y) = @_;
+
+ my ($gesture,$explanation) = AnalyzeGesture(@{$self -> {trace}});
+ $self -> {trace} = ();
+ $self -> notify ('RECONIZED', $gesture, $explanation);
+
+ if (defined $self -> {__dessin})
+ {
+ $self -> {__anim__disparition} -> start ();
+ }
+}
+
+1;
+
diff --git a/src/MTools/Comp/MTremor.pm b/src/MTools/Comp/MTremor.pm
new file mode 100644
index 0000000..25b5023
--- /dev/null
+++ b/src/MTools/Comp/MTremor.pm
@@ -0,0 +1,121 @@
+package MTools::Comp::MTremor;
+# 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 permet d'ajouter un comportement de tremblement ? un objet cible
+#
+# Parametres :
+# * target : objet cible du tremblement
+# * %options : table de hash permettant la configuration initiale des proprietes
+# Propriete :
+# * timeout : periode / 2 du tremblement
+# * target : cible
+# * amplitude_x, amplitude_y : amplitude du deplacement
+# * -visible : visibilite versus activation du comportement
+
+use strict;
+use MTools;
+#use MTools::MSwitch;
+use MTools::MTimer;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MObjet/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, $target, %options) = @_;
+
+ $self -> {__timer} = my $timer = new MTools::MTimer (200, 1, \&tremble);
+ my $self = new MTools::MObjet ();
+# $self -> {__sw} = new MTools::MSwitch (
+# $parent,
+# tremble => [$timer],
+# fixe => [],
+# );
+# $self -> {__sw} -> mconfigure (state => 'fixe');
+ $timer -> mconfigure ( callback => [$self, '__tremble']);
+ bless $self, $class;
+
+ $self -> recordProperty ('timeout', 200);
+ $self -> recordProperty ('target', $target);
+ $self -> recordProperty ('amplitude_x', 2);
+ $self -> recordProperty ('amplitude_y', 2);
+ $self -> recordProperty ('-visible', 0);
+ $self -> plisten ('-visible', sub {
+ my ($src, $key, $val) = @_;
+ if ($val == 0)
+ {
+ $self -> __stop ();
+ }
+ else
+ {
+ $self -> __start ();
+ }
+ });
+
+ $self -> mconfigure (%options);
+
+ plink ([$self, 'timeout'], [$timer, 'timeout']);
+ $self -> {__timer} = $timer;
+ $self -> {__x} = 0;
+ $self -> {__y} = 0;
+ $self -> {__started} = 0;
+ return $self;
+}
+
+sub __tremble {
+ my ($self) = @_;
+ my $target = $self -> mget ('target');
+ my $dx = -2 * $self -> {__x};
+ my $dy = -2 * $self -> {__y};
+ $self -> {__x} = -$self -> {__x};
+ $self -> {__y} = -$self -> {__y};
+ $target -> translate ($dx, $dy);
+}
+
+sub __start {
+ my ($self) = @_;
+ if ($self -> {__started}) {return;}
+ $self -> {__started} = 1;
+ my $target = $self -> mget ('target');
+ my $amplitudex = $self -> mget ('amplitude_x');
+ my $amplitudey = $self -> mget ('amplitude_y');
+ $self -> {__x} = $amplitudex;
+ $self -> {__y} = $amplitudey;
+ $target -> translate ($amplitudex, $amplitudey);
+# $self -> {__sw} -> mconfigure ('state' => 'tremble');
+ $self -> {__timer} -> start ();
+}
+
+sub __stop {
+ my ($self) = @_;
+ if (!$self -> {__started}) {return;}
+ $self -> {__started} = 0;
+ my $target = $self -> mget ('target');
+ $target -> translate (-$self -> {__x}, -$self -> {__y});
+ $self -> {__x} = 0;
+ $self -> {__y} = 0;
+ $self -> {__sw} -> mconfigure ('state' => 'fixe');
+ $self -> {__timer} -> stop ();
+}
+
+1;
diff --git a/src/MTools/Comp/MWritable.pm b/src/MTools/Comp/MWritable.pm
new file mode 100644
index 0000000..8a2a2d5
--- /dev/null
+++ b/src/MTools/Comp/MWritable.pm
@@ -0,0 +1,276 @@
+package MTools::Comp::MWritable;
+# 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 MWritable permet d'associer un comportement scritptible a un objet zinc
+# Le composant peut alors etre ecrit et l'ecriture effacee
+#
+# Parametres :
+# * parent : objet parent des curves qui vont etre dessinee au cours de l'ecriture
+# * src : objet source des evenements qui vont generer le dessin
+# * button : bouton de la souris utilise pour genere la reco de geste
+# * %options : table de hash permettant la configuration initiale des proprietes et de definir un objet clip ($options {clip})
+# l'objet clip permet de contenir l'ecriture libre dans une zone.
+# Proprietes :
+# * color : couleur d'ecriture
+# * writing_mode : ('write' ou 'erase') permet de specifier le resultat de l'interaction sur l'objet source (ecriture ou effacement)
+# Evenements :
+# * BEGIN_WRITE : Message emis lors d'un debut d'ecriture
+# * WRITE : Message emis lors de l'ecriture
+# * END_WRITE :Message emis lors d'une fin d'ecriture
+# * ERASE : Message emis lors de l'effacement
+# Fonctions :
+# * begin_write : force un debut d'ecriture
+# * write : force l'ecriture
+# * end_write : force une fin d'ecriture
+# * erase : force un effacement
+
+
+use strict;
+use MTools;
+use MTools::MObjet;
+use MTools::GUI::MClip;
+
+use vars qw /@ISA/;
+
+BEGIN
+{
+ @ISA = qw /MTools::MGroup/;
+}
+
+use Tk;
+
+sub new {
+ my ($class, $parent, $src, $button, %options) = @_;
+ my $self = new MTools::MGroup ($parent);
+ bless $self, $class;
+ if (defined $options {clip})
+ {
+ $self -> {__clip} = new MTools::GUI::MClip (
+ $self,
+ $options {clip},
+ );
+ }
+ delete $options {clip};
+ $self -> mconfigure (-atomic => 1);
+ $self -> recordProperty ('color', '#000000');
+ $self -> recordProperty ('writing_mode', 'write');
+ $self -> recordEvent ('BEGIN_WRITE');
+ $self -> recordEvent ('END_WRITE');
+ $self -> recordEvent ('WRITE');
+ $self -> recordEvent ('ERASE');
+ $button = 1 if ! defined $button;
+ binding ($src, "<Button-$button>", [\&__beginWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($src, "<Button$button-Motion>", [\&__writing, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($src, "<ButtonRelease-$button>", [\&__endWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($self, "<Button-$button>", [\&__beginWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($self, "<Button$button-Motion>", [\&__writing, $self, Ev('x'), Ev('y'), Ev('t')]);
+ binding ($self, "<ButtonRelease-$button>", [\&__endWrite, $self, Ev('x'), Ev('y'), Ev('t')]);
+ $self -> {__curves} = ();
+ $self -> {__points} = ();
+ $self -> {__current_curves} = ();
+ $self -> {__tmp_curves} = new MTools::MGroup ($self);
+ return $self;
+}
+
+sub __beginWrite {
+ my ($self, $x, $y) = @_;
+ ($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+ $self -> beginWrite ($x, $y);
+ $self -> notify ('BEGIN_WRITE', $x, $y)
+}
+
+sub beginWrite {
+ my ($self, $x, $y) = @_;
+ push (@{$self -> {__old_coords}}, ($x, $y));
+}
+
+sub __endWrite {
+ my ($self, $x, $y) = @_;
+ if ($self -> mget ('writing_mode') eq 'write')
+ {
+ ($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+ $self -> writing ($x, $y);
+ $self -> notify ('WRITE', $x, $y);
+ $self -> notify ('END_WRITE');
+ $self -> endWrite ();
+ }
+ else
+ {
+ $self -> {__old_coords} = ();
+ }
+}
+
+sub endWrite {
+ my ($self) = @_;
+ if (defined $self -> {__points} && @{$self -> {__points}})
+ {
+ my @points = @{$self -> {__points}};
+ push (@{$self -> {__curves}}, $zinc -> add (
+ 'curve',
+ minstance ($self),
+ [@points],
+ -linecolor => $self -> mget ('color'),
+ -linewidth => 1,
+ -priority => 2,
+ -visible => 1,
+ -sensitive => 0
+ )
+ );
+ $self -> {__points} = ();
+ $self -> {__tmp_curves} -> mdelete ();
+ $self -> {__tmp_curves} = new MTools::MGroup ($self);
+ }
+ $self -> {__old_coords} = ();
+}
+
+sub __writing {
+ my ($self, $x, $y) = @_;
+ if ($self -> mget ('writing_mode') eq 'write')
+ {
+ ($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+ $self -> writing ($x, $y);
+ $self -> notify ('WRITE', $x, $y)
+ }
+ else
+ {
+ erase ($self, $x, $y);
+ }
+}
+
+
+sub writing {
+ my ($self, $x, $y) = @_;
+ $self -> write ($x, $y);
+}
+
+sub write {
+ my ($self, $x, $y) = @_;
+ my @coords;
+ push (@{$self -> {__old_coords}}, ($x, $y));
+ my $list_size = @{$self -> {__old_coords}};
+ if ($list_size >= 6)
+ {
+ my $x1 = $self -> {__old_coords} -> [$list_size - 6];
+ my $y1 = $self -> {__old_coords} -> [$list_size - 5];
+ my $x2 = $self -> {__old_coords} -> [$list_size - 4];
+ my $y2 = $self -> {__old_coords} -> [$list_size - 3];
+ my $x3 = $self -> {__old_coords} -> [$list_size - 2];
+ my $y3 = $self -> {__old_coords} -> [$list_size - 1];
+ my $cx2 = ($x1 - $x3) * 0.2 + $x2;
+ my $cy2 = ($y1 - $y3) * 0.2 + $y2;
+ if ($list_size == 6)
+ {
+ @coords = ([$x1,$y1],[$cx2,$cy2,'c'],[$x2,$y2]);
+ }
+ else
+ {
+ my $cx1 = ($x2 - $self -> {__old_coords} -> [$list_size - 8]) * 0.2 + $x1;
+ my $cy1 = ($y2 - $self -> {__old_coords} -> [$list_size - 7]) * 0.2 + $y1;
+ @coords = ([$x1, $y1], [$cx1, $cy1, 'c'], [$cx2, $cy2, 'c'], [$x2, $y2]);
+ }
+ push (@{$self -> {__points}}, @coords);
+ push (@{$self -> {__current_curves}}, $zinc -> add (
+ 'curve',
+ minstance ($self -> {__tmp_curves}),
+ [@coords],
+ -linecolor => $self -> mget ('color'),
+ -linewidth => 1,
+ -priority => 2,
+ -visible => 1,
+ -sensitive => 0
+ )
+ );
+ }
+}
+
+my $k = 5;
+sub erase {
+ my ($self, $x, $y) = @_;
+ ($x, $y) = $zinc -> transform ('device', minstance ($self), [$x, $y]);
+ if (defined $self -> {__curves})
+ {
+ my @curves = @{$self -> {__curves}};
+ for (my $i = @curves - 1; $i >= 0 ; $i --)
+ {
+ my @points = $zinc -> coords ($curves [$i], 0);
+ for (my $j = 0; $j < @points - 1; $j ++)
+ {
+ my $pt1 = $points [$j];
+ my $pt2 = $points [$j + 1];
+
+ if ($pt1 -> [0] == $pt2 -> [0])
+ {
+ if (in ($y, $pt1 -> [1], $pt2 -> [1]) && ( abs ($pt1 -> [0] - $x) <= $k))
+ {
+ $self -> __deleteCurve ($i);
+ last;
+ }
+ }
+ else
+ {
+ my $a = ($pt1 -> [1] - $pt2 -> [1]) / ($pt1 -> [0] - $pt2 -> [0]);
+ my $b = $pt2 -> [1] - $a * $pt2 -> [0];
+ my $ar = ($a ** 2 + 1);
+ my $br = (2 * $a * ($b - $y) - 2 * $x);
+ my $cr = ($x ** 2 + ($b - $y) ** 2 - $k ** 2);
+ my $d = $br ** 2 - 4 * $ar * $cr;
+ if ($d >= 0)
+ {
+ if (mdist ($pt1 -> [0], $pt1 -> [1], $x ,$y) || mdist ($pt2 -> [0], $pt2 -> [1], $x ,$y))
+ {
+ $self -> __deleteCurve ($i);
+ last;
+ }
+ my $x1 = (-$br + sqrt ($d)) / (2 * $ar);
+ my $x2 = (-$br - sqrt ($d)) / (2 * $ar);
+ if (in ($x1, $pt1 -> [0], $pt2 -> [0]) || in ($x2, $pt1 -> [0], $pt2 -> [0]))
+ {
+ $self -> __deleteCurve ($i);
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+sub __deleteCurve {
+ my ($self, $index) = @_;
+ $self -> notify ('ERASE', $index);
+ $self -> deleteCurve ($index);
+}
+
+sub deleteCurve {
+ my ($self, $index) = @_;
+ $self -> {__old_coords} = ();
+ mdelete ($self -> {__curves} [$index]);
+ splice (@{$self -> {__curves}}, $index, 1);
+}
+
+sub in {
+ my ($x, $x0, $x1) = @_;
+ return (($x0 <= $x) && ($x <= $x1) || ($x1 <= $x) && ($x <= $x0));
+}
+
+sub mdist {
+ my ($x1, $y1, $x2, $y2) = @_;
+ return (($x1 - $x2) ** 2 + ($y1 - $y2) ** 2 <= ($k) ** 2);
+}
+
+1;
generated by cgit v1.1 at 2024-09-21 09:58:18 +0000