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, "", [\&__beginWrite, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($src, "", [\&__writing, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($src, "", [\&__endWrite, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($self, "", [\&__beginWrite, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($self, "", [\&__writing, $self, Ev('x'), Ev('y'), Ev('t')]); binding ($self, "", [\&__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;