From 3756e0088bed99e82f7726eaa08a80ccc888b296 Mon Sep 17 00:00:00 2001 From: etienne Date: Tue, 17 Jun 2003 16:11:01 +0000 Subject: ZincTraceUtils, Tk::ZincText and LogoZinc are renamed Tk::Zinc::TraceUtils, Tk::Zinc::Text and Tk::Zinc::Logo. ZincTrace et ZincTraceErrors which load Tk::Zinc::TraceUtils need update. --- Perl/Zinc/Logo.pm | 187 ++++++++++++++++++++++++++++++++++ Perl/Zinc/Text.pm | 260 +++++++++++++++++++++++++++++++++++++++++++++++ Perl/Zinc/Trace.pm | 2 +- Perl/Zinc/TraceErrors.pm | 2 +- Perl/Zinc/TraceUtils.pm | 90 ++++++++++++++++ Perl/ZincText.pm | 260 ----------------------------------------------- Perl/debug/LogoZinc.pm | 187 ---------------------------------- 7 files changed, 539 insertions(+), 449 deletions(-) create mode 100644 Perl/Zinc/Logo.pm create mode 100644 Perl/Zinc/Text.pm create mode 100644 Perl/Zinc/TraceUtils.pm delete mode 100644 Perl/ZincText.pm delete mode 100644 Perl/debug/LogoZinc.pm diff --git a/Perl/Zinc/Logo.pm b/Perl/Zinc/Logo.pm new file mode 100644 index 0000000..5e9db69 --- /dev/null +++ b/Perl/Zinc/Logo.pm @@ -0,0 +1,187 @@ +#!/usr/bin/perl +#--------------------------------------------------------------- +# Project : Harmony +# Module : Harmony +# File : Logo.pm +# +# Copyright (C) 2001 +# Centre d'Études de la Navigation Aérienne +# Authors: Vinot Jean-Luc +# +#--------------------------------------------------------------- + +package Tk::Zinc::Logo; + +use strict; +use Carp; +use Math::Trig; + +Construct Tk::Widget 'Tk::Zinc::Logo'; + + +my @Gradiants; + +# paramètres de construction graphique +my %builder = (-gradset => {'logoshape' => '=axial 270 |#ffffff;100 0 28|#66848c;100 96|#7192aa;100 100', + 'logopoint' => '=radial -20 -20 |#ffffff;100 0|#f70000;100 48|#900000;100 80|#ab0000;100 100', + 'logoptshad' => '=path 0 0 |#770000;64 0|#770000;70 78|#770000;0 100', + }, + + -shape => {-form => {-itemtype => 'curve', + -coords => [[0, 0],[106, 0],[106, 58],[122, 41],[156, 41],[131, 69], + [153, 99],[203, 41],[155, 41],[155, 0],[218, 0],[240, 0, 'c'], + [252, 17, 'c'],[252, 34],[252, 40, 'c'],[249, 50, 'c'], + [244, 56],[202, 105],[246, 105],[246, 87],[246, 60, 'c'], + [271, 37, 'c'],[297, 37],[323, 37, 'c'],[342, 57, 'c'],[344, 68], + [347, 64, 'c'],[350, 60, 'c'],[353, 56],[363, 46, 'c'],[375, 37, 'c'], + [395, 37],[395, 79],[393, 79],[385, 79, 'c'],[379, 86, 'c'], + [379, 93],[379, 100, 'c'],[385, 107, 'c'],[393, 107],[409, 107], + [409, 148],[397, 148],[378, 148, 'c'],[364, 144, 'c'],[354, 133], + [346, 124],[346, 148],[305, 148],[305, 87],[305, 83, 'c'],[301, 79, 'c'], + [297, 79],[293, 79, 'c'],[289, 83, 'c'],[289, 87],[289, 150],[251, 150], + [251, 130],[251, 126, 'c'],[247, 122, 'c'],[243, 122],[239, 122, 'c'], + [235, 126, 'c'],[235, 130],[235, 150],[176, 150],[154, 150,'c'], + [146, 131,'c'],[146, 114],[148, 105],[120, 105],[104, 81],[104, 105], + [74, 105],[74, 41],[52, 41],[52, 105],[20, 105],[20, 41],[0, 41], + ], + + -params => {-priority => 50, + -linewidth => 3, + -linecolor => '#000000;100', + -filled => 1, + -closed => 0, + -fillcolor => 'logoshape', + }, + }, + + -shadow => {-clone => '-form', + -translate => [6, 6], + -params => {-fillcolor => '#000000;18', + -linewidth => 0, + -priority => 20, + }, + }, + }, + + -point => {-coords => [240, 96], + -params => {-alpha => 80, + -priority => 100, + }, + + -form => {-itemtype => 'arc', + -coords => [[-20, -20], [20, 20]], + -params => {-priority => 50, + -filled => 1, + -linewidth => 1, + -linecolor => '#a10000;100', + -fillcolor => 'logopoint', + -closed => 1, + }, + }, + + -shadow => {-clone => '-form', + -translate => [5, 5], + -params => {-fillcolor => 'logoptshad', + -linewidth => 0, + -priority => 20, + }, + }, + }, + ); + + + +sub new { + my $proto = shift; + my $type = ref($proto) || $proto; + my $widget = shift; + my %params = @_; + + my $self = {}; + bless ($self, $type); + + $self->{'-widget'} = $widget; + $self->{'-parent'} = (exists $params{'-parent'}) ? $params{'-parent'} : 1; + $self->{'-priority'} = (exists $params{'-priority'}) ? $params{'-priority'} : 500; + $self->{'-position'} = (exists $params{'-position'}) ? $params{'-position'} : [0, 0]; + $self->{'-scale'} = (exists $params{'-scale'}) ? $params{'-scale'} : [1, 1]; + + $self->drawLogo(); + + return bless $self, $type; +} + + + +sub drawLogo { + my ($self) = @_; + my $zinc = $self->{'-widget'}; + my $parent = $self->{'-parent'}; + my $priority = $self->{'-priority'}; + + + if ($builder{'-gradset'}) { + while (my ($name, $gradiant) = each( %{$builder{'-gradset'}})) { + # création des gradiants nommés + $zinc->gname($gradiant, $name) unless $zinc->gname($name); + push(@Gradiants, $name); + } + } + + # création des groupes logo + # logogroup : groupe de coordonnées + my $logogroup = $self->{'-item'} = $zinc->add('group', $parent, -priority => $priority); + $zinc->coords($logogroup, $self->{'-position'}) if ($self->{'-position'}); + + # group de scaling + my $group = $self->{'-scaleitem'} = $zinc->add('group', $logogroup); + $zinc->scale($group, @{$self->{'-scale'}}) if ($self->{'-scale'}); + + + # création de l'item shape (Zinc) + my $formstyle = $builder{'-shape'}->{'-form'}; + $self->ajustLineWidth($formstyle->{'-params'}); + my $shape = $zinc->add('curve', $group, + $formstyle->{'-coords'}, + %{$formstyle->{'-params'}}, + ); + + # ombre portée de la shape + my $shadstyle = $builder{'-shape'}->{'-shadow'}; + my $shadow = $zinc->clone($shape, %{$shadstyle->{'-params'}}); + $zinc->translate($shadow, @{$shadstyle->{'-translate'}}) if ($shadstyle->{'-translate'}); + + # réalisation du point + my $pointconf = $builder{'-point'}; + my $ptgroup = $zinc->add('group', $group, %{$pointconf->{'-params'}}); + $zinc->coords($ptgroup, $pointconf->{'-coords'}); + + my $pointstyle = $pointconf->{'-form'}; + my $point = $zinc->add('arc', $ptgroup, + $pointstyle->{'-coords'}, + %{$pointstyle->{'-params'}}, + ); + + my $shadpoint = $zinc->clone($point, %{$shadstyle->{'-params'}}); + $shadstyle = $pointconf->{'-shadow'}; + $zinc->translate($shadpoint, @{$shadstyle->{'-translate'}}); + +} + + +sub ajustLineWidth { + my ($self, $style, $scale) = @_; + + if ($style->{'-linewidth'}) { + my ($sx, $sy) = @{$self->{'-scale'}}; + my $linewidth = $style->{'-linewidth'}; + if ($linewidth >= 2) { + my $ratio = ($sx > $sy) ? $sy : $sx; + $style->{'-linewidth'} = $linewidth * $ratio; + } + } +} + +1; + + diff --git a/Perl/Zinc/Text.pm b/Perl/Zinc/Text.pm new file mode 100644 index 0000000..2cf4fd2 --- /dev/null +++ b/Perl/Zinc/Text.pm @@ -0,0 +1,260 @@ + +package Tk::Zinc::Text; + + +sub new { + my $proto = shift; + my $type = ref($proto) || $proto; + my ($zinc) = @_; + my $self = {}; + + $zinc->bind('text', '<1>' => sub {startSel($zinc)}); + $zinc->bind('text', '<2>' => sub {pasteSel($zinc)}); + $zinc->bind('text', '' => sub {extendSel($zinc)}); + $zinc->bind('text', '' => sub {extendSel($zinc)}); + $zinc->bind('text', '' => sub { + my $e = $zinc->XEvent(); + my($x, $y) = ($e->x, $e->y); + $zinc->select('adjust', 'current', "\@$x,$y"); }); + $zinc->bind('text', '' => sub {moveCur($zinc, -1);}); + $zinc->bind('text', '' => sub {moveCur($zinc, 1);}); + $zinc->bind('text', '' => sub {setCur($zinc, 'up');}); + $zinc->bind('text', '' => sub {setCur($zinc, 'down');}); + $zinc->bind('text', '' => sub {setCur($zinc, 'bol');}); + $zinc->bind('text', '' => sub {setCur($zinc, 'bol');}); + $zinc->bind('text', '' => sub {setCur($zinc, 'eol');}); + $zinc->bind('text', '' => sub {setCur($zinc, 'eol');}); + $zinc->bind('text', '' => sub {setCur($zinc, 0);}); + $zinc->bind('text', '' => sub {setCur($zinc, 'end');}); + $zinc->bind('text', '' => sub {insertKey($zinc);}); + $zinc->bind('text', '' => sub {insertKey($zinc);}); + $zinc->bind('text', '' => sub { insertChar($zinc, chr(10)); }); + $zinc->bind('text', '' => sub {textDel($zinc, -1)}); + $zinc->bind('text', '' => sub {textDel($zinc, -1)}); + $zinc->bind('text', '' => sub {textDel($zinc, 0)}); + + bless ($self, $type); + return $self; +} + + +sub pasteSel { + my ($w) = @_; + my $e = $w->XEvent; + my($x, $y) = ($e->x(), $e->y()); + my @it = $w->focus(); + + if (@it != 0) { + eval { $w->insert(@it, "\@$x,$y", $w->SelectionGet()); }; + } +} + + +sub insertChar { + my ($w, $c) = @_; + my @it = $w->focus(); + my @selit = $w->select('item'); + + if (@it == 0) { + return; + } + + if ((scalar(@selit) == scalar(@it)) && + ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) { + $w->dchars(@it, 'sel.first', 'sel.last'); + } + $w->insert(@it, 'insert', $c); +} + + +sub insertKey { + my ($w) = @_; + my $c = $w->XEvent->A(); + + if ((ord($c) < 32) || (ord($c) == 128)) { + return; + } + + insertChar($w, $c); +} + + +sub setCur { + my ($w, $where) = @_; + my @it = $w->focus(); + + if (@it != 0) { + $w->cursor(@it, $where); + } +} + + +sub moveCur { + my ($w, $dir) = @_; + my @it = $w->focus(); + my $index; + + if (@it != 0) { + $index = $w->index(@it, 'insert'); + $w->cursor(@it, $index + $dir); + } +} + + +sub startSel { + my($w) = @_; + my $e = $w->XEvent; + my($x, $y) = ($e->x(), $e->y()); + my $part = $w->currentpart(1); + + $w->cursor('current', $part, "\@$x,$y"); + $w->focus('current', $part); + $w->Tk::focus(); + $w->select('from', 'current', $part, "\@$x,$y"); +} + + +sub extendSel { + my($w) = @_; + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + my $part = $w->currentpart(1); + + $w->select('to', 'current', $part, "\@$x,$y"); +} + + +sub textDel { + my($w, $dir) = @_; + my @it = $w->focus(); + my @selit = $w->select('item'); + my $ind; + + if (@it == 0) { + return; + } + + if ((scalar(@selit) == scalar(@it)) && + ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) { + $w->dchars(@it, 'sel.first', 'sel.last'); + } + else { + $ind = $w->index(@it, 'insert') + $dir; + $w->dchars(@it, $ind, $ind) if ($ind >= 0); + } +} + +1; +__END__ + +=head1 NAME + +Tk::Zinc::Text - Zinc extension for easing text input on text item or on fields + +=head1 SYNOPSIS + + use Tk::Zinc::Text; + + $zinc = $mw->Zinc(); + new Tk::Zinc::Text ($zinc); + .... + $zinc->addtag('text', 'withtag', $a_text); + $zinc->addtag('text', 'withtag', $a_track); + $zinc->addtag('text', 'withtag', $a_waypoint); + $zinc->addtag('text', 'withtag', $a_tabular); + +=head1 DESCRIPTION + +This module implements text input with the mouse and keyboard 'a la emacs'. +Text items must have the 'text' tag and must of course be sensitive. +Track, waypoint and tabular items have fields and these fields can +be edited the same way. Only sensitive fields can be edited. the following +interactions are supported: + +=over 2 + +=item B + +To set the cursor position + +=item B + +To paste the current selection + +=item B + +To make a selection + +=item B + +To extend the current selection + +=item B + +To extend the current selection + +=item B, B + +To move the cursor to the left or to the right + +=item B, B + +To move the cursor up or down a line + +=item B, B + +To move the cursor at the begining of the line + +=item B, B + +To move the cursor at the end of the line + +=item B, B> + +To move the cursor at the beginning / end of the text + +=item B, B + +To delete the char just before the cursor + +=item B + +To delete the char just after the cursor + +=item B + +To insert a return char. This does not validate the input! + +=back + +=head1 BUGS + +No known bugs at this time. If you find one, please report them to the authors. + +=head1 SEE ALSO + +perl(1), Tk(1), Tk::Zinc(3), zinc-demos(1) + +=head1 AUTHORS + +Patrick Lecoanet +(and some documentation by Christophe Mertz ) + +=head1 COPYRIGHT + +CENA (C) 2002 + +Tk::Zinc::Text is part of Zinc and has been developed by the CENA (Centres d'Etudes de la Navigation Aérienne) +for its own needs in advanced HMI (Human Machine Interfaces or Interactions). Because we are confident +in the benefit of free software, the CENA delivered this toolkit under the GNU +Library General Public License. + +This code is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even +the implied warranty of MER­CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library +General Public License for more details. + +=head1 HISTORY + +June 2002 : initial release with Zinc-perl 3.2.6 + +=cut diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm index 0a2b7c4..e9bb01c 100644 --- a/Perl/Zinc/Trace.pm +++ b/Perl/Zinc/Trace.pm @@ -26,7 +26,7 @@ package ZincTrace; use Tk; use strict; -use ZincTraceUtils; +use Tk::Zinc::TraceUtils; my $WidgetMethodfunction; BEGIN { diff --git a/Perl/Zinc/TraceErrors.pm b/Perl/Zinc/TraceErrors.pm index f5d1069..43c4e3d 100644 --- a/Perl/Zinc/TraceErrors.pm +++ b/Perl/Zinc/TraceErrors.pm @@ -29,7 +29,7 @@ package ZincTraceErrors; use Tk; use strict; -use ZincTraceUtils; +use Tk::Zinc::TraceUtils; my $WidgetMethodfunction; my $bold = ""; diff --git a/Perl/Zinc/TraceUtils.pm b/Perl/Zinc/TraceUtils.pm new file mode 100644 index 0000000..07b0413 --- /dev/null +++ b/Perl/Zinc/TraceUtils.pm @@ -0,0 +1,90 @@ +package Tk::Zinc::TraceUtils; + +use Tk; +use strict; +use Tk::Font; +use Tk::Photo; +use vars qw(@EXPORT); +@EXPORT = qw(printItem printArray printList); + + +### to print something +sub printItem { + my ($value) = @_; + my $ref = ref($value); +# print "VALUE=$value REF=$ref\n"; + if ($ref eq 'ARRAY') { + printArray ( @{$value} ); + } + elsif ($ref eq 'CODE') { + print "{CODE}"; + } + elsif ($ref eq 'Tk::Photo') { +# print " **** $value ***** "; + print "Tk::Photo(\"". scalar $value->cget('-file') . "\")"; + } + elsif ($ref eq 'Tk::Font') { + print "'$value'"; + } + elsif ($ref eq '') { # scalar + if (defined $value) { + if ($value eq '') { + print "''"; + } elsif ($value =~ /\s/ + or $value =~ /^[a-zA-Z]/ + or $value =~ /^[\W]$/ ) { + print "'$value'"; + } else { + print $value; + } + } + else { + print "undef"; + } + } + else { # some class instance + return $value; + } + +} # end printitem + + +### to print a list of something +sub printArray { + my (@values) = @_; + if (! scalar @values) { + print "[]"; + } + else { # the list is not empty + my @res; + print "["; + while (@values) { + my $value = shift @values; + &printItem ($value); + print ", " if (@values); + } + print "]" ; + } + +} # end printArray + + +sub printList { + print "("; + while (@_) { + my $v = shift @_; + printItem $v; + if ($v =~ /^-\w+/) { + print " => "; + } elsif (@_) { + print ", "; + } + } + print ")"; + +} # end printList + +1; + + + diff --git a/Perl/ZincText.pm b/Perl/ZincText.pm deleted file mode 100644 index 26ff038..0000000 --- a/Perl/ZincText.pm +++ /dev/null @@ -1,260 +0,0 @@ - -package ZincText; - - -sub new { - my $proto = shift; - my $type = ref($proto) || $proto; - my ($zinc) = @_; - my $self = {}; - - $zinc->bind('text', '<1>' => sub {startSel($zinc)}); - $zinc->bind('text', '<2>' => sub {pasteSel($zinc)}); - $zinc->bind('text', '' => sub {extendSel($zinc)}); - $zinc->bind('text', '' => sub {extendSel($zinc)}); - $zinc->bind('text', '' => sub { - my $e = $zinc->XEvent(); - my($x, $y) = ($e->x, $e->y); - $zinc->select('adjust', 'current', "\@$x,$y"); }); - $zinc->bind('text', '' => sub {moveCur($zinc, -1);}); - $zinc->bind('text', '' => sub {moveCur($zinc, 1);}); - $zinc->bind('text', '' => sub {setCur($zinc, 'up');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'down');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'bol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'bol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'eol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'eol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 0);}); - $zinc->bind('text', '' => sub {setCur($zinc, 'end');}); - $zinc->bind('text', '' => sub {insertKey($zinc);}); - $zinc->bind('text', '' => sub {insertKey($zinc);}); - $zinc->bind('text', '' => sub { insertChar($zinc, chr(10)); }); - $zinc->bind('text', '' => sub {textDel($zinc, -1)}); - $zinc->bind('text', '' => sub {textDel($zinc, -1)}); - $zinc->bind('text', '' => sub {textDel($zinc, 0)}); - - bless ($self, $type); - return $self; -} - - -sub pasteSel { - my ($w) = @_; - my $e = $w->XEvent; - my($x, $y) = ($e->x(), $e->y()); - my @it = $w->focus(); - - if (@it != 0) { - eval { $w->insert(@it, "\@$x,$y", $w->SelectionGet()); }; - } -} - - -sub insertChar { - my ($w, $c) = @_; - my @it = $w->focus(); - my @selit = $w->select('item'); - - if (@it == 0) { - return; - } - - if ((scalar(@selit) == scalar(@it)) && - ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) { - $w->dchars(@it, 'sel.first', 'sel.last'); - } - $w->insert(@it, 'insert', $c); -} - - -sub insertKey { - my ($w) = @_; - my $c = $w->XEvent->A(); - - if ((ord($c) < 32) || (ord($c) == 128)) { - return; - } - - insertChar($w, $c); -} - - -sub setCur { - my ($w, $where) = @_; - my @it = $w->focus(); - - if (@it != 0) { - $w->cursor(@it, $where); - } -} - - -sub moveCur { - my ($w, $dir) = @_; - my @it = $w->focus(); - my $index; - - if (@it != 0) { - $index = $w->index(@it, 'insert'); - $w->cursor(@it, $index + $dir); - } -} - - -sub startSel { - my($w) = @_; - my $e = $w->XEvent; - my($x, $y) = ($e->x(), $e->y()); - my $part = $w->currentpart(1); - - $w->cursor('current', $part, "\@$x,$y"); - $w->focus('current', $part); - $w->Tk::focus(); - $w->select('from', 'current', $part, "\@$x,$y"); -} - - -sub extendSel { - my($w) = @_; - my $e = $w->XEvent; - my($x, $y) = ($e->x, $e->y); - my $part = $w->currentpart(1); - - $w->select('to', 'current', $part, "\@$x,$y"); -} - - -sub textDel { - my($w, $dir) = @_; - my @it = $w->focus(); - my @selit = $w->select('item'); - my $ind; - - if (@it == 0) { - return; - } - - if ((scalar(@selit) == scalar(@it)) && - ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) { - $w->dchars(@it, 'sel.first', 'sel.last'); - } - else { - $ind = $w->index(@it, 'insert') + $dir; - $w->dchars(@it, $ind, $ind) if ($ind >= 0); - } -} - -1; -__END__ - -=head1 NAME - -ZincText - Zinc extension for easing text input on text item or on fields - -=head1 SYNOPSIS - - use ZincText; - - $zinc = $mw->Zinc(); - new ZincText ($zinc); - .... - $zinc->addtag('text', 'withtag', $a_text); - $zinc->addtag('text', 'withtag', $a_track); - $zinc->addtag('text', 'withtag', $a_waypoint); - $zinc->addtag('text', 'withtag', $a_tabular); - -=head1 DESCRIPTION - -This module implements text input with the mouse and keyboard 'a la emacs'. -Text items must have the 'text' tag and must of course be sensitive. -Track, waypoint and tabular items have fields and these fields can -be edited the same way. Only sensitive fields can be edited. the following -interactions are supported: - -=over 2 - -=item B - -To set the cursor position - -=item B - -To paste the current selection - -=item B - -To make a selection - -=item B - -To extend the current selection - -=item B - -To extend the current selection - -=item B, B - -To move the cursor to the left or to the right - -=item B, B - -To move the cursor up or down a line - -=item B, B - -To move the cursor at the begining of the line - -=item B, B - -To move the cursor at the end of the line - -=item B, B> - -To move the cursor at the beginning / end of the text - -=item B, B - -To delete the char just before the cursor - -=item B - -To delete the char just after the cursor - -=item B - -To insert a return char. This does not validate the input! - -=back - -=head1 BUGS - -No known bugs at this time. If you find one, please report them to the authors. - -=head1 SEE ALSO - -perl(1), Tk(1), Tk::Zinc(3), zinc-demos(1) - -=head1 AUTHORS - -Patrick Lecoanet -(and some documentation by Christophe Mertz ) - -=head1 COPYRIGHT - -CENA (C) 2002 - -ZincText is part of Zinc and has been developed by the CENA (Centres d'Etudes de la Navigation Aérienne) -for its own needs in advanced HMI (Human Machine Interfaces or Interactions). Because we are confident -in the benefit of free software, the CENA delivered this toolkit under the GNU -Library General Public License. - -This code is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even -the implied warranty of MER­CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library -General Public License for more details. - -=head1 HISTORY - -June 2002 : initial release with Zinc-perl 3.2.6 - -=cut diff --git a/Perl/debug/LogoZinc.pm b/Perl/debug/LogoZinc.pm deleted file mode 100644 index 0b81b62..0000000 --- a/Perl/debug/LogoZinc.pm +++ /dev/null @@ -1,187 +0,0 @@ -#!/usr/bin/perl -#--------------------------------------------------------------- -# Project : Harmony -# Module : Harmony -# File : LogoZinc.pm -# -# Copyright (C) 2001 -# Centre d'Études de la Navigation Aérienne -# Authors: Vinot Jean-Luc -# -#--------------------------------------------------------------- - -package LogoZinc; - -use strict; -use Carp; -use Math::Trig; - -Construct Tk::Widget 'LogoZinc'; - - -my @Gradiants; - -# paramètres de construction graphique -my %builder = (-gradset => {'logoshape' => '=axial 270 |#ffffff;100 0 28|#66848c;100 96|#7192aa;100 100', - 'logopoint' => '=radial -20 -20 |#ffffff;100 0|#f70000;100 48|#900000;100 80|#ab0000;100 100', - 'logoptshad' => '=path 0 0 |#770000;64 0|#770000;70 78|#770000;0 100', - }, - - -shape => {-form => {-itemtype => 'curve', - -coords => [[0, 0],[106, 0],[106, 58],[122, 41],[156, 41],[131, 69], - [153, 99],[203, 41],[155, 41],[155, 0],[218, 0],[240, 0, 'c'], - [252, 17, 'c'],[252, 34],[252, 40, 'c'],[249, 50, 'c'], - [244, 56],[202, 105],[246, 105],[246, 87],[246, 60, 'c'], - [271, 37, 'c'],[297, 37],[323, 37, 'c'],[342, 57, 'c'],[344, 68], - [347, 64, 'c'],[350, 60, 'c'],[353, 56],[363, 46, 'c'],[375, 37, 'c'], - [395, 37],[395, 79],[393, 79],[385, 79, 'c'],[379, 86, 'c'], - [379, 93],[379, 100, 'c'],[385, 107, 'c'],[393, 107],[409, 107], - [409, 148],[397, 148],[378, 148, 'c'],[364, 144, 'c'],[354, 133], - [346, 124],[346, 148],[305, 148],[305, 87],[305, 83, 'c'],[301, 79, 'c'], - [297, 79],[293, 79, 'c'],[289, 83, 'c'],[289, 87],[289, 150],[251, 150], - [251, 130],[251, 126, 'c'],[247, 122, 'c'],[243, 122],[239, 122, 'c'], - [235, 126, 'c'],[235, 130],[235, 150],[176, 150],[154, 150,'c'], - [146, 131,'c'],[146, 114],[148, 105],[120, 105],[104, 81],[104, 105], - [74, 105],[74, 41],[52, 41],[52, 105],[20, 105],[20, 41],[0, 41], - ], - - -params => {-priority => 50, - -linewidth => 3, - -linecolor => '#000000;100', - -filled => 1, - -closed => 0, - -fillcolor => 'logoshape', - }, - }, - - -shadow => {-clone => '-form', - -translate => [6, 6], - -params => {-fillcolor => '#000000;18', - -linewidth => 0, - -priority => 20, - }, - }, - }, - - -point => {-coords => [240, 96], - -params => {-alpha => 80, - -priority => 100, - }, - - -form => {-itemtype => 'arc', - -coords => [[-20, -20], [20, 20]], - -params => {-priority => 50, - -filled => 1, - -linewidth => 1, - -linecolor => '#a10000;100', - -fillcolor => 'logopoint', - -closed => 1, - }, - }, - - -shadow => {-clone => '-form', - -translate => [5, 5], - -params => {-fillcolor => 'logoptshad', - -linewidth => 0, - -priority => 20, - }, - }, - }, - ); - - - -sub new { - my $proto = shift; - my $type = ref($proto) || $proto; - my $widget = shift; - my %params = @_; - - my $self = {}; - bless ($self, $type); - - $self->{'-widget'} = $widget; - $self->{'-parent'} = (exists $params{'-parent'}) ? $params{'-parent'} : 1; - $self->{'-priority'} = (exists $params{'-priority'}) ? $params{'-priority'} : 500; - $self->{'-position'} = (exists $params{'-position'}) ? $params{'-position'} : [0, 0]; - $self->{'-scale'} = (exists $params{'-scale'}) ? $params{'-scale'} : [1, 1]; - - $self->drawLogo(); - - return bless $self, $type; -} - - - -sub drawLogo { - my ($self) = @_; - my $zinc = $self->{'-widget'}; - my $parent = $self->{'-parent'}; - my $priority = $self->{'-priority'}; - - - if ($builder{'-gradset'}) { - while (my ($name, $gradiant) = each( %{$builder{'-gradset'}})) { - # création des gradiants nommés - $zinc->gname($gradiant, $name) unless $zinc->gname($name); - push(@Gradiants, $name); - } - } - - # création des groupes logo - # logogroup : groupe de coordonnées - my $logogroup = $self->{'-item'} = $zinc->add('group', $parent, -priority => $priority); - $zinc->coords($logogroup, $self->{'-position'}) if ($self->{'-position'}); - - # group de scaling - my $group = $self->{'-scaleitem'} = $zinc->add('group', $logogroup); - $zinc->scale($group, @{$self->{'-scale'}}) if ($self->{'-scale'}); - - - # création de l'item shape (Zinc) - my $formstyle = $builder{'-shape'}->{'-form'}; - $self->ajustLineWidth($formstyle->{'-params'}); - my $shape = $zinc->add('curve', $group, - $formstyle->{'-coords'}, - %{$formstyle->{'-params'}}, - ); - - # ombre portée de la shape - my $shadstyle = $builder{'-shape'}->{'-shadow'}; - my $shadow = $zinc->clone($shape, %{$shadstyle->{'-params'}}); - $zinc->translate($shadow, @{$shadstyle->{'-translate'}}) if ($shadstyle->{'-translate'}); - - # réalisation du point - my $pointconf = $builder{'-point'}; - my $ptgroup = $zinc->add('group', $group, %{$pointconf->{'-params'}}); - $zinc->coords($ptgroup, $pointconf->{'-coords'}); - - my $pointstyle = $pointconf->{'-form'}; - my $point = $zinc->add('arc', $ptgroup, - $pointstyle->{'-coords'}, - %{$pointstyle->{'-params'}}, - ); - - my $shadpoint = $zinc->clone($point, %{$shadstyle->{'-params'}}); - $shadstyle = $pointconf->{'-shadow'}; - $zinc->translate($shadpoint, @{$shadstyle->{'-translate'}}); - -} - - -sub ajustLineWidth { - my ($self, $style, $scale) = @_; - - if ($style->{'-linewidth'}) { - my ($sx, $sy) = @{$self->{'-scale'}}; - my $linewidth = $style->{'-linewidth'}; - if ($linewidth >= 2) { - my $ratio = ($sx > $sy) ? $sy : $sx; - $style->{'-linewidth'} = $linewidth * $ratio; - } - } -} - -1; - - -- cgit v1.1