diff options
Diffstat (limited to 'exemples/Rattrapage.pm')
| -rw-r--r-- | exemples/Rattrapage.pm | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/exemples/Rattrapage.pm b/exemples/Rattrapage.pm new file mode 100644 index 0000000..c6ec0bc --- /dev/null +++ b/exemples/Rattrapage.pm @@ -0,0 +1,181 @@ +package Rattrapage; +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU GPL 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 General Public License for more details. +# +# You should have received a copy of the GNU 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/gpl.html +# + +use strict; + +use vars qw /@ISA/; + +use MTools; +use MTools::MGroup; +use MTools::Widget::MToggleBouton; +use MTools::Widget::MBouton; +use Lien; + +use Tk; + +BEGIN +{ + @ISA = qw /MTools::MGroup/; +} + +sub new { + my ($class, $parent, $comete1, $comete2, $manager, %options) = @_; + my $lien = new Lien ($parent, $comete1, $comete2); + my $self = new MTools::MGroup ($parent); + bless $self, $class; + + $self -> {__lien} = $lien; + $self -> {__manager} = $manager; + + $self -> recordProperty ('seuil', 8); + $self -> recordProperty ('mesure', 10); + $self -> recordProperty ('statut', 'editable'); + $self -> mconfigure (%options); + $self -> recordProperty ('warning', 0); + + $self -> {__listener} = $manager -> plisten ('-visible', sub { + my ($src, $key, $val, $old) = @_; + $self -> mconfigure ('statut' => $val ? 'editable':'non_editable'); + }); + + plink ([$lien, 'distance'], [$self, 'mesure']); + $lien -> plisten ('c_x', sub { + my ($src, $key, $val, $old) = @_; + $self -> translate ($val - $old, 0); + }); + $lien -> plisten ('c_y', sub { + my ($src, $key, $val, $old) = @_; + $self -> translate (0, $val - $old); + }); + $self -> translate ($lien -> mget ('c_x'), $lien -> mget ('c_y')); + + my $bck = minstanciate ('rattrapage.svg#bck', $self); + + my $evolution = new MTools::MSwitch ( + $self, + stable => ['rattrapage.svg#stable'], + montee => ['rattrapage.svg#croissant'], + descente => ['rattrapage.svg#decroissant'], + ); + $self -> plisten ('mesure', sub { + my ($src, $key, $val, $old) = @_; + $self -> {__old_val} = $self -> {__old_val_wait}; + my $tval = $self -> {__old_val}; + if ($val < $tval) + { + $evolution -> mconfigure (state => 'descente'); + } + elsif ($val > $tval) + { + $evolution -> mconfigure (state => 'montee'); + } + $self -> {__old_val_wait} = $old; + if ($val <= $self -> mget ('seuil')) + { + $self -> mconfigure (warning => 1); + } + else + { + $self -> mconfigure (warning => 0); + } + }); + $self -> plisten ('seuil', sub { + my ($src, $key, $val, $old) = @_; + if ($val >= $self -> mget ('mesure')) + { + $self -> mconfigure (warning => 1); + } + else + { + $self -> mconfigure (warning => 0); + } + }); + + my $mesure = minstanciate ('rattrapage.svg#mesure', $self); + my $seuil = minstanciate ('rattrapage.svg#seuil', $self); + minstanciate ('rattrapage.svg#cdr_seuil_h', $self); + minstanciate ('rattrapage.svg#cdr_seuil_b', $self); + + my $bouton_cloche = new MTools::Widget::MToggleBouton ( + parent => $self, + g_on => 'rattrapage.svg#cloche', + g_off => 'rattrapage.svg#cloche_fantome', + e_press => 'CLOCHE', + e_release => 'PAS_CLOCHE' + ); + + my $bouton_delete = new MTools::Widget::MBouton ( + parent => $self, + g_on => 'rattrapage.svg#delete_on', + g_off => 'rattrapage.svg#delete_off', + e_release => 'DELETE' + ); + + my $gp_mask = new MTools::MGroup ($self); + $self -> {__down} = minstanciate ('rattrapage.svg#mask_seuil_down', $gp_mask); + $self -> {__down} -> mconfigure (-visible => 0); + $self -> {__up} = minstanciate ('rattrapage.svg#mask_seuil', $gp_mask); + my $seuil_mask = minstanciate ('rattrapage.svg#seuil', $gp_mask); + minstanciate ('rattrapage.svg#cdr_seuil_h_edit', $gp_mask); + minstanciate ('rattrapage.svg#cdr_seuil_b_edit', $gp_mask); + + my $editable = new MTools::MSwitch ( + $self, + editable => [$bouton_delete, $gp_mask, $bouton_cloche], + non_editable => [], + ); + + $gp_mask -> binding ('<Button-1>', ['pressed', $self, Ev ('y')]); + $gp_mask -> binding ('<Button1-Motion>', ['motion', $self, Ev ('y')]); + $gp_mask -> binding ('<ButtonRelease-1>', ['released', $self, Ev ('y')]); + $bouton_delete -> binding ('DELETE', ['mdelete', $self]); + + plink ([$self, 'mesure'], [$mesure, '-text']); + plink ([$self, 'seuil'], [$seuil, '-text'], [$seuil_mask, '-text']); + plink ([$self, 'statut'], [$editable, 'state']); + plink ([$self, 'warning'], [$lien, 'warning']); + + return $self; +} + +sub mdelete { + my ($self) = @_; + $self -> {__manager} -> unplisten ('-visible', $self -> {__listener}); + $self -> {__lien} -> mdelete (); + MTools::mdelete ($self); +} + +sub pressed { + my ($self, $y) = @_; + $self -> {__y} = $y; + $self -> {__init_value} = $self -> mget ('seuil'); + $self -> {__down} -> mconfigure (-visible => 1); + $self -> {__up} -> mconfigure (-visible => 0); +} + +sub motion { + my ($self, $y) = @_; + $self -> mconfigure ('seuil', $self -> {__init_value} - int (($y - $self -> {__y}) / 20) * 0.5); +} + +sub released { + my ($self, $y) = @_; + $self -> {__down} -> mconfigure (-visible => 0); + $self -> {__up} -> mconfigure (-visible => 1); +} + +1; |