Import initial

1 files changed, 276 insertions, 0 deletions

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;