Ajout de 2 nouvelles widgets (Merci JL Vinot):

Une pour creer un fond d'appli selon un style passe en parametre : MControlBoard
Une pour creer une "belle" fleche : MArrow
Pour l'instant pas d'exemples les utilisant (si ce n'est l'appli approche Acropole), peut etre ulterieurement.
Un peu de robustesse pour le MBouton...

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;
+