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;