aboutsummaryrefslogtreecommitdiff
path: root/src/MTools
diff options
context:
space:
mode:
Diffstat (limited to 'src/MTools')
-rw-r--r--src/MTools/Widget/MArrow.pm297
-rw-r--r--src/MTools/Widget/MBouton.pm4
-rw-r--r--src/MTools/Widget/MControlBoard.pm192
3 files changed, 491 insertions, 2 deletions
diff --git a/src/MTools/Widget/MArrow.pm b/src/MTools/Widget/MArrow.pm
new file mode 100644
index 0000000..abfb5a3
--- /dev/null
+++ b/src/MTools/Widget/MArrow.pm
@@ -0,0 +1,297 @@
+package MTools::Widget::MArrow;
+# 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
+#
+##################################################################
+
+use strict;
+use Math::Trig;
+require Exporter;
+use Tk::Zinc::Graphics;
+use MTools;
+use MTools::GUI::MGroup;
+
+use vars qw /@ISA/;
+@ISA = qw(Exporter);
+my @EXPORT = qw(&arrowCoords);
+
+# orientation des flèches
+my $direction2angle = {'left' => 180,
+ 'top'=> 90,
+ 'right' => 0,
+ 'bottom' => 270,
+ 'w' => 180,
+ 'nw'=> 135,
+ 'n' => 90,
+ 'ne'=> 45,
+ 'e' => 0,
+ 'se' => 315,
+ 's' => 270,
+ 'sw' => 225
+ };
+
+
+BEGIN
+{
+ @ISA = qw /MTools::GUI::MGroup/;
+}
+
+sub new {
+ my ($class, %options) = @_;
+ my $parentgroup = $options {'parent'} ? $options {'parent'} : 1;
+ my $self = new MTools::GUI::MGroup ($parentgroup);
+
+
+ bless $self, $class;
+
+ # coords
+ $self -> coords ($options {'coords'}) if ($options {'coords'});
+
+ # coordonnées de la ligne support de flèche
+ if ($options {'linecoords'}) {
+ $self -> {'linecoords'} = $options {'linecoords'};
+ $self -> {'length'} = &distance(@{$self -> {'linecoords'}->[-1]},
+ @{$self -> {'linecoords'}->[-2]});
+ } else {
+ $self -> {'length'} = (defined $options {'length'}) ? $options {'length'} : 100;
+ $self -> {'linecoords'} = [[0,0],[$self -> {'length'},0]];
+ }
+
+ $self -> {'width'} = ($options{'width'}) ? $options{'width'} : $self -> {'length'};
+
+
+ # paramètres de direction
+ if (defined $options {angle}) {
+ $self -> {'angle'} = $options {'angle'};
+ $self -> {'direction'} = undef;
+
+ } else {
+ $self -> {'direction'} = ($options {'direction'}) ? $options {'direction'} : 'right';
+ }
+
+
+ # paramètres de forme
+ # (style, longueur et angle du marqueur flèche, épaisseur et rayon du tracé)
+ $self -> {'head_style'} = $options {'head_style'};
+ $self -> {'head_length'} = (defined $options {'head_length'}) ? $options {'head_length'} : $self -> {'length'}/2;
+
+ $self -> {'thick'} = ($options{'thick'})
+ ? $options{'thick'} : $self -> {'length'}/5;
+ $self -> {'radius'} = (defined $options{'radius'})
+ ? $options{'radius'} : $self -> {'thick'}/2;
+ $self -> {'head_angle'} = ($options{'head_angle'})
+ ? $options{'head_angle'} : 45;
+
+ # style graphique
+ $self -> {'style'} = $options {style};
+
+
+ $self -> build;
+
+ return $self;
+}
+
+
+sub build {
+ my $self = shift;
+
+ # le group de transformation (rotation) de la flèche
+ $self -> {'r_group'} = new MTools::GUI::MGroup ($self -> {instance});
+
+ # calcul des coordonnées de la curve
+ my $coords = $self->arrowCoords;
+
+ # style de l'item zinc
+ my $style = {-itemtype => 'curve',
+ -coords => $coords,
+ -params => {-closed => 1,
+ %{$self -> {'style'}},
+ },
+ };
+
+ # item TkZinc de forme de la flèche
+ $self -> {'-form'} = &buildZincItem($zinc, $self -> {'r_group'} -> {instance}, %{$style});
+
+ # orientation
+ $self->direction;
+
+}
+
+
+sub arrowCoords {
+ my ($self, %options) = @_;
+ my @pts;
+
+ my $width = ($options{'width'}) ? $options{'width'} : $self -> {'width'};;
+ my $head_length = ($options{'head_length'}) ? $options{'head_length'} : $self -> {'head_length'};
+ my $thick = ($options{'thick'}) ? $options{'thick'} : $self -> {'thick'};
+ my $head_angle = ($options{'head_angle'}) ? $options{'head_angle'} : $self -> {'head_angle'};
+ my $linecoords = ($options{'linecoords'}) ? $options{'linecoords'} : $self -> {'linecoords'};
+ my $radius = ($options{'radius'}) ? $options{'radius'} : $self -> {'radius'};
+
+ my ($pt0,$pt1) = reverse @{$linecoords};
+ my $endangle = &lineAngle($pt0,$pt1);
+
+
+ # points de flèche
+ my ($ptA,$ptB);
+
+ if (!defined $head_length) {
+ my $b_sin = sin(deg2rad($endangle + $head_angle));
+ $head_length = ($b_sin) ? abs(($width/2) / $b_sin) : $width/2;
+
+ } elsif ($head_length) {
+ my ($x2,$y2) = &rad_point($pt0, $head_length, $endangle -90 - $head_angle);
+ $ptA = [$x2,$y2];
+ my ($x3,$y3) = &rad_point($pt0, $head_length, $endangle -90 + $head_angle);
+ $ptB = [$x3,$y3];
+ }
+
+ # dl décalage de ligne = épaisseur forme /2
+ my $dl = $thick/2;
+
+ # la liste des points de la flèche
+ # (si $head_length = 0 pas de marker pointe)
+ my @vertex = reverse @{$linecoords};
+ pop @vertex;
+ push (@vertex, @{$linecoords});
+ if ($head_length) {
+ push(@vertex, ($ptA,$pt0,$ptB));
+ } else {
+ push(@vertex, $pt1);
+ }
+
+ # liste (booleens) du type raccord des sommets
+ my @corners;
+
+ my $numfaces = scalar(@vertex);
+ my $previous = $vertex[-1];
+
+ # on parcours la forme d'arete en arete
+ for (my $i = 0; $i < $numfaces; $i++) {
+ my $pt = $vertex[$i];
+ my $next = ($i < ($numfaces -1)) ? $vertex[$i+1] : $vertex[0];
+ my ($angle,$bis);
+
+ # angle du sommet
+ ($angle,$bis) = &vertexAngle($previous, $pt, $next);
+
+ # angle plat : projection du contour
+ if ($angle < 1) {
+ $angle = &lineNormal($pt,$next);
+ my ($x2,$y2) = &rad_point($pt, $dl, $angle-90);
+ my ($x1,$y1) = &rad_point($pt, $dl, $angle+90);
+ push (@pts, [$x1,$y1]);
+ push (@pts, [$x2,$y2]);
+
+ # accumulation d'un raccord supplémentaire
+ push(@corners, 1);
+
+
+ } else {
+
+ # distance au centre du cercle inscrit : rayon/sinus demi-angle
+ my $sin = sin(deg2rad($angle/2));
+ my $delta = ($sin) ? abs($dl/$sin) : $dl;
+
+ # calcul du point de contour (projection angulaire sur mediatrice)
+ my ($x,$y) = &rad_point($pt, $delta, $bis-90);
+ push (@pts, [$x,$y]);
+
+ }
+
+ # ajout d'un raccord
+ push(@corners, 1);
+
+ # nouveau point précédent
+ $previous = $pt;
+ }
+
+
+ # calcul des raccords d'angle si option radius
+ if ($radius) {
+ if ($head_length) {
+ push @pts, shift @pts;
+ $corners[-1] = 0;
+ $corners[-7] = 0;
+
+ if (scalar @{$linecoords} > 2) {
+ @corners[0] = 0;
+ for (my $il = 2; $il < scalar @{$linecoords}; $il++) {
+ $corners[$il*2] = 0;
+ }
+ }
+ }
+ my $newpts = &roundedCurveCoords(\@pts,
+ -radius => $radius,
+ -corners => \@corners);
+ @pts = @{$newpts};
+ }
+
+ return \@pts;
+}
+
+
+sub direction {
+ my $self = shift;
+ my $angle;
+
+ if (defined $self -> {'angle'}) {
+ $angle = $self -> {'angle'};
+ $self -> {'direction'} = undef;
+
+ } else {
+
+ if ($self -> {'direction'}) {
+ $angle = $direction2angle->{$self -> {'direction'}};
+ } else {
+ $self -> {'direction'} = 'right';
+ $angle = $direction2angle->{'right'};
+ }
+
+ }
+
+ if (defined $angle) {
+ $self -> {'r_group'} -> treset;
+ $self -> {'r_group'} -> rotate (deg2rad($angle)*-1);
+ }
+
+}
+
+
+sub distance
+{
+ my @p = @_;
+ my $d = @p / 2; # nombre de dimensions
+
+ # 2 dimensions
+ return sqrt(($_[0] - $_[2])**2 + ($_[1] - $_[3])**2)
+ if ($d == 2);
+
+ my $S = 0;
+ my @p0 = splice @p, 0, $d; # point de départ
+
+ for (my $i = 0; $i < $d; $i++) {
+ my $di = $p0[$i] - $p[$i];
+ $S += $di * $di;
+ }
+
+ return sqrt($S);
+
+}
+
+
+1;
+
diff --git a/src/MTools/Widget/MBouton.pm b/src/MTools/Widget/MBouton.pm
index f49af90..acabe65 100644
--- a/src/MTools/Widget/MBouton.pm
+++ b/src/MTools/Widget/MBouton.pm
@@ -38,7 +38,7 @@ sub new {
my $on = minstance ($options {g_on}, $self);
my $off = minstance ($options {g_off}, $self);
- my $over = defined $options {g_over} ? minstance ($options {g_over}, $self) : $on;
+ my $over = defined $options {g_over} && $options {g_over} ne ''? minstance ($options {g_over}, $self) : $on;
my $eventOn = defined $options {e_press} ? $options {e_press} : 'PRESS';
my $eventOff = defined $options {e_release} ? $options {e_release} : 'RELEASED';
my $cb = $options {call} if (defined $options {call});
@@ -55,7 +55,7 @@ sub new {
my @gover;
push (@gover, $over);
- if (defined $options {g_text})
+ if (defined $options {g_text} && $options {g_text} ne "")
{
$self -> recordProperty ('text', $options {text});
my $txt = minstance ($options {g_text}, $self);
diff --git a/src/MTools/Widget/MControlBoard.pm b/src/MTools/Widget/MControlBoard.pm
new file mode 100644
index 0000000..16cf0a1
--- /dev/null
+++ b/src/MTools/Widget/MControlBoard.pm
@@ -0,0 +1,192 @@
+package MTools::Widget::MControlBoard;
+# 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
+#
+##################################################################
+
+use strict;
+use IO::Dir;
+use Data::Dumper;
+use Tk::Zinc::Graphics;
+use MTools;
+use MTools::GUI::MGroup;
+
+use vars qw /@ISA/;
+
+my @Gradiants;
+my %textures;
+my %groups;
+my %clips;
+
+
+BEGIN
+{
+ @ISA = qw /MTools::GUI::MGroup/;
+}
+
+sub new {
+ my ($class, %options) = @_;
+ my $parentgroup = $options {parent} ? $options {parent} : 1;
+ my $self = new MTools::GUI::MGroup ($parentgroup);
+
+ bless $self, $class;
+ %groups = ();
+ my $name = $options {name};
+ $self -> {'label'} = (defined $options {label}) ? $options {label} : $name;
+
+ $self -> {'style'} = $options {style};
+
+ $self ->{'coef'} = defined $options {coef} ? $options {coef} : {'x' =>1,'y'=>1};
+ $self -> build;
+
+ return $self;
+}
+
+
+sub build {
+ my $self = shift;
+
+ if ($self -> {'style'})
+ {
+ my $hashtable = $self -> parse ($self -> {'style'});
+
+ if ($hashtable) {
+ if ($hashtable->{'gradset'}) {
+ my $gradset = delete $hashtable->{'gradset'};
+ $self -> createGradset ($gradset);
+
+ }
+
+ while (my ($name, $style) = each(%{$hashtable})) {
+
+ push @{$self->{groups}},$self -> createZone($name, $style);
+
+ }
+
+ }
+ }
+}
+
+sub createGradset {
+ my ($self, $gradset) = @_;
+
+ while (my ($name, $gradiant) = each(%{$gradset})) {
+ # cr�ation des gradiants nomm�s
+ if (! $zinc->gname($name))
+ {
+ $zinc->gname($gradiant, $name);
+ }
+ push(@Gradiants, $name);
+ }
+}
+
+
+sub parse {
+ my ($self, $filename) = @_;
+ open FD, "<$filename" or die "Cannot open $filename";
+ my $text;
+
+ while (<FD>)
+ {
+ $text .= $_;
+ }
+
+ my $d = eval $text;
+ die "Error while parsing file $filename : ", $@ if ($@);
+ return $d;
+}
+
+sub createZone {
+ my ($self, $zone, $zonestyle) = @_;
+
+ my $itemzone;
+ my %buttons;
+ my $zgroup;
+ if ($zonestyle)
+ {
+ my $name = $zonestyle->{'-name'};
+
+ # cr�ation du groupe zone
+ my $grouptags;
+
+ my $parent_zone = $zonestyle->{'-parent'};
+ my $parent_group = getZoneGroup($parent_zone);
+
+ # item group Zone
+ $zgroup = $zinc->add('group', $parent_group);
+ $groups{$zone} = $zgroup;
+ $zinc->coords($zgroup, $zonestyle->{'-coords'}) if ($zonestyle->{'-coords'});
+
+ # clipping de zone si n�cessaire
+ if ($zonestyle->{'-group'}) {
+ $zinc->itemconfigure($zgroup, %{$zonestyle->{'-group'}});
+ }
+
+
+ # cr�ation de l'item zone
+ if ($zonestyle->{'-form'}) {
+ $itemzone = &buildZincItem($zinc, $zgroup, %{$zonestyle->{'-form'}});
+ }
+
+ # cr�ation des "d�corations"
+ if ($zonestyle->{'-decos'}) {
+ my %items = %{$zonestyle->{'-decos'}};
+ my ($name, $itemstyle);
+ while (($name, $itemstyle) = each(%items)) {
+ my $item = &buildZincItem($zinc, $zgroup, %{$itemstyle});
+ }
+ }
+
+ # cr�ation des zones de "feedback" dans le tray
+ if ($zonestyle->{'-feedbacks'}) {
+ my %items = %{$zonestyle->{'-feedbacks'}};
+ my ($name, $itemstyle);
+ while (($name, $itemstyle) = each(%items)) {
+ my $item = &buildZincItem($zinc, $zgroup, $itemstyle);
+ }
+ }
+
+
+
+ # cr�ation des boutons de zone
+ if ($zonestyle->{'-buttons'}) {
+ %buttons = &buildButtons($zgroup, $zonestyle->{'-buttons'});
+ }
+ $zinc->scale($zgroup,$self->{'coef'}->{x},$self->{'coef'}->{y});
+ }
+ return ($zgroup);
+}
+
+
+sub getZoneGroup
+{
+ my $zone = shift;
+ return $groups{$zone} if (defined $groups{$zone});
+ return 1;
+}
+
+sub mdelete
+{
+ my ($self) = @_;
+ foreach (keys %groups)
+ {
+ $zinc->remove($groups{$_}) if (defined $groups{$_});
+ }
+ MTools::GUI::MGroup::mdelete($self);
+
+}
+
+1;
+
generated by cgit v1.1 at 2024-11-10 23:12:00 +0000