diff options
Diffstat (limited to 'src/MTools/Comp/MWritable.pm')
| -rw-r--r-- | src/MTools/Comp/MWritable.pm | 276 |
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; |