diff options
Diffstat (limited to 'Perl/Zinc')
| -rw-r--r-- | Perl/Zinc/Debug.pm | 3023 | ||||
| -rw-r--r-- | Perl/Zinc/Graphics.pm | 3067 | ||||
| -rw-r--r-- | Perl/Zinc/Graphics.pod | 1749 | ||||
| -rw-r--r-- | Perl/Zinc/Logo.pm | 238 | ||||
| -rw-r--r-- | Perl/Zinc/Text.pm | 262 | ||||
| -rw-r--r-- | Perl/Zinc/Trace.pm | 227 | ||||
| -rw-r--r-- | Perl/Zinc/TraceErrors.pm | 149 | ||||
| -rw-r--r-- | Perl/Zinc/TraceUtils.pm | 111 |
8 files changed, 0 insertions, 8826 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm deleted file mode 100644 index 6d4758c..0000000 --- a/Perl/Zinc/Debug.pm +++ /dev/null @@ -1,3023 +0,0 @@ -# Tk::Zinc::Debug Perl Module : -# -# For debugging/analysing a Zinc application. -# -# Author : Daniel Etienne <etienne@cena.fr> -# -# $Id$ -#--------------------------------------------------------------------------- -package Tk::Zinc::Debug; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use strict 'vars'; -use vars qw(@ISA @EXPORT @EXPORT_OK $WARNING $endoptions); -use Carp; -use English; -require Exporter; -use File::Basename; -use Tk::Dialog; -use Tk::Tree; -use Tk::ItemStyle; -use Tk::Pane; -use Tk::FBox; -use Tk::Balloon; - -@ISA = qw(Exporter); -@EXPORT = qw(finditems snapshot tree init); -@EXPORT_OK = qw(finditems snapshot tree init); - -my ($itemstyle, $groupstyle, $step); -my (%result_tl, $result_fm, $search_tl, $helptree_tl, %coords_tl, %transfo_tl, - $helpcoords_tl, $searchtree_tl, $tree_tl, %alloptions_tl, $tree, - $cursorxy_tl, $cursorxy); -my $showitemflag; -my ($x0, $y0); -my ($help_print, $imagecounter, $saving) = (0, 0, 0); -my %searchEntryValue; -my $searchTreeEntryValue; -my %wwidth; -my %wheight; -my $preload; -my %defaultoptions; -my %instances; -my @instances; -my %cmdoptions; -my $initobjectfunction; -my %userbindings; -my $selectedzinc; -my $control_tl; -my %button; -my %on_command; -my %off_command; -my @znpackinfo; -my $screenwidth; -my $balloonhelp; -#--------------------------------------------------------------------------- -# -# Initialisation functions for plugin usage -# -#--------------------------------------------------------------------------- - -# Hack to overload the Tk::Zinc::InitObject method -# -BEGIN { - - # test if Tk::Zinc::Debug is loaded using the -M perl option - $preload = 1 if (caller(2))[2] == 0; - return unless $preload; - # parse Tk::Zinc::Debug options - require Getopt::Long; - Getopt::Long::Configure('pass_through'); - Getopt::Long::GetOptions(\%cmdoptions, 'optionsToDisplay=s', 'optionsFormat=s', - 'snapshotBasename=s', 'expandTagsField=i'); - # save current Tk::Zinc::InitObject function; it will be invoked in - # overloaded one (see below) - use Tk; - use Tk::Zinc; - $initobjectfunction = Tk::Zinc->can('InitObject'); - -} # end BEGIN - - -# Hack to capture the instance(s) of zinc. Tk::Zinc::Debug init function -# is invoked here. -# -sub Tk::Zinc::InitObject { - - # invoke function possibly overloaded in other modules - &$initobjectfunction(@_) if $initobjectfunction; - return unless $preload; - my $zinc = $_[0]; - &init($zinc); - -} # end Tk::Zinc::InitObject - - -#--------------------------------------------------------------------------- -# -# Initialisation function -# -#--------------------------------------------------------------------------- - -sub init { - - my $zinc = shift; - $screenwidth = $zinc->screenwidth; - my %options = @_; - for my $opt (keys(%options)) { - carp "in Tk::Zinc::Debug initialisation function, unknown option $opt\n" - unless $opt eq '-optionsToDisplay' or $opt eq '-optionsFormat' - or $opt eq '-snapshotBasename' or $opt eq '-expandTagsField' ; - } - $cmdoptions{optionsToDisplay} = $options{-optionsToDisplay} if - not defined $cmdoptions{optionsToDisplay} and - defined $options{-optionsToDisplay}; - $cmdoptions{optionsFormat} = $options{-optionsFormat} if - not defined $cmdoptions{optionsFormat} and - defined $options{-optionsFormat}; - $cmdoptions{snapshotBasename} = $options{-snapshotBasename} if - not defined $cmdoptions{snapshotBasename} and - defined $options{-snapshotBasename}; - $cmdoptions{expandTagsField} = $options{-expandTagsField} if - not defined $cmdoptions{expandTagsField} and - defined $options{-expandTagsField}; - - &newinstance($zinc); - return if Tk::Exists($control_tl); - print "Tk::Zinc::Debug is ON\n"; - my $bitmaps = &createBitmaps($zinc); - $control_tl = $zinc->Toplevel; - $control_tl->title("Tk::Zinc::Debug (V $VERSION)"); - my $fm1 = $control_tl->Frame()->pack(-side => 'left', -padx => 0); - my $fm2 = $control_tl->Frame()->pack(-side => 'left', -padx => 20); - my $fm3 = $control_tl->Frame()->pack(-side => 'left', -padx => 0); - - for (qw(zn findenclosed findoverlap tree item id snapshot cursorxy)) { - $button{$_} = $fm1->Checkbutton(-image => $bitmaps->{$_}, - -indicatoron => 0, - -foreground => 'gray20')->pack(-side => 'left'); - } - for (qw(zoomminus zoomplus move)) { - $button{$_} = $fm2->Checkbutton(-image => $bitmaps->{$_}, - -indicatoron => 0, - -foreground => 'gray20')->pack(-side => 'left'); - } - for (qw(balloon close)) { - $button{$_} = $fm3->Checkbutton(-image => $bitmaps->{$_}, - -indicatoron => 0, - -foreground => 'gray20')->pack(-side => 'left'); - } - my $bg = $button{zn}->cget(-background); - for (values(%button)) { - $_->configure(-selectcolor => $bg); - } - $balloonhelp = &balloonhelp(); - $button{balloon}->toggle; - $control_tl->withdraw(); - $button{zn}->configure(-command => \&focuscommand); - $button{balloon}->configure(-command => sub { - if ($button{balloon}->{Value} == 0) { - $balloonhelp->configure(-state => 'none'); - } else { - $balloonhelp->configure(-state => 'balloon'); - } - }); - #-------------------------------------------------- - # on/off commands for exclusive modes : - #-------------------------------------------------- - - # findenclosed mode - $on_command{findenclosed} = sub { - &saveDragAndDropBindings($selectedzinc); - $button{findenclosed}->{Value} = 1; - $selectedzinc->Tk::bind("<ButtonPress-1>", - [\&startrectangle, 'simple', 'Enclosed', - 'sienna']); - $selectedzinc->Tk::bind("<B1-Motion>", \&resizerectangle); - $selectedzinc->Tk::bind("<ButtonRelease-1>", - [\&stoprectangle, 'enclosed', - 'Items enclosed in rectangle']); - }; - $off_command{findenclosed} = sub { - $button{findenclosed}->{Value} = 0; - &restoreDragAndDropBindings($selectedzinc); - $selectedzinc->remove("zincdebugrectangle", "zincdebuglabel"); - }; - # findoverlap mode - $on_command{findoverlap} = sub { - &saveDragAndDropBindings($selectedzinc); - $button{findoverlap}->{Value} = 1; - $selectedzinc->Tk::bind("<ButtonPress-1>", [\&startrectangle, 'mixed', - 'Overlap', 'sienna']); - $selectedzinc->Tk::bind("<B1-Motion>", \&resizerectangle); - $selectedzinc->Tk::bind("<ButtonRelease-1>", - [\&stoprectangle, 'overlapping', - 'Items which overlap rectangle']); - }; - $off_command{findoverlap} = sub { - $button{findoverlap}->{Value} = 0; - &restoreDragAndDropBindings($selectedzinc); - $selectedzinc->remove("zincdebugrectangle", "zincdebuglabel"); - }; - # item mode - $on_command{item} = sub { - &saveDragAndDropBindings($selectedzinc); - $button{item}->{Value} = 1; - $selectedzinc->Tk::bind("<ButtonPress-1>", [\&findintree]); - }; - $off_command{item} = sub { - $button{item}->{Value} = 0; - &restoreDragAndDropBindings($selectedzinc); - }; - # cursor device position mode - $on_command{cursorxy} = sub { - &saveMotionBinding($selectedzinc); - $button{cursorxy}->{Value} = 1; - &cursorxyOpen; - $selectedzinc->Tk::bind("<Motion>", [\&cursorxy]); - }; - $off_command{cursorxy} = sub { - $button{cursorxy}->{Value} = 0; - &cursorxyClose; - &restoreMotionBinding($selectedzinc); - }; - - # move mode - $on_command{move} = sub { - &saveDragAndDropBindings($selectedzinc); - $button{move}->{Value} = 1; - my ($x0, $y0); - $selectedzinc->Tk::bind('<ButtonPress-1>', sub { - my $ev = $selectedzinc->XEvent; - ($x0, $y0) = ($ev->x, $ev->y); - }); - $selectedzinc->Tk::bind('<B1-Motion>', sub { - my $ev = $selectedzinc->XEvent; - my ($x, $y) = ($ev->x, $ev->y); - $selectedzinc->translate(1, $x-$x0, $y-$y0) if defined $x0; - ($x0, $y0) = ($x, $y); - }); - }; - $off_command{move} = sub { - $button{move}->{Value} = 0; - &restoreDragAndDropBindings($selectedzinc); - }; - # zn mode - $on_command{zn} = sub { - $button{zn}->{Value} = 1; - for my $zinc (&instances) { - $zinc->remove("zincdebugrectangle", "zincdebuglabel"); - &saveDragAndDropBindings($zinc); - my $r; - $zinc->Tk::bind("<ButtonPress-1>", sub { - $zinc->update; - my ($w, $h) = ($zinc->cget(-width), $zinc->cget(-height)); - $zinc->tsave(1, 'transfoTopgroup', 1); - $r = $zinc->add('rectangle', 1, [30, 30, $w-30, $h-30], - -linecolor => 'red', - -linewidth => 10); - $zinc->trestore($r, 'transfoTopgroup'); - $zinc->raise($r); - $selectedzinc = $zinc; - }); - $zinc->Tk::bind("<ButtonRelease-1>", sub { - $zinc->remove($r); - }); - } - }; - $off_command{zn} = sub { - $button{zn}->{Value} = 0; - for my $zinc (&instances) { - &restoreDragAndDropBindings($zinc); - } - }; - - my @but = qw(findenclosed findoverlap item move zn cursorxy); - for my $name (@but) { - $button{$name}->configure(-command => sub { - if ($button{$name}->{Value} == 1) { - for my $other (@but) { - &{$off_command{$other}} unless $other eq $name; - } - &{$on_command{$name}}; - } else { - &{$off_command{$name}}; - }}); - } - - $button{id}->configure(-command => sub { - $button{id}->update; - &searchentry($zinc); - $button{id}->toggle; - }); - - $button{snapshot}->configure(-command => sub { - $button{snapshot}->update; - &printWindow($zinc); - $button{snapshot}->toggle; - }); - - $button{zoomminus}->configure(-command => sub { - $button{zoomminus}->update; - my $w = $selectedzinc->cget(-width); - my $h = $selectedzinc->cget(-height); - $selectedzinc->translate(1, -$w/2, -$h/2); - $selectedzinc->scale(1, 1/1.1, 1/1.1); - $selectedzinc->translate(1, $w/2, $h/2); - $button{zoomminus}->toggle; - }); - - $button{zoomplus}->configure(-command => sub { - $button{zoomplus}->update; - my $w = $selectedzinc->cget(-width); - my $h = $selectedzinc->cget(-height); - $selectedzinc->translate(1, -$w/2, -$h/2); - $selectedzinc->scale(1, 1.1, 1.1); - $selectedzinc->translate(1, $w/2, $h/2); - $button{zoomplus}->toggle; - }); - - $button{tree}->configure(-command => sub { - $button{tree}->update; - &showtree($selectedzinc); - $button{tree}->toggle; - }); - - $button{close}->configure(-command => sub { - $button{close}->update; - &Tk::Zinc::Debug::iconify; - &restoreDragAndDropBindings($selectedzinc); - for my $name (@but) { - &{$off_command{$name}}; - } - $button{close}->toggle; - }); - -} # end init - - -#--------------------------------------------------------------------------- -# -# Deprecated functions -# -#--------------------------------------------------------------------------- - -sub tree { - - carp "in Tk::Zinc::Debug module, tree() function is deprecated.\n"; - &init($_[0]); - -} # end tree - - -sub finditems { - - carp "in Tk::Zinc::Debug module, finditems() function is deprecated.\n"; - &init($_[0]); - -} # end finditems - - - -sub snapshot { - - carp "in Tk::Zinc::Debug module, snapshot() function is deprecated.\n"; - &init($_[0]); - -} # end snapshot - - -#--------------------------------------------------------------------------- -# -# Functions related to cursor position -# -#--------------------------------------------------------------------------- -sub cursorxy { - - my $ev = shift->XEvent; - $cursorxy = $ev->x.", ".$ev->y; - -} # end cursorxy - - -sub cursorxyOpen { - - if (Tk::Exists($cursorxy_tl)) { - $cursorxy_tl->raise; - return; - } - $cursorxy_tl = $control_tl->Toplevel; - $cursorxy_tl->Label(-text => "Cursor device position")->pack; - $cursorxy_tl->Label(-textvariable => \$cursorxy)->pack; - $cursorxy_tl->minsize(150, 40); - $cursorxy_tl->raise; - -} # end cursorxyOpen - - -sub cursorxyClose { - - $cursorxy_tl->destroy if Tk::Exists($cursorxy_tl); - -} # end cursorxyClose - - -#--------------------------------------------------------------------------- -# -# Functions related to items tree -# -#--------------------------------------------------------------------------- - -# build or rebuild the items tree -sub showtree { - - my $zinc = shift; - my $optionstodisplay = $cmdoptions{optionsToDisplay}; - my $optionsFormat = $cmdoptions{optionsFormat}; - # styles definition - $itemstyle = - $zinc->ItemStyle('text', -stylename => "item", -foreground => 'black') - unless $itemstyle; - $groupstyle = - $zinc->ItemStyle('text', -stylename => "group", -foreground => 'black') - unless $groupstyle; - - $WARNING = 0; - my @optionstodisplay = split(/,/, $optionstodisplay); - $WARNING = 1; - &hidetree(); - $tree_tl = $control_tl->Toplevel; - $tree_tl->minsize(280, 200); - $tree_tl->title("Zinc Items Tree"); - $tree = $tree_tl->Scrolled('Tree', - -scrollbars => 'se', - -height => 40, - -width => 50, - -itemtype => 'text', - -selectmode => 'single', - -separator => '.', - -drawbranch => 1, - -indent => 30, - -command => sub { - my $path = shift; - my $item = (split(/\./, $path))[-1]; - &showresult("Attributes of item $item", $zinc, $item); - $zinc->after(100, sub { - &undohighlightitem(undef, $zinc)}); - }, - ); - &wheelmousebindings($tree); - $tree->bind('<1>', [sub { - my $path = $tree->nearest($_[1]); - my $item = (split(/\./, $path))[-1]; - &highlightitem($tree, $zinc, $item, 0); - - }, Ev('y')]); - - $tree->bind('<2>', [sub { - my $path = $tree->nearest($_[1]); - return if $path eq 1; - $tree->selectionClear; - $tree->selectionSet($path); - $tree->anchorSet($path); - my $item = (split(/\./, $path))[-1]; - &highlightitem($tree, $zinc, $item, 1); - - }, Ev('y')]); - - $tree->bind('<3>', [sub { - my $path = $tree->nearest($_[1]); - return if $path eq 1; - $tree->selectionClear; - $tree->selectionSet($path); - $tree->anchorSet($path); - my $item = (split(/\./, $path))[-1]; - &highlightitem($tree, $zinc, $item, 2); - - }, Ev('y')]); - - $tree->add("1", -text => "Group(1)", -state => 'disabled'); - &scangroup($zinc, $tree, 1, "1", $optionsFormat, @optionstodisplay); - $tree->autosetmode; - # control buttons frame - my $tree_butt_fm = $tree_tl->Frame(-height => 40)->pack(-side => 'bottom', - -fill => 'y'); - $tree_butt_fm->Button(-text => 'Help', - -command => [\&showHelpAboutTree, $zinc], - )->pack(-side => 'left', -pady => 10, - -padx => 10, -fill => 'both'); - - $tree_butt_fm->Button(-text => 'Search', - -command => [\&searchInTree, $zinc], - )->pack(-side => 'left', -pady => 10, - -padx => 10, -fill => 'both'); - $tree_butt_fm->Button(-text => "Build\ncode", - -command => [\&buildCode, $zinc, $tree], - )->pack(-side => 'left', -pady => 10, - -padx => 10, -fill => 'both'); - - $tree_butt_fm->Button(-text => "Attributes", - -command => sub { - my $path = $tree->selectionGet; - $path = 1 unless $path; - my $item = (split(/\./, $path))[-1]; - &showresult("Attributes of item $item", $zinc, $item); - }, - )->pack(-side => 'left', -pady => 10, - -padx => 10, -fill => 'both'); - - - $tree_butt_fm->Button(-text => 'Close', - -command => sub {$zinc->remove("zincdebug"); - $tree_tl->destroy}, - )->pack(-side => 'left', -pady => 10, - -padx => 20, -fill => 'both'); - # pack tree - $tree->pack(-padx => 10, -pady => 10, - -ipadx => 10, - -side => 'top', - -fill => 'both', - -expand => 1, - ); - - -} # end showtree - - -# destroy the items tree -sub hidetree { - - $tree_tl->destroy if $tree_tl and Tk::Exists($tree_tl); - -} # end hidetree - - -# find a pointed item in the items tree -sub findintree { - - my $zinc = shift; - if (not Tk::Exists($tree_tl)) { - &showtree($zinc); - } - my $ev = $zinc->XEvent; - ($x0, $y0) = ($ev->x, $ev->y); - my @atomicgroups = &unsetAtomicity($zinc); - my $item = $zinc->find('closest', $x0, $y0); - &restoreAtomicity($zinc, @atomicgroups); - return unless $item > 1; - my @ancestors = reverse($zinc->find('ancestors', $item)); - my $path = join('.', @ancestors).".".$item; - # tree is rebuilded unless path exists - unless ($tree->info('exists', $path)) { - $tree_tl->destroy; - #print "path=$path rebuild tree\n"; - &showtree($zinc); - } - $tree->see($path); - $tree->selectionClear; - $tree->anchorSet($path); - $tree->selectionSet($path); - &surrounditem($zinc, $item); - $tree->focus; - -} # end findintree - - -sub searchInTree { - - my $zinc = shift; - $searchtree_tl->destroy if $searchtree_tl and Tk::Exists($searchtree_tl); - $searchtree_tl = $tree_tl->Toplevel; - $searchtree_tl->transient($tree_tl); - $searchtree_tl->title("Find string in tree"); - my $fm = $searchtree_tl->Frame->pack(-side => 'top'); - $fm->Label(-text => "Find : ", - )->pack(-side => 'left', -padx => 10, -pady => 10); - my $entry = $fm->Entry(-width => 20)->pack(-side => 'left', - -padx => 10, -pady => 10); - my $status = $searchtree_tl->Label(-foreground => 'sienna', - )->pack(-side => 'top'); - my $ep = 1; - my $searchfunc = sub { - my $side = shift; - my $found = 0; - #print "ep=$ep side=$side\n"; - $status->configure(-text => ""); - $status->update; - $searchTreeEntryValue = $entry->get(); - $searchTreeEntryValue = quotemeta($searchTreeEntryValue); - my $text; - while ($ep) { - $ep = $tree->info($side, $ep); - unless ($ep) { - $ep = 1; - $found = 0; - last; - } - $text = $tree->entrycget($ep, -text); - if ($text =~ /$searchTreeEntryValue/) { - $tree->see($ep); - $tree->selectionClear; - $tree->anchorSet($ep); - $tree->selectionSet($ep); - $found = 1; - last; - } - } - #print "searchTreeEntryValue=$searchTreeEntryValue found=$found\n"; - $status->configure(-text => "Search string not found") unless $found > 0; - }; - - my $fm2 = $searchtree_tl->Frame->pack(-side => 'top'); - $fm2->Button(-text => 'Prev', - -command => sub {&$searchfunc('prev');}, - )->pack(-side => 'left', -pady => 10); - $fm2->Button(-text => 'Next', - -command => sub {&$searchfunc('next');}, - )->pack(-side => 'left', -pady => 10); - $fm2->Button(-text => 'Close', - -command => sub {$searchtree_tl->destroy}, - )->pack(-side => 'right', -pady => 10); - $entry->focus; - $entry->delete(0, 'end'); - $entry->insert(0, $searchTreeEntryValue) if $searchTreeEntryValue; - $entry->bind('<Key-Return>', sub {&$searchfunc('next');}); - -} # end searchInTree - - -sub extractinfo { - my $zinc = shift; - my $item = shift; - my $format = shift; - my $option = shift; - my $titleflag = shift; - $option =~ s/^\s+//; - $option =~ s/\s+$//; - #print "option=[$option]\n"; - my @info; - $WARNING = 0; - eval {@info = $zinc->itemcget($item, $option)}; - #print "eval $option = (@info) $@\n"; - return if $@; - return if @info == 0; - my $info; - my $sep = ($format eq 'column') ? "\n " : ", "; - if ($titleflag) { - $info = $sep."[$option] ".$info[0]; - } else { - $info = $sep.$info[0]; - } - if (@info > 1) { - shift(@info); - for (@info) { - if ($format eq 'column') { - if (length($info." ".$_) > 40) { - if ($titleflag) { - $info .= $sep."[$option] ".$_; - } else { - $info .= $sep.$_; - } - } else { - $info .= ", $_"; - } - } else { - $info .= $sep.$_; - } - } - } - $WARNING = 1; - return $info; - -} # end extractinfo - - -sub scangroup { - - my ($zinc, $tree, $group, $path, $format, @optionstodisplay) = @_; - my @items = $zinc->find('withtag', "$group."); - for my $item (@items) { - my $Type = ucfirst($zinc->type($item)); - my $info = " "; - if (@optionstodisplay == 1) { - $info .= &extractinfo($zinc, $item, $format, $optionstodisplay[0]); - } elsif (@optionstodisplay > 1) { - for my $opt (@optionstodisplay) { - $info .= &extractinfo($zinc, $item, $format, $opt, 1); - } - } - if ($Type eq "Group") { - $tree->add($path.".".$item, - -text => "$Type($item)$info", - -style => 'group', - ); - &scangroup($zinc, $tree, $item, $path.".".$item, $format, @optionstodisplay); - } else { - $tree->add($path.".".$item, - -text => "$Type($item)$info", - -style => 'item', - ); - } - } - -} # end scangroup - -#--------------------------------------------------------------------------- -# -# Functions used to build code -# -#--------------------------------------------------------------------------- - -# build perl code corresponding to a branch of the items tree -sub buildCode { - - my $zinc = shift; - my $tree = shift; - my @code; - push(@code, 'use Tk;'); - push(@code, 'use Tk::Zinc;'); - push(@code, 'my $mw = MainWindow->new();'); - push(@code, 'my $zinc = $mw->Zinc(-render => '.$zinc->cget(-render). - ')->pack(-expand => 1, -fill => "both");'); - push(@code, '# hash %items : keys are original items ID, values are built items ID'); - push(@code, 'my %items;'); - push(@code, ''); - my $path = $tree->selectionGet; - $path = 1 unless $path; - my $item = (split(/\./, $path))[-1]; - $endoptions = []; - if ($zinc->type($item) eq 'group') { - push(@code, &buildGroup($zinc, $item, 1)); - for(@$endoptions) { - my ($item, $option, $value) = @$_; - push(@code, - '$zinc->itemconfigure('.$item.', '.$option.' => '.$value.');'); - } - } else { - push(@code, &buildItem($zinc, $item, 1)); - } - push(@code, &buildEnd); - - my $file = $zinc->getSaveFile(-filetypes => [['Perl Files', '.pl'], - ['All Files', '*']], - -initialfile => 'zincdebug.pl', - -title => 'Save code', - ); - return unless defined $file; - $zinc->Busy; - open (OUT, ">$file"); - for (@code) { - print OUT $_."\n"; - } - close(OUT); - $zinc->Unbusy; - -} # end buildCode - - -sub buildEnd { - - my @code; - push(@code, 'for (keys(%items)) {'); - push(@code, ' $zinc->addtag(\'orig\'.$_, "withtag", $items{$_});'); - push(@code, '}'); - push(@code, 'MainLoop;'); - return @code - -} # end buildEnd - - -# build a node of tree (corresponding to a TkZinc group item) -sub buildGroup { - - my $zinc = shift; - my $item = shift; - my $group = shift; - my @code; - # creation - push(@code, '$items{'.$item.'}=$zinc->add("group", '.$group.', '); - # options - push(@code, &buildOptions($zinc, $item)); - push(@code, ');'); - push(@code, ''); - # coords - push(@code, '$zinc->coords($items{'.$item.'}, ['. - join(',', $zinc->coords($item)).']);'); - # transformations - push(@code, &buildTransformations($zinc, $item)); - - my @items = $zinc->find('withtag', "$item."); - for my $it (reverse(@items)) { - if ($zinc->type($it) eq 'group') { - push(@code, &buildGroup($zinc, $it, '$items{'.$item.'}')); - } else { - push(@code, &buildItem($zinc, $it, '$items{'.$item.'}')); - } - } - return @code; - -} # end buildGroup - - -# build a leaf of tree (corresponding to a TkZinc non-group item) -sub buildItem { - - my $zinc = shift; - my $item = shift; - my $group = shift; - my $type = $zinc->type($item); - my @code; - my $numfields = 0; - my $numcontours = 0; - # creation - my $initstring = '$items{'.$item.'}=$zinc->add("'.$type.'", '.$group.', '; - if ($type eq 'tabular' or $type eq 'track' or $type eq 'waypoint') { - $numfields = $zinc->itemcget($item, -numfields); - $initstring .= $numfields.' ,'; - } elsif ($type eq 'curve' or $type eq 'triangles' or - $type eq 'arc' or $type eq 'rectangle') { - $initstring .= "[ "; - my (@coords) = $zinc->coords($item); - if (ref($coords[0]) eq 'ARRAY') { - my @coords2; - for my $c (@coords) { - if (@$c > 2) { - push(@coords2, '['.$c->[0].', '.$c->[1].', "'.$c->[2].'"]'); - } else { - push(@coords2, '['.$c->[0].', '.$c->[1].']'); - - } - } - $initstring .= join(', ', @coords2); - } else { - $initstring .= join(', ', @coords); - } - $initstring .= " ], "; - $numcontours = $zinc->contour($item); - } - push(@code, $initstring); - # options - push(@code, &buildOptions($zinc, $item)); - push(@code, ');'); - push(@code, ''); - # fields - if ($numfields > 0) { - for (my $i=0; $i < $numfields; $i++) { - push(@code, &buildField($zinc, $item, $i)); - } - } - # contours - if ($numcontours > 1) { - for (my $i=1; $i < $numcontours; $i++) { - my (@coords) = $zinc->coords($item); - my @coords2; - for my $c (@coords) { - if (@$c > 2) { - push(@coords2, '['.$c->[0].', '.$c->[1].', "'.$c->[2].'"]'); - } else { - push(@coords2, '['.$c->[0].', '.$c->[1].']'); - } - } - my $coordstr = '[ '.join(', ', @coords2).' ]'; - push(@code, '$zinc->contour($items{'.$item.'}, "add", 0, '); - push(@code, ' '.$coordstr.');'); - } - } - # transformations - push(@code, &buildTransformations($zinc, $item)); - - return @code; - -} # end buildItem - - -# add an information field to an item of the tree -sub buildField { - - my $zinc = shift; - my $item = shift; - my $field = shift; - my @code; - # type group and initargs - push(@code, '$zinc->itemconfigure($items{'.$item.'}, '.$field.', '); - # options - push(@code, &buildOptions($zinc, $item, $field)); - push(@code, ');'); - push(@code, ''); - return @code; - -} # end buildField - - -sub buildTransformations { - - my $zinc = shift; - my $item = shift; - my @tr = $zinc->tget($item); - my @code; - return ('$zinc->tset($items{'.$item.'}, '.join(", ", @tr).');'); - -} # end buildTransformations - - -sub buildOptions { - - my $zinc = shift; - my $item = shift; - my $field = shift; - my @code; - my @args = defined($field) ? ($item, $field) : ($item); - my @options = $zinc->itemconfigure(@args); - for my $elem (@options) { - my ($option, $type, $readonly, $value) = (@$elem)[0, 1, 2, 4]; - next if $value eq ''; - next if $readonly; - if ($type eq 'point') { - push(@code, " ".$option." => [".join(',', @$value)."], "); - - } elsif (($type eq 'bitmap' or $type eq 'image') and $value !~ /^AtcSymbol/ - and $value !~ /^AlphaStipple/) { - push(@code, "# ".$option." => '".$value."', "); - - } elsif ($type eq 'item') { - $endoptions->[@$endoptions] = - ['$items{'.$item.'}', $option, '$items{'.$value.'}']; - - } elsif ($option eq '-text') { - $value =~ s/\"/\\"/; # comment for emacs legibility => " - push(@code, " ".$option.' => "'.$value.'", '); - - } elsif (ref($value) eq 'ARRAY') { - push(@code, " ".$option." => [qw(".join(' ', @$value).")], "); - - } else { - push(@code, " ".$option." => '".$value."', "); - } - } - return @code; - -} # end buildOptions - -#--------------------------------------------------------------------------- -# -# Functions related to search in a rectangular area -# -#--------------------------------------------------------------------------- - -# begin to draw rectangular area for search -sub startrectangle { - - my ($zinc, $style, $text, $color) = @_; - $zinc->remove("zincdebugrectangle", "zincdebuglabel"); - my $ev = $zinc->XEvent; - ($x0, $y0) = ($ev->x, $ev->y); - # store and name the inverted transformation of top group - $zinc->tsave(1, 'zoom+move', 1); - $zinc->add('rectangle', 1, [$x0, $y0, $x0, $y0], - -linecolor => $color, - -linewidth => 2, - -linestyle => $style, - -tags => ["zincdebugrectangle"], - ); - $zinc->add('text', 1, - -color => $color, - -font => '7x13', - -position => [$x0+5, $y0-15], - -text => $text, - -tags => ["zincdebuglabel"], - ); - # apply to new rectangle the (inverted) transformation stored below - $zinc->trestore("zincdebugrectangle", 'zoom+move'); - $zinc->trestore("zincdebuglabel", 'zoom+move'); - -} # end startrectangle - - -# resize the rectangular area for search -sub resizerectangle { - - my $zinc = shift; - my $ev = $zinc->XEvent; - my ($x, $y) = ($ev->x, $ev->y); - return unless ($zinc->find('withtag', "zincdebugrectangle")); - - $zinc->coords("zincdebugrectangle", 1, 1, [$x, $y]); - if ($x < $x0) { - if ($y < $y0) { - $zinc->coords("zincdebuglabel", [$x+5, $y-15]); - } else { - $zinc->coords("zincdebuglabel", [$x+5, $y0-15]); - } - } else { - if ($y < $y0) { - $zinc->coords("zincdebuglabel", [$x0+5, $y-15]); - } else { - $zinc->coords("zincdebuglabel", [$x0+5, $y0-15]); - } - } - $zinc->raise("zincdebugrectangle"); - $zinc->raise("zincdebuglabel"); - -} # end resizerectangle - - -# stop drawing rectangular area for search -sub stoprectangle { - - my ($zinc, $searchtype, $text) = @_; - return unless ($zinc->find('withtag', "zincdebugrectangle")); - - my @atomicgroups = &unsetAtomicity($zinc); - $zinc->update; - my ($c0, $c1) = $zinc->coords("zincdebugrectangle"); - my @coords = (@$c0, @$c1); - my @items; - for my $item ($zinc->find($searchtype, @coords, 1, 1)) { - push (@items, $item) unless $zinc->hastag($item, "zincdebugrectangle") or - $zinc->hastag($item, "zincdebuglabel"); - } - &restoreAtomicity($zinc, @atomicgroups); - if (@items) { - &showresult($text, $zinc, @items); - } else { - $zinc->remove("zincdebugrectangle", "zincdebuglabel"); - } - -} # end stoprectangle - - -# in order to avoid find problems with group atomicity, we set all -atomic -# attributes to 0 -sub unsetAtomicity { - - my $zinc = shift; - my @groups = $zinc->find('withtype', 'group'); - my @atomicgroups; - for my $group (@groups) { - if ($zinc->itemcget($group, -atomic)) { - push(@atomicgroups, $group); - $zinc->itemconfigure($group, -atomic => 0); - } - } - return @atomicgroups; - -} # end unsetAtomicity - - -sub restoreAtomicity { - - my $zinc = shift; - my @atomicgroups = @_; - for my $group (@atomicgroups) { - $zinc->itemconfigure($group, -atomic => 1); - } - -} # end restoreAtomicity - - -#--------------------------------------------------------------------------- -# -# Function related to item's id search -# -#--------------------------------------------------------------------------- - -sub searchentry { - - my $zinc = shift; - $search_tl->destroy if $search_tl and Tk::Exists($search_tl); - $search_tl = $control_tl->Toplevel; - $search_tl->title("Specific search"); - my $fm = $search_tl->Frame->pack(-side => 'top'); - $fm->Label(-text => "Item TagOrId : ", - )->pack(-side => 'left', -padx => 10, -pady => 10); - my $entry = $fm->Entry(-width => 20)->pack(-side => 'left', - -padx => 10, -pady => 10); - my $status = $search_tl->Label(-foreground => 'sienna', - )->pack(-side => 'top'); - $search_tl->Button(-text => 'Close', - -command => sub {$search_tl->destroy}, - )->pack(-side => 'top', -pady => 10); - $entry->focus; - $entry->delete(0, 'end'); - $entry->insert(0, $searchEntryValue{$zinc}) if $searchEntryValue{$zinc}; - $entry->bind('<Key-Return>', [sub { - $status->configure(-text => ""); - $status->update; - $searchEntryValue{$zinc} = $entry->get(); - my @items = $zinc->find('withtag', $searchEntryValue{$zinc}); - if (@items) { - my $label; - if ($searchEntryValue{$zinc} =~ /^\d/) { - $label = "Attributes of item $searchEntryValue{$zinc}"; - } else { - $label = "Attributes of item(s) with tag $searchEntryValue{$zinc}" - } - &showresult($label, $zinc, @items); - } else { - $status->configure(-text => "No such tagOrId ($searchEntryValue{$zinc})"); - } - }]); - -} # end searchentry - - -#--------------------------------------------------------------------------- -# -# Functions related to transformations parameters -# -#--------------------------------------------------------------------------- - -sub showtransfoparams { - - my ($label, $zinc, $item) = @_; - my @m = $zinc->tget($item); - my ($m00, $m01, $m10, $m11, $m20, $m21) = @m; - my ($xt, $yt, $xsc, $ysc, $a, $xsk, $ysk) = $zinc->tget($item, 'all'); - # bug zinc - $ysk = 0 unless defined $ysk; - for ($m00, $m01, $m10, $m11, $m20, $m21, $xt, $yt, $xsc, $ysc, $a, $xsk, $ysk) { - $_ = sprintf("%.2f", $_) if /^-?\d+\.\d/; - } - $transfo_tl{$item}->destroy if Tk::Exists($transfo_tl{$item}); - $transfo_tl{$item} = $control_tl->Toplevel(); - $transfo_tl{$item}->transient($result_tl{$label}) - if Tk::Exists($result_tl{$label}); - my $title = "Transformations of item $item"; - $transfo_tl{$item}->title($title); - my $bgcolor = 'ivory'; - my $fm1 = $transfo_tl{$item}->Frame()->pack(-side => 'top', - -padx => 20, - -pady => 10, - -expand => 1, - -fill => 'x', - ); - # set transformation to ident - my $btn = $fm1->Button(-text => "Show item with transformation\nset to identity", - -bg => $bgcolor, - )->pack(-side => 'top', -padx => 5, -pady => 10); - $balloonhelp->attach($btn,-balloonmsg => - "Click and maintain to show the transformation \n". - "animation. Use btn1, btn2 or btn3 to select the\n". - "best background color for a good visibility. "); - $btn->bind('<1>', [\&showtransfo, $zinc, $item, 0]); - $btn->bind('<2>', [\&showtransfo, $zinc, $item, 1]); - $btn->bind('<3>', [\&showtransfo, $zinc, $item, 2]); - - my $fm11 = $fm1->Frame()->pack(-side => 'left', - -padx => 20, - ); - - my ($set_cb, $reset_cb, $upd_cb); - - # matrix - my $r = 0; - my $c = 0; - $fm11->Label(-text => 'matrix', -relief => 'ridge', -bg => $bgcolor) - ->grid(-row => $r++, -columnspan => 2, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm11->Label(-textvariable => \$m00, -relief => 'ridge') - ->grid(-row => $r, -column => $c, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm11->Label(-textvariable => \$m01, -relief => 'ridge') - ->grid(-row => $r++, -column => $c+1, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm11->Label(-textvariable => \$m10, -relief => 'ridge') - ->grid(-row => $r, -column => $c, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm11->Label(-textvariable => \$m11, -relief => 'ridge') - ->grid(-row => $r++, -column => $c+1, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm11->Label(-textvariable => \$m20, -relief => 'ridge') - ->grid(-row => $r, -column => $c, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm11->Label(-textvariable => \$m21, -relief => 'ridge') - ->grid(-row => $r++, -column => $c+1, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - - - my $fm12 = $fm1->Frame()->pack(-side => 'left', - -padx => 20, - ); - my ($e_xt, $e_yt, $e_xsc, $e_ysc, $e_a, $e_xsk, $e_ysk); - - $set_cb = sub { - $zinc->treset($item); - $zinc->translate($item, $e_xt, $e_yt); - $zinc->rotate($item, $e_a); - $zinc->scale($item, $e_xsc, $e_ysc); - $zinc->skew($item, $e_xsk, $e_ysk); - ($m00, $m01, $m10, $m11, $m20, $m21) = $zinc->tget($item); - for ($m00, $m01, $m10, $m11, $m20, $m21) { - $_ = sprintf("%.2f", $_) if /^-?\d+\.\d/; - } - }; - - # translate params - $r = 0; - $c = 0; - $fm12->Label(-text => 'translate', -relief => 'ridge', -bg => $bgcolor) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - &entrytransfo($fm12, $item, $zinc, 'xt', $xt, \$e_xt, 4, $set_cb) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - &entrytransfo($fm12, $item, $zinc, 'yt', $yt, \$e_yt, 4, $set_cb) - ->grid(-row => $r++, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - # rotate params - $c = 0; - $fm12->Label(-text => 'rotate', -relief => 'ridge', -bg => $bgcolor) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - &entrytransfo($fm12, $item, $zinc, 'a', $a, \$e_a, 4, $set_cb) - ->grid(-row => $r++, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - # scale params - $c = 0; - $fm12->Label(-text => 'scale', -relief => 'ridge', -bg => $bgcolor) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - &entrytransfo($fm12, $item, $zinc, 'xsc', $xsc, \$e_xsc, 4, $set_cb) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - &entrytransfo($fm12, $item, $zinc, 'ysc', $ysc, \$e_ysc, 4, $set_cb) - ->grid(-row => $r++, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - # skew params - $c = 0; - $fm12->Label(-text => 'skew', -relief => 'ridge', -bg => $bgcolor) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - &entrytransfo($fm12, $item, $zinc, 'xsk', $xsk, \$e_xsk, 4, $set_cb) - ->grid(-row => $r, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - &entrytransfo($fm12, $item, $zinc, 'ysk', $ysk, \$e_ysk, 4, $set_cb) - ->grid(-row => $r++, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - - - my $fm2 = $transfo_tl{$item}->Frame()->pack(-side => 'top', - -padx => 20, - -pady => 0, - ); - $fm2->Button(-text => 'Close', - -command => sub { - $transfo_tl{$item}->destroy; - delete $transfo_tl{$item}; - })->pack(-side => 'top', -padx => 40, -pady => 20); - - - -} # end showtransfoparams - - -#--------------------------------------------------------------------------- -# -# Functions related to results tables display -# -#--------------------------------------------------------------------------- - -# display in a toplevel the result of search ; a new toplevel destroyes the -# previous one -sub showresult { - - my ($label, $zinc, @items) = @_; - # toplevel (re-)creation - $result_tl{$label}->destroy if Tk::Exists($result_tl{$label}); - $result_tl{$label} = $control_tl->Toplevel(); - my $title = "TK::Zinc Debug"; - $title .= " - $label" if $label; - $result_tl{$label}->title($title); - $result_tl{$label}->geometry('+10+20'); - $control_tl->raise; - my $fm = $result_tl{$label}->Frame()->pack(-side => 'bottom', - ); - $fm->Button(-text => 'Close', - -command => sub { - $result_tl{$label}->destroy; - delete $result_tl{$label}; - $zinc->remove("zincdebugrectangle", "zincdebuglabel"); - })->pack(-side => 'left', -padx => 40, -pady => 10); - - # scrolled pane creation - $result_fm = $result_tl{$label}->Scrolled('Pane', - -scrollbars => 'osoe', - -height => 200, - -width => 1024, - ); - &wheelmousebindings($result_fm); - my $fm2 = $result_fm->Frame->pack; - # attributes display - &showattributes($zinc, $fm2, $label, \@items); - $result_fm->update; - $fm2->update; - my $width = $fm2->width + 10; - $width = $screenwidth if $width > $screenwidth; - $result_fm->configure(-width => $width); - $result_fm->pack(-padx => 10, -pady => 10, - -ipadx => 10, - -fill => 'both', - -expand => 1, - ); - -} # end showresult - -# display table containing additionnal options/values -sub showalloptions { - - my ($label, $zinc, $item, $fmp) = @_; - $alloptions_tl{$item}->destroy if Tk::Exists($alloptions_tl{$item}); - $alloptions_tl{$item} = $control_tl->Toplevel(); - $alloptions_tl{$item}->transient($result_tl{$label}) - if Tk::Exists($result_tl{$label}); - my $tl = $alloptions_tl{$item}; - my $title = "All options of item $item"; - $tl->title($title); - $tl->geometry('-10+0'); - - - # footer - #---------------- - $tl->Button(-text => 'Close', - -command => sub { - $alloptions_tl{$item}->destroy; - delete $alloptions_tl{$item}; - })->pack(-side => 'bottom'); - # option scrolled frame - #----------------------- - my $fm = $tl->Scrolled('Pane', - -scrollbars => 'oe', - -height => 500, - )->pack(-padx => 10, -pady => 10, - -ipadx => 10, - -expand => 1, - -fill => 'both'); - - my $bgcolor = 'ivory'; - my $i = 1; - $fm->Label(-text => $title, -background => $bgcolor, - -fg => 'sienna', -relief => 'ridge') - ->grid(-row => $i++, -column => 1, -ipady => 5, -ipadx => 5, - -columnspan => 2, -sticky => 'nswe') if $label; - $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => 'Value', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i++, -column => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - - my @options = $zinc->itemconfigure($item); - for my $elem (@options) { - my ($option, $type, $value) = (@$elem)[0,1,4]; - $fm->Label(-text => $option, -relief => 'ridge') - ->grid(-row => $i, -column => 1, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - if ($option eq '-tags') { - &entryoption($fm, $item, $zinc, $option, - join("\n", @$value), 30, 30, scalar @$value) - ->grid(-row => $i, -column => 2, -ipady => 5, - -ipadx => 5, -sticky => 'nswe'); - } else { - &entryoption($fm, $item, $zinc, $option, undef, 50, 25) - ->grid(-row => $i, -column => 2, -ipady => 5, - -ipadx => 5, -sticky => 'nswe'); - } - $i++; - } - -} # end showalloptions - - -# display device coords table -sub showdevicecoords { - - my ($label, $zinc, $item) = @_; - &showcoords($label, $zinc, $item, 1); - -} # end showdevicecoords - - -# display coords table -sub showcoords { - - my ($label, $zinc, $item, $deviceflag) = @_; - my $bgcolor = 'ivory'; - my $bgcolor2 = 'gray75'; - $coords_tl{$item}->destroy if Tk::Exists($coords_tl{$item}) and not $deviceflag; - $coords_tl{$item} = $control_tl->Toplevel(); - $coords_tl{$item}->transient($result_tl{$label}) if Tk::Exists($result_tl{$label}); - my $title = "Zinc Debug"; - if ($deviceflag) { - $title .= " - Coords of item $item"; - } else { - $title .= " - Device coords of item $item"; - } - $coords_tl{$item}->title($title); - $coords_tl{$item}->geometry('+10+20'); - my $coords_fm0 = $coords_tl{$item}->Frame()->pack(-side => 'bottom'); - $coords_fm0->Button(-text => 'Help', - -command => [\&showHelpAboutCoords, $zinc] - )->pack(-side => 'left', -padx => 40, -pady => 10); - $coords_fm0->Button(-text => 'Close', - -command => sub { - &hidecontour($zinc); - $coords_tl{$item}->destroy; - delete $coords_tl{$item}; - })->pack(-side => 'left', -padx => 40, -pady => 10); - # scrolled pane creation - my $coords_fm = $coords_tl{$item}->Scrolled('Pane', - -scrollbars => 'oe', - -height => 200, - )->pack(-padx => 10, -pady => 10, - -ipadx => 10, - -expand => 1, - -fill => 'both'); - my @contour; - my $contournum = $zinc->contour($item); - for (my $i=0; $i < $contournum; $i++) { - my @coords = $zinc->coords($item, $i); - if (!ref $coords[0]) { - ## The first item of the list is not a reference, so the - ## list is guarranted to be a flat list (x, y, ...) - ## normaly of only one pair of (x y) - @coords = $zinc->transform($item, 'device', [@coords]) - if $deviceflag; - for (my $j=0; $j < @coords; $j += 2) { - push(@{$contour[$i]}, [$coords[$j], $coords[$j+1]]); - } - } - else { - ## the first element is an array reference, as every - ## other elements of the list - for (my $j=0; $j < @coords; $j ++) { - my @c = @{$coords[$j]}; - @c = $zinc->transform($item, 'device', [@c]) - if $deviceflag; - push(@{$contour[$i]}, [@c]); - } - } - } - my $row = 1; - my $col = 1; - for (my $i=0; $i < @contour; $i++) { - $col = 1; - my $lab = $coords_fm->Label(-text => "Contour $i", - -background => $bgcolor, - -relief => 'ridge')->grid(-row => $row, - -column => $col, - -ipadx => 5, - -ipady => 5, - -sticky => 'nswe'); - $lab->bind('<1>', [\&showcontour, $zinc, 'black', $item, $contour[$i], - $deviceflag]); - $lab->bind('<2>', [\&showcontour, $zinc, 'white', $item, $contour[$i], - $deviceflag]); - $lab->bind('<3>', [\&showcontour, $zinc, 'red', $item, $contour[$i], - $deviceflag]); - $lab->bind('<ButtonRelease-1>', sub { &hidecontour($zinc); }); - $lab->bind('<ButtonRelease-2>', sub { &hidecontour($zinc); }); - $lab->bind('<ButtonRelease-3>', sub { &hidecontour($zinc); }); - my $lab1 = $coords_fm->Label(-text => scalar(@{$contour[$i]})." points", - -background => $bgcolor, - -relief => 'ridge')->grid(-row => $row+1, - -column => $col, - -ipadx => 5, - -ipady => 5, - -sticky => 'nswe'); - $lab1->bind('<1>', [\&showcontourpts, $zinc, 'black', $item, $contour[$i], - $deviceflag]); - $lab1->bind('<2>', [\&showcontourpts, $zinc, 'white', $item, $contour[$i], - $deviceflag]); - $lab1->bind('<3>', [\&showcontourpts, $zinc, 'red', $item, $contour[$i], - $deviceflag]); - $lab1->bind('<ButtonRelease-1>', sub { &hidecontour($zinc); }); - $lab1->bind('<ButtonRelease-2>', sub { &hidecontour($zinc); }); - $lab1->bind('<ButtonRelease-3>', sub { &hidecontour($zinc); }); - $col++; - my @lab; - for my $coords (@{$contour[$i]}) { - if ($col > 10) { - $col = 2; - $row++; - } - $coords->[0] =~ s/\.(\d\d).*/\.$1/; - $coords->[1] =~ s/\.(\d\d).*/\.$1/; - my @opt; - if (defined $coords->[2]) { - @opt = (-text => sprintf('%s, %s, %s', @$coords), - -underline => length(join(',', @$coords)) + 1, - ); - } else { - @opt = (-text => sprintf('%s, %s', @{$coords}[0,1])); - } - push (@lab, $coords_fm->Label(@opt, - -width => 15, - -relief => 'ridge')->grid(-row => $row, - -ipadx => 5, - -ipady => 5, - -column => $col++, - -sticky => 'nswe')); - } - $row++ if (@{$contour[$i]} < 10); - $row++; - my $j = 0; - for (@lab) { - $_->bind('<1>', [\&showcontourpt, $zinc, 'black', - $item, $j, $deviceflag, \@lab, @{$contour[$i]}]); - $_->bind('<2>', [\&showcontourpt, $zinc, 'white', - $item, $j, $deviceflag, \@lab, @{$contour[$i]}]); - $_->bind('<3>', [\&showcontourpt, $zinc, 'red', - $item, $j, $deviceflag, \@lab, @{$contour[$i]}]); - $j++; - } - - } - -} # end showcoords - - - -# display in a grid the values of most important attributes -sub showattributes { - - my ($zinc, $fm, $label, $items, $expandTagsFlag) = @_; - $expandTagsFlag = 1; - &getsize($zinc); - my $bgcolor = 'ivory'; - my $i = 1; - $fm->Label(-text => $label, -background => $bgcolor, - -fg => 'sienna', -relief => 'ridge') - ->grid(-row => $i++, -column => 0, -ipady => 0, -ipadx => 5, - -columnspan => 7, -sticky => 'nswe') if $label; - - &showbanner($fm, $i++); - $i++; - for my $item (@$items) { - my $c = 0; - my $type = $zinc->type($item); - # id - my $idbtn = - $fm->Button(-text => $item, - -foreground => 'sienna' - )->grid(-row => $i, -column => $c++, -sticky => 'nswe', - -ipadx => 5); - $idbtn->bind('<1>', [\&highlightitem, $zinc, $item, 0]); - $idbtn->bind('<2>', [\&highlightitem, $zinc, $item, 1]); - $idbtn->bind('<3>', [\&highlightitem, $zinc, $item, 2]); - $balloonhelp->attach($idbtn,-balloonmsg => - "Click and maintain to show the item. \n". - "Use btn1, btn2 or btn3 to select the best\n". - "background color for a good visibility. "); - # type - if ($type eq 'group') { - my $gbtn = - $fm->Button(-text => $type, - -command => sub { - my @items = $zinc->find('withtag', $item."."); - &showresult("Content of group $item", $zinc, @items); - }); - $gbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - $balloonhelp->attach($gbtn,-balloonmsg => - "Click to display the group's content."); - } else { - $fm->Label(-text => $type, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - } - # parent group - my $group = $zinc->group($item); - my $pgbtn = - $fm->Button(-text => $group, - -command => [\&showresult, - "Attributes of group $group (parent of $item)", - $zinc, $group]); - $pgbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - $balloonhelp->attach($pgbtn,-balloonmsg => - "Click to display the parent group's attributes."); - # priority - &entryoption($fm, $item, $zinc, -priority) - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2); - # sensitiveness - &entryoption($fm, $item, $zinc, -sensitive) - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2); - # visibility - &entryoption($fm, $item, $zinc, -visible) - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2); - # other options - $fm->Button(-text => 'show', - -command => [\&showalloptions, $label, $zinc, $item, $fm]) - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - # transformations - my $tlabel = 'yes'; - my ($xt, $yt, $xsc, $ysc, $a, $xsk) = $zinc->tget($item, 'all'); - $tlabel = 'no' if ($xt == 0 and $yt == 0 and $xsc == 1 and $ysc == 1 and - $a == 0 and $xsk == 0); - my $tbtn = - $fm->Button(-text => $tlabel, - -command => [\&showtransfoparams, $label, $zinc, $item], - ); - $tbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - $balloonhelp->attach($tbtn,-balloonmsg => - "Click to display transformation parameters.\n". - "Some of them can be updated. "); - - # coords - my @coords = $zinc->coords($item); - my $coords; - if (!ref $coords[0]) { - my $x0 = int($coords[0]); - my $y0 = int($coords[1]); - $coords = "($x0, $y0)"; - } else { - my @points0 = @{$coords[0]}; - my $n = $#coords; - my @pointsN = @{$coords[$n]}; - my $x0 = int($points0[0]); - my $y0 = int($points0[1]); - my $xn = int($pointsN[0]); - my $yn = int($pointsN[1]); - if ($n == 1) { ## a couple of points - $coords = "($x0, $y0, $xn, $yn)"; - } else { - $coords = "P0=($x0, $y0), ..., P".$n."=($xn, $yn)"; - } - } - if (@coords > 2) { - my $cbtn = $fm->Button(-text => $coords, - -command => [\&showcoords, $label, $zinc, $item]); - $cbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2); - $balloonhelp->attach($cbtn,-balloonmsg => - "Click to show all coordinates."); - } else { - $fm->Label(-text => $coords, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - } - # device coords - @coords = $zinc->transform($item, 'device', [@coords]); - if (!ref $coords[0]) { - my $x0 = int($coords[0]); - my $y0 = int($coords[1]); - $coords = "($x0, $y0)"; - } else { - my @points0 = @{$coords[0]}; - my $n = $#coords; - my @pointsN = @{$coords[$n]}; - my $x0 = int($points0[0]); - my $y0 = int($points0[1]); - my $xn = int($pointsN[0]); - my $yn = int($pointsN[1]); - if ($n == 1) { ## a couple of points - $coords = "($x0, $y0, $xn, $yn)"; - } else { - $coords = "P0=($x0, $y0), ..., P".$n."=($xn, $yn)"; - } - } - if (@coords > 2) { - my $dcbtn = - $fm->Button(-text => $coords, - -command => [\&showdevicecoords, $label, $zinc, $item]); - $dcbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2); - $balloonhelp->attach($dcbtn,-balloonmsg => - "Click to show all device coordinates."); - } else { - $fm->Label(-text => $coords, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - } - # bounding box - my @bbox = $zinc->bbox($item); - if (@bbox == 4) { - my ($b0, $b1, $b2, $b3) = @bbox; - $b0 = sprintf("%.2f", $b0) if int($b0) ne $b0; - $b1 = sprintf("%.2f", $b1) if int($b1) ne $b1; - $b2 = sprintf("%.2f", $b2) if int($b2) ne $b2; - $b3 = sprintf("%.2f", $b3) if int($b3) ne $b3; - my $btn = $fm->Button(-text => "($b0, $b1), ($b2, $b3)") - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - $btn->bind('<1>', [\&showbbox, $zinc, $item]); - $btn->bind('<ButtonRelease-1>', [\&hidebbox, $zinc]) ; - $balloonhelp->attach($btn,-balloonmsg => - "Click to show the bounding box."); - } else { - $fm->Label(-text => "--", , -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - } - # tags - my @tags = $zinc->gettags($item); - my $height = 2; - $height = scalar @tags if $cmdoptions{expandTagsField}; - &entryoption($fm, $item, $zinc, -tags, join("\n", @tags), 30, 30, $height) - ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5); - - $i++; - &showbanner($fm, $i++) if ($i % 15 == 0); - } - -} # end showattributes - - -sub showbanner { - - my $fm = shift; - my $i = shift; - my $bgcolor = 'ivory'; - my $c = 0; - $fm->Label(-text => "Item\nId", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "Item\nType", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "Parent\ngroup", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "P\nr\ni\no", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -ipady => 2, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "S\ne\nn\ns", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -ipady => 2, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "V\ni\ns\ni", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, -ipady => 2, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "All\noptions", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, - -ipady => 5, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => "Transfo", -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, - -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => 'Coords', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, - -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => 'Device coords', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, - -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => 'Bounding box', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, - -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => 'Tags', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => $i, -column => $c++, - -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label()->grid(-row => 1, -column => $c++, -pady => 10); - -} # end showbanner - - -#--------------------------------------------------------------------------- -# -# Functions related to contours display -# -#--------------------------------------------------------------------------- - -# display contour (as simple curve) -sub showcontour { - my ($widget, $zinc, $color, $item, $contourcoords, $deviceflag) = @_; - if ($deviceflag) { - $zinc->add('curve', 1, $contourcoords, - -filled => 0, - -linecolor => $color, - -tags => ['zincdebugcontour']); - - } else { - $zinc->add('curve', 1, [$zinc->transform($item, 1, $contourcoords)], - -filled => 0, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } - $zinc->raise('zincdebugcontour'); - -} # end showcontour - - -sub hidecontour { - - my ($zinc) = @_; - $zinc->remove('zincdebugcontour'); - -} # end hidecontour - - -# display contours points (one rectangle per point) -sub showcontourpts { - my ($widget, $zinc, $color, $item, $contourcoords, $deviceflag) = @_; - my $i = 0; - for my $coords (@$contourcoords) { - my ($x, $y); - if ($deviceflag) { - ($x, $y) = @$coords; - } else { - ($x, $y) = $zinc->transform($item, 1, $coords); - } - if ($i == 0) { - $zinc->add('arc', 1, [$x-10, $y-10, $x+10, $y+10], - -filled => 0, - -linewidth => 1, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } elsif ($i == @$contourcoords -1) { - $zinc->add('arc', 1, [$x-10, $y-10, $x+10, $y+10], - -filled => 0, - -linewidth => 1, - -linecolor => $color, - -tags => ['zincdebugcontour']); - $zinc->add('arc', 1, [$x-13, $y-13, $x+13, $y+13], - -filled => 0, - -linewidth => 1, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } - my $dx = 3; - if (@$coords > 2) { - $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx], - -filled => 0, - -linewidth => 1, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } else { - $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx], - -filled => 1, - -linewidth => 1, - -fillcolor => $color, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } - $i++; - } - $zinc->raise('zincdebugcontour'); - -} # end showcontourpts - - -# display one point of a contour (as a rectangle) -sub showcontourpt { - - my ($widget, $zinc, $color, $item, $index, $deviceflag, $labels, @contour) = @_; - $widget->focus; - if ($index < 0 or $index >= @contour) { - $widget->bell; - return; - } - &hidecontour($zinc); - my $bgcolor = ($labels->[0]->configure(-background))[3]; - for (@$labels) { - $_->configure(-background => $bgcolor); - } - $labels->[$index]->configure(-background => 'bisque'); - my @coords = @{$contour[$index]}; - my ($x, $y); - if ($deviceflag) { - ($x, $y) = @coords; - } else { - ($x, $y) = $zinc->transform($item, 1, [@coords]); - } - my $dx = 3; - if (@coords > 2) { - $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx], - -filled => 0, - -linewidth => 1, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } else { - $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx], - -filled => 1, - -linewidth => 1, - -fillcolor => $color, - -linecolor => $color, - -tags => ['zincdebugcontour']); - } - $widget->bind('<Key-Down>', [\&showcontourpt, $zinc, $color, - $item, $index+1, $deviceflag, $labels, @contour]); - $widget->bind('<Key-Right>', [\&showcontourpt, $zinc, $color, - $item, $index+1, $deviceflag, $labels, @contour]); - $widget->bind('<Key-Up>', [\&showcontourpt, $zinc, $color, - $item, $index-1, $deviceflag, $labels, @contour]); - $widget->bind('<Key-Left>', [\&showcontourpt, $zinc, $color, - $item, $index-1, $deviceflag, $labels, @contour]); - $zinc->raise('zincdebugcontour'); - -} # end showcontourpt - - -#--------------------------------------------------------------------------- -# -# Functions related to items graphical presentation -# -#--------------------------------------------------------------------------- - -# display the bbox of a group item -sub showbbox { - - my ($btn, $zinc, $item) = @_; - $zinc->tsave(1, 'zoom+move', 1); - my @bbox = $zinc->bbox($item); - if (scalar @bbox == 4) { - # If item is visible, rectangle is drawm surround it. - # Else, a warning is displayed. - unless (&itemisoutside($zinc, @bbox)) { - my $i = -2; - for ('white', 'blue', 'white') { - $zinc->add('rectangle', 1, - [$bbox[0] + $i, $bbox[1] + $i, - $bbox[2] - $i, $bbox[3] - $i], - -linecolor => $_, - -linewidth => 1, - -tags => ['zincdebugbbox']); - $i += 2; - } - } - } - $zinc->trestore('zincdebugbbox', 'zoom+move'); - $zinc->raise('zincdebugbbox'); - -} # end showbbox - - -sub hidebbox { - - my ($btn, $zinc) = @_; - $zinc->remove("zincdebugbbox"); - -} # end hidebbox - - -# display a message box when an item is not visible because outside window -sub itemisoutside { - - my $zinc = shift; - my @bbox = @_; - return unless @bbox == 4; - &getsize($zinc); - #print "bbox=(@bbox) wheight=$wheight{$zinc} wwidth=$wwidth{$zinc}\n"; - my $outflag; - $WARNING = 0; - if ($bbox[2] < 0) { - if ($bbox[1] > $wheight{$zinc}) { - $outflag = 'left+bottom'; - } elsif ($bbox[3] < 0) { - $outflag = 'left+top'; - } else { - $outflag = 'left'; - } - } elsif ($bbox[0] > $wwidth{$zinc}) { - if ($bbox[1] > $wheight{$zinc}) { - $outflag = 'right+bottom'; - } elsif ($bbox[3] < 0) { - $outflag = 'right+top'; - } else { - $outflag = 'right'; - } - } elsif ($bbox[3] < 0) { - $outflag = 'top'; - } elsif ($bbox[1] > $wheight{$zinc}) { - $outflag = 'bottom'; - } - #print "outflag=$outflag bbox=@bbox\n"; - return 0 unless $outflag; - # create first group which will be translated. We will apply to this group - # the reverse transformation of topgroup. - my $g = $zinc->add('group', 1, -tags => ['zincdebug']); - # create child group which won't be affected by ancestor's scale. - my $g1 = $zinc->add('group', $g, -composescale => 0); - my $hw = 110; - my $hh = 80; - my $r = 5; - $zinc->add('rectangle', $g1, [-$hw, -$hh, $hw, $hh], - -filled => 1, - -linecolor => 'sienna', - -linewidth => 3, - -fillcolor => 'bisque', - -priority => 1, - ); - $zinc->add('text', $g1, - -position => [0, 0], - -color => 'sienna', - -font => '-b&h-lucida-bold-i-normal-sans-34-240-*-*-p-*-iso8859-1', - -anchor => 'center', - -priority => 2, - -text => "Item is\noutside\nwindow\n"); - my ($x, $y); - if ($outflag eq 'bottom') { - $x = $bbox[0] + ($bbox[2]-$bbox[0])/2; - $x = $hw + 10 if $x < $hw + 10; - $x = $wwidth{$zinc} - $hw - 10 if $x > $wwidth{$zinc} - $hw - 10; - $y = $wheight{$zinc} - $hh - 10; - } elsif ($outflag eq 'top') { - $x = $bbox[0] + ($bbox[2]-$bbox[0])/2; - $x = $hw + 10 if $x < $hw + 10; - $x = $wwidth{$zinc} - $hw - 10if $x > $wwidth{$zinc} - $hw - 10; - $y = $hh + 10; - } elsif ($outflag eq 'left') { - $x = $hw + 10; - $y = $bbox[1] + ($bbox[3]-$bbox[1])/2; - $y = $hh + 10 if $y < $hh + 10; - $y = $wheight{$zinc} - $hh - 10 if $y > $wheight{$zinc} - $hh - 10; - } elsif ($outflag eq 'right') { - $x = $wwidth{$zinc} - $hw - 10; - $y = $bbox[1] + ($bbox[3]-$bbox[1])/2; - $y = $hh + 10 if $y < $hh + 10; - $y = $wheight{$zinc} - $hh - 10 if $y > $wheight{$zinc} - $hh - 10; - } elsif ($outflag eq 'left+top') { - $x = $hw + 10; - $y = $hh + 10; - } elsif ($outflag eq 'left+bottom') { - $x = $hw + 10; - $y = $wheight{$zinc} - $hh - 10; - } elsif ($outflag eq 'right+top') { - $x = $wwidth{$zinc} - $hw - 10; - $y = $hh + 10; - } elsif ($outflag eq 'right+bottom') { - $x = $wwidth{$zinc} - $hw - 10; - $y = $wheight{$zinc} - $hh - 10; - } - # apply the reverse transformation of topgroup to group $g - $zinc->tsave(1, 'transfo', 1); - $zinc->trestore($g, 'transfo'); - # then translate group $g1 - $zinc->coords($g1, [$x, $y]); - $zinc->raise('zincdebug'); - -} # end itemisoutside - - - -# highlight an item (by cloning it and hiding other found items) -# why cloning? because we can't simply make visible an item which -# belongs to an invisible group. -sub highlightitem { - - my ($btn, $zinc, $item, $level) = @_; - return if $showitemflag or $item == 1; - $showitemflag = 1; - &surrounditem($zinc, $item, $level); - - $btn->bind('<ButtonRelease>', [\&undohighlightitem, $zinc]) if $btn; - -} # end highlightitem - - -sub undohighlightitem { - - my ($btn, $zinc) = @_; - #print "undohighlightitem\n"; - $btn->bind('ReleaseButton', '') if $btn; - $zinc->remove('zincdebug'); - $showitemflag = 0; - -} # end undohighlightitem - - -sub surrounditem { - - my ($zinc, $item, $level) = @_; - $zinc->remove("zincdebug"); - # cloning - my $clone = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']); - $zinc->tsave(1, 'zoom+move', 1); - $zinc->chggroup($clone, 1, 1); - my @bbox = $zinc->bbox($clone); - # create a rectangle around - if (scalar @bbox == 4) { - # If item is visible, rectangle is drawm surround it. - # Else, a warning is displayed. - unless (&itemisoutside($zinc, @bbox)) { - if (defined($level) and $level > 0) { - my $r = $zinc->add('rectangle', 1, - [$bbox[0] - 10, $bbox[1] - 10, - $bbox[2] + 10, $bbox[3] + 10], - -linewidth => 0, - -filled => 1, - -tags => ['zincdebug', 'zincdebugdecorator'], - -fillcolor => "gray20"); - $zinc->itemconfigure($r, -fillcolor => "gray80") if $level == 1; - } - my $i = 0; - for ('white', 'red', 'white') { - $zinc->add('rectangle', 1, - [$bbox[0] - 5 - 2*$i, $bbox[1] - 5 - 2*$i, - $bbox[2] + 5 + 2*$i, $bbox[3] + 5 + 2*$i], - -linecolor => $_, - -linewidth => 1, - -tags => ['zincdebug', 'zincdebugdecorator']); - $i++; - } - } - } - # raise - $zinc->trestore('zincdebugdecorator', 'zoom+move'); - $zinc->raise('zincdebug'); - $zinc->raise($clone); - -} # end surrounditem - - -# functions related to transformation animations -sub showtransfo { - - my ($btn, $zinc, $item, $level) = @_; - my $anim = &highlighttransfo($zinc, $item, $level); - $btn->bind('<ButtonRelease>', [\&undohighlighttransfo, $zinc, $anim]) if $btn; - -} # end showtransfo - - -sub highlighttransfo { - - my ($zinc, $item, $level) = @_; - $zinc->remove("zincdebug"); - my $g = $zinc->add('group', 1); - my $g0 = $zinc->add('group', $g, -alpha => 0); - my $g1 = $zinc->add('group', $g); - # clone item and reset its transformation - my $clone0 = $zinc->clone($item, -visible => 1, -tags =>['zincdebug']); - $zinc->treset($clone0); - # clone item and preserve its transformation - my $clone1 = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']); - # move clones is dedicated group - $zinc->chggroup($clone0, $g0, 1); - $zinc->chggroup($clone1, $g1, 1); - # create a rectangle around - my @bbox0 = $zinc->bbox($g); - if (scalar @bbox0 == 4) { - $zinc->tsave(1, 'transfo', 1); - my @bbox = $zinc->transform(1, $g, [@bbox0]); - # If item is visible, rectangle is drawm surround it. - # Else, a warning is displayed. - unless (&itemisoutside($zinc, @bbox0)) { - my $r = $zinc->add('rectangle', $g, - [$bbox[0] - 10, $bbox[1] - 10, - $bbox[2] + 10, $bbox[3] + 10], - -filled => 1, - -linewidth => 0, - -tags => ['zincdebug'], - -fillcolor => "gray90"); - $zinc->itemconfigure($r, -fillcolor => "gray50") if $level == 1; - $zinc->itemconfigure($r, -fillcolor => "gray20") if $level == 2; - $zinc->trestore($r, 'transfo'); - } - } - # raise - $zinc->raise($g); - $zinc->raise($g0); - $zinc->raise($g1); - # animation - my $anim; - if ($zinc->cget(-render) == 0) { - $anim = $zinc->after(150, [sub { - $zinc->itemconfigure($g1, -visible => 0); - $zinc->itemconfigure($g0, -visible => 1); - $zinc->update; - }]); - } else { - my $maxsteps = 5; - $step = $maxsteps; - $anim = $zinc->repeat(100, [sub { - return if $step < 0; - $zinc->itemconfigure($g1, -alpha => ($step)*100/$maxsteps); - $zinc->itemconfigure($g0, -alpha => ($maxsteps-$step)*100/$maxsteps); - $zinc->update; - $step--; - }]); - - - } - return $anim; - -} # end highlighttransfo - - -sub undohighlighttransfo { - - my ($btn, $zinc, $anim) = @_; - $btn->bind('ReleaseButton', '') if $btn; - $zinc->remove('zincdebug'); - $zinc->afterCancel($anim); - -} # end undohighlighttransfo - - -#--------------------------------------------------------------------------- -# -# Snapshot functions -# -#--------------------------------------------------------------------------- - -# print a zinc window in png format -sub printWindow { - - exit if $saving; - $saving = 1; - my ($zinc) = @_; - my $basename = $cmdoptions{snapshotBasename}; - my $id = $zinc->id; - my $filename = $basename . $imagecounter . ".png"; - $imagecounter++; - my $original_cursor = ($zinc->configure(-cursor))[3]; - $zinc->configure(-cursor => 'watch'); - $zinc->update; - my $res = system("import", -window, $id, $filename); - $zinc->configure(-cursor => $original_cursor); - - $saving = 0; - if ($res) { - &showErrorWhilePrinting($zinc, $res) - } - else { - my $dir = `pwd`; chomp ($dir); - print "Tk::Zinc::Debug: Zinc window snapshot saved in $dir". "/$filename\n"; - } - -} # end printWindow - - -# display complete help screen -sub showErrorWhilePrinting { - - my ($zinc, $res) = @_; - my $dir = `pwd`; chomp ($dir); - $help_print->destroy if $help_print and Tk::Exists($help_print); - $help_print = $zinc->Dialog(-title => 'Zinc Print info', - -text => - "To acquire a TkZinc window snapshot, you must " . - "have access to the import command, which is ". - "part of imageMagic package\n\n". - "You must also have the rights to write ". - "in the current dir : $dir", - -bitmap => 'warning', - ); - $help_print->after(300, sub {$help_print->grabRelease}); - $help_print->Show(); - -} # end showErrorWhilePrinting - -#--------------------------------------------------------------------------- -# -# Help functions -# -#--------------------------------------------------------------------------- - -# display help about tree -sub showHelpAboutTree { - - my $zinc = shift; - $helptree_tl->destroy if $helptree_tl and Tk::Exists($helptree_tl); - $helptree_tl = $tree_tl->Toplevel; - $helptree_tl->title("Help about Tree"); - - my $text = $helptree_tl->Scrolled('Text', - -font => scalar $zinc->cget(-font), - -wrap => 'word', - -foreground => 'gray10', - -scrollbars => 'osoe', - ); - &wheelmousebindings($text); - $text->tagConfigure('keyword', -foreground => 'darkblue'); - $text->insert('end', "\nNAVIGATION IN TREE\n\n"); - $text->insert('end', "<Up>", "keyword"); - $text->insert('end', " arrow key moves the anchor point to the item right on ". - "top of the current anchor item. "); - $text->insert('end', "<Down>", "keyword"); - $text->insert('end', " arrow key moves the anchor point to the item right below ". - "the current anchor item. "); - $text->insert('end', "<Left>", "keyword"); - $text->insert('end', " arrow key moves the anchor to the parent item of the ". - "current anchor item. "); - $text->insert('end', "<Right>", "keyword"); - $text->insert('end', " moves the anchor to the first child of the current anchor ". - "item. If the current anchor item does not have any children, moves ". - "the anchor to the item right below the current anchor item.\n\n"); - $text->insert('end', "\nHIGHLIGHTING ITEMS\n\n"); - $text->insert('end', "To display item's features, "); - $text->insert('end', "double-click", "keyword"); - $text->insert('end', " on it, press "); - $text->insert('end', "<Return>", "keyword"); - $text->insert('end', " key or click on the "); - $text->insert('end', "Attributes", "keyword"); - $text->insert('end', " button.\n\n"); - $text->insert('end', "To highlight item in the application, simply "); - $text->insert('end', "click", "keyword"); - $text->insert('end', " on it."); - &infoAboutHighlighting($text); - $text->insert('end', "\n\n\nBUILDING CODE\n\n"); - $text->insert('end', "To build perl code, select a branch or a leaf ". - "and click on the "); - $text->insert('end', "Build code", "keyword"); - $text->insert('end', " button. Then select an output file with the ". - "file selector.\n\n"); - $text->configure(-state => 'disabled'); - - $helptree_tl->Button(-command => sub {$helptree_tl->destroy}, - -text => 'Close')->pack(-side => 'bottom', - -pady => 10); - $text->pack->pack(-side => 'top', -pady => 10, -padx => 10); - -} # end showHelpAboutTree - - -sub showHelpAboutCoords { - - my $zinc = shift; - $helpcoords_tl->destroy if $helpcoords_tl and Tk::Exists($helpcoords_tl); - $helpcoords_tl = $zinc->Toplevel; - $helpcoords_tl->title("Help about coordinates"); - - my $text = $helpcoords_tl->Scrolled('Text', - -font => scalar $zinc->cget(-font), - -wrap => 'word', - -height => 30, - -foreground => 'gray10', - -scrollbars => 'oe', - ); - &wheelmousebindings($text); - $text->tagConfigure('keyword', -foreground => 'darkblue'); - $text->tagConfigure('title', -foreground => 'ivory', - -background => 'gray60', - -spacing1 => 3, - -spacing3 => 3); - - - $text->insert('end', " To display a contour\n", 'title'); - $text->insert('end', "Press button labeled "); - $text->insert('end', 'Contour i', 'keyword'); - $text->insert('end', " (*). Release it to hide contour."); - $text->insert('end', "\n\n"); - $text->insert('end', " To display all the points of a contour\n", 'title'); - $text->insert('end', "Press button labeled "); - $text->insert('end', 'n points', 'keyword'); - $text->insert('end', " (*). Release it to hide points. First plot is ". - "particularized by a circle, last one by a double circle. ". - "Non-filled plots represent control points of a Bezier curve."); - $text->insert('end', "\n\n"); - $text->insert('end', " To navigate in the contour\n", 'title'); - $text->insert('end', "Select first a point by clicking in the coordinates table "); - $text->insert('end', "(*). Th corresponding plot is displayed. Then use the "); - $text->insert('end', "Up/Down", 'keyword'); - $text->insert('end', " (or "); - $text->insert('end', "Left/Right", 'keyword'); - $text->insert('end', ") arrows keys to navigate in the contour"); - $text->insert('end', "\n\n"); - $text->insert('end', "\n\n"); - $text->insert('end', "(*) The color of displayed elements depends on the mouse ". - "button you press."); - $text->insert('end', "\n\n"); - $text->configure(-state => 'disabled'); - - $helpcoords_tl->Button(-command => sub {$helpcoords_tl->destroy}, - -text => 'Close')->pack(-side => 'bottom', - -pady => 10); - $text->pack->pack(-side => 'top', -pady => 10, -padx => 10); - -} # end showHelpAboutCoords - - - -sub infoAboutHighlighting { - - my $text = shift; - $text->insert('end', "By default, using "); - $text->insert('end', "left mouse button", "keyword"); - $text->insert('end', ", highlighting is done by raising selected item and drawing ". - "a rectangle arround. "); - $text->insert('end', "In order to improve visibility, "); - $text->insert('end', "item will be light backgrounded if you use "); - $text->insert('end', "center mouse button", "keyword"); - $text->insert('end', " and dark backgrounded if you use "); - $text->insert('end', "right mouse button", "keyword"); - $text->insert('end', ". "); - -} # end infoAboutHighlighting - - -sub entryballoonhelp { - - my $e = shift; - my $msg = shift; - $msg .= "Editable field. To restore the inital value\n". - "after edition, enter <Control-z> sequence. "; - $balloonhelp->attach($e, -balloonposition => 'mouse', - -balloonmsg => $msg); - -} # end entryballoonhelp - - -sub balloonhelp { - - my $b = $control_tl->Balloon(-balloonposition => 'widget', - -font => '6x13'); - $b->attach($button{zn},-balloonmsg => - "Widget instance selector. Use it when \n". - "your application takes more than one \n". - "TkZinc instance. When this mode is on,\n". - "select the TkZinc instance you want \n". - "inspect just by clicking on it. "); - $b->attach($button{findenclosed}, -balloonmsg => - "Inspect all items *enclosed* in a \n". - "rectangular area. When this mode is\n". - "selected, draw rectangle using left\n". - "mouse button. "); - $b->attach($button{findoverlap}, -balloonmsg => - "Inspect all items which *overlap* \n". - "a rectangular area. When this mode\n". - "is selected, draw rectangle using \n". - "left mouse button. "); - $b->attach($button{tree}, -balloonmsg => - #"Display the items hierarchy. Can\n". - #"build perl code corresponding to\n". - #"a specific branch. "); - "Display the items hierarchy. Provide\n". - "some related functions, like building\n". - "perl code corresponding to a branch."); - $b->attach($button{item}, -balloonmsg => - "Locate an item in the items tree. \n". - "When this mode is on, select in \n". - "your application the item you want\n". - "to inspect just by clicking on it."); - $b->attach($button{id}, -balloonmsg => - "Open an entry field in which you will \n". - "enter an item's id you want to inspect."); - $b->attach($button{snapshot}, -balloonmsg => - "Snapshot the application window."); - $b->attach($button{cursorxy}, -balloonmsg => - "Display the device coordinates\n". - "of the X cursor. "); - $b->attach($button{zoomminus}, -balloonmsg => - "Shrink the top group."); - $b->attach($button{zoomplus}, -balloonmsg => - "Expand the top group."); - $b->attach($button{move}, -balloonmsg => - "Translate the top group. When this\n". - "mode is selected, move the top \n". - "group using left mouse button. "); - $b->attach($button{balloon},-balloonmsg => - "Balloon help toggle."); - $b->attach($button{close},-balloonmsg => - "Close this buttons bar."); - return $b; - -} # end balloonhelp - - - -#--------------------------------------------------------------------------- -# -# Bitmaps creation for the buttons of the control bar -# -#--------------------------------------------------------------------------- - -sub createBitmaps { - - my $zinc = shift; - my $bitmaps; - - $bitmaps->{close} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define close_width 29 -#define close_height 29 -static unsigned char close_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02, 0x08, 0x00, - 0x00, 0x07, 0x1c, 0x00, 0x00, 0x0e, 0x0e, 0x00, 0x00, 0x1c, 0x07, 0x00, - 0x00, 0xb8, 0x03, 0x00, 0x00, 0xf0, 0x01, 0x00, 0x00, 0xe0, 0x00, 0x00, - 0x00, 0xf0, 0x01, 0x00, 0x00, 0xb8, 0x03, 0x00, 0x00, 0x1c, 0x07, 0x00, - 0x00, 0x0e, 0x0e, 0x00, 0x00, 0x07, 0x1c, 0x00, 0x00, 0x02, 0x08, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - $bitmaps->{zn} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define focus_width 29 -#define focus_height 29 -static unsigned char focus_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0xe0, 0x3f, 0x00, 0x00, 0x60, 0x38, 0x00, 0x00, - 0x20, 0x18, 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00, 0x00, 0x8e, 0x33, 0x00, - 0x00, 0x06, 0x7b, 0x00, 0x00, 0x07, 0x67, 0x00, 0x80, 0x03, 0x63, 0x00, - 0xc0, 0x01, 0x63, 0x00, 0xc0, 0x00, 0x63, 0x00, 0xe0, 0x20, 0x63, 0x00, - 0x70, 0x30, 0x63, 0x00, 0xf0, 0xbf, 0xe7, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, }; -EOF - $bitmaps->{findenclosed} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define findenclosed_width 29 -#define findenclosed_height 29 -static unsigned char findenclosed_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x00, 0x00, - 0xfc, 0xff, 0xff, 0x03, 0xfc, 0xff, 0xff, 0x03, 0x3c, 0x00, 0x00, 0x03, - 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, - 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, - 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, - 0x18, 0x80, 0x00, 0x03, 0x18, 0x00, 0x01, 0x03, 0x18, 0x00, 0x22, 0x03, - 0x18, 0x00, 0x24, 0x03, 0x18, 0x00, 0x28, 0x03, 0x18, 0x00, 0x20, 0x03, - 0x18, 0x00, 0x3e, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, - 0xf8, 0xff, 0xff, 0x03, 0xf8, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - $bitmaps->{findoverlap} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define findoverlap_width 29 -#define findoverlap_height 29 -static unsigned char findoverlap_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x00, 0x00, - 0xfc, 0xb6, 0x6d, 0x03, 0xfc, 0xb6, 0x6d, 0x03, 0x3c, 0x00, 0x00, 0x00, - 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, - 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, - 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, - 0x18, 0x80, 0x00, 0x03, 0x18, 0x00, 0x01, 0x03, 0x00, 0x00, 0x22, 0x00, - 0x18, 0x00, 0x24, 0x03, 0x18, 0x00, 0x28, 0x03, 0x00, 0x00, 0x20, 0x00, - 0x18, 0x00, 0x3e, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, - 0xd8, 0xb6, 0x6d, 0x03, 0xd8, 0xb6, 0x6d, 0x03, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - $bitmaps->{tree} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define tree_width 29 -#define tree_height 29 -static unsigned char tree_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xf0, 0x07, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x04, 0x00, - 0xc0, 0x1f, 0x04, 0x00, 0x40, 0x10, 0x04, 0x00, 0x40, 0x10, 0x04, 0x00, - 0x40, 0xf0, 0x07, 0x00, 0x40, 0x00, 0x00, 0x00, 0x40, 0x00, 0xe0, 0x0f, - 0x40, 0x00, 0x20, 0x08, 0x7c, 0x00, 0x20, 0x08, 0x40, 0x00, 0x3f, 0x08, - 0x40, 0x00, 0x21, 0x08, 0x40, 0x00, 0x21, 0x08, 0x40, 0x00, 0xe1, 0x0f, - 0x40, 0x00, 0x01, 0x00, 0x40, 0x00, 0x01, 0x00, 0xc0, 0xff, 0x01, 0x00, - 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x01, 0x00, - 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x5f, 0x01, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - $bitmaps->{item} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define item_width 29 -#define item_height 29 -static unsigned char item_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x08, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0xf0, 0x00, 0x00, 0x00, - 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xc0, 0x1f, 0x00, 0x00, - 0xc0, 0x7f, 0x00, 0x00, 0x80, 0xff, 0x01, 0x00, 0x00, 0xff, 0x03, 0x00, - 0x00, 0xff, 0x00, 0x00, 0x00, 0x7e, 0x00, 0x00, 0x00, 0xfe, 0x00, 0x00, - 0x00, 0xdc, 0x01, 0x00, 0x00, 0x8c, 0x03, 0x00, 0x00, 0x08, 0x07, 0x00, - 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00, 0x00, 0x38, 0x00, - 0x00, 0x00, 0x70, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x00, 0x40, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - $bitmaps->{id} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define id_width 29 -#define id_height 29 -static unsigned char id_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x06, 0x0e, 0x00, 0x00, 0x06, 0x0c, 0x00, - 0x00, 0x00, 0x0c, 0x00, 0x00, 0x00, 0x0c, 0x00, 0x00, 0x87, 0x0f, 0x00, - 0x00, 0xc6, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00, - 0x00, 0x66, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00, - 0x00, 0xc6, 0x0c, 0x00, 0x00, 0x8f, 0x1f, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, }; -EOF - $bitmaps->{snapshot} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define snapshot_width 29 -#define snapshot_height 29 -static unsigned char snapshot_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x03, 0x1f, 0x00, - 0x80, 0x03, 0x11, 0x00, 0xe0, 0xff, 0xf1, 0x00, 0xf0, 0xff, 0xff, 0x01, - 0xf0, 0xff, 0xff, 0x01, 0xf0, 0xff, 0xff, 0x01, 0xf0, 0x0f, 0xfe, 0x01, - 0xf0, 0xe7, 0xfc, 0x01, 0xf0, 0x13, 0xf9, 0x01, 0xf0, 0x09, 0xf2, 0x01, - 0xf0, 0x05, 0xf4, 0x01, 0xf0, 0x05, 0xf4, 0x01, 0xf0, 0x05, 0xf4, 0x01, - 0xf0, 0x09, 0xf2, 0x01, 0xf0, 0x13, 0xf9, 0x01, 0xf0, 0xe7, 0xfc, 0x01, - 0xf0, 0x0f, 0xfe, 0x01, 0xf0, 0xff, 0xff, 0x01, 0xe0, 0xff, 0xff, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - $bitmaps->{zoomminus} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define zoomminus_width 29 -#define zoomminus_height 29 -static unsigned char zoomminus_bits[] = { - 0x00, 0x0e, 0x00, 0x00, 0xc0, 0x71, 0x00, 0x00, 0x30, 0x80, 0x01, 0x00, - 0x08, 0x00, 0x02, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, - 0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00, - 0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00, - 0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00, - 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x08, 0x00, 0x02, 0x00, - 0x30, 0x80, 0x05, 0x00, 0xc0, 0x71, 0x28, 0x00, 0x00, 0x0e, 0x70, 0x00, - 0x00, 0x00, 0xf8, 0x00, 0x00, 0x00, 0xf0, 0x01, 0x00, 0x00, 0xe0, 0x03, - 0x00, 0x00, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x00, 0x1f, - 0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x04}; -EOF - - $bitmaps->{zoomplus} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define zoomplus_width 29 -#define zoomplus_height 29 -static unsigned char zoomplus_bits[] = { - 0x00, 0x0e, 0x00, 0x00, 0xc0, 0x71, 0x00, 0x00, 0x30, 0x80, 0x01, 0x00, - 0x08, 0x00, 0x02, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x0e, 0x04, 0x00, - 0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00, - 0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00, - 0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00, - 0x04, 0x0e, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x08, 0x00, 0x02, 0x00, - 0x30, 0x80, 0x05, 0x00, 0xc0, 0x71, 0x28, 0x00, 0x00, 0x0e, 0x70, 0x00, - 0x00, 0x00, 0xf8, 0x00, 0x00, 0x00, 0xf0, 0x01, 0x00, 0x00, 0xe0, 0x03, - 0x00, 0x00, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x00, 0x1f, - 0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x04}; -EOF - - $bitmaps->{move} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define hand_width 29 -#define hand_height 29 -static unsigned char hand_bits[] = { - 0x00, 0xe0, 0x00, 0x00, 0x00, 0x10, 0x01, 0x00, 0x80, 0x13, 0x0f, 0x00, - 0x40, 0x12, 0x11, 0x00, 0x40, 0x14, 0x11, 0x00, 0x40, 0x14, 0xd1, 0x01, - 0x80, 0x14, 0x31, 0x02, 0x80, 0x14, 0x31, 0x02, 0x80, 0x18, 0x31, 0x02, - 0x80, 0x18, 0x31, 0x02, 0x00, 0x11, 0x31, 0x02, 0x00, 0x11, 0x11, 0x01, - 0x1c, 0x11, 0x11, 0x01, 0x22, 0x01, 0x11, 0x01, 0x42, 0x01, 0x10, 0x01, - 0x84, 0x01, 0x00, 0x01, 0x88, 0x01, 0x00, 0x01, 0x08, 0x01, 0x00, 0x02, - 0x08, 0x02, 0x00, 0x02, 0x10, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02, - 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, - 0x80, 0x00, 0x80, 0x00, 0x00, 0x01, 0x80, 0x00, 0x00, 0x06, 0x40, 0x00, - 0x00, 0x08, 0x40, 0x00, 0x00, 0x08, 0x40, 0x00}; -EOF - - $bitmaps->{balloon} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define balloon_width 29 -#define balloon_height 29 -static unsigned char balloon_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x00, - 0x10, 0x00, 0x00, 0x01, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, - 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, - 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, - 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, - 0x10, 0x00, 0x00, 0x01, 0xe0, 0xe0, 0xff, 0x00, 0x00, 0x11, 0x00, 0x00, - 0x00, 0x09, 0x00, 0x00, 0x80, 0x04, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, - 0x40, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; -EOF - - $bitmaps->{cursorxy} = $zinc->toplevel->Bitmap(-data => <<EOF); -#define balloon_width 29 -#define balloon_height 29 -static unsigned char balloon_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, - 0x00, 0x06, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0x7c, 0x00, 0x00, - 0x00, 0x1c, 0x00, 0x00, 0x00, 0x28, 0x00, 0x00, 0x00, 0x48, 0x00, 0x00, - 0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x02, 0x00, - 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x30, 0x06, 0x8c, 0x01, 0x70, 0x07, 0x8c, 0x01, 0x60, 0x03, 0x8c, 0x01, - 0xc0, 0x01, 0xd8, 0x00, 0xc0, 0x01, 0xd8, 0x00, 0x60, 0xe3, 0xd8, 0x00, - 0x70, 0x66, 0x70, 0x00, 0x30, 0x66, 0x70, 0x00, 0x00, 0x30, 0x60, 0x00, - 0x00, 0x30, 0x30, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, }; -EOF - - return $bitmaps; - -} # end createBitmaps - - -#--------------------------------------------------------------------------- -# -# Miscellaneous -# -#--------------------------------------------------------------------------- - -sub getsize { - - my $zinc = shift; - $wwidth{$zinc} = $zinc->cget(-width); - $wheight{$zinc} = $zinc->cget(-height); - -} # end getsize - - -sub entryoption { - - my ($fm, $item, $zinc, $option, $def, $widthmax, $widthmin, $height) = @_; - my $arrayflag; - unless (defined $def) { - my @def = $zinc->itemcget($item, $option); - if (@def > 1) { - $arrayflag = 1; - $def = join(', ', @def); - } else { - $def = $def[0]; - } - } - $def = "" unless defined $def; - my $i0; - my $e; - if ($def =~ /\n/) { - $height = 1 unless defined($height); - $e = $fm->Text(-height => $height, -width => 1, -wrap => 'none'); - $i0 = '0.0'; - } else { - $e = $fm->Entry(); - $i0 = 0; - } - &entryballoonhelp($e); - my $width = length($def); - $width = $widthmax if defined($widthmax) and $width > $widthmax; - $width = $widthmin if defined($widthmin) and $width < $widthmin; - $e->configure(-width => $width); - if ($defaultoptions{$item}->{$option} and - $def ne $defaultoptions{$item}->{$option}) { - $e->configure(-foreground => 'blue'); - } - - $e->insert($i0, $def); - $e->bind('<Control-z>', sub { - return unless defined $defaultoptions{$item}->{$option}; - my $bg = $e->cget(-background); - $zinc->itemconfigure($item, $option => $defaultoptions{$item}->{$option}); - $e->delete($i0, 'end'); - $e->insert($i0, $defaultoptions{$item}->{$option}); - $e->configure(-background => 'ivory'); - $e->after(80, sub {$e->configure(-background => $bg, -foreground => 'black')}); - }); - $e->bind('<Key-Return>', - sub {my $val = $e->get; - my $bg = $e->cget(-background); - $e->configure(-background => 'ivory'); - if ($def ne $val) { - $defaultoptions{$item}->{$option} = $def - unless $defaultoptions{$item}->{$option}; - } - my $fg = ($val ne $defaultoptions{$item}->{$option}) ? - 'blue' : 'black'; - $e->after(80, sub { - $e->configure(-background => $bg, -foreground => $fg); - }); - if ($arrayflag) { - $zinc->itemconfigure($item, $option => [split(/,/, $val)]); - } else { - $zinc->itemconfigure($item, $option => $val); - } - }); - - return $e; - -} # end entryoption - - -sub entrytransfo { - - my ($fm, $item, $zinc, $attr, $def, $var, $width, $set_cb) = @_; - my $i0; - my $e; - $e = $fm->Entry(-textvariable => $var); - &entryballoonhelp($e); - $i0 = 0; - my $width = length($def); - $e->configure(-width => $width); - $e->insert($i0, $def); - $e->bind('<Control-z>', sub { - my $bg = $e->cget(-background); - $e->delete($i0, 'end'); - $e->insert($i0, $def); - $e->configure(-background => 'ivory'); - $e->after(80, sub {$e->configure(-background => $bg, -foreground => 'black')}); - &$set_cb; - }); - $e->bind('<Key-Return>', - sub {my $val = $e->get; - my $bg = $e->cget(-background); - $e->configure(-background => 'ivory'); - my $fg = ($val ne $def) ? 'blue' : 'black'; - $e->after(80, sub { - $e->configure(-background => $bg, -foreground => $fg); - }); - &$set_cb; - }); - - return $e; - -} # end entrytransfo - - -sub instances { - - return @instances; - -} # end instances - - -sub saveMotionBinding { - - my ($zinc) = @_; - for my $seq ('Motion') { - $userbindings{$zinc}->{$seq} = $zinc->Tk::bind('<'.$seq.'>') - unless defined $userbindings{$zinc}->{$seq}; - $userbindings{$zinc}->{$seq} = "" unless defined $userbindings{$zinc}->{$seq}; - $zinc->Tk::bind('<'.$seq.'>', ""); - } - -} # end saveMotionBinding - - -sub restoreMotionBinding { - - my ($zinc) = @_; - for my $seq ('Motion') { - next unless defined $userbindings{$zinc}->{$seq}; - $zinc->Tk::bind('<'.$seq.'>', $userbindings{$zinc}->{$seq}); - delete $userbindings{$zinc}->{$seq}; - } - -} # end restoreMotionBinding - - -sub saveDragAndDropBindings { - - my ($zinc) = @_; - for my $seq ('ButtonPress-1', 'B1-Motion', 'ButtonRelease-1') { - $userbindings{$zinc}->{$seq} = $zinc->Tk::bind('<'.$seq.'>') - unless defined $userbindings{$zinc}->{$seq}; - $userbindings{$zinc}->{$seq} = "" unless defined $userbindings{$zinc}->{$seq}; - #print "saveDragAndDropBindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n"; - $zinc->Tk::bind('<'.$seq.'>', ""); - } - -} # end saveDragAndDropBindings - - -sub restoreDragAndDropBindings { - - my ($zinc) = @_; - for my $seq ('ButtonPress-1', 'B1-Motion', 'ButtonRelease-1') { - next unless defined $userbindings{$zinc}->{$seq}; - $zinc->Tk::bind('<'.$seq.'>', $userbindings{$zinc}->{$seq}); - #print "restoreDragAndDropBindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n"; - delete $userbindings{$zinc}->{$seq}; - } - -} # end restoreDragAndDropBindings - - -sub newinstance { - - my $zinc = shift; - return if $instances{$zinc}; - $zinc->toplevel->Tk::bind('<Key-Escape>', \&Tk::Zinc::Debug::deiconify); - $instances{$zinc} = 1; - push(@instances, $zinc); - $zinc->Tk::focus; - $selectedzinc = $zinc; - -} # end newinstance - - -sub deiconify { - - $button{zn}->destroy() if @instances == 1 and Tk::Exists($button{zn}); - $control_tl->deiconify(); - for (values %result_tl) { - $_->deiconify if Tk::Exists($_); - } - for (values %coords_tl) { - $_->deiconify if Tk::Exists($_); - } - for (values %alloptions_tl) { - $_->deiconify if Tk::Exists($_); - } - $tree_tl->deiconify if Tk::Exists($tree_tl); - $search_tl->deiconify if Tk::Exists($search_tl); - $searchtree_tl->deiconify if Tk::Exists($searchtree_tl); - $cursorxy_tl->deiconify if Tk::Exists($cursorxy_tl); - $control_tl->raise(); - -} # end deiconify - - -sub iconify { - - for (values %result_tl) { - $_->withdraw if Tk::Exists($_); - } - for (values %coords_tl) { - $_->withdraw if Tk::Exists($_); - } - for (values %alloptions_tl) { - $_->withdraw if Tk::Exists($_); - } - $tree_tl->withdraw if Tk::Exists($tree_tl); - $search_tl->withdraw if Tk::Exists($search_tl); - $searchtree_tl->withdraw if Tk::Exists($searchtree_tl); - $cursorxy_tl->withdraw if Tk::Exists($cursorxy_tl); - $control_tl->withdraw(); - -} # end iconify - -# wheelmousebindings doesn't work for Tk::Pane widgets... -sub wheelmousebindings { - my $w = shift; - my $count = shift; - $count = 3 unless $count > 0; - - $w->bind('<Control-ButtonPress-4>', sub {$w->yview('scroll', -1, 'page')}); - $w->bind('<Shift-ButtonPress-4>', sub {$w->yview('scroll', -1, 'unit')}); - $w->bind('<ButtonPress-4>', sub {$w->yview('scroll', -$count, 'unit')}); - - $w->bind('<Control-ButtonPress-5>', sub {$w->yview('scroll', 1, 'page')}); - $w->bind('<Shift-ButtonPress-5>', sub {$w->yview('scroll', 1, 'unit')}); - $w->bind('<ButtonPress-5>', sub {$w->yview('scroll', $count, 'unit')}); - -} # end wheelmousebindings - -1; - -__END__ - - -=head1 NAME - -Tk::Zinc::Debug - a perl module for analysing a Zinc application. - - -=head1 SYNOPSIS - - perl -MTk::Zinc::Debug zincscript [zincscript-opts] [Debug-initopts] - - or - - use Tk::Zinc::Debug; - my $zinc = MainWindow->new()->Zinc()->pack; - Tk::Zinc::Debug::init($zinc, [options]); - - -=head1 DESCRIPTION - -Tk::Zinc::Debug provides an interface to help developers to inspect Zinc applications. - -Press the B<Escape> key in the toplevel of your application to display the Tk::Zinc::Debug buttons bar. - - -Features : - -=over - -=item B<o> scan a rectangular area - -Scan all items which are enclosed in a rectangular area you have first drawn by drag & drop, or all items which overlap it. Result is a Tk table which presents details (options, coordinates, ...) about found items; you can also highlight a particular item, even if it's not visible, by clicking on its corresponding button in the table. You can also display particular item's features by entering this id in dedicated entry field - -=item B<o> display items hierarchy - -You can find a particular item's position in the tree and you can highlight items and see their features as described above. You can also generate the perl code corresponding to a selected branch (but images can't be reproduced). - -=item B<o> snapshot the application window - -In order to illustrate a graphical bug for example. - -=item B<o> display coordinates of the X cursor. - -=item B<o> zoom/translate the top group - -=back - - -=head2 Loading Tk::Zinc::Debug as a plugin - -If you load Tk::Zinc::Debug using the -M perl option, B<nothing needs to be added to your code>. In this case, the B<init()> function is automatically invoked with its default attributes for each instance of Zinc widget. You can overload these by passing the same options to the command. - -=head1 FUNCTION - - -=over - -=item B<init>($zinc, ?option => value, ...?) - -This function creates required Tk bindings to permit items search. You can specify the following options : - -=over - -=item E<32>E<32>E<32>B<-optionsToDisplay> => opt1[,..,optN] - -Used to display some option's values associated to items of the tree. Expected argument is a string of commas separated options. - -=item E<32>E<32>E<32>B<-optionsFormat> => row | column - -Defines the display format of option's values. Default is 'row'. - -=item E<32>E<32>E<32>B<-snapshotBasename> => string - -Defines the basename used for the file containing the snaphshot. The filename will be <currentdir>/basename<n>.png Defaulted to 'zincsnapshot'. - -=item E<32>E<32>E<32>B<-expandTagsField> => 0 | 1 - -Specifies if the tags field in the attributes window will be expanded to show all the items tags (it should take up a lot of space). In the default case (value is set to 0), only the head of the list is displayed. - - -=back - - -=back - - -=head1 AUTHOR - -Daniel Etienne <etienne@cena.fr> - - -=head1 HISTORY - -Oct 5 2004 : transformations are correctly managed in built code. Transfo parameters can be displayed and set. new mode to display coordinateds of X cursor. - -Oct 14 2003 : add a control bar, and zoom/translate new functionalities. finditems(), tree(), snapshot() functions become deprecated, initialisation is done using the new init() function. - -Oct 07 2003 : contours of curves can be displayed and explored. - -Sep 15 2003 : due to CPAN-isation, the ZincDebug module has been renamed Tk::Zinc::Debug - -May 20 2003 : perl code can be generated from the items tree, with some limitations concerning transformations and images. - -Mar 11 2003 : ZincDebug can manage several instances of Zinc widget. Options of ZincDebug functions can be set on the command line. - -Jan 20 2003 : item's attributes can be edited. - -Jan 14 2003 : ZincDebug can be loaded at runtime using the -M perl option without any change in the application's code. - -Nov 6 2002 : some additional informations (like tags or other attributes values) can be displayed in the items tree. Add feedback when selected item is not visible because outside window. - -Sep 2 2002 : add the tree() function - -May 27 2002 : add the snapshot() function contributed by Ch. Mertz. - -Jan 28 2002 : Zincdebug provides the finditems() function and can manage only one instance of Zinc widget. diff --git a/Perl/Zinc/Graphics.pm b/Perl/Zinc/Graphics.pm deleted file mode 100644 index 8305c81..0000000 --- a/Perl/Zinc/Graphics.pm +++ /dev/null @@ -1,3067 +0,0 @@ -#----------------------------------------------------------------------------------- -# -# Graphics.pm -# some graphic design functions -# -#----------------------------------------------------------------------------------- -# Functions to create complexe graphic component : -# ------------------------------------------------ -# buildZincItem (realize a zinc item from description hash table -# management of enhanced graphics functions) -# -# repeatZincItem (duplication of given zinc item) -# -# Function to compute complexe geometrical forms : -# (text header of functions explain options for each form, -# function return curve coords using control points of cubic curve) -# ----------------------------------------------------------------- -# roundedRectangleCoords (return curve coords of rounded rectangle) -# hippodromeCoords (return curve coords of circus form) -# ellipseCoords (return curve coords of ellipse form) -# polygonCoords (return curve coords of regular polygon) -# roundedCurveCoords (return curve coords of rounded curve) -# polylineCoords (return curve coords of polyline) -# shiftPathCoords (return curve coords of shifting path) -# tabBoxCoords (return curve coords of tabBox's pages) -# pathLineCoords (return triangles coords of pathline) -# -# Function to compute 2D 1/2 relief and shadow : -# function build zinc items (triangles and curve) to simulate this -# ----------------------------------------------------------------- -# graphicItemRelief (return triangle items simulate relief of given item) -# polylineReliefParams (return triangle coords and lighting triangles color list) -# graphicItemShadow (return triangles and curve items simulate shadow of given item)) -# polylineShadowParams (return triangle and curve coords and shadow triangles color list)) -# -# Geometrical basic Functions : -# ----------------------------- -# perpendicularPoint -# lineAngle -# lineNormal -# vertexAngle -# arc_pts -# rad_point -# bezierCompute -# bezierSegment -# bezierPoint -# -# Pictorial Functions : -# ---------------------- -# setGradients -# getPattern -# getTexture -# getImage -# init_pixmaps -# zincItemPredominantColor -# ZnColorToRGB -# hexaRGBcolor -# createGraduate -# pathGraduate -# MedianColor -# LightingColor -# RGBtoLCH -# LCHtoRGB -# RGBtoHLS -# HLStoRGB -# -#----------------------------------------------------------------------------------- -# Authors: Jean-Luc Vinot <vinot@cena.fr> -# -# $Id$ -#----------------------------------------------------------------------------------- -package Tk::Zinc::Graphics; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(&buildZincItem &repeatZincItem &buidTabBoxItem - - &roundedRectangleCoords &hippodromeCoords &polygonCoords &ellipseCoords - &roundedCurveCoords &polylineCoords &tabBoxCoords &pathLineCoords &shiftPathCoords - - &perpendicularPoint &lineAngle &vertexAngle &rad_point &arc_pts &lineNormal - &curve2polylineCoords &curveItem2polylineCoords &bezierSegment &bezierCompute - - &graphicItemRelief &graphicItemShadow - - &setGradients &getPattern &getTexture &getImage &init_pixmaps - - &hexaRGBcolor &createGraduate &lightingColor &zincItemPredominantColor - &MedianColor &RGBtoLCH &LCHtoRGB &RGBtoHLS &HLStoRGB - ); - -use strict; -use Carp; -use Tk; -use Tk::PNG; -use Tk::JPEG; -use Math::Trig; - -# constante facteur point directeur (conique -> quadratique) -my $const_ptd_factor = .5523; - -# constante white point (conversion couleur espace CIE XYZ) -my ($Xw, $Yw, $Zw) = (95.047, 100.0, 108.883); - -# limite globale d'approximation courbe bezier -my $bezierClosenessThreshold = .2; - -# initialisation et partage de ressources couleurs et images -my @Gradients; -my %textures; -my %images; -my %bitmaps; - - - -#----------------------------------------------------------------------------------- -# Graphics::buildZincItem -# Création d'un objet Zinc de représentation -#----------------------------------------------------------------------------------- -# types d'items valides : -# les items natifs zinc : group, rectangle, arc, curve, text, icon -# les items ci-après permettent de spécifier des curves 'particulières' : -# -roundedrectangle : rectangle à coin arrondi -# -hippodrome : hippodrome -# -ellipse : ellipse un centre 2 rayons -# -polygone : polygone régulier à n cotés (convexe ou en étoile) -# -roundedcurve : curve multicontours à coins arrondis (rayon unique) -# -polyline : curve multicontours à coins arrondis (le rayon pouvant être défini -# spécifiquement pour chaque sommet) -# -pathline : création d'une ligne 'épaisse' avec l'item Zinc triangles -# décalage par rapport à un chemin donné (largeur et sens de décalage) -# dégradé de couleurs de la ligne (linéaire, transversal ou double) -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget Zinc -# parentgroup : <tagOrId> identifiant du group parent -# -# options : -# -itemtype : type de l'item à construire (type zinc ou metatype) -# -coords : <coords|coordsList> coordonnées de l'item -# -metacoords : <hastable> calcul de coordonnées par type d'item différent de -itemtype -# -contours : <contourList> paramètres multi-contours -# -params : <hastable> arguments spécifiques de l'item à passer au widget -# -addtags : [list of specific tags] to add to params -tags -# -texture : <imagefile> ajout d'une texture à l'item -# -pattern : <imagefile> ajout d'un pattern à l'item -# -relief : <hastable> création d'un relief à l'item invoque la fonction &graphicItemRelief() -# -shadow : <hastable> création d'une ombre portée à l'item invoque la fonction &graphicItemShadow() -# -scale : <scale_factor|[xscale_factor,yscale_factor]> application d'une transformation zinc->scale à l'item -# -translate : <[dx,dy]> application d'un transformation zinc->translate à l'item. -# -rotate : <angle> application d'une transformation zinc->rotate (en degré) à l'item -# -name : <str> nom de l'item -# spécifiques item group : -# -clip : <coordList|hashtable> paramètres de clipping d'un item group (coords ou item) -# -items : <hashtable> appel récursif de la fonction permettant d'inclure des items au groupe -#----------------------------------------------------------------------------------- -# -#----------------------------------------------------------------------------------- -sub buildZincItem { - my ($widget, $parentgroup, %options) = @_; - $parentgroup = 1 if !$parentgroup; - - my $itemtype = $options{'-itemtype'}; - my $coords = $options{'-coords'}; - my $params = $options{'-params'}; - - return unless ($widget and $itemtype and ($coords or $options{'-metacoords'})); - - my $name = ($options{'-name'}) ? $options{'-name'} : 'none'; - - my $item; - my $metatype; - my (@items, @reliefs, @shadows); - my @tags; - - - #-------------------- - # GEOMETRIE DES ITEMS - - # gestion des types d'items particuliers et à raccords circulaires - if ($itemtype eq 'roundedrectangle' - or $itemtype eq 'hippodrome' - or $itemtype eq 'polygone' - or $itemtype eq 'ellipse' - or $itemtype eq 'roundedcurve' - or $itemtype eq 'polyline' - or $itemtype eq 'curveline') { - - # par défaut la curve sera fermée -closed = 1 - $params->{'-closed'} = 1 if (!defined $params->{'-closed'}); - $metatype = $itemtype; - $itemtype = 'curve'; - - # possibilité de définir les coordonnées initiales par metatype - if ($options{'-metacoords'}) { - $options{'-coords'} = &metaCoords(%{$options{'-metacoords'}}); - - } - - # création d'une pathline à partir d'item zinc triangles - } elsif ($itemtype eq 'pathline') { - - $itemtype = 'triangles'; - if ($options{'-metacoords'}) { - $coords = &metaCoords(%{$options{'-metacoords'}}); - - } - - if ($options{'-graduate'}) { - my $numcolors = scalar(@{$coords}); - $params->{'-colors'} = &pathGraduate($widget, $numcolors, $options{'-graduate'}); - } - - $coords = &pathLineCoords($coords, %options); - - - # création d'une boite à onglet - } elsif ($itemtype eq 'tabbox') { - return &buildTabBoxItem($widget, $parentgroup, %options); - - } - - # calcul des coordonnées finales de la curve - $coords = &metaCoords(-type => $metatype, %options) if ($metatype); - - - # gestion du multi-contours (accessible pour tous les types d'items géometriques) - if ($options{'-contours'} and $metatype) { - my @contours = @{$options{'-contours'}}; - my $numcontours = scalar(@contours); - for (my $i = 0; $i < $numcontours; $i++) { - # radius et corners peuvent être défini spécifiquement pour chaque contour - my ($type, $way, $addcoords, $radius, $corners, $corners_radius) = @{$contours[$i]}; - $radius = $options{'-radius'} if (!defined $radius); - - my $newcoords = &metaCoords(-type => $metatype, - -coords => $addcoords, - -radius => $radius, - -corners => $corners, - -corners_radius => $corners_radius - ); - - $options{'-contours'}->[$i] = [$type, $way, $newcoords]; - } - } - - - #---------------------- - # REALISATION DES ITEMS - - # ITEM GROUP - # gestion des coordonnées et du clipping - if ($itemtype eq 'group') { - $item = $widget->add($itemtype, - $parentgroup, - %{$params}); - - $widget->coords($item, $coords) if $coords; - - # clipping du groupe par item ou par géometrie - if ($options{'-clip'}) { - my $clipbuilder = $options{'-clip'}; - my $clip; - - # création d'un item de clipping - if ($clipbuilder->{'-itemtype'}) { - $clip = &buildZincItem($widget, $item, %{$clipbuilder}); - - } elsif (ref($clipbuilder) eq 'ARRAY' or $widget->type($clipbuilder)) { - $clip = $clipbuilder; - } - - $widget->itemconfigure($item, -clip => $clip) if ($clip); - } - - # créations si besoin des items contenus dans le groupe - if ($options{'-items'} and ref($options{'-items'}) eq 'HASH') { - while (my ($itemname, $itemstyle) = each(%{$options{'-items'}})) { - $itemstyle->{'-name'} = $itemname if (!$itemstyle->{'-name'}); - &buildZincItem($widget, $item, %{$itemstyle}); - } - } - - - # ITEM TEXT ou ICON - } elsif ($itemtype eq 'text' or $itemtype eq 'icon') { - my $imagefile; - if ($itemtype eq 'icon') { - $imagefile = $params->{'-image'}; - my $image = &getImage($widget, $imagefile); - $params->{'-image'} = ($image) ? $image : ""; - } - - $item = $widget->add($itemtype, - $parentgroup, - -position => $coords, - %{$params}, - ); - - $params->{'-image'} = $imagefile if $imagefile; - - - # ITEMS GEOMETRIQUES -> CURVE - } else { - - $item = $widget->add($itemtype, - $parentgroup, - $coords, - %{$params}, - ); - - if ($itemtype eq 'curve' and $options{'-contours'}) { - foreach my $contour (@{$options{'-contours'}}) { - $widget->contour($item, @{$contour}); - } - } - - # gestion du mode norender - if ($options{'-texture'}) { - my $texture = &getTexture($widget, $options{'-texture'}); - $widget->itemconfigure($item, -tile => $texture) if $texture; - } - - if ($options{'-pattern'}) { - my $bitmap = &getBitmap($options{'-pattern'}); - $widget->itemconfigure($item, -fillpattern => $bitmap) if $bitmap; - } - - } - - - # gestion des tags spécifiques - if ($options{'-addtags'}) { - my @tags = @{$options{'-addtags'}}; - - my $params_tags = $params->{'-tags'}; - push (@tags, @{$params_tags}) if $params_tags; - - $widget->itemconfigure($item, -tags => \@tags); - - } - - - #------------------------------- - # TRANSFORMATIONS ZINC DE L'ITEM - - # transformation scale de l'item si nécessaire - if ($options{'-scale'}) { - my $scale = $options{'-scale'}; - $scale = [$scale, $scale] if (ref($scale) ne 'ARRAY'); - $widget->scale($item, @{$scale}) ; - } - - # transformation rotate de l'item si nécessaire - $widget->rotate($item, deg2rad($options{'-rotate'})) if ($options{'-rotate'}); - - # transformation translate de l'item si nécessaire - $widget->translate($item, @{$options{'-translate'}}) if ($options{'-translate'}); - - - # répétition de l'item - if ($options{'-repeat'}) { - push (@items, $item, - &repeatZincItem($widget, $item, %{$options{'-repeat'}})); - } - - - #----------------------- - # RELIEF ET OMBRE PORTEE - - # gestion du relief - if ($options{'-relief'}) { - my $target = (@items) ? \@items : $item; - push (@reliefs, &graphicItemRelief($widget, $target, %{$options{'-relief'}})); - } - - # gestion de l'ombre portée - if ($options{'-shadow'}) { - my $target = (@items) ? \@items : $item; - push (@shadows, &graphicItemShadow($widget, $target, %{$options{'-shadow'}})); - } - - push(@items, @reliefs) if @reliefs; - push(@items, @shadows) if @shadows; - - return (@items) ? @items : $item; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::repeatZincItem -# Duplication (clonage) d'un objet Zinc de représentation -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item source -# options : -# -num : <n> nombre d'item total (par defaut 2) -# -dxy : <[dx, dy]> translation entre 2 duplications (par defaut [0,0]) -# -angle : <angle> rotation entre 2 duplications -# -copytag : <sting> ajout d'un tag indexé pour chaque copie -# -params : <hashtable> {clef => [value list]}> valeur de paramètre de chaque copie -#----------------------------------------------------------------------------------- -sub repeatZincItem { - my ($widget, $item, %options) = @_; - my @clones; - - # duplication d'une liste d'items -> appel récursif - if (ref($item) eq 'ARRAY') { - foreach my $part (@{$item}) { - push (@clones, &repeatZincItem($widget, $part, %options)); - } - - return wantarray ? @clones : \@clones; - } - - my $num = ($options{'-num'}) ? $options{'-num'} : 2; - my ($dx, $dy) = (defined $options{'-dxy'}) ? @{$options{'-dxy'}} : (0, 0); - my $angle = $options{'-angle'}; - my $params = $options{'-params'}; - my $copytag = $options{'-copytag'}; - my @tags; - - if ($copytag) { - @tags = $widget->itemcget($item, -tags); - unshift (@tags, $copytag."0"); - $widget->itemconfigure($item, -tags => \@tags); - } - - for (my $i = 1; $i < $num; $i++) { - my $clone; - - if ($copytag) { - $tags[0] = $copytag.$i; - $clone = $widget->clone($item, -tags => \@tags); - - } else { - $clone = $widget->clone($item); - } - - push(@clones, $clone); - $widget->translate($clone, $dx*$i, $dy*$i); - $widget->rotate($clone, deg2rad($angle*$i)) if $angle; - - if ($params) { - while (my ($attrib, $value) = each(%{$params})) { - $widget->itemconfigure($clone, $attrib => $value->[$i]); - } - } - } - - return wantarray ? @clones : \@clones; - -} - - -#----------------------------------------------------------------------------------- -# FONCTIONS GEOMETRIQUES -#----------------------------------------------------------------------------------- - -#----------------------------------------------------------------------------------- -# Graphics::metaCoords -# retourne une liste de coordonnées en utilisant la fonction du type d'item spécifié -#----------------------------------------------------------------------------------- -# paramètres : (passés par %options) -# -type : <string> type de primitive utilisée -# -coords : <coordsList> coordonnées nécessitée par la fonction [type]Coords -# -# les autres options spécialisées au type seront passés à la fonction [type]coords -#----------------------------------------------------------------------------------- -sub metaCoords { - my (%options) = @_; - my $pts; - - my $type = delete $options{'-type'}; - my $coords = delete $options{'-coords'}; - - if ($type eq 'roundedrectangle') { - $pts = &roundedRectangleCoords($coords, %options); - - } elsif ($type eq 'hippodrome') { - $pts = &hippodromeCoords($coords, %options); - - } elsif ($type eq 'ellipse') { - $pts = &ellipseCoords($coords, %options); - - } elsif ($type eq 'roundedcurve') { - $pts = &roundedCurveCoords($coords, %options); - - } elsif ($type eq 'polygone') { - $pts = &polygonCoords($coords, %options); - - } elsif ($type eq 'polyline') { - $pts = &polylineCoords($coords, %options); - - } elsif ($type eq 'curveline') { - $pts = &curveLineCoords($coords, %options); - } - - return $pts; -} - - -#----------------------------------------------------------------------------------- -# Graphics::ZincItem2CurveCoords -# retourne une liste des coordonnées 'Curve' d'un l'item Zinc -# rectangle, arc ou curve -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item source -# options : -# -linear : <boolean> réduction à des segments non curviligne (par défaut 0) -# -realcoords : <boolean> coordonnées à transformer dans le groupe père (par défaut 0) -# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1) -#----------------------------------------------------------------------------------- -sub ZincItem2CurveCoords { - my ($widget, $item, %options) = @_; - - my $itemtype = $widget->type($item); - return unless ($itemtype); - - my $linear = $options{-linear}; - my $realcoords = $options{-realcoords}; - my $adjust = (defined $options{-adjust}) ? $options{-adjust} : 1; - - my @itemcoords = $widget->coords($item); - - my $coords; - my @multi; - - if ($itemtype eq 'rectangle') { - $coords = &roundedRectangleCoords(\@itemcoords, -radius => 0); - - } elsif ($itemtype eq 'arc') { - $coords = &ellipseCoords(\@itemcoords); - $coords = &curve2polylineCoords($coords, $adjust) if $linear; - - } elsif ($itemtype eq 'curve') { - my $numcontours = $widget->contour($item); - - if ($numcontours < 2) { - $coords = \@itemcoords; - $coords = &curve2polylineCoords($coords, $adjust) if $linear; - - - } else { - if ($linear) { - @multi = &curveItem2polylineCoords($widget, $item); - - } else { - for (my $contour = 0; $contour < $numcontours; $contour++) { - my @points = $widget->coords($item, $contour); - push (@multi, \@points); - } - } - - $coords = \@multi; - } - } - - if ($realcoords) { - my $parentgroup = $widget->group($item); - if (@multi) { - my @newcoords; - foreach my $points (@multi) { - my @transcoords = $widget->transform($item, $parentgroup, $points); - push(@newcoords, \@transcoords); - } - - $coords = \@newcoords; - - } else { - my @transcoords = $widget->transform($item, $parentgroup, $coords); - $coords = \@transcoords; - } - - } - - if (@multi) { - return (wantarray) ? @{$coords} : $coords; - } else { - return (wantarray) ? ($coords) : $coords; - } -} - -#----------------------------------------------------------------------------------- -# Graphics::roundedRectangleCoords -# calcul des coords du rectangle à coins arrondis -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> coordonnées bbox (haut-gauche et bas-droite) du rectangle -# options : -# -radius : <dimension> rayon de raccord d'angle -# -corners : <booleanList> liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1] -#----------------------------------------------------------------------------------- -sub roundedRectangleCoords { - my ($coords, %options) = @_; - my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], - $coords->[1]->[0], $coords->[1]->[1]); - - my $radius = $options{'-radius'}; - my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1]; - - # attention aux formes 'négatives' - if ($xn < $x0) { - my $xs = $x0; - ($x0, $xn) = ($xn, $xs); - } - if ($yn < $y0) { - my $ys = $y0; - ($y0, $yn) = ($yn, $ys); - } - - my $height = &_min($xn -$x0, $yn - $y0); - - if (!defined $radius) { - $radius = int($height/10); - $radius = 3 if $radius < 3; - } - - if (!$radius or $radius < 2) { - return [[$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]]; - - } - - - # correction de radius si necessaire - my $max_rad = $height; - $max_rad /= 2 if (!defined $corners); - $radius = $max_rad if $radius > $max_rad; - - # points remarquables - my $ptd_delta = $radius * $const_ptd_factor; - my ($x2, $x3) = ($x0 + $radius, $xn - $radius); - my ($x1, $x4) = ($x2 - $ptd_delta, $x3 + $ptd_delta); - my ($y2, $y3) = ($y0 + $radius, $yn - $radius); - my ($y1, $y4) = ($y2 - $ptd_delta, $y3 + $ptd_delta); - - # liste des 4 points sommet du rectangle : angles sans raccord circulaire - my @angle_pts = ([$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]); - - # liste des 4 segments quadratique : raccord d'angle = radius - my @roundeds = ([[$x2, $y0],[$x1, $y0, 'c'],[$x0, $y1, 'c'],[$x0, $y2],], - [[$x0, $y3],[$x0, $y4, 'c'],[$x1, $yn, 'c'],[$x2, $yn],], - [[$x3, $yn],[$x4, $yn, 'c'],[$xn, $y4, 'c'],[$xn, $y3],], - [[$xn, $y2],[$xn, $y1, 'c'],[$x4, $y0, 'c'],[$x3, $y0],]); - - my @pts = (); - my $previous; - for (my $i = 0; $i < 4; $i++) { - if ($corners->[$i]) { - if ($previous) { - # on teste si non duplication de point - my ($nx, $ny) = @{$roundeds[$i]->[0]}; - if ($previous->[0] == $nx and $previous->[1] == $ny) { - pop(@pts); - } - } - push(@pts, @{$roundeds[$i]}); - $previous = $roundeds[$i]->[3]; - - } else { - push(@pts, $angle_pts[$i]); - } - } - - return \@pts; -} - -#----------------------------------------------------------------------------------- -# Graphics::ellipseCoords -# calcul des coords d'une ellipse -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> coordonnées bbox du rectangle exinscrit -# options : -# -corners : <booleanList> liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1] -#----------------------------------------------------------------------------------- -sub ellipseCoords { - my ($coords, %options) = @_; - my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], - $coords->[1]->[0], $coords->[1]->[1]); - - my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1]; - - # attention aux formes 'négatives' - if ($xn < $x0) { - my $xs = $x0; - ($x0, $xn) = ($xn, $xs); - } - if ($yn < $y0) { - my $ys = $y0; - ($y0, $yn) = ($yn, $ys); - } - - # points remarquables - my $dx = ($xn - $x0)/2 * $const_ptd_factor; - my $dy = ($yn - $y0)/2 * $const_ptd_factor; - my ($x2, $y2) = (($x0+$xn)/2, ($y0+$yn)/2); - my ($x1, $x3) = ($x2 - $dx, $x2 + $dx); - my ($y1, $y3) = ($y2 - $dy, $y2 + $dy); - - # liste des 4 points sommet de l'ellipse : angles sans raccord circulaire - my @angle_pts = ([$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]); - - # liste des 4 segments quadratique : raccord d'angle = arc d'ellipse - my @roundeds = ([[$x2, $y0],[$x1, $y0, 'c'],[$x0, $y1, 'c'],[$x0, $y2],], - [[$x0, $y2],[$x0, $y3, 'c'],[$x1, $yn, 'c'],[$x2, $yn],], - [[$x2, $yn],[$x3, $yn, 'c'],[$xn, $y3, 'c'],[$xn, $y2],], - [[$xn, $y2],[$xn, $y1, 'c'],[$x3, $y0, 'c'],[$x2, $y0],]); - - my @pts = (); - my $previous; - for (my $i = 0; $i < 4; $i++) { - if ($corners->[$i]) { - if ($previous) { - # on teste si non duplication de point - my ($nx, $ny) = @{$roundeds[$i]->[0]}; - if ($previous->[0] == $nx and $previous->[1] == $ny) { - pop(@pts); - } - } - push(@pts, @{$roundeds[$i]}); - $previous = $roundeds[$i]->[3]; - - } else { - push(@pts, $angle_pts[$i]); - } - } - - return \@pts; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::hippodromeCoords -# calcul des coords d'un hippodrome -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> coordonnées bbox du rectangle exinscrit -# options : -# -orientation : orientation forcée de l'hippodrome [horizontal|vertical] -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] -# -trunc : troncatures [left|right|top|bottom|both] -#----------------------------------------------------------------------------------- -sub hippodromeCoords { - my ($coords, %options) = @_; - my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], - $coords->[1]->[0], $coords->[1]->[1]); - - my $orientation = ($options{'-orientation'}) ? $options{'-orientation'} : 'none'; - - # orientation forcée de l'hippodrome (sinon hippodrome sur le plus petit coté) - my $height = ($orientation eq 'horizontal') ? abs($yn - $y0) - : ($orientation eq 'vertical') ? abs($xn - $x0) : &_min(abs($xn - $x0), abs($yn - $y0)); - my $radius = $height/2; - my $corners = [1, 1, 1, 1]; - - if ($options{'-corners'}) { - $corners = $options{'-corners'}; - - } elsif ($options{'-trunc'}) { - my $trunc = $options{'-trunc'}; - if ($trunc eq 'both') { - return [[$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]]; - - } else { - $corners = ($trunc eq 'left') ? [0, 0, 1, 1] : - ($trunc eq 'right') ? [1, 1, 0, 0] : - ($trunc eq 'top') ? [0, 1, 1, 0] : - ($trunc eq 'bottom') ? [1, 0, 0, 1] : [1, 1, 1, 1]; - - } - } - - # l'hippodrome est un cas particulier de roundedRectangle - # on retourne en passant la 'configuration' à la fonction générique roundedRectangleCoords - return &roundedRectangleCoords($coords, -radius => $radius, -corners => $corners); -} - - -#----------------------------------------------------------------------------------- -# Graphics::polygonCoords -# calcul des coords d'un polygone régulier -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coords> point centre du polygone -# options : -# -numsides : <integer> nombre de cotés -# -radius : <dimension> rayon de définition du polygone (distance centre-sommets) -# -inner_radius : <dimension> rayon interne (polygone type étoile) -# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1] -# -corner_radius : <dimension> rayon de raccord des cotés -# -startangle : <angle> angle de départ en degré du polygone -#----------------------------------------------------------------------------------- -sub polygonCoords { - my ($coords, %options) = @_; - - my $numsides = $options{'-numsides'}; - my $radius = $options{'-radius'}; - if ($numsides < 3 or !$radius) { - print "Vous devez au moins spécifier un nombre de cotés >= 3 et un rayon...\n"; - return undef; - } - - $coords = [0, 0] if (!defined $coords); - my $startangle = ($options{'-startangle'}) ? $options{'-startangle'} : 0; - my $anglestep = 360/$numsides; - my $inner_radius = $options{'-inner_radius'}; - my @pts; - - # points du polygone - for (my $i = 0; $i < $numsides; $i++) { - my ($xp, $yp) = &rad_point($coords, $radius, $startangle + ($anglestep*$i)); - push(@pts, ([$xp, $yp])); - - # polygones 'étoiles' - if ($inner_radius) { - ($xp, $yp) = &rad_point($coords, $inner_radius, $startangle + ($anglestep*($i+ 0.5))); - push(@pts, ([$xp, $yp])); - } - } - - - @pts = reverse @pts; - - if ($options{'-corner_radius'}) { - return &roundedCurveCoords(\@pts, -radius => $options{'-corner_radius'}, -corners => $options{'-corners'}); - } else { - return \@pts; - } -} - - - -#----------------------------------------------------------------------------------- -# Graphics::roundedAngle -# THIS FUNCTION IS NO MORE USED, NEITHER EXPORTED -# curve d'angle avec raccord circulaire -#----------------------------------------------------------------------------------- -# paramètres : -# widget : identifiant du widget Zinc -# parentgroup : <tagOrId> identifiant de l'item group parent -# coords : <coordsList> les 3 points de l'angle -# radius : <dimension> rayon de raccord -#----------------------------------------------------------------------------------- -sub roundedAngle { - my ($widget, $parentgroup, $coords, $radius) = @_; - my ($pt0, $pt1, $pt2) = @{$coords}; - - my ($corner_pts, $center_pts) = &roundedAngleCoords($coords, $radius); - my ($cx0, $cy0) = @{$center_pts}; - - # valeur d'angle et angle formé par la bisectrice - my ($angle) = &vertexAngle($pt0, $pt1, $pt2); - - $parentgroup = 1 if (!defined $parentgroup); - - $widget->add('curve', $parentgroup, - [$pt0,@{$corner_pts},$pt2], - -closed => 0, - -linewidth => 1, - -priority => 20, - ); - -} - -#----------------------------------------------------------------------------------- -# Graphics::roundedAngleCoords -# calcul des coords d'un raccord d'angle circulaire -#----------------------------------------------------------------------------------- -# le raccord circulaire de 2 droites sécantes est traditionnellement réalisé par un -# arc (conique) du cercle inscrit de rayon radius tangent à ces 2 droites -# -# Quadratique : -# une approche de cette courbe peut être réalisée simplement par le calcul de 4 points -# spécifiques qui définiront - quelle que soit la valeur de l'angle formé par les 2 -# droites - le segment de raccord : -# - les 2 points de tangence au cercle inscrit seront les points de début et de fin -# du segment de raccord -# - les 2 points de controle seront situés chacun sur le vecteur reliant le point de -# tangence au sommet de l'angle (point secant des 2 droites) -# leur position sur ce vecteur peut être simplifiée comme suit : -# - à un facteur de 0.5523 de la distance au sommet pour un angle >= 90° et <= 270° -# - à une 'réduction' de ce point vers le point de tangence pour les angles limites -# de 90° vers 0° et de 270° vers 360° -# ce facteur sera légérement modulé pour recouvrir plus précisement l'arc correspondant -#----------------------------------------------------------------------------------- -# coords : <coordsList> les 3 points de l'angle -# radius : <dimension> rayon de raccord -#----------------------------------------------------------------------------------- -sub roundedAngleCoords { - my ($coords, $radius) = @_; - my ($pt0, $pt1, $pt2) = @{$coords}; - - # valeur d'angle et angle formé par la bisectrice - my ($angle, $bisecangle) = &vertexAngle($pt0, $pt1, $pt2); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($radius / $sin) : $radius; - - # point centre du cercle inscrit de rayon $radius - my $refangle = ($angle < 180) ? $bisecangle+90 : $bisecangle-90; - my ($cx0, $cy0) = rad_point($pt1, $delta, $refangle); - - # points de tangeance : pts perpendiculaires du centre aux 2 droites - my ($px1, $py1) = &perpendicularPoint([$cx0, $cy0], [$pt0, $pt1]); - my ($px2, $py2) = &perpendicularPoint([$cx0, $cy0], [$pt1, $pt2]); - - # point de controle de la quadratique - # facteur de positionnement sur le vecteur pt.tangence, sommet - my $ptd_factor = $const_ptd_factor; - if ($angle < 90 or $angle > 270) { - my $diffangle = ($angle < 90) ? $angle : 360 - $angle; - $ptd_factor -= (((90 - $diffangle)/90) * ($ptd_factor/4)) if $diffangle > 15 ; - $ptd_factor = ($diffangle/90) * ($ptd_factor + ((1 - $ptd_factor) * (90 - $diffangle)/90)); - } else { - my $diffangle = abs(180 - $angle); - $ptd_factor += (((90 - $diffangle)/90) * ($ptd_factor/3)) if $diffangle > 15; - } - - # delta xy aux pts de tangence - my ($d1x, $d1y) = (($pt1->[0] - $px1) * $ptd_factor, ($pt1->[1] - $py1) * $ptd_factor); - my ($d2x, $d2y) = (($pt1->[0] - $px2) * $ptd_factor, ($pt1->[1] - $py2) * $ptd_factor); - - # les 4 points de l'arc 'quadratique' - my $corner_pts = [[$px1, $py1],[$px1+$d1x, $py1+$d1y, 'c'], - [$px2+$d2x, $py2+$d2y, 'c'],[$px2, $py2]]; - - - # retourne le segment de quadratique et le centre du cercle inscrit - return ($corner_pts, [$cx0, $cy0]); - -} - - -#----------------------------------------------------------------------------------- -# Graphics::roundedCurveCoords -# retourne les coordonnées d'une curve à coins arrondis -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points de la curve -# options : -# -radius : <dimension> rayon de raccord d'angle -# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1] -#----------------------------------------------------------------------------------- -sub roundedCurveCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @curve_pts; - - my $radius = (defined $options{'-radius'}) ? $options{'-radius'} : 0; - my $corners = $options{'-corners'}; - - for (my $index = 0; $index < $numfaces; $index++) { - if ($corners and !$corners->[$index]) { - push(@curve_pts, $coords->[$index]); - - } else { - my $prev = ($index) ? $index - 1 : $numfaces - 1; - my $next = ($index > $numfaces - 2) ? 0 : $index + 1; - my $anglecoords = [$coords->[$prev], $coords->[$index], $coords->[$next]]; - - my ($quad_pts) = &roundedAngleCoords($anglecoords, $radius); - push(@curve_pts, @{$quad_pts}); - } - } - - return \@curve_pts; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::polylineCoords -# retourne les coordonnées d'une polyline -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des sommets de la polyline -# options : -# -radius : <dimension> rayon global de raccord d'angle -# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1], -# -corners_radius : <dimensionList> liste des rayons de raccords de sommets -#----------------------------------------------------------------------------------- -sub polylineCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @curve_pts; - - my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0; - my $corners_radius = $options{'-corners_radius'}; - my $corners = ($corners_radius) ? $corners_radius : $options{'-corners'}; - - for (my $index = 0; $index < $numfaces; $index++) { - if ($corners and !$corners->[$index]) { - push(@curve_pts, $coords->[$index]); - - } else { - my $prev = ($index) ? $index - 1 : $numfaces - 1; - my $next = ($index > $numfaces - 2) ? 0 : $index + 1; - my $anglecoords = [$coords->[$prev], $coords->[$index], $coords->[$next]]; - - my $rad = ($corners_radius) ? $corners_radius->[$index] : $radius; - my ($quad_pts) = &roundedAngleCoords($anglecoords, $rad); - push(@curve_pts, @{$quad_pts}); - } - } - - return \@curve_pts; - -} - -#----------------------------------------------------------------------------------- -# Graphics::pathLineCoords -# retourne les coordonnées d'une pathLine -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points du path -# options : -# -closed : <boolean> ligne fermée -# -shifting : <out|center|in> sens de décalage du path (par défaut center) -# -linewidth : <dimension> epaisseur de la ligne -#----------------------------------------------------------------------------------- -sub pathLineCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @pts; - - my $closed = $options{'-closed'}; - my $linewidth = ($options{'-linewidth'}) ? $options{'-linewidth'} : 2; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'center'; - - return undef if (!$numfaces or $linewidth < 2); - - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - $linewidth /= 2 if ($shifting eq 'center'); - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth; - - if ($shifting eq 'out' or $shifting eq 'in') { - my $adding = ($shifting eq 'out') ? -90 : 90; - push (@pts, &rad_point($pt, $delta, $bisecangle + $adding)); - push (@pts, @{$pt}); - - } else { - push (@pts, &rad_point($pt, $delta, $bisecangle-90)); - push (@pts, &rad_point($pt, $delta, $bisecangle+90)); - - } - - if ($i == $numfaces - 2) { - $next = ($closed) ? $coords->[0] : - [$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - if ($closed) { - push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3])); - } - - return \@pts; -} - -#----------------------------------------------------------------------------------- -# Graphics::curveLineCoords -# retourne les coordonnées d'une curveLine -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points de la ligne -# options : -# -closed : <boolean> ligne fermée -# -shifting : <out|center|in> sens de décalage du contour (par défaut center) -# -linewidth : <dimension> epaisseur de la ligne -#----------------------------------------------------------------------------------- -sub curveLineCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @gopts; - my @backpts; - my @pts; - - my $closed = $options{'-closed'}; - my $linewidth = (defined $options{'-linewidth'}) ? $options{'-linewidth'} : 2; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'center'; - - return undef if (!$numfaces or $linewidth < 2); - - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - $linewidth /= 2 if ($shifting eq 'center'); - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth; - - if ($shifting eq 'out' or $shifting eq 'in') { - my $adding = ($shifting eq 'out') ? -90 : 90; - push (@pts, &rad_point($pt, $delta, $bisecangle + $adding)); - push (@pts, @{$pt}); - - } else { - @pts = &rad_point($pt, $delta, $bisecangle+90); - push (@gopts, \@pts); - @pts = &rad_point($pt, $delta, $bisecangle-90); - unshift (@backpts, \@pts); - } - - if ($i == $numfaces - 2) { - $next = ($closed) ? $coords->[0] : - [$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - push(@gopts, @backpts); - - if ($closed) { - push (@gopts, ($gopts[0], $gopts[1])); - } - - return \@gopts; -} - - -#----------------------------------------------------------------------------------- -# Graphics::shiftPathCoords -# retourne les coordonnées d'un décalage de path -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points du path -# options : -# -closed : <boolean> ligne fermée -# -shifting : <'out'|'in'> sens de décalage du path (par défaut out) -# -width : <dimension> largeur de décalage (par défaut 1) -#----------------------------------------------------------------------------------- -sub shiftPathCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - - my $closed = $options{'-closed'}; - my $width = (defined $options{'-width'}) ? $options{'-width'} : 1; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'out'; - - return $coords if (!$numfaces or !$width); - - my @pts; - - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($width / $sin) : $width; - - my $adding = ($shifting eq 'out') ? -90 : 90; - my ($x, $y) = &rad_point($pt, $delta, $bisecangle + $adding); - push (@pts, [$x, $y]); - - - if ($i > $numfaces - 3) { - my $j = $numfaces - 1; - $next = ($closed) ? $coords->[0] : - [$pt->[0] + ($pt->[0] - $previous->[0]), $pt->[1] + ($pt->[1] - $previous->[1])]; - - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - return \@pts; -} - -#----------------------------------------------------------------------------------- -# Graphics::perpendicularPoint -# retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne -#----------------------------------------------------------------------------------- -# paramètres : -# point : <coords> coordonnées du point de référence -# line : <coordsList> coordonnées des 2 points de la ligne de référence -#----------------------------------------------------------------------------------- -sub perpendicularPoint { - my ($point, $line) = @_; - my ($p1, $p2) = @{$line}; - - # cas partiuculier de lignes ortho. - my $min_dist = .01; - if (abs($p2->[1] - $p1->[1]) < $min_dist) { - # la ligne de référence est horizontale - return ($point->[0], $p1->[1]); - - } elsif (abs($p2->[0] - $p1->[0]) < $min_dist) { - # la ligne de référence est verticale - return ($p1->[0], $point->[1]); - } - - my $a1 = ($p2->[1] - $p1->[1]) / ($p2->[0] - $p1->[0]); - my $b1 = $p1->[1] - ($a1 * $p1->[0]); - - my $a2 = -1.0 / $a1; - my $b2 = $point->[1] - ($a2 * $point->[0]); - - my $x = ($b2 - $b1) / ($a1 - $a2); - my $y = ($a1 * $x) + $b1; - - return ($x, $y); - -} - - -#----------------------------------------------------------------------------------- -# Graphics::lineAngle -# retourne l'angle d'un point par rapport à un centre de référence -#----------------------------------------------------------------------------------- -# paramètres : -# startpoint : <coords> coordonnées du point de départ du segment -# endpoint : <coords> coordonnées du point d'extremité du segment -#----------------------------------------------------------------------------------- -sub lineAngle { - my ($startpoint, $endpoint) = @_; - my $angle = atan2($endpoint->[1] - $startpoint->[1], $endpoint->[0] - $startpoint->[0]); - - $angle += pi/2; - $angle *= 180/pi; - $angle += 360 if ($angle < 0); - - return $angle; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::lineNormal -# retourne la valeur d'angle perpendiculaire à une ligne -#----------------------------------------------------------------------------------- -# paramètres : -# startpoint : <coords> coordonnées du point de départ du segment -# endpoint : <coords> coordonnées du point d'extremité du segment -#----------------------------------------------------------------------------------- -sub lineNormal { - my ($startpoint, $endpoint) = @_; - my $angle = &lineAngle($startpoint, $endpoint) + 90; - - $angle -= 360 if ($angle > 360); - return $angle; - -} - - - -#----------------------------------------------------------------------------------- -# Graphics::vertexAngle -# retourne la valeur de l'angle formée par 3 points -# ainsi que l'angle de la bisectrice -#----------------------------------------------------------------------------------- -# paramètres : -# pt0 : <coords> coordonnées du premier point de définition de l'angle -# pt1 : <coords> coordonnées du deuxième point de définition de l'angle -# pt2 : <coords> coordonnées du troisième point de définition de l'angle -#----------------------------------------------------------------------------------- -sub vertexAngle { - my ($pt0, $pt1, $pt2) = @_; - my $angle1 = &lineAngle($pt0, $pt1); - my $angle2 = &lineAngle($pt2, $pt1); - - $angle2 += 360 if $angle2 < $angle1; - my $alpha = $angle2 - $angle1; - my $bisectrice = $angle1 + ($alpha/2); - - return ($alpha, $bisectrice); -} - - -#----------------------------------------------------------------------------------- -# Graphics::arc_pts -# calcul des points constitutif d'un arc -#----------------------------------------------------------------------------------- -# paramètres : -# center : <coordonnées> centre de l'arc, -# radius : <dimension> rayon de l'arc, -# options : -# -angle : <angle> angle de départ en degré de l'arc (par défaut 0) -# -extent : <angle> delta angulaire en degré de l'arc (par défaut 360), -# -step : <dimension> pas de progresion en degré (par défaut 10) -#----------------------------------------------------------------------------------- -sub arc_pts { - my ($center, $radius, %options) = @_; - return unless ($radius); - - $center = [0, 0] if (!defined $center); - my $angle = (defined $options{'-angle'}) ? $options{'-angle'} : 0; - my $extent = (defined $options{'-extent'}) ? $options{'-extent'} : 360; - my $step = (defined $options{'-step'}) ? $options{'-step'} : 10; - my @pts = (); - - if ($extent > 0) { - for (my $alpha = $angle; $alpha <= ($angle + $extent); $alpha += $step) { - my ($xn, $yn) = &rad_point($center, $radius,$alpha); - push (@pts, ([$xn, $yn])); - } - } else { - for (my $alpha = $angle; $alpha >= ($angle + $extent); $alpha += $step) { - push (@pts, &rad_point($center, $radius, $alpha)); - } - } - - return @pts; -} - - -#----------------------------------------------------------------------------------- -# Graphics::rad_point -# retourne le point circulaire défini par centre-rayon-angle -#----------------------------------------------------------------------------------- -# paramètres : -# center : <coordonnée> coordonnée [x,y] du centre de l'arc, -# radius : <dimension> rayon de l'arc, -# angle : <angle> angle du point de circonférence avec le centre du cercle -#----------------------------------------------------------------------------------- -sub rad_point { - my ($center, $radius, $angle) = @_; - my $alpha = deg2rad($angle); - - my $xpt = $center->[0] + ($radius * cos($alpha)); - my $ypt = $center->[1] + ($radius * sin($alpha)); - - return ($xpt, $ypt); -} - - -#----------------------------------------------------------------------------------- -# Graphics::curveItem2polylineCoords -# Conversion des coordonnées ZnItem curve (multicontours) en coordonnées polyline(s) -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item source -# options : -# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20) -# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1) -#----------------------------------------------------------------------------------- -sub curveItem2polylineCoords { - my ($widget, $item, %options) = @_; - return unless ($widget and $widget->type($item)); - - my @coords; - my $numcontours = $widget->contour($item); - my $parentgroup = $widget->group($item); - - for (my $contour = 0; $contour < $numcontours; $contour++) { - my @points = $widget->coords($item, $contour); - my @contourcoords = &curve2polylineCoords(\@points, %options); - - push(@coords, \@contourcoords); - - } - - return wantarray ? @coords : \@coords; -} - -#----------------------------------------------------------------------------------- -# Graphics::curve2polylineCoords -# Conversion curve -> polygone -#----------------------------------------------------------------------------------- -# paramètres : -# points : <coordsList> liste des coordonnées curve à transformer -# options : -# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20) -# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1) -#----------------------------------------------------------------------------------- -sub curve2polylineCoords { - my ($points, %options) = @_; - - my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20; - my $adjust = (defined $options{'-adjust'}) ? $options{'-adjust'} : 1; - - my @poly; - my $previous; - my @bseg; - my $numseg = 0; - my $prevtype; - - foreach my $point (@{$points}) { - my ($x, $y, $c) = @{$point}; - if ($c eq 'c') { - push(@bseg, $previous) if (!@bseg); - push(@bseg, $point); - - } else { - if (@bseg) { - push(@bseg, $point); - - if ($adjust) { - my @pts = &bezierCompute(\@bseg, -skipend => 1); - shift @pts; - shift @pts; - push(@poly, @pts); - - } else { - my @pts = &bezierSegment(\@bseg, -tunits => $tunits, -skipend => 1); - shift @pts; - shift @pts; - push(@poly, @pts); - - } - - @bseg = (); - $numseg++; - $prevtype = 'bseg'; - - } else { - push(@poly, ([$x, $y])); - $prevtype = 'line'; - } - } - - $previous = $point; - } - - - return wantarray ? @poly : \@poly; -} - - -#----------------------------------------------------------------------------------- -# Graphics::buildTabBoxItem -# construit les items de représentations Zinc d'une boite à onglets -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# parentgroup : <tagOrId> identifiant de l'item group parent -# -# options : -# -coords : <coordsList> coordonnées haut-gauche et bas-droite du rectangle -# englobant du TabBox -# -params : <hastable> arguments spécifiques des items curve à passer au widget -# -texture : <imagefile> ajout d'une texture aux items curve -# -tabtitles : <hashtable> table de hash de définition des titres onglets -# -pageitems : <hashtable> table de hash de définition des pages internes -# -relief : <hashtable> table de hash de définition du relief de forme -# -# (options de construction géometrique passées à tabBoxCoords) -# -numpages : <integer> nombre de pages (onglets) de la boite -# -anchor : <'n'|'e'|'s'|'w'> ancrage (positionnement) de la ligne d'onglets -# -alignment : <'left'|'center'|'right'> alignement des onglets sur le coté d'ancrage -# -tabwidth : <'auto'>|<dimension>|<dimensionList> : largeur des onglets -# 'auto' largeur répartie, les largeurs sont auto-ajustée si besoin. -# -tabheight : <'auto'>|<dimension> : hauteur des onglets -# -tabshift : <'auto'>|<dimension> offset de 'biseau' entre base et haut de l'onglet (défaut auto) -# -radius : <dimension> rayon des arrondis d'angle -# -overlap : <'auto'>|<dimension> offset de recouvrement/séparation entre onglets -# -corners : <booleanList> liste 'spécifique' des raccords de sommets [0|1] -#----------------------------------------------------------------------------------- -sub buildTabBoxItem { - my ($widget, $parentgroup, %options) = @_; - my $coords = $options{'-coords'}; - my $params = $options{'-params'}; - my @tags = @{$params->{'-tags'}}; - my $texture; - - if ($options{'-texture'}) { - $texture = &getTexture($widget, $options{'-texture'}); - } - - my $titlestyle = $options{'-tabtitles'}; - my $titles = ($titlestyle) ? $titlestyle->{'-text'} : undef ; - - return undef if (!$coords); - - my @tabs; - my ($shapes, $tcoords, $invert) = &tabBoxCoords($coords, %options); - my $k = ($invert) ? scalar @{$shapes} : -1; - foreach my $shape (reverse @{$shapes}) { - $k += ($invert) ? -1 : +1; - my $group = $widget->add('group', $parentgroup); - $params->{'-tags'} = [@tags, $k, 'intercalaire']; - my $form = $widget->add('curve', $group, $shape, %{$params}); - $widget->itemconfigure($form, -tile => $texture) if $texture; - - if ($options{'-relief'}) { - &graphicItemRelief($widget, $form, %{$options{'-relief'}}); - } - - if ($options{'-page'}) { - my $page = &buildZincItem($widget, $group, %{$options{'-page'}}); - } - - if ($titles) { - my $tindex = ($invert) ? $k : $#{$shapes} - $k; - $titlestyle->{'-itemtype'} = 'text'; - $titlestyle->{'-coords'} = $tcoords->[$tindex]; - $titlestyle->{'-params'}->{'-text'} = $titles->[$tindex],; - $titlestyle->{'-params'}->{'-tags'} = [@tags, $tindex, 'titre']; - &buildZincItem($widget, $group, %{$titlestyle}); - - } - - - } - - return @tabs; -} - - -#----------------------------------------------------------------------------------- -# tabBoxCoords -# Calcul des shapes de boites à onglets -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordList> coordonnées haut-gauche bas-droite du rectangle englobant -# de la tabbox -# options -# -numpages : <integer> nombre de pages (onglets) de la boite -# -anchor : <'n'|'e'|'s'|'w'> ancrage (positionnement) de la ligne d'onglets -# -alignment : <'left'|'center'|'right'> alignement des onglets sur le coté d'ancrage -# -tabwidth : <'auto'>|<dimension>|<dimensionList> : largeur des onglets -# 'auto' largeur répartie, les largeurs sont auto-ajustée si besoin. -# -tabheight : <'auto'>|<dimension> : hauteur des onglets -# -tabshift : <'auto'>|<dimension> offset de 'biseau' entre base et haut de l'onglet (défaut auto) -# -radius : <dimension> rayon des arrondis d'angle -# -overlap : <'auto'>|<dimension> offset de recouvrement/séparation entre onglets -# -corners : <booleanList> liste 'spécifique' des raccords de sommets [0|1] -#----------------------------------------------------------------------------------- -sub tabBoxCoords { - my ($coords, %options) = @_; - - my ($x0, $y0, $xn, $yn) = (@{$coords->[0]}, @{$coords->[1]}); - my (@shapes, @titles_coords); - my $inverse; - - my @options = keys(%options); - my $numpages = $options{'-numpages'}; - - if (!defined $x0 or !defined $y0 or !defined $xn or !defined $yn or !$numpages) { - print "Vous devez au minimum spécifier le rectangle englobant et le nombre de pages\n"; - return undef; - - } - - my $anchor = ($options{'-anchor'}) ? $options{'-anchor'} : 'n'; - my $alignment = ($options{'-alignment'}) ? $options{'-alignment'} : 'left'; - my $len = ($options{'-tabwidth'}) ? $options{'-tabwidth'} : 'auto'; - my $thick = ($options{'-tabheight'}) ? $options{'-tabheight'} : 'auto'; - my $biso = ($options{'-tabshift'}) ? $options{'-tabshift'} : 'auto'; - my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0; - my $overlap = ($options{'-overlap'}) ? $options{'-overlap'} : 0; - my $corners = $options{'-corners'}; - my $orientation = ($anchor eq 'n' or $anchor eq 's') ? 'horizontal' : 'vertical'; - my $maxwidth = ($orientation eq 'horizontal') ? ($xn - $x0) : ($yn - $y0); - my $tabswidth = 0; - my $align = 1; - - if ($len eq 'auto') { - $tabswidth = $maxwidth; - $len = ($tabswidth + ($overlap * ($numpages - 1)))/$numpages; - - } else { - if (ref($len) eq 'ARRAY') { - foreach my $w (@{$len}) { - $tabswidth += ($w - $overlap); - } - $tabswidth += $overlap; - } else { - $tabswidth = ($len * $numpages) - ($overlap * ($numpages - 1)); - } - - if ($tabswidth > $maxwidth) { - $tabswidth = $maxwidth; - $len = ($tabswidth + ($overlap * ($numpages - 1)))/$numpages; - } - - $align = 0 if ($alignment eq 'center' and (($maxwidth - $tabswidth) > $radius)); - } - - - if ($thick eq 'auto') { - $thick = ($orientation eq 'horizontal') ? int(($yn - $y0)/10) : int(($xn - $y0)/10); - $thick = 10 if ($thick < 10); - $thick = 40 if ($thick > 40); - } - - if ($biso eq 'auto') { - $biso = int($thick/2); - } - - if (($alignment eq 'right' and $anchor ne 'w') or - ($anchor eq 'w' and $alignment ne 'right')) { - - if (ref($len) eq 'ARRAY') { - for (my $p = 0; $p < $numpages; $p++) { - $len->[$p] *= -1; - } - } else { - $len *= -1; - } - $biso *= -1; - $overlap *= -1; - } - - my ($biso1, $biso2) = ($alignment eq 'center') ? ($biso/2, $biso/2) : (0, $biso); - - my (@cadre, @tabdxy); - my ($xref, $yref); - if ($orientation eq 'vertical') { - $thick *= -1 if ($anchor eq 'w'); - my ($startx, $endx) = ($anchor eq 'w') ? ($x0, $xn) : ($xn, $x0); - my ($starty, $endy) = (($anchor eq 'w' and $alignment ne 'right') or - ($anchor eq 'e' and $alignment eq 'right')) ? - ($yn, $y0) : ($y0, $yn); - - $xref = $startx - $thick; - $yref = $starty; - if ($alignment eq 'center') { - my $ratio = ($anchor eq 'w') ? -2 : 2; - $yref += (($maxwidth - $tabswidth)/$ratio); - } - - @cadre = ([$xref, $endy], [$endx, $endy], [$endx, $starty], [$xref, $starty]); - - # flag de retournement de la liste des pts de curve si nécessaire -> sens anti-horaire - $inverse = ($alignment ne 'right'); - - } else { - $thick *= -1 if ($anchor eq 's'); - my ($startx, $endx) = ($alignment eq 'right') ? ($xn, $x0) : ($x0, $xn); - my ($starty, $endy) = ($anchor eq 's') ? ($yn, $y0) : ($y0, $yn); - - - $yref = $starty + $thick; - $xref = ($alignment eq 'center') ? $x0 + (($maxwidth - $tabswidth)/2) : $startx; - - @cadre = ([$endx, $yref], [$endx, $endy], [$startx, $endy], [$startx, $yref]); - - # flag de retournement de la liste des pts de curve si nécessaire -> sens anti-horaire - $inverse = (($anchor eq 'n' and $alignment ne 'right') or ($anchor eq 's' and $alignment eq 'right')); - } - - for (my $i = 0; $i < $numpages; $i++) { - my @pts = (); - - # décrochage onglet - #push (@pts, ([$xref, $yref])) if $i > 0; - - # cadre - push (@pts, @cadre); - - # points onglets - push (@pts, ([$xref, $yref])) if ($i > 0 or !$align); - - my $tw = (ref($len) eq 'ARRAY') ? $len->[$i] : $len; - @tabdxy = ($orientation eq 'vertical') ? - ([$thick, $biso1],[$thick, $tw - $biso2],[0, $tw]) : ([$biso1, -$thick],[$tw - $biso2, -$thick],[$tw, 0]); - foreach my $dxy (@tabdxy) { - push (@pts, ([$xref + $dxy->[0], $yref + $dxy->[1]])); - } - - if ($radius) { - if (!defined $options{'-corners'}) { - $corners = ($i > 0 or !$align) ? [0, 1, 1, 0, 0, 1, 1, 0] : [0, 1, 1, 0, 1, 1, 0, 0, 0]; - } - my $curvepts = &roundedCurveCoords(\@pts, -radius => $radius, -corners => $corners); - @{$curvepts} = reverse @{$curvepts} if ($inverse); - push (@shapes, $curvepts); - } else { - @pts = reverse @pts if ($inverse); - push (@shapes, \@pts); - } - - if ($orientation eq 'horizontal') { - push (@titles_coords, [$xref + ($tw - ($biso2 - $biso1))/2, $yref - ($thick/2)]); - $xref += ($tw - $overlap); - - } else { - push (@titles_coords, [$xref + ($thick/2), $yref + ($len - (($biso2 - $biso1)/2))/2]); - $yref += ($len - $overlap); - } - - } - - return (\@shapes, \@titles_coords, $inverse); - -} - - -#----------------------------------------------------------------------------------- -# Graphics::graphicItemRelief -# construit un relief à l'item Zinc en utilisant des items Triangles -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item zinc -# options : <hash> table d'options -# -closed : <boolean> le relief assure la fermeture de forme (défaut 1) -# -profil : <'rounded'|'flat'> type de profil (defaut 'rounded') -# -relief : <'raised'|'sunken'> (défaut 'raised') -# -side : <'inside'|'outside'> relief interne ou externe à la forme (défaut 'inside') -# -color : <color> couleur du relief (défaut couleur de la forme) -# -smoothed : <boolean> facettes relief lissées ou non (défaut 1) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -width : <dimension> 'épaisseur' du relief en pixel -# -fine : <boolean> mode précision courbe de bezier (défaut 0 : auto-ajustée) -#----------------------------------------------------------------------------------- -sub graphicItemRelief { - my ($widget, $item, %options) = @_; - my @items; - - # relief d'une liste d'items -> appel récursif - if (ref($item) eq 'ARRAY') { - foreach my $part (@{$item}) { - push(@items, &graphicItemRelief($widget, $part, %options)); - } - - } else { - my $itemtype = $widget->type($item); - - return unless ($itemtype); - - my $parentgroup = $widget->group($item); - my $priority = (defined $options{'-priority'}) ? $options{'-priority'} : - $widget->itemcget($item, -priority)+1; - - # coords transformés (polyline) de l'item - my $adjust = !$options{'-fine'}; - foreach my $coords (&ZincItem2CurveCoords($widget, $item, -linear => 1, - -realcoords => 1,-adjust => $adjust)) { - my ($pts, $colors) = &polylineReliefParams($widget, $item, $coords, %options); - - push(@items, $widget->add('triangles', $parentgroup, $pts, - -priority => $priority, - -colors => $colors)); - } - - - # renforcement du contour - if ($widget->itemcget($item, -linewidth)) { - push(@items, $widget->clone($item, -filled => 0, -priority => $priority+1)); - } - } - - return \@items; -} - - -#----------------------------------------------------------------------------------- -# Graphics::polylineReliefParams -# retourne la liste des points et des couleurs nécessaires à la construction -# de l'item Triangles du relief -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant widget Zinc -# item : <tagOrId> identifiant item Zinc -# options : <hash> table d'options -# -closed : <boolean> le relief assure la fermeture de forme (défaut 1) -# -profil : <'rounded'|'flat'> type de profil (defaut 'rounded') -# -relief : <'raised'|'sunken'> (défaut 'raised') -# -side : <'inside'|'outside'> relief interne ou externe à la forme (défaut 'inside') -# -color : <color> couleur du relief (défaut couleur de la forme) -# -smoothed : <boolean> facettes relief lissées ou non (défaut 1) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -width : <dimension> 'épaisseur' du relief en pixel -#----------------------------------------------------------------------------------- -sub polylineReliefParams { - my ($widget, $item, $coords, %options) = @_; - - my $closed = (defined $options{'-closed'}) ? $options{'-closed'} : 1; - my $profil = ($options{'-profil'}) ? $options{'-profil'} : 'rounded'; - my $relief = ($options{'-relief'}) ? $options{'-relief'} : 'raised'; - my $side = ($options{'-side'}) ? $options{'-side'} : 'inside'; - my $basiccolor = ($options{'-color'}) ? $options{'-color'} : &zincItemPredominantColor($widget, $item); - my $smoothed = (defined $options{'-smooth'}) ? $options{'-smooth'} : 1; - my $lightangle = (defined $options{'-lightangle'}) ? $options{'-lightangle'} - : $widget->cget('-lightangle'); - - my $width = $options{'-width'}; - if (!$width or $width < 1) { - my ($x0, $y0, $x1, $y1) = $widget->bbox($item); - $width = &_min($x1 -$x0, $y1 - $y0)/10; - $width = 2 if ($width < 2); - } - - my $numfaces = scalar(@{$coords}); - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - - my @pts; - my @colors; - my $alpha = 100; - if ($basiccolor =~ /;/) { - ($basiccolor, $alpha) = split /;/, $basiccolor; - - } - - $alpha /= 2 if (!($options{'-color'} =~ /;/) and $profil eq 'flat'); - - my $reliefalphas = ($profil eq 'rounded') ? [0,$alpha] : [$alpha, $alpha]; - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($width / $sin) : $width; - my $decal = ($side eq 'outside') ? -90 : 90; - - my @shift_pt = &rad_point($pt, $delta, $bisecangle+$decal); - push (@pts, @shift_pt); - push (@pts, @{$pt}); - - if (!$smoothed and $i) { - push (@pts, @shift_pt); - push (@pts, @{$pt}); - } - - my $faceangle = 360 -(&lineNormal($previous, $next)+90); - - my $light = abs($lightangle - $faceangle); - $light = 360 - $light if ($light > 180); - $light = 1 if $light < 1; - - my $lumratio = ($relief eq 'sunken') ? (180-$light)/180 : $light/180; - - if (!$smoothed and $i) { - push(@colors, ($colors[-2],$colors[-1])); - } - - if ($basiccolor) { - # création des couleurs dérivées - my $shade = &LightingColor($basiccolor, $lumratio); - my $color0 = $shade.";".$reliefalphas->[0]; - my $color1 = $shade.";".$reliefalphas->[1]; - push(@colors, ($color0, $color1)); - - } else { - my $c = (255*$lumratio); - my $color0 = &hexaRGBcolor($c, $c, $c, $reliefalphas->[0]); - my $color1 = &hexaRGBcolor($c, $c, $c, $reliefalphas->[1]); - push(@colors, ($color0, $color1)); - } - - if ($i == $numfaces - 2) { - $next = ($closed) ? $coords->[0] : - [$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - if ($closed) { - push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3])); - push (@colors, ($colors[0], $colors[1])); - - if (!$smoothed) { - push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3])); - push (@colors, ($colors[0], $colors[1])); - } - - } - - - return (\@pts, \@colors); -} - - -#----------------------------------------------------------------------------------- -# Graphics::graphicItemShadow -# Création d'une ombre portée à l'item -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant widget Zinc -# item : <tagOrId> identifiant item Zinc -# options : <hash> table d'options -# -opacity : <percent> opacité de l'ombre (défaut 50) -# -filled : <boolean> remplissage totale de l'ombre (hors bordure) (defaut 1) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -distance : <dimension> distance de projection de l'ombre en pixel -# -enlarging : <dimension> grossi de l'ombre portée en pixels (defaut 0) -# -width : <dimension> taille de diffusion/diffraction (défaut 4) -# -color : <color> couleur de l'ombre portée (défaut black) -#----------------------------------------------------------------------------------- -sub graphicItemShadow { - my ($widget, $item, %options) = @_; - my @items; - - # relief d'une liste d'items -> appel récursif - if (ref($item) eq 'ARRAY') { - foreach my $part (@{$item}) { - push(@items, &graphicItemShadow($widget, $part, %options)); - } - - return \@items; - - } else { - - my $itemtype = $widget->type($item); - - return unless ($itemtype); - - # création d'un groupe à l'ombre portée - my $parentgroup = ($options{'-parentgroup'}) ? $options{'-parentgroup'} : - $widget->group($item); - my $priority = (defined $options{'-priority'}) ? $options{'-priority'} : - ($widget->itemcget($item, -priority))-1; - $priority = 0 if ($priority < 0); - - my $shadow = $widget->add('group', $parentgroup, -priority => $priority); - - if ($itemtype eq 'text') { - my $opacity = (defined $options{'-opacity'}) ? $options{'-opacity'} : 50; - my $color = ($options{'-color'}) ? $options{'-color'} : '#000000'; - - my $clone = $widget->clone($item, -color => $color.";".$opacity); - $widget->chggroup($clone, $shadow); - - } else { - - # création des items (de dessin) de l'ombre - my $filled = (defined $options{'-filled'}) ? $options{'-filled'} : 1; - - # coords transformés (polyline) de l'item - foreach my $coords (&ZincItem2CurveCoords($widget, $item, -linear => 1, -realcoords => 1)) { - my ($t_pts, $i_pts, $colors) = &polylineShadowParams($widget, $item, $coords, %options); - - # option filled : remplissage hors bordure de l'ombre portée (item curve) - if ($filled) { - if (@items) { - $widget->contour($items[0], 'add', 0, $i_pts); - - } else { - push(@items, $widget->add('curve', $shadow, $i_pts, - -linewidth => 0, - -filled => 1, - -fillcolor => $colors->[0], - )); - } - } - - # bordure de diffusion de l'ombre (item triangles) - push(@items, $widget->add('triangles', $shadow, $t_pts, - -colors => $colors)); - } - } - - # positionnement de l'ombre portée - my $distance = (defined $options{'-distance'}) ? $options{'-distance'} : 10; - my $lightangle = (defined $options{'-lightangle'}) ? $options{'-lightangle'} - : $widget->cget('-lightangle'); - - my ($dx, $dy) = &rad_point([0, 0], $distance, $lightangle+180); - $widget->translate($shadow, $dx, -$dy); - - return $shadow; - - } - -} - - -#----------------------------------------------------------------------------------- -# Graphics::polylineShadowParams -# retourne les listes des points et de couleurs nécessaires à la construction des -# items triangles (bordure externe) et curve (remplissage interne) de l'ombre portée -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant widget Zinc -# item : <tagOrId> identifiant item Zinc -# options : <hash> table d'options -# -opacity : <percent> opacité de l'ombre (défaut 50) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -distance : <dimension> distance de projection de l'ombre en pixel (défaut 10) -# -enlarging : <dimension> grossi de l'ombre portée en pixels (defaut 2) -# -width : <dimension> taille de diffusion/diffraction (défaut distance -2) -# -color : <color> couleur de l'ombre portée (défaut black) -#----------------------------------------------------------------------------------- -sub polylineShadowParams { - my ($widget, $item, $coords, %options) = @_; - - my $distance = (defined $options{'-distance'}) ? $options{'-distance'} : 10; - my $width = (defined $options{'-width'}) ? $options{'-width'} : $distance-2; - my $opacity = (defined $options{'-opacity'}) ? $options{'-opacity'} : 50; - my $color = ($options{'-color'}) ? $options{'-color'} : '#000000'; - my $enlarging = (defined $options{'-enlarging'}) ? $options{'-enlarging'} : 2; - - if ($enlarging) { - $coords = &shiftPathCoords($coords, -width => $enlarging, -closed => 1, -shifting => 'out'); - } - - my $numfaces = scalar(@{$coords}); - my $previous = $coords->[$numfaces - 1]; - my $next = $coords->[1]; - - my @t_pts; - my @i_pts; - my @colors; - my ($color0, $color1) = ($color.";$opacity", $color.";0"); - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($width / $sin) : $width; - my $decal = 90; - - my @shift_pt = &rad_point($pt, $delta, $bisecangle+$decal); - push (@i_pts, @shift_pt); - push (@t_pts, @shift_pt); - push (@t_pts, @{$pt}); - - push(@colors, ($color0, $color1)); - - if ($i == $numfaces - 2) { - $next = $coords->[0]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - # fermeture - push(@t_pts, ($t_pts[0], $t_pts[1],$t_pts[2],$t_pts[3])); - push(@i_pts, ($t_pts[0], $t_pts[1])); - push(@colors, ($color0, $color1,$color0,$color1)); - - return (\@t_pts, \@i_pts, \@colors); -} - - -#----------------------------------------------------------------------------------- -# Graphics::bezierSegment -# Calcul d'une approximation de segment (Quadratique ou Cubique) de bezier -#----------------------------------------------------------------------------------- -# paramètres : -# points : <[P1, C1, <C1>, P2]> liste des points définissant le segment de bezier -# -# options : -# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20) -# -skipend : <boolean> : ne pas retourner le dernier point du segment (chainage) -#----------------------------------------------------------------------------------- -sub bezierSegment { - my ($coords, %options) = @_; - my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20; - my $skipendpt = $options{'-skipend'}; - - my @pts; - - my $lastpt = ($skipendpt) ? $tunits-1 : $tunits; - foreach (my $i = 0; $i <= $lastpt; $i++) { - my $t = ($i) ? ($i/$tunits) : $i; - push(@pts, &bezierPoint($t, $coords)); - } - - return wantarray ? @pts : \@pts; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::bezierPoint -# calcul d'un point du segment (Quadratique ou Cubique) de bezier -# params : -# t = <n> (représentation du temps : de 0 à 1) -# coords = (P1, C1, <C1>, P2) liste des points définissant le segment de bezier -# P1 et P2 : extémités du segment et pts situés sur la courbe -# C1 <C2> : point(s) de contrôle du segment -#----------------------------------------------------------------------------------- -# courbe bezier niveau 2 sur (P1, P2, P3) -# P(t) = (1-t)²P1 + 2t(1-t)P2 + t²P3 -# -# courbe bezier niveau 3 sur (P1, P2, P3, P4) -# P(t) = (1-t)³P1 + 3t(1-t)²P2 + 3t²(1-t)P3 + t³P4 -#----------------------------------------------------------------------------------- -sub bezierPoint { - my ($t, $coords) = @_; - my ($p1, $c1, $c2, $p2) = @{$coords}; - - # quadratique - if (!defined $p2) { - $p2 = $c2; - $c2 = undef; - } - - # extrémités : points sur la courbe - return wantarray ? @{$p1} : $p1 if (!$t); - return wantarray ? @{$p2} : $p2 if ($t >= 1.0); - - - my $t2 = $t * $t; - my $t3 = $t2 * $t; - my @pt; - - # calcul pour x et y - foreach my $i (0, 1) { - - if (defined $c2) { - my $r1 = (1 - (3*$t) + (3*$t2) - $t3) * $p1->[$i]; - my $r2 = ( (3*$t) - (6*$t2) + (3*$t3)) * $c1->[$i]; - my $r3 = ( (3*$t2) - (3*$t3)) * $c2->[$i]; - my $r4 = ( $t3) * $p2->[$i]; - - $pt[$i] = ($r1 + $r2 + $r3 + $r4); - - } else { - my $r1 = (1 - (2*$t) + $t2) * $p1->[$i]; - my $r2 = ( (2*$t) - (2*$t2)) * $c1->[$i]; - my $r3 = ( $t2) * $p2->[$i]; - - $pt[$i] = ($r1 + $r2 + $r3); - } - } - - #return wantarray ? @pt : \@pt; - return \@pt; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::bezierCompute -# Retourne une liste de coordonnées décrivant un segment de bezier -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste des points définissant le segment de bezier -# -# options : -# -precision : <dimension> seuil limite du calcul d'approche de la courbe -# -skipend : <boolean> : ne pas retourner le dernier point du segment (chaînage bezier) -#----------------------------------------------------------------------------------- -sub bezierCompute { - my ($coords, %options) = @_; - my $precision = ($options{'-precision'}) ? $options{'-precision'} : $bezierClosenessThreshold; - my $lastit = []; - - &subdivideBezier($coords, $lastit, $precision); - - push(@{$lastit}, $coords->[3]) if (!$options{'-skipend'}); - - return wantarray ? @{$lastit} : $lastit; -} - -#------------------------------------------------------------------------------------ -# Graphics::smallEnought -# intégration code Stéphane Conversy : calcul points bezier (précision auto ajustée) -#------------------------------------------------------------------------------------ -# distance is something like num/den with den=sqrt(something) -# what we want is to test that distance is smaller than precision, -# so we have distance < precision ? eq. to distance^2 < precision^2 ? -# eq. to (num^2/something) < precision^2 ? -# eq. to num^2 < precision^2*something -# be careful with huge values though (hence 'long long') -# with common values: 9add 9mul -#------------------------------------------------------------------------------------ -sub smallEnoughBezier { - my ($bezier, $precision) = @_; - my ($x, $y) = (0, 1); - my ($A, $B) = ($bezier->[0], $bezier->[3]); - - my $den = (($A->[$y]-$B->[$y])*($A->[$y]-$B->[$y])) + (($B->[$x]-$A->[$x])*($B->[$x]-$A->[$x])); - my $p = $precision*$precision; - - # compute distance between P1|P2 and P0|P3 - my $M = $bezier->[1]; - my $num1 = (($M->[$x]-$A->[$x])*($A->[$y]-$B->[$y])) + (($M->[$y]-$A->[$y])*($B->[$x]-$A->[$x])); - - $M = $bezier->[2]; - my $num2 = (($M->[$x]-$A->[$x])*($A->[$y]-$B->[$y])) + (($M->[$y]-$A->[$y])*($B->[$x]-$A->[$x])); - - # take the max - $num1 = $num2 if ($num2 > $num1); - - return ($p*$den > ($num1*$num1)) ? 1 : 0; - -} - -#----------------------------------------------------------------------------------- -# Graphics::subdivideBezier -# subdivision d'une courbe de bezier -#----------------------------------------------------------------------------------- -sub subdivideBezier { - my ($bezier, $it, $precision, $integeropt) = @_; - my ($b0, $b1, $b2, $b3) = @{$bezier}; - - if (&smallEnoughBezier($bezier, $precision)) { - push(@{$it}, ([$b0->[0],$b0->[1]])); - - } else { - my ($left, $right); - - foreach my $i (0, 1) { - - if ($integeropt) { - # int optimized (6+3=9)add + (5+3=8)shift - - $left->[0][$i] = $b0->[$i]; - $left->[1][$i] = ($b0->[$i] + $b1->[$i]) >> 1; - $left->[2][$i] = ($b0->[$i] + $b2->[$i] + ($b1->[$i] << 1)) >> 2; # keep precision - my $tmp = ($b1->[$i] + $b2->[$i]); - $left->[3][$i] = ($b0->[$i] + $b3->[$i] + ($tmp << 1) + $tmp) >> 3; - - $right->[3][$i] = $b3->[$i]; - $right->[2][$i] = ($b3->[$i] + $b2->[$i]) >> 1; - $right->[1][$i] = ($b3->[$i] + $b1->[$i] + ($b2->[$i] << 1) ) >> 2; # keep precision - $right->[0][$i] = $left->[3]->[$i]; - - } else { - # float - - $left->[0][$i] = $b0->[$i]; - $left->[1][$i] = ($b0->[$i] + $b1->[$i]) / 2; - $left->[2][$i] = ($b0->[$i] + (2*$b1->[$i]) + $b2->[$i]) / 4; - $left->[3][$i] = ($b0->[$i] + (3*$b1->[$i]) + (3*$b2->[$i]) + $b3->[$i]) / 8; - - $right->[3][$i] = $b3->[$i]; - $right->[2][$i] = ($b3->[$i] + $b2->[$i]) / 2; - $right->[1][$i] = ($b3->[$i] + (2*$b2->[$i]) + $b1->[$i]) / 4; - $right->[0][$i] = ($b3->[$i] + (3*$b2->[$i]) + (3*$b1->[$i]) + $b0->[$i]) / 8; - - } - } - - &subdivideBezier($left, $it, $precision, $integeropt); - &subdivideBezier($right, $it, $precision, $integeropt); - - } -} - - - -#----------------------------------------------------------------------------------- -# RESOURCES GRAPHIQUES PATTERNS, TEXTURES, IMAGES, GRADIENTS, COULEURS... -#----------------------------------------------------------------------------------- -#----------------------------------------------------------------------------------- -# Graphics::getPattern -# retourne la ressource bitmap en l'initialisant si première utilisation -#----------------------------------------------------------------------------------- -# paramètres : -# filename : nom du fichier bitmap pattern -# options -# -storage : <hastable> référence de la table de stockage de patterns -#----------------------------------------------------------------------------------- -sub getPattern { - my ($filename, %options) = @_; - my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? - $options{'-storage'} : \%bitmaps; - - if (!exists($table->{$filename})) { - my $bitmap = '@'.Tk::findINC($filename); - $table->{$filename} = $bitmap if $bitmap; - - } - - return $table->{$filename}; -} - -#----------------------------------------------------------------------------------- -# Graphics::getTexture -# retourne l'image de texture en l'initialisant si première utilisation -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# filename : nom du fichier texture -# options -# -storage : <hastable> référence de la table de stockage de textures -#----------------------------------------------------------------------------------- -sub getTexture { - my ($widget, $filename, %options) = @_; - my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? - $options{'-storage'} : \%textures; - - return &getImage($widget, $filename, -storage => $table); - -} - -#----------------------------------------------------------------------------------- -# Graphics::getImage -# retourne la ressource image en l'initialisant si première utilisation -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# filename : nom du fichier image -# options -# -storage : <hastable> référence de la table de stockage d'images -#----------------------------------------------------------------------------------- -sub getImage { - my ($widget, $filename, %options) = @_; - my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? - $options{'-storage'} : \%images; - - if (!exists($table->{$filename})) { - my $image; - if ($filename =~ /.png|.PNG/) { - $image = $widget->Photo(-format => 'png', -file => Tk::findINC($filename)); - - } elsif ($filename =~ /.jpg|.JPG|.jpeg|.JPEG/) { - $image = $widget->Photo(-format => 'jpeg', -file => Tk::findINC($filename)); - - } else { - $image = $widget->Photo(-file => Tk::findINC($filename)); - } - - $table->{$filename} = $image if $image; - - } - - return $table->{$filename}; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::init_pixmaps -# initialise une liste de fichier image -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# filenames : <filenameList> list des noms des fichier image -# options -# -storage : <hastable> référence de la table de stockage d'images -#----------------------------------------------------------------------------------- -sub init_pixmaps { - my ($widget, $filenames, %options) = @_; - my @imgs = (); - - my @files = (ref($filenames) eq 'ARRAY') ? @{$filenames} : ($filenames); - - foreach (@files) { - push(@imgs, &getImage($widget, $_, %options)); - } - - return @imgs; -} - - -#----------------------------------------------------------------------------------- -# Graphics::_min -# retourne la plus petite valeur entre 2 valeurs -#----------------------------------------------------------------------------------- -sub _min { - my ($n1, $n2) = @_; - my $mini = ($n1 > $n2) ? $n2 : $n1; - return $mini; - -} - -#----------------------------------------------------------------------------------- -# Graphics::_max -# retourne la plus grande valeur entre 2 valeurs -#----------------------------------------------------------------------------------- -sub _max { - my ($n1, $n2) = @_; - my $maxi = ($n1 > $n2) ? $n1 : $n2; - return $maxi; - -} - -#----------------------------------------------------------------------------------- -# Graphics::_trunc -# fonction interne de troncature des nombres: n = position décimale -#----------------------------------------------------------------------------------- -sub _trunc { - my ($val, $n) = @_; - my $str; - my $dec; - - ($val) =~ /([0-9]+)\.?([0-9]*)/; - $str = ($val < 0) ? "-$1" : $1; - - if (($2 ne "") && ($n != 0)) { - $dec = substr($2, 0, $n); - if ($dec != 0) { - $str = $str . "." . $dec; - } - } - return $str; -} - -#----------------------------------------------------------------------------------- -# Graphics::setGradients -# création de gradient nommés Zinc -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# grads : <hastable> table de hash de définition de couleurs zinc -#----------------------------------------------------------------------------------- -sub setGradients { - my ($widget, $grads) = @_; - - # initialise les gradients de taches - unless (@Gradients) { - while (my ($name, $gradient) = each( %{$grads})) { - # création des gradients nommés - $widget->gname($gradient, $name); - push(@Gradients, $name); - } - } -} - - -#----------------------------------------------------------------------------------- -# Graphics::RGB_dec2hex -# conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff' -#----------------------------------------------------------------------------------- -# paramètres : -# rgb : <rgbColorList> liste de couleurs au format RGB -#----------------------------------------------------------------------------------- -sub RGB_dec2hex { - my (@rgb) = @_; - return (sprintf("#%04x%04x%04x", @rgb)); -} - -#----------------------------------------------------------------------------------- -# Graphics::pathGraduate -# création d'un jeu de couleurs dégradées pour item pathLine -#----------------------------------------------------------------------------------- -sub pathGraduate { - my ($widget, $numcolors, $style) = @_; - - my $type = $style->{'-type'}; - my $triangles_colors; - - if ($type eq 'linear') { - return &createGraduate($widget, $numcolors, $style->{'-colors'}, 2); - - } elsif ($type eq 'double') { - my $colors1 = &createGraduate($widget, $numcolors/2+1, $style->{'-colors'}->[0]); - my $colors2 = &createGraduate($widget, $numcolors/2+1, $style->{'-colors'}->[1]); - my @colors; - for (my $i = 0; $i <= $numcolors; $i++) { - push(@colors, ($colors1->[$i], $colors2->[$i])); - } - - return \@colors; - - } elsif ($type eq 'transversal') { - my ($c1, $c2) = @{$style->{'-colors'}}; - my @colors = ($c1, $c2); - for (my $i = 0; $i < $numcolors; $i++) { - push(@colors, ($c1, $c2)); - } - - return \@colors; - } -} - -#----------------------------------------------------------------------------------- -# Graphics::createGraduate -# création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs -#----------------------------------------------------------------------------------- -sub createGraduate { - my ($widget, $totalsteps, $refcolors, $repeat) = @_; - my @colors; - - $repeat = 1 if (!$repeat); - my $numgraduates = scalar @{$refcolors} - 1; - - if ($numgraduates < 1) { - print "Le dégradé necessite au minimum 2 couleurs de référence...\n"; - return undef; - } - - my $steps = ($numgraduates > 1) ? $totalsteps/($numgraduates -1) : $totalsteps; - - for (my $c = 0; $c < $numgraduates; $c++) { - my ($c1, $c2) = ($refcolors->[$c], $refcolors->[$c+1]); - - for (my $i = 0 ; $i < $steps ; $i++) { - my $color = MedianColor($c1, $c2, $i/($steps-1)); - for (my $k = 0; $k < $repeat; $k++) { - push (@colors, $color); - } - } - - if ($c < $numgraduates - 1) { - for (my $k = 0; $k < $repeat; $k++) { - pop @colors; - } - } - } - - return \@colors; -} - -#----------------------------------------------------------------------------------- -# Graphics::LightingColor -# modification d'une couleur par sa composante luminosité -#----------------------------------------------------------------------------------- -# paramètres : -# color : <color> couleur au format zinc -# newL : <pourcent> (de 0 à 1) nouvelle valeur de luminosité -#----------------------------------------------------------------------------------- -sub LightingColor { - my ($color, $newL) = @_; - my ($H, $L, $S); - - if ($color and $newL) { - my ($RGB) = &hexa2RGB($color); - ($H, $L, $S) = @{&RGBtoHLS(@{$RGB})}; - - - $newL = 1 if $newL > 1; - my ($nR, $nG, $nB) = @{&HLStoRGB($H, $newL, $S)}; - return &hexaRGBcolor($nR*255, $nG*255, $nB*255); - - } - - return undef; -} - - -#----------------------------------------------------------------------------------- -# Graphics::zincItemPredominantColor -# retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor) -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item zinc -#----------------------------------------------------------------------------------- -sub zincItemPredominantColor { - my ($widget, $item) = @_; - my $type = $widget->type($item); - - if ($type eq 'text' or '$type' eq 'icon') { - return $widget->itemcget($item, -color); - - } elsif ($type eq 'triangles' or - $type eq 'rectangle' or - $type eq 'arc' or - $type eq 'curve') { - - my @colors; - - if ($type eq 'triangles') { - @colors = $widget->itemcget($item, -colors); - - } else { - my $grad = $widget->itemcget($item, -fillcolor); - - return $grad if (scalar (my @unused = (split / /, $grad)) < 2); - - my @colorparts = split /\|/, $grad; - foreach my $section (@colorparts) { - if ($section !~ /=/) { - my ($color, $director, $position) = split / /, $section; - push (@colors, $color); - } - } - } - - - my ($Rs, $Gs, $Bs, $As, $numcolors) = (0, 0, 0, 0, 0); - foreach my $color (@colors) { - my ($r, $g, $b, $a) = ZnColorToRGB($color); - $Rs += $r; - $Gs += $g; - $Bs += $b; - $As += $a; - $numcolors++; - } - - my $newR = int($Rs/$numcolors); - my $newG = int($Gs/$numcolors); - my $newB = int($Bs/$numcolors); - my $newA = int($As/$numcolors); - - my $newcolor = &hexaRGBcolor($newR, $newG, $newB, $newA); - - return $newcolor - - } else { - return '#777777'; - } -} - -#----------------------------------------------------------------------------------- -# Graphics::MedianColor -# calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleurs -#----------------------------------------------------------------------------------- -# paramètres : -# color1 : <color> première couleur zinc -# color2 : <color> seconde couleur zinc -# rate : <pourcent> (de 0 à 1) position de la couleur intermédiaire -#----------------------------------------------------------------------------------- -sub MedianColor { - my ($color1, $color2, $rate) = @_; - $rate = 1 if ($rate > 1); - $rate = 0 if ($rate < 0); - - my ($r0, $g0, $b0, $a0) = &ZnColorToRGB($color1); - my ($r1, $g1, $b1, $a1) = &ZnColorToRGB($color2); - - my $r = $r0 + int(($r1 - $r0) * $rate); - my $g = $g0 + int(($g1 - $g0) * $rate); - my $b = $b0 + int(($b1 - $b0) * $rate); - my $a = $a0 + int(($a1 - $a0) * $rate); - - return &hexaRGBcolor($r, $g, $b, $a); -} - - -#----------------------------------------------------------------------------------- -# Graphics::ZnColorToRGB -# conversion d'une couleur Zinc au format RGBA (255,255,255,100) -#----------------------------------------------------------------------------------- -# paramètres : -# zncolor : <color> couleur au format hexa zinc (#ffffff ou #ffffffffffff) -#----------------------------------------------------------------------------------- -sub ZnColorToRGB { - my ($zncolor) = @_; - - my ($color, $alpha) = split /;/, $zncolor; - my $ndigits = (length($color) > 8) ? 4 : 2; - my $R = hex(substr($color, 1, $ndigits)); - my $G = hex(substr($color, 1+$ndigits, $ndigits)); - my $B = hex(substr($color, 1+($ndigits*2), $ndigits)); - - $alpha = 100 if (!defined $alpha or $alpha eq ""); - - return ($R, $G, $B, $alpha); - -} - -#----------------------------------------------------------------------------------- -# ALGORYTHMES DE CONVERSION ENTRE ESPACES DE COULEURS -#----------------------------------------------------------------------------------- -#----------------------------------------------------------------------------------- -# Graphics::RGBtoLCH -# Algorythme de conversion RGB -> CIE LCH° -#----------------------------------------------------------------------------------- -# paramètres : -# r : <pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB -# g : <pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB -# b : <pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB -#----------------------------------------------------------------------------------- -sub RGBtoLCH { - my ($r, $g, $b) = @_; - - # Conversion RGBtoXYZ - my $gamma = 2.4; - my $rgblimit = 0.03928; - - - $r = ($r > $rgblimit) ? (($r + 0.055)/1.055)**$gamma : $r / 12.92; - $g = ($g > $rgblimit) ? (($g + 0.055)/1.055)**$gamma : $g / 12.92; - $b = ($b > $rgblimit) ? (($b + 0.055)/1.055)**$gamma : $b / 12.92; - - $r *= 100; - $g *= 100; - $b *= 100; - - my $X = (0.4124 * $r) + (0.3576 * $g) + (0.1805 * $b); - my $Y = (0.2126 * $r) + (0.7152 * $g) + (0.0722 * $b); - my $Z = (0.0193 * $r) + (0.1192 * $g) + (0.9505 * $b); - - - # Conversion XYZtoLab - $gamma = 1/3; - my ($L, $A, $B); - - if ($Y == 0) { - ($L, $A, $B) = (0, 0, 0); - - } else { - - my ($Xs, $Ys, $Zs) = ($X/$Xw, $Y/$Yw, $Z/$Zw); - - $Xs = ($Xs > 0.008856) ? $Xs**$gamma : (7.787 * $Xs) + (16/116); - $Ys = ($Ys > 0.008856) ? $Ys**$gamma : (7.787 * $Ys) + (16/116); - $Zs = ($Zs > 0.008856) ? $Zs**$gamma : (7.787 * $Zs) + (16/116); - - $L = (116.0 * $Ys) - 16.0; - - $A = 500 * ($Xs - $Ys); - $B = 200 * ($Ys - $Zs); - - } - - # conversion LabtoLCH - my ($C, $H); - - - if ($A == 0) { - $H = 0; - - } else { - - $H = atan2($B, $A); - - if ($H > 0) { - $H = ($H / pi) * 180; - - } else { - $H = 360 - ( abs($H) / pi) * 180 - } - } - - - $C = sqrt($A**2 + $B**2); - - return [$L, $C, $H]; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::LCHtoRGB -# Algorythme de conversion CIE L*CH -> RGB -#----------------------------------------------------------------------------------- -# paramètres : -# L : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH -# C : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH -# H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur CIE LCH -#----------------------------------------------------------------------------------- -sub LCHtoRGB { - my ($L, $C, $H) = @_; - my ($a, $b); - - # Conversion LCHtoLab - $a = cos( deg2rad($H)) * $C; - $b = sin( deg2rad($H)) * $C; - - # Conversion LabtoXYZ - my $gamma = 3; - my ($X, $Y, $Z); - - my $Ys = ($L + 16.0) / 116.0; - my $Xs = ($a / 500) + $Ys; - my $Zs = $Ys - ($b / 200); - - - $Ys = (($Ys**$gamma) > 0.008856) ? $Ys**$gamma : ($Ys - 16 / 116) / 7.787; - $Xs = (($Xs**$gamma) > 0.008856) ? $Xs**$gamma : ($Xs - 16 / 116) / 7.787; - $Zs = (($Zs**$gamma) > 0.008856) ? $Zs**$gamma : ($Zs - 16 / 116) / 7.787; - - - $X = $Xw * $Xs; - $Y = $Yw * $Ys; - $Z = $Zw * $Zs; - - # Conversion XYZtoRGB - $gamma = 1/2.4; - my $rgblimit = 0.00304; - my ($R, $G, $B); - - - $X /= 100; - $Y /= 100; - $Z /= 100; - - $R = (3.2410 * $X) + (-1.5374 * $Y) + (-0.4986 * $Z); - $G = (-0.9692 * $X) + (1.8760 * $Y) + (0.0416 * $Z); - $B = (0.0556 * $X) + (-0.2040 * $Y) + (1.0570 * $Z); - - $R = ($R > $rgblimit) ? (1.055 * ($R**$gamma)) - 0.055 : (12.92 * $R); - $G = ($G > $rgblimit) ? (1.055 * ($G**$gamma)) - 0.055 : (12.92 * $G); - $B = ($B > $rgblimit) ? (1.055 * ($B**$gamma)) - 0.055 : (12.92 * $B); - - $R = ($R < 0) ? 0 : ($R > 1.0) ? 1.0 : &_trunc($R, 5); - $G = ($G < 0) ? 0 : ($G > 1.0) ? 1.0 : &_trunc($G, 5); - $B = ($B < 0) ? 0 : ($B > 1.0) ? 1.0 : &_trunc($B, 5); - - return [$R, $G, $B]; - -} - -#----------------------------------------------------------------------------------- -# Graphics::RGBtoHLS -# Algorythme de conversion RGB -> HLS -#----------------------------------------------------------------------------------- -# r : <pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB -# g : <pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB -# b : <pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB -#----------------------------------------------------------------------------------- -sub RGBtoHLS { - my ($r, $g, $b) = @_; - my ($H, $L, $S); - my ($min, $max, $diff); - - - $max = &max($r,$g,$b); - $min = &min($r,$g,$b); - - # calcul de la luminosité - $L = ($max + $min) / 2; - - # calcul de la saturation - if ($max == $min) { - # couleur a-chromatique (gris) $r = $g = $b - $S = 0; - $H = undef; - - return [$H, $L, $S]; - } - - # couleurs "Chromatiques" -------------------- - - # calcul de la saturation - if ($L <= 0.5) { - $S = ($max - $min) / ($max + $min); - - } else { - $S = ($max - $min) / (2 - $max - $min); - - } - - # calcul de la teinte - $diff = $max - $min; - - if ($r == $max) { - # couleur entre jaune et magenta - $H = ($g - $b) / $diff; - - } elsif ($g == $max) { - # couleur entre cyan et jaune - $H = 2 + ($b - $r) / $diff; - - } elsif ($b == $max) { - # couleur entre magenta et cyan - $H = 4 + ($r - $g) / $diff; - } - - # Conversion en degrés - $H *= 60; - - # pour éviter une valeur négative - if ($H < 0.0) { - $H += 360; - } - - return [$H, $L, $S]; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::HLStoRGB -# Algorythme de conversion HLS -> RGB -#----------------------------------------------------------------------------------- -# paramètres : -# H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur HLS -# L : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur HLS -# S : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur HLS -#----------------------------------------------------------------------------------- -sub HLStoRGB { - my ($H, $L, $S) = @_; - my ($R, $G, $B); - my ($p1, $p2); - - - if ($L <= 0.5) { - $p2 = $L + ($L * $S); - - } else { - $p2 = $L + $S - ($L * $S); - - } - - $p1 = 2.0 * $L - $p2; - - if ($S == 0) { - # couleur a-chromatique (gris) - # $R = $G = $B = $L - $R = $L; - $G = $L; - $B = $L; - - } else { - # couleurs "Chromatiques" - $R = &hlsValue($p1, $p2, $H + 120); - $G = &hlsValue($p1, $p2, $H); - $B = &hlsValue($p1, $p2, $H - 120); - - } - - return [$R, $G, $B]; - -} - -#----------------------------------------------------------------------------------- -# Graphics::hlsValue (sous fonction interne HLStoRGB) -#----------------------------------------------------------------------------------- -sub hlsValue { - my ($q1, $q2, $hue) = @_; - my $value; - - $hue = &r_modp($hue, 360); - - if ($hue < 60) { - $value = $q1 + ($q2 - $q1) * $hue / 60; - - } elsif ($hue < 180) { - $value = $q2; - - } elsif ($hue < 240) { - $value = $q1 + ($q2 - $q1) * (240 - $hue) / 60; - - } else { - $value = $q1; - - } - - return $value; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::hexaRGBcolor -# conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff' -#----------------------------------------------------------------------------------- -sub hexaRGBcolor { - my ($r, $g, $b, $a) = @_; - - if (defined $a) { - my $hexacolor = sprintf("#%02x%02x%02x", ($r, $g, $b)); - return ($hexacolor.";".$a); - } - - return (sprintf("#%02x%02x%02x", ($r, $g, $b))); -} - - - -sub hexa2RGB { - my ($hexastr) = @_; - my ($r, $g, $b); - - if ($hexastr =~ /(\w\w)(\w\w)(\w\w)/) { - $r = hex($1); - $g = hex($2); - $b = hex($3); - - return [$r/255, $g/255, $b/255] if (defined $r and defined $g and defined $b); - - } - - return undef; -} - -#----------------------------------------------------------------------------------- -# Graphics::max -# renvoie la valeur maximum d'une liste de valeurs -#----------------------------------------------------------------------------------- -sub max { - my (@values) = @_; - return undef if !scalar(@values); - - my $max = undef; - - foreach my $val (@values) { - if (!defined $max or $val > $max) { - $max = $val; - } - } - - return $max; -} - - -#----------------------------------------------------------------------------------- -# Graphics::min -# renvoie la valeur minimum d'une liste de valeurs -#----------------------------------------------------------------------------------- -sub min { - my (@values) = @_; - return undef if !scalar(@values); - - my $min = undef; - - foreach my $val (@values) { - if (!defined $min or $val < $min) { - $min = $val; - } - } - - return $min; -} - - -#----------------------------------------------------------------------------------- -# Graphics::r_modp -# fonction interne : renvoie le résultat POSITIF du modulo m d'un nombre x -#----------------------------------------------------------------------------------- -sub r_modp { - my ($x, $m) = @_; - - return undef if $m == 0; - - my $value = $x%$m; - - if ($value < 0.0) { - $value = $value + abs($m); - } - - return $value; - -} - - -1; - - -__END__ - diff --git a/Perl/Zinc/Graphics.pod b/Perl/Zinc/Graphics.pod deleted file mode 100644 index 579b6d7..0000000 --- a/Perl/Zinc/Graphics.pod +++ /dev/null @@ -1,1749 +0,0 @@ - -=head1 NAME - -Graphics : module Perl facilitant la creation d'objets graphiques complexes -par une description simplifiee. - - -=head1 SYNOPSIS - -use Graphics; - -&GraphicsFunction(@params, ?option => value?, ...); - -=head1 DESCRIPTION - -Z<> - -=head2 Fonctions exportées - -=head3 1. Création de composants graphiques - -=over - -=item B<o> buildZincItem(Z<>) - -=item B<o> repeatZincItem(Z<>) - -=item B<o> buildTabBoxItem(Z<>) - -=back - -=head3 2. Calculs de formes géométriques complexes - -=over - -=item B<o> roundedRectangleCoords(Z<>) - -=item B<o> hippodromeCoords(Z<>) - -=item B<o> ellipseCoords(Z<>) - -=item B<o> roundedCurveCoords(Z<>) - -=item B<o> polygonCoords(Z<>) - -=item B<o> polylineCoords(Z<>) - -=item B<o> curveLineCoords>(Z<>) - -=item B<o> pathLineCoords(Z<>) - -=item B<o> shiftPathCoords(Z<>) - -=item B<o> tabBoxCoords(Z<>) - -=back - -=head3 3. Création de relief et ombre portée - -=over - -=item B<o> graphicItemRelief(Z<>) - -=item B<o> graphicItemShadow(Z<>) - -=back - -=head3 4. Fonctions géométriques de base - -=over - -=item B<o> perpendicularPoint(Z<>) - -=item B<o> lineAngle(Z<>) - -=item B<o> vertexAngle(Z<>) - -=item B<o> arc_pts(Z<>) - -=item B<o> rad_point(Z<>) - -=item B<o> bezierCompute(Z<>) - -=item B<o> bezierSegment(Z<>) - -=item B<o> bezierPoint(Z<>) - -=back - -=head3 5. Gestion des ressources images - -=over - -=item B<o> getPattern(Z<>) - -=item B<o> getTexture(Z<>) - -=item B<o> getImage(Z<>) - -=item B<o> init_pixmaps(Z<>) - -=back - -=head3 6. Gestion des couleurs - -=over - -=item B<o> setGradiants(Z<>) - -=item B<o> zincItemPredominantColor(Z<>) - -=item B<o> ZnColorToRGB(Z<>) - -=item B<o> hexaRGBcolor(Z<>) - -=item B<o> createGraduate(Z<>) - -=item B<o> MedianColor(Z<>) - -=item B<o> LightingColor(Z<>) - -=item B<o> RGBtoLCH(Z<>) - -=item B<o> LCHtoRGB(Z<>) - -=item B<o> RGBtoHLS(Z<>) - -=item B<o> HLStoRGB(Z<>) - -=back - -Z<> - -=head2 1. Création de composants graphiques - - -=over - -=item B<buildZincItem>(widget, parentgroup, options); - -Creation d'items de representations Zinc. -Les objets graphiques generes peuvent etre complexes (geometrie, multi contours, -operateur de forme, empilage d'items, reliefs, ombre portee, repetition, -transformations...) mais sont decrits par des -options geometriques ou de surfacage 2D 1/2 de haut niveau. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget zinc. - -=item B<parentgroup> - -<tagOrId> identifiant de l'item group parent. - - -=back - - -=item B<Options> : - - -=over - -=item B<-itemtype> => type - -Specifie le(s) type(s) d'item(s) souhaite(s). Peut etre celui d'un item -natif zinc (B<group>, B<rectangle>, B<arc>, B<curve>, B<text>, B<icon>), -ou un B<'metatype'> permettant de specifier des curves 'particulieres'. Les sections coniques -de ces metatypes (raccords ou arcs) seront simulees par des segments quadratiques de bezier. Ces metatypes sont : - -=over - -=item roundedrectangle - -decrit par 2 cordonnees (haut-gauche et bas-droite du rectangle) et un rayon de raccord angulaire. -Une liste optionnelle de realisation des raccords [0 = sans raccord|1 = avec raccord] permet de specifier pour chaque angle le type de raccord -(angle ou arc). - -=item hippodrome - -decrit par 2 cordonnees (haut-gauche et bas-droite du rectangle englobant). -Si l'orientation n'est pas specifiee, le rayon de raccord sera egal a la moitie du plus petit cote . -Une liste optionnelle de realisation des raccords permet de specifier pour chaque angle le type de raccord -(angle ou arc). - -=item ellipse - -decrit par 2 cordonnees (haut-gauche et bas-droite du rectangle englobant). -Une liste optionnelle de realisation des raccords permet de specifier pour chaque angle le type de raccord -(angle ou arc). - -=item polygone - -polygone regulier a n cotes, (triangle equilateral, carre, pentagone, hexagone...) -convexe ou en etoile. Le polygone sera inscrit dans un cercle dont le rayon est passe en parametres -(un 2eme rayon 'interne' decrira un polygone etoile). Un rayon de raccord et une liste de realisation des raccords permettent -des variantes interressantes. - -=item roundedcurve - -curve multicontours a coins arrondis, de rayon raccord unique, -pour specifier une forme quelconque. - -=item polyline - -curve multicontours a coins arrondis. Le rayon de chaque raccord pouvant etre defini -specifiquement. - -=item pathline - -creation d'une ligne multisegments 'epaisse', -realisee par 'decalage' par rapport a un path donne (largeur et sens de decalage - [left|both|right] optionnels). Le contour transforme en surface avec l'item Zinc triangles -permet d'appliquer un degrade de couleurs le long du trace (lineaire, transversal ou double). - -=back - - -=item B<-coords> => \@xy - -<coords list> coordonnees geometriques ou de position de l'item. - -=item B<-metacoords> => \%metatype_params - -<hashtable> calcul des coordonnées de l'item par passage d'un [meta]type d'item -différent de celui décrit par -itemtype. (ex. un pathline défini par un polygone) - -<coords list> coordonnees geometriques ou de position de l'item. - -=item B<-params> => \%zinc_attr - -<hashtable> parametres zinc de l'item. - -=item B<-contours> => \@list - -<contours list> arguments zinc d'ajout de contours . - -=item B<-clip> - -<coords list or hashtable> clipping d'un item group. - -=item B<-items> - -<hashtable> table d'items contenus dans un item group. -provoque un appel récursif de la fonction buildZincItem(). - -=item B<-texture> - -<imagefile> ajout d'une texture a l'item. - -=item B<-pattern> - -<imagefile> ajout d'un pattern a l'item. - -=item B<-relief> - -<hash table> creation d'un relief a l'item a l'aide d'item zinc triangles. -Invoque la fonction du module Graphics graphicItemRelief() - -=item B<-shadow> - -<hash table> creation d'une ombre portee a l'item. -Invoque la fonction du module Graphics graphicItemShadow() - -=item B<-repeat> - -<hash table> repetition de l'item. -Invoque la fonction du module Graphics repeatZincItem() - -=item B<-scale> => scale factor or [xscale, yscale] - -application d'une transformation zinc->scale a l'item - -=item B<-translate> => [dx,dy] - - application d'une transformation zinc->translate a l'item - -=item B<-rotate> => <angle> (en degré) - -application d'une transformation zinc->rotate a l'item - -=item B<-addtags> - -<tags list> liste de tags specifiques a ajouter aux parametre item -tags. - -=item B<-name> - -<string> nom de l'item. - -=back - -=back - -Z<> - -=item B<repeatZincItem>(widget, item, options); - -Répétition (clonage) d'un objet Zinc de representation. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget zinc. - -=item B<item> - -<tagOrId> identifiant de l'item zinc a dupliquer. - -=back - -=item B<Options> : - -=over - -=item B<-num> => integer - -Nombre de répétitions. - -=item B<-dxy> => [dx, dy] - -Paramètres de translation a appliquer entre 2 copies. - -=item B<-angle> => <angle> - -angle de rotation en degré a appliquer entre 2 copies. - -=item B<-copytag> => <tag name> - -ajout d'un tag indexé pour chaque copie. - -=item B<-params> => \%zinc_attr - -Paramétrage specialises de chaque copie - - -=back - -=back - -Z<> - -=item B<buildTabBoxItem>(widget, parentgroup, options); - -Construit les items de représentation d'une boîte à onglets multi-pages. -Le positionnement, la forme et la taille des onglets est définie automatiquement -ou spécifiés par options. L'ajout de titres aux pages est possible. Des tags -de base (intercalaires et titres) permettent de définir des interactions de -sélection/navigation par bindings. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget zinc. - -=item B<parentgroup> - -<tagOrId> identifiant de l'item group parent. - -=back - -=item B<Options> : - -=over - -=item B<-coords> => [[x0,y0],[x1,y1]] - -<coords> coordonnées haut-gauche et bas-droite de la BoundingBox du tabBox. - -=item B<-numpages> - -<integer> nombre de pages du TabBox. - -=item B<-anchor> => 'n'|'e'|'s'|'w' - -ancrage nord, est, sud ou ouest des onglets (par défaut 'n') - -=item B<-alignment> => 'left'|'center'|'right' - -alignement gauche, centré ou droit des onglets sur l'ancrage (par défaut left) - -=item B<-tabwidth> => 'auto'|<dimension>|<dimensionList> - -longeur des onglets : 'auto' longeur répartie sur le coté, longeur absolue ou liste de longeurs -ces dimensions sont autoajustées si dépassement. (par défaut 'auto'). - -=item B<-tabheight> => 'auto'|<dimension> - -hauteur des onglets (par défaut 'auto') - -=item B<-tabshift> => 'auto'|<dimension> - -offset de biseau entre la base et le haut de l'onglet (par défaut 'auto'). - -=item B<-overlap> => 'auto'|<dimension> - -offset de décalage entre 2 onglets (par défaut 'auto'). - -=item B<-radius> - -<dimension> rayon des arrondis d'angle des onglets. (par défaut 0) - -=item B<-corners> - -<booleanList> liste d'application du raccord aux angles sous forme booleenne -0 = sans raccord 1 = avec raccord. - -=item B<-params> => \%zinc_attr - -<hashtable> parametres zinc de l'item. - -=item B<-texture> - -<imagefile> ajout d'une texture a l'item. - -=item B<-relief> - -<hash table> creation d'un relief pour les pages du tabBox. -Invoque la fonction du module Graphics graphicItemRelief() - -=item B<-tabtitles> - -<hashtable> table de hash de définition des titres d'onglets (label, params). - -=item B<-pageitems> - -<hashtable> table d'items 'complémentaire' à réaliser pour chaque page. -provoque un appel récursif de la fonction buildZincItem(). - - -=back - -=back - -=back - -Z<> - -=head2 2. Calculs de formes géométriques complexes - -=over - -=item B<roundedRectangleCoords>(coords, options); - -Retourne les coordonnées (curve) d'un rectangle à coins arrondis - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],[x1,y1]] - -<coordList> coordonnées haut-gauche et bas-droite du rectangle. - -=back - -=item B<Options> : - -=over - -=item B<-radius> - -<dimension> rayon de raccord circulaire des angles. - -=item B<-corners> => \@cornersList - -Liste de réalisation des raccords de sommets [0 = pad de raccord (droit)| 1 = raccord circulaire]. -(par défaut [1,1,1,1]). - -=back - -=back - -Z<> - -=item B<hippodromeCoords>(coords, options); - -Retourne les coordonnées (curve) d'un hippodrome - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],[x1,y1]] - -<coordList> coordonnées haut-gauche et bas-droite du rectangle exinscrit à l'hippodrome. - -=back - -=item B<Options> : - -=over - -=item B<-orientation> => <horizontal|vertical> - -orientation forcée de l'hippodrome (sinon hauteur = plus petit coté). - -=item B<-corners> => \@cornersList - -Liste de réalisation des raccords de sommets [0 = pad de raccord (droit)| 1 = raccord circulaire]. -(par défaut [1,1,1,1]). - -=item B<-trunc> => <left|right|top|bottom|both> - -troncatures des cotés circulaires de l'hippodrome. - -=back - -=back - -Z<> - -=item B<ellipseCoords>(coords, options); - -Retourne les coordonnées (curve) d'une ellipse - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],[x1,y1]] - -<coordList> coordonnées haut-gauche et bas-droite du rectangle exinscrit. - -=back - -=item B<Options> : - -=over - -=item B<-corners> => \@cornersList - -Liste de réalisation des quadrants [0 = angle droit| 1 = raccord d'ellipse]. -(par défaut [1,1,1,1]). - -=back - -=back - -Z<> - -=item B<roundedCurveCoords>(coords, options); - -Retourne les coordonnées d'une curve à coins arrondis. - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],...[xn,yn]] - -<coordList> coordonnées de la curve - -=back - -=item B<Options> : - -=over - -B<-radius> : <dimension> -rayon de raccord des angles. par defaut 0 - -B<-corners> : <booleanList> -liste d'application du raccord circulaire aux angles sous forme booleenne -0 = sans raccord 1 = avec raccord. par defaut [1,1,...,1]. - -=back - -=back - -Z<> - -=item B<polygonCoords>(coords, options); - -Retourne les coordonnées d'un polygone régulier à n cotés ou d'une étoile à -n branches. Le polygone sera inscrit dans un cercle de rayon -radius, un 2ème -rayon interne décrira les sommets interne de l'étoile. Raccords circulaires -optionnels des sommets du polygone/étoile - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [x0,y0] - -<coords> coordonnées du centre du cercle exinscrit au polygone/étoile - -=back - -=item B<Options> : - -=over - -B<-numsides> : <dimension> nombre de cote du polygone ou nombre de branches de l'etoile - -B<-radius> : <dimension> rayon du cercle exinscrit au polygone - -B<-startangle> : <angle> angle de depart du trace de la figure - -B<-inner_radius> : <dimension> rayon du cercle des points 'internes' de l'etoile - -B<-corner_radius> : <dimension> rayon des raccords d'angles - -B<-corners> : <booleanList> liste d'application du raccord aux angles sous forme booleenne -0 = sans raccord 1 = avec raccord. par defaut [1,1,1,1]. - -=back - -=back - -Z<> - -=item B<polylineCoords>(coords, options); - -Retourne les coordonnées d'une polyline, ligne 'brisée' multi-segments -avec raccords angulaires optionnels. - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],...[xn,yn]] - -<coordList> liste de coordonnées des sommets de la polyline - -=back - -=item B<Options> : - -=over - -B<-radius> : <dimension> -rayon global de raccord des angles. par defaut 0 - -B<-corners> : <booleanList> -liste d'application du raccord circulaire aux angles sous forme booleenne -0 = sans raccord 1 = avec raccord. par defaut [1,1,...,1]. - -B<-corners_radius> : <dimensionList> -Liste des rayons de raccord des angles. - -=back - -=back - -Z<> - -=item B<curveLineCoords>(coords, options); - -ATTENTION FONCTION EN CHANTIER - -Retourne les coordonnées curve (de surface) d'un stroke. la ligne est décrite -le long d'un chemin et dessinée selon les attributs graphiques classiques 'stroke' -(style d'épaisseur, d'extremité, de jointure, de tiret...) - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],...[xn,yn]] - -<coordList> coordonnées de la curve - -=back - -=item B<Options> : - -=over - -B<-width> : <dimension> -épaisseur de la ligne. par defaut 1 - -B<-linecap> : <'butt'|'round'|'square'> -Forme des extrémités des tracés ouverts. - -B<-linejoin> : <'miter'|'round'|'bevel'> -Forme des sommets des tracés. - -B<-dasharray> : <'none'|motifList> -Spécification du tireté : none (aucun) ou liste de longueurs tiret,[espace],[tiret]... -permettant de définir le dessin du tireté (par défaut none) - -B<-dashoffset> : <dimension> -distance décalage de départ dans le dessin du tireté (par défaut 0) - -=back - -=back - -Z<> - -=item B<pathLineCoords>(coords, %options); - -retourne les coordonnées (triangles) d'une ligne multisegments 'epaisse', -realisee par 'décalage' par rapport à un path donné (largeur et sens de décalage - [out|center|in] optionnels). - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],...[xn,yn]] - -<coordList> liste de coordonnées du path - -=back - -=item B<Options> : - -=over - -B<-closed> : <boolean> -fermeture du tracé. par defaut 0 - -B<-shifting> : <'out'|'center'|'in'> -sens de décalage de l'épaisseur de contour : 'center' (1/2 décalage de chaque coté du path) 'out' (décalage externe) 'in' (décalage interne) par défaut 'center'. - -B<-width> : <dimension> -Largeur du décalage de ligne (par défaut 2). - -=back - -=back - -Z<> - -=item B<shiftPathCoords>(coords, %options); - -retourne les coordonnées curve de 'décalage' par rapport à un path donné. - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],...[xn,yn]] - -<coordList> liste de coordonnées du path - -=back - -=item B<Options> : - -=over - -B<-closed> : <boolean> -fermeture du tracé. par defaut 0 - -B<-shifting> : <'out'|'in'> -sens de décalage du path : 'out' (décalage externe) 'in' (décalage interne) par défaut 'out'. - -B<-width> : <dimension> -Largeur du décalage de ligne (par défaut 1). - -=back - -=back - -Z<> - -=item B<tabBoxCoords>(coords, options); - -Retourne les coordonnées de construction d'un TabBox (boîte à onglets) : liste de curve décrivant les 'pages' du TabBox et coordonnées de position des titres onglets. - -=over - -=item B<Parametres> : - -=over - -=item B<coords> => [[x0,y0],[x1,y1]] - -<coords> coordonnées haut-gauche et bas-droite de la BoundingBox du tabBox. - -=back - -=item B<Options> : - -=over - -B<-numpages> : <integer> nombre de pages du TabBox. - -B<-anchor> : <'n'|'e'|'s'|'w'> ancrage nord, est, sud ou ouest des onglets (par défaut 'n') - -B<-alignment> : <'left'|'center'|'right'> alignement gauche, centré ou droit des onglets sur l'ancrage (par défaut left) - -B<-tabwidth> : 'auto'|<dimension|dimensionList> longeur des onglets : 'auto' longeur répartie sur le coté, longeur absolue ou liste de longeurs -ces dimensions sont autoajustées si dépassement. (par défaut 'auto'). - -B<-tabheight> : 'auto'|<dimension> hauteur des onglets (par défaut 'auto') - -B<-tabshift> : 'auto'<dimension> offset de biseau entre la base et le haut de l'onglet (par défaut 'auto'). - -B<-overlap> : 'auto'<dimension> offset de décalage entre 2 onglets (par défaut 'auto'). - -B<-radius> : <dimension> -rayon des arrondis d'angle des onglets. (par défaut 0) - -B<-corners> : <booleanList> liste d'application du raccord aux angles sous forme booleenne -0 = sans raccord 1 = avec raccord. - -=back - -=back - -=back - -Z<> - -=head2 3. Création de reliefs et ombre portée - -Z<> - -=over - -=item B<graphicItemRelief>(widget, item, %options); - -Construit un relief à l'item géometrique -(qui peut etre multicontours) en utilisant des items zinc triangles. -Ce relief de type 'embossage' de forme possede un -profil (flat ou rounded) et dérive en luminosite la couleur dominante -de l'item (ou une couleur donnée) suivant l'orientation d'éclairage global zinc --lighangle (ou un angle de lumière donné). - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -identifiant du widget zinc. - -=item B<item> - -identifiant de l'item zinc à mettre en relief. - -=back - -=item B<Options> : - -=over - -B<-closed> : <boolean> fermeture (de forme) du relief (par défaut 1). - -B<-profil> : <'flat'|'rounded'> type de profil du relief (par défaut 'rounded'). - -B<-relief> : <'raised'|'sunken'> sens de l'embossage (par defaut 'raised'). - -B<-side> : <outside|inside> position externe ou interne du relief (defaut 'inside'). - -B<-color> : <color> couleur de base du relief (défaut couleur dominante de l'item). - -B<-smoothed> : <boolean> lissage des 'facettes' du relief (par defaut 1). - -B<-lightangle> : <angle> angle de la lumiere (par defaut attribut -lightangle du widget). - -B<-width> : <dimension> largeur du 'contour' relief. - -B<-fine> : <boolean> mode precision courbe de bezier (par defaut 0 : auto-ajustee). - -=back - -=back - -Z<> - -=item B<graphicItemShadow>(widget, item, %options); - -Cree une ombre portee a l'item geometrique -(qui peut etre multicontours) en utilisant des items zinc triangles et curve. -Cette ombre correspond a une projection de la forme en fonction -d'une distance (par defaut 10) d'une orientation lumineuse (par defaut la valeur -globale -lightangle du widget) et d'un 'grossissement' (par defaut 0). -Une largeur 'width' de perimetre de diffusion/diffraction lumineuse (par defaut 4) -qui permet de lisser le passage de l'ombre au fond, une couleur (par defaut black) -et une opacite (par defaut 50) completent la specification. - -=over - -B<Parametres> : - -=over - -B<widget> : <widget> identifiant du widget zinc - -B<item> : <tagOrId> identifiant de l'item zinc - -=back - -B<Options> : - -=over - -B<-opacity> : <percent> poucentage d'opacite de l'ombre (par defaut 50). - -B<-distance> : <dimension> distance de projection de l'ombre (par defaut 10). - -B<-enlarging> : <dimension> 'grossissement' cone de projection (defaut 0). - -B<-color> : <color> couleur de l'ombre (par defaut black). - -B<-lightangle> : <angle> angle de la lumiere (par defaut attribut -lightangle du widget). - -B<-width> : <dimension> largeur du perimetre de diffusion/diffraction (par defaut 4). - -=back - -=back - -=back - -Z<> - -=head2 4. Fonctions géométriques de base - -Z<> - -=over - -=item B<perpendicularPoint>(point, line); - -retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne. - -=over - -=item B<Parametres> : - -=over - -=item B<point> => [x, y] - -<coords> coordonnées du point de référence. - -=item B<line> => [[x0, y0],[x1, y1]] - -<coordsList> liste de coordonnées des deux points de la ligne de référence. - -=back - -=back - -Z<> - - -=item B<lineAngle>(startpoint, endpoint); - -retourne l'angle formée par un vecteur, s'utilise aussi pour connaitre l'angle 'circulaire' -d'un point par rapport à un centre de référence. - -=over - -=item B<Parametres> : - -=over - -=item B<startpoint> => [x, y] - -<coords> coordonnées du point de départ du segment (ou centre de référence). - -=item B<endpoint> => [x, y] - -<coords> coordonnées du point de fin du segment (ou point 'circulaire' de référence). - -=back - -=back - -Z<> - -=item B<lineNormal>(startpoint, endpoint); - -retourne la valeur d'angle perpendiculaire à un vecteur (utilisée par exemple -pour mesurer l'incidence de lumière d'une facette). - -=over - -=item B<Parametres> : - -=over - -=item B<startpoint> => [x, y] - -<coords> coordonnées du point de départ du segment (ou centre de référence). - -=item B<endpoint> => [x, y] - -<coords> coordonnées du point de fin du segment (ou point 'circulaire' de référence). - -=back - -=back - -Z<> - -=item B<vertexAngle>(point0, point1, point2); - -retourne la valeur de l'angle formé par trois points ainsi que la valeur d'angle -de la bisectrice de l'angle (fonction utilisé pour les calculs de décalages de path. - -=over - -=item B<Parametres> : - -=over - -=item B<point0> => [x, y] - -<coords> coordonnées du premier point de définition de l'angle. - -=item B<point1> => [x, y] - -<coords> coordonnées du deuxième point de définition de l'angle (sommet). - -=item B<point2> => [x, y] - -<coords> coordonnées du troisième point de définition de l'angle. - - -=back - -=back - -Z<> - -=item B<arc_pts>(center, radius, %options); - -Calcul des points constitutifs d'un arc - -=over - -=item B<Parametres> : - -=over - -=item B<center> => [x0,y0] - -<coords> coordonnées du centre de l'arc. - -=item B<radius> - -<dimension> rayon de l'arc. - -=back - -=item B<Options> : - -=over - -=item B<-angle> - -<angle> angle de départ (en degré) de l'arc (par défaut 0) - -=item B<-extent> - -<angle> delta angulaire (en degré) de l'arc (par défaut 360) - -=item B<-step> - -<angle> pas de progression angulaire (en degré) de calcul des points (par défaut 10). - -=back - -=back - -Z<> - -=item B<rad_point>(center, radius, angle); - -Retourne le point circulaire défini par centre-rayon-angle. - -=over - -=item B<Parametres> : - -=over - -=item B<center> => [x0,y0] - -<coords> coordonnées du centre de l'arc. - -=item B<radius> - -<dimension> rayon de l'arc. - -=item B<angle> - -<angle> angle (en degré) du point de circonférence avec le centre du cercle. - -=back - -=back - -Z<> - -=item B<bezierSegment>(coords, %options); - -Calcul d'une approximation de segment (Quadratique ou Cubique) de bezier. - -=over - -=item B<Parametres> : - -=over - -=item B<coords> - -<coordsList> Liste de coordonnées des points définissant le segment de bezier. - -=back - -=item B<Options> : - -=over - -=item B<-tunits> - -<integer> nombre pas de division des segments bezier (par défaut 20) - -=item B<-skipend> - -<boolean> ne pas retourner le dernier point du segment (pour chaînage de segments). - -=back - -=back - -Z<> - -=item B<bezierPoint>(t, coords); - -Calcul d'un point du segment (Quadratique ou Cubique) de bezier. -t représentation du temps (de 0 à 1). -coords = (P1, C1, <C1>, P2) liste des points définissant le segment de bezier -P1 et P2 : extémités du segment et pts situés sur la courbe -C1 <C2> : point(s) de contrôle du segment - -courbe bezier niveau 2 sur (P1, P2, P3) P(t) = (1-t)²P1 + 2t(1-t)P2 + t²P3 - -courbe bezier niveau 3 sur (P1, P2, P3, P4) P(t) = (1-t)³P1 + 3t(1-t)²P2 + 3t²(1-t)P3 + t³P4 - -=over - -=item B<Parametres> : - -=over - -=item B<t> - -<pourcent> (de 0 à 1) représentation du temps. - -=item B<coords> - -<coordsList> Liste de coordonnées des points définissant le segment de bezier. - -=back - -=back - -Z<> - - -=item B<bezierCompute>(coords, %options); - -Calcul d'une approximation auto-ajustée de segment (Quadratique ou Cubique) de bezier. -l'approximation se fait par subdivision successive de la courbe jusqu'à atteindre une -distance avec la courbe théorique <= à la précision passée par option (par défaut 0.2). - -=over - -=item B<Parametres> : - -=over - -=item B<coords> - -<coordsList> Liste de coordonnées des points définissant le segment de bezier. - -=back - -=item B<Options> : - -=over - -=item B<-precision> - -<dimension> seuil limite du calcul d'approche de la courbe (par défaut .2) - -=item B<-skipend> - -<boolean> ne pas retourner le dernier point du segment (pour chaînage de segments). - -=back - -=back - -=back - -Z<> - -=head2 5. Gestion des ressources images - -Z<> - -=over - -=item B<getPattern>(filename, %options); - -retourne et partage la ressource image bitmap en l'initialisant et la stockant si première utilisation. - -=over - -=item B<Parametres> : - -=over - -=item B<filename> - -<image filename> non du fichier bitmap pattern - -=back - -=item B<Options> : - -=over - -=item B<-storage> - -<hashtable> référence de la table de stockage privée des patterns. - -=back - -=back - -Z<> - -=item B<getTexture>(widget, filename, %options); - -retourne et partage la ressource image texture en l'initialisant et la stockant si première utilisation. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget zinc. - -=item B<filename> - -<imagefile> non du fichier image texture - -=back - -=item B<Options> : - -=over - -=item B<-storage> - -<hashtable> référence de la table de stockage privée des textures. - -=back - -=back - -Z<> - -=item B<getImage>(widget, filename, %options); - -retourne et partage la ressource image en l'initialisant et la stockant si première utilisation. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget zinc. - -=item B<filename> - -<imagefile> non du fichier image - -=back - -=item B<Options> : - -=over - -=item B<-storage> - -<hashtable> référence de la table de stockage privée des images. - -=back - -=back - -Z<> - -=item B<init_pixmaps>(widget, filenames, %options); - -Initialise et stocke un ensemble d'images. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget zinc. - -=item B<filenames> - -<imagefileList> Liste des fichier images à initialiser. - -=back - -=item B<Options> : - -=over - -=item B<-storage> - -<hashtable> référence de la table de stockage privée des images. - -=back - -=back - -=back - -Z<> - -=head2 6. Gestion des couleurs - -Z<> - -=over - -=item B<setGradients>(widget, gradients); - -Création de gradiants nommés Zinc - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget Zinc - -=item B<gradients> - -<hashtable> référence de la table de définition des gradiants zinc ('non' => 'zincGradient'). - -=back - -=back - -Z<> - -=item B<zincItemPredominantColor>(widget, item); - -retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor). - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget Zinc - -=item B<item> - -<tagOrId> identifiant de l'item zinc. - -=back - -=back - -Z<> - -=item B<medianColor>(color1, color2, rate); - -calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleurs. - -=over - -=item B<Parametres> : - -=over - -=item B<color1> - -<color> première couleur - -=item B<color2> - -<color> première couleur - -=item B<rate> - -<pourcent> (de 0 à 1) position de la couleur intermédiaire. - -=back - -=back - -Z<> - -=item B<createGraduate>(widget, steps, refcolors, repeat); - -création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs. - -=over - -=item B<Parametres> : - -=over - -=item B<widget> - -<widget> identifiant du widget Zinc - -=item B<steps> - -<integer> nombre totale de couleurs retournées. - -=item B<refcolors> - -<colorList> liste de couleurs servant à créer le dégradé. - -=item B<repeat> - -<integer> répétition de chaque couleur utilisé par exemple pour triangles path -où la couleur est répétée 2 fois (par défaut 1). - -=back - -=back - -Z<> - -=item B<lightingColor>(color, newL); - -Modification d'une couleur par sa composante luminosité (exemple relief). - -=over - -=item B<Parametres> : - -=over - -=item B<color> - -<color> couleur au format zinc. - -=item B<newL> - -<pourcent> (de 0 à 1) nouvelle valeur de luminosité. - -=back - -=back - -Z<> - -=item B<ZnColorToRGB>(zncolor); - -conversion d'une couleur Zinc hexa au format RGBA (255,255,255,100). - -=over - -=item B<Parametres> : - -=over - -=item B<zncolor> - -<color> couleur au format hexa zinc (#ffffff ou #ffffffffffff). - -=back - -=back - -Z<> - -=item B<RGBtoLCH>(r, g, b); - -conversion d'une couleur de l'espace RGB à l'espace CIE LCH°. - -=over - -=item B<Parametres> : - -=over - -=item B<r> - -<pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB. - -=item B<g> - -<pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB. - -=item B<b> - -<pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB. - -=back - -=back - -Z<> - -=item B<LCHtoRGB>(L, C, H); - -conversion d'une couleur de l'espace CIE LCH° à l'espace RGB. - -=over - -=item B<Parametres> : - -=over - -=item B<L> - -<pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH. - -=item B<C> - -C : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH - -=item B<H> - -H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur CIE LCH - -=back - -=back - -Z<> - -=item B<RGBtoHLS>(r, g, b); - -conversion d'une couleur de l'espace RGB à l'espace HLS. - -=over - -=item B<Parametres> : - -=over - -=item B<r> - -<pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB. - -=item B<g> - -<pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB. - -=item B<b> - -<pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB. - -=back - -=back - -Z<> - -=item B<HLStoRGB>(H, L, S); - -conversion d'une couleur de l'espace HLS à l'espace RGB. - -=over - -=item B<Parametres> : - -=over - -=item B<H> - -<pourcent> (de 0 à 1) valeur de la composante teinte de la couleur HLS. - -=item B<L> - -C : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur HLS. - -=item B<S> - -H : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur HLS. - -=back - -=back - -Z<> - -=item B<hexaRGBcolor>(r, g, b, a); - -conversion d'une couleur RGBA (255,255,255,100) au format Zinc '#ffffff'. - -=over - -=item B<Parametres> : - -=over - -=item B<r> - -<colorComposant> (0 à 255) composante rouge de la couleur rgba. - -=item B<g> - -<colorComposant> (0 à 255) composante verte de la couleur rgba. - -=item B<b> - -<colorComposant> (0 à 255) composante bleue de la couleur rgba. - -=item B<a> - -<colorComposant> (0 à 255) composante alpha de la couleur rgba. - -=back - -=back - -Z<> - -=back - -Z<> - - -=head1 EXEMPLE - -my %gradset = ( - 'gdlens' => '=radial -15 -20|#ffb7b7;70|#bd6622;90', - 'gdstar' => '=radial -15 -20|#ffb7b7;50|#bd6622;90'); - -my %starstyle => ( - # table hash parametres et options - -itemtype => 'group', - -coords => [250, 250], - -params => {-priority => 90, - -tags => ['starlens', 'move'], - -sensitive => 1, - -atomic => 1, - }, - -items => { - 'lens' => {-itemtype => 'hippodrome', - -coords => [[-200, -200], - [200, 200]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'gdlens', - -linewidth => 1.5, - -linecolor => '#440000', - -priority => 10, - }, - -relief => {-width => 14, - -profil => 'rounded', - -lightangle => 135, - }, - -shadow => {-distance => 20, - -width => 18, - -lightangle => 135, - -opacity => 40, - -enlarging => 6, - }, - }, - 'star' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 5, - -radius => 180, - -inner_radius => 70, - -corner_radius => 10, - -startangle => 270, - -corners => [0,1,0,1,0,1,0,1,0,1], - -params => {-filled => 1, - -fillcolor => 'gradstar', - -linewidth => 1, - -linecolor => '#330000', - -priority => 20, - }, - -relief => {-width => 10, - -profil => 'rounded', - -side => 'outside', - -relief => 'sunken', - }, - }, - }, - ); - - -&setGradients($widget, \%gradset); - -my $star = &buildZincItem($zinc, $topgroup, \%starstyle); - -=head1 AUTEURS - -Jean-Luc Vinot <vinot@cena.fr> diff --git a/Perl/Zinc/Logo.pm b/Perl/Zinc/Logo.pm deleted file mode 100644 index 486c904..0000000 --- a/Perl/Zinc/Logo.pm +++ /dev/null @@ -1,238 +0,0 @@ -package Tk::Zinc::Logo; - -#--------------------------------------------------------------- -# -# Module : Logo.pm -# $Id$ -# -# Copyright (C) 2001-2003 -# Centre d'Études de la Navigation Aérienne -# Authors: Jean-Luc Vinot <vinot@cena.fr> -# -#--------------------------------------------------------------- - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use strict; -use Carp; -use Math::Trig; - - -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],[225.71,0],[251.34,0,'c'],[265.17,29.63,'c'], - [248.71,49.27],[202,105],[246,105],[246,87],[246,59.385,'c'],[268.38,37,'c'], - [296,37],[323.62,37,'c'],[346,59.385,'c'],[346,87],[346,148],[305,148], - [305,87],[305,82.58,'c'],[301.42,79,'c'],[297,79],[292.58,79,'c'], - [289,82.58,'c'],[289,87],[289,150],[251,150],[251,130],[251,125.58,'c'], - [247.42,122,'c'],[243,122],[243,122],[238.58,122,'c'],[235,125.58,'c'], - [235,130],[235,150],[168.12,150],[144.7,150,'c'],[132.38,122.57,'c'], - [147.94,105.06],[148,105],[120,105],[104,81],[104,105],[74,105],[74,41], - [52,41],[52,105],[20,105],[20,41],[0,41]], - - -contour => ['add', -1, [[395,78],[395,37],[364.62,37,'c'],[340,61.62,'c'],[340,92], - [340,93],[340,123.38,'c'],[364.62,148,'c'],[395,148],[409,148], - [409,107],[395,107],[386.72,107,'c'],[380,100.28,'c'],[380,92], - [380,93],[380,84.72,'c'],[386.72,78,'c'],[395,78]]], - - - -params => {-closed => 0, - -filled => 1, - -visible => 1, - -fillcolor => 'logoshape', - -linewidth => 2.5, - -linecolor => '#000000', - -priority => 40, - -fillrule => 'nonzero', - -tags => ['zinc_shape'], - }, - }, - - -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 %params = @_; - - my $self = {}; - bless ($self, $type); - if (exists $params{'-widget'}) { - $self->{'-widget'} = $params{'-widget'}; - } else { - croak "in Tk::Zinc::Logo constructor, the -widget attribute must be defined\n"; - } - $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'}}, - ); - - $zinc->contour($shape, @{$formstyle->{'-contour'}}); - - # 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; - -__END__ - -=head1 NAME - -Tk::Zinc::Logo - a perl module for drawing the TkZinc logo. - - -=head1 SYNOPSIS - - use Tk::Zinc::Logo; - my $zinc = MainWindow->new()->Zinc()->pack; - my $logo = $zinc->ZincLogo([options]); - - - -=head1 OPTIONS - -=over - -=item B<-parent> => zinc group - -Specify the parent group. Default is 1. - -=item B<-position> => [x, y] - -Specify the relative position of the logo in its parent group. Default is [0, 0]. - -=item B<-priority> => integer - -Specify the priority of the logo in its parent group. Default is 500. - -=item B<-scale> => [sx, sy] - -Scecify the xscale and yscale factors of the logo. Default is [1, 1]. - - -=back - - -=head1 AUTEUR - -Jean-Luc Vinot <vinot@cena.fr> - - - diff --git a/Perl/Zinc/Text.pm b/Perl/Zinc/Text.pm deleted file mode 100644 index 63e9573..0000000 --- a/Perl/Zinc/Text.pm +++ /dev/null @@ -1,262 +0,0 @@ -package Tk::Zinc::Text; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -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', '<B1-Motion>' => sub {extendSel($zinc)}); - $zinc->bind('text', '<Shift-B1-Motion>' => sub {extendSel($zinc)}); - $zinc->bind('text', '<Shift-1>' => sub { - my $e = $zinc->XEvent(); - my($x, $y) = ($e->x, $e->y); - $zinc->select('adjust', 'current', "\@$x,$y"); }); - $zinc->bind('text', '<Left>' => sub {moveCur($zinc, -1);}); - $zinc->bind('text', '<Right>' => sub {moveCur($zinc, 1);}); - $zinc->bind('text', '<Up>' => sub {setCur($zinc, 'up');}); - $zinc->bind('text', '<Down>' => sub {setCur($zinc, 'down');}); - $zinc->bind('text', '<Control-a>' => sub {setCur($zinc, 'bol');}); - $zinc->bind('text', '<Home>' => sub {setCur($zinc, 'bol');}); - $zinc->bind('text', '<Control-e>' => sub {setCur($zinc, 'eol');}); - $zinc->bind('text', '<End>' => sub {setCur($zinc, 'eol');}); - $zinc->bind('text', '<Meta-less>' => sub {setCur($zinc, 0);}); - $zinc->bind('text', '<Meta-greater>' => sub {setCur($zinc, 'end');}); - $zinc->bind('text', '<KeyPress>' => sub {insertKey($zinc);}); - $zinc->bind('text', '<Shift-KeyPress>' => sub {insertKey($zinc);}); - $zinc->bind('text', '<Return>' => sub { insertChar($zinc, chr(10)); }); - $zinc->bind('text', '<BackSpace>' => sub {textDel($zinc, -1)}); - $zinc->bind('text', '<Control-h>' => sub {textDel($zinc, -1)}); - $zinc->bind('text', '<Delete>' => 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<click 1> - -To set the cursor position - -=item B<click 2> - -To paste the current selection - -=item B<drag 1> - -To make a selection - -=item B<shift drag 1> - -To extend the current selection - -=item B<shift 1> - -To extend the current selection - -=item B<left arrow>, B<right arrow> - -To move the cursor to the left or to the right - -=item B<up arrow>, B<down arrow> - -To move the cursor up or down a line - -=item B<ctrl+a>, B<home> - -To move the cursor at the begining of the line - -=item B<ctrl+e>, B<end> - -To move the cursor at the end of the line - -=item B<meta+<>, B<meta+E<gt>> - -To move the cursor at the beginning / end of the text - -=item B<BackSpace>, B<ctrl+h> - -To delete the char just before the cursor - -=item B<Delete> - -To delete the char just after the cursor - -=item B<Return> - -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 <lecoanet@cena.fr> -(and some documentation by Christophe Mertz <mertz@cena.fr>) - -=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 MERCHANTABILITY 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 deleted file mode 100644 index f115171..0000000 --- a/Perl/Zinc/Trace.pm +++ /dev/null @@ -1,227 +0,0 @@ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in Tk/license.terms due to partial -# derivation from Tk8.0 sources. -# -# Copyright (c) 2002 CENA, C.Mertz <mert@cena.fr> to trace all -# Tk::Zinc methods calls as well as the args in a human readable -# form. Updated by D.Etienne. -# -# This package overloads the Tk::Methods function in order to trace -# every Tk::Zinc method call in your application. -# -# This may be very usefull when your application segfaults and -# when you have no idea where this happens in your code. -# -# $Id$ -# -# To trap Tk::Zinc errors, use rather the Tk::Zinc::TraceErrors package. -# -# for using this file do some thing like : -# perl -MTk::Zinc::Trace myappli.pl - -package Tk::Zinc::Trace; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use vars qw( $ForReplay ); - -use Tk; -use strict; -use Tk::Zinc::TraceUtils; - -my $WidgetMethodfunction; -my %moduleOptions; - - -BEGIN { - if (defined $ZincTraceErrors::on && $ZincTraceErrors::on == 1) { - print STDERR "Tk::Zinc::Trace: incompatible package Tk::Zinc::TraceErrors is already ". - "loaded (exit 1)\n"; - exit 1; - } - print "## Tk::Zinc::Trace ON\n"; - $ZincTrace::on = 1; - require Getopt::Long; - Getopt::Long::Configure('pass_through'); - Getopt::Long::GetOptions(\%moduleOptions, 'code'); - $ForReplay=1 if defined $moduleOptions{code} ; - select STDOUT; $|=1; ## for flushing the trace output - # save current Tk::Zinc::InitObject function; it will be invoked in - # overloaded one (see below) - use Tk; - use Tk::Zinc; - $WidgetMethodfunction = Tk::Zinc->can('WidgetMethod'); - -} - -print "## following trace should be very close to a replay-script code\n" if $ForReplay; - -my $ZincCounter= ""; -my %ZincHash; - -#sub Tk::Zinc { -# print "CREATING Zinc : @_"; -# &$ZincCreationMethodfunction; -#} - -sub Tk::Zinc::WidgetMethod { - my ($zinc, $name, @args) = @_; - if (defined $Tk::Zinc::Trace::off and $Tk::Zinc::Trace::off > 0) { - return &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - } - my ($package, $filename, $line) = caller(1); - $package="" unless defined $package; - $filename="" unless defined $filename; - $line="" unless defined $line; - my $widget; - if (defined $ZincHash{$zinc}) { - $widget = $ZincHash{$zinc}; - } elsif ($ZincCounter) { - $ZincHash{$zinc} = '$zinc'.$ZincCounter; - $widget = '$zinc'.$ZincCounter; - $ZincCounter++; - } else { - $ZincHash{$zinc} = '$zinc'; - $widget = '$zinc'; - $ZincCounter=1; # for the next zinc - } - - if ($ForReplay) { - print "$widget->$name"; - } else { - print "TRACE: $filename line $line $name"; - } - - &printList(@args); - # invoke function possibly overloaded in other modules - if (wantarray()) { - my @res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - if ($ForReplay) { - print ";\n"; - } else { - print " RETURNS "; - &printList (@res); - print "\n"; - } - $zinc->update; - return @res; - } else { - my $res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - if ($ForReplay) { - print ";\n"; - } else { - print " RETURNS "; - &printItem ($res); - print "\n"; - } - $zinc->update; - return $res; - } -} - -1; - - -__END__ - -=head1 NAME - -Tk::Zinc::Trace - A module to trace all Tk::Zinc method calls - -=head1 SYNOPSIS - -use Tk::Zinc::Trace; -$Tk::Zinc::Trace:ForReplay = 1; - -or - -perl -MTk::Zinc::Trace YourZincBasedScript.pl [--code] - -=head1 DESCRIPTION - -When loaded, this module overloads a Tk mechanism so that every -Tk::Zinc method call will be traced. Every call will also be followed by a -$zinc->update() so that the method call will be effectively treated. - -This module can be very effective for debugging when Tk::Zinc -core dumps and you have no clue which method call can be responsible for. If -you just want to trace Tk::Zinc errors when calling a method you -should rather use the Tk::Zinc::TraceErrors module - -The global variable $Tk::Zinc::Trace:off can be used to trace some specific blocks. If set to 1, traces are deactivated, if set to 0, traces are reactivated. - -If the global variable $Tk::Zinc::Trace:ForReplay is set or if the --code -option is set in the second form, the printout will be very close to re-executable -code, like this: - - ## following trace should be very close to a replay-script code - $zinc->configure(-relief => 'sunken', -borderwidth => 3, - -width => 700, -font => 10x20, -height => 600); - $zinc->add('rectangle', 1, [10, 10, 100, 50], - -fillcolor => 'green', -filled => 1, -linewidth => 10, - -relief => 'roundridge', -linecolor => 'darkgreen'); - $zinc->add('text', 1, -font => -adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-* => - -text => 'A filled rectangle with a "roundridge" relief border of 10 pixels.', - -anchor => 'nw', -position => [120, 20]); - $zinc->add('track', 1, 6, - -labelformat => 'x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2', - -position => [20, 120], -speedvector => [40, -10], -speedvectormark => 1, -speedvectorticks => 1); - $zinc->coords(4, [20, 120]); - - -If not (the default), the printout will be more informtative, giving -the following information: - -=over 6 - -=item * the source filename where the method has been invoked - -=item * the line number in the source file - -=item * the TkZinc method name - -=item * the list of arguments in a human-readable form - -=item * the returned value - -=back - -The trace will look like: - - ## Tk::Zinc::Trace ON - TRACE: /usr/lib/perl5/Tk/Widget.pm line 196 configure(-relief => 'sunken', -borderwidth => 3, -width => 700, -font => 10x20, -height => 600) RETURNS undef - TRACE: Perl/demos/demos/zinc_lib/items.pl line 21 add('rectangle', 1, [10, 10, 100, 50], -fillcolor => 'green', -filled => 1, -linewidth => 10, -relief => 'roundridge', -linecolor => 'darkgreen') RETURNS 2 - TRACE: Perl/demos/demos/zinc_lib/items.pl line 25 add('text', 1, -font => -adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-* => -text => 'A filled rectangle with a "roundridge" relief border of 10 pixels.', -anchor => 'nw', -position => [120, 20]) RETURNS 3 - TRACE: Perl/demos/demos/zinc_lib/items.pl line 36 add('track', 1, 6, -labelformat => 'x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2', -position => [20, 120], -speedvector => [40, -10], -speedvectormark => 1, -speedvectorticks => 1) RETURNS 4 - -=head1 AUTHOR - -C.Mertz <mertz@cena.fr> and D.Etienne <etienne@cena.fr> - -=head1 CAVEATS and BUGS - -This module cannot be used when Tk::Zinc::TraceErrors is already in use. - -As every Tk::Zinc method call is followed by an ->update call, this may -dramatically slowdown an application. The trade-off is between application -run-time and developper debug-time. - -When using an output "code-like" they are still part of the output which is -not executable code. However, the ouptut could be easily and manually -edited to be executable perl code. - -=head1 COPYRIGHT - -See Tk::Zinc copyright; LGPL - -=head1 SEE ALSO - -L<Tk::Zinc(3pm)>, L<Tk::Zinc::TraceErrors(3pm)>. L<Tk::Zinc::Debug(3pm)>. - -=cut diff --git a/Perl/Zinc/TraceErrors.pm b/Perl/Zinc/TraceErrors.pm deleted file mode 100644 index e74f28a..0000000 --- a/Perl/Zinc/TraceErrors.pm +++ /dev/null @@ -1,149 +0,0 @@ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in Tk/license.terms due to partial -# derivation from Tk8.0 sources. -# -# Copyright (c) 2003 CENA, D.Etienne <etienne@cena.fr> to trace all -# Tk::Zinc errors. -# -# This package overloads the Tk::Zinc::WidgetMethods function in order to -# to trap errors by calling every Tk::Zinc method in an eval() block. -# -# This may be very usefull when your application encounters errors such as -# "error .... at /usr/lib/perl5/Tk.pm line 228". With ZincTraceErrors, the -# module name, the line number and the complete error messages are reported -# for each error. -# -# $Id$ -# -# When you have no idea where this happens in your code or when your -# application segfaults, use the Tk::Zinc::Trace package which traces every -# Tk::Zinc method call. -# -# for using this file do some thing like : -# perl -MTk::Zinc::TraceErrors myappli.pl - -package Tk::Zinc::TraceErrors; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use strict; -use Tk::Zinc::TraceUtils; - -my $WidgetMethodfunction; -my $bold = "[1m"; -my $_bold = "[m"; - -BEGIN { - my $bold = "[1m"; - my $_bold = "[m"; - - if (defined $ZincTrace::on and $ZincTrace::on == 1) { - print STDERR $bold."Tk::Zinc::TraceErrors: incompatible package Tk::Zinc::Trace is already ". - "loaded".$_bold." (exit 1)\n"; - exit 1; - } - print $bold."Tk::Zinc::TraceErrors is ON".$_bold."\n"; - $ZincTraceErrors::on = 1; - select STDOUT; $|=1; ## for flushing the trace output - # save current Tk::Zinc::InitObject function; it will be invoked in - # overloaded one (see below) - use Tk; - use Tk::Zinc; - $WidgetMethodfunction = Tk::Zinc->can('WidgetMethod'); - -} - -sub Tk::Zinc::WidgetMethod { - my ($zinc, $name, @args) = @_; - my ($package, $filename, $line) = caller(1); - $package="" unless defined $package; - $filename="" unless defined $filename; - $line="" unless defined $line; - # invoke function possibly overloaded in other modules - my ($res, @res); - if (wantarray()) { - eval {@res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;}; - } else { - eval {$res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;}; - } - if ($@) { - print $bold."error:".$_bold." $filename line $line $name"; - &printList (@args); - my $msg = $@; - $msg =~ s/at .*//g; - print " ".$bold."returns".$_bold." $msg\n"; - } - if (wantarray()) { - return @res; - } else { - return $res; - } -} - - - -1; - - -__END__ - -=head1 NAME - -Tk::Zinc::TraceErrors - A module to trace all Tk::Zinc method calls which generate an error - -=head1 SYNOPSIS - -use Tk::Zinc::TraceErrors; - -or - -perl -MTk::Zinc::TraceErrors YourZincBasedScript.pl - -=head1 DESCRIPTION - -When loaded, this module overloads a Tk mechanism so that every -Tk::Zinc method call will be traced if it provokes an error. The execution -will then continue. - -This module can be very effective for debugging and application, specially -when Tk gives an unusuable error message such as ".... errors in Tk.pm line 228" - -=over 6 - -=item * the source filename where the method has been invoked - -=item * the line number in the source file - -=item * the TkZinc method name - -=item * the list of arguments in a human-readable form - -=item * the error message - -=back - -=head1 AUTHOR - -D.Etienne <etienne@cena.fr> and C.Mertz <mertz@cena.fr> - -=head1 CAVEAT - -This module cannot be used when Tk::Zinc::Trace is already in use. - -=head1 COPYRIGHT - -See Tk::Zinc copyright; LGPL - -=head1 SEE ALSO - -L<Tk::Zinc(3pm)>, L<Tk::Zinc::Trace(3pm)>. L<Tk::Zinc::Debug(3pm)>. - -=cut - diff --git a/Perl/Zinc/TraceUtils.pm b/Perl/Zinc/TraceUtils.pm deleted file mode 100644 index 8a3bc76..0000000 --- a/Perl/Zinc/TraceUtils.pm +++ /dev/null @@ -1,111 +0,0 @@ -package Tk::Zinc::TraceUtils; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Font; -use Tk::Photo; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(printItem printArray printList Item Array List); - -use strict; - -sub printItem { - print &Item (@_); -} - -sub printArray { - print &Array (@_); -} - -sub printList { - print &List (@_); -} - - -### to print something -sub Item { - my ($value) = @_; - my $ref = ref($value); -# print "VALUE=$value REF=$ref\n"; - if ($ref eq 'ARRAY') { - return Array ( @{$value} ); - } elsif ($ref eq 'CODE') { - return "{CODE}"; - } elsif ($ref eq 'Tk::Photo') { -# print " **** $value ***** "; - return "Tk::Photo(\"". scalar $value->cget('-file') . "\")"; - } elsif ($ref eq 'Tk::Font') { - return "'$value'"; - } elsif ($ref eq '') { # scalar - if (defined $value) { - if ($value =~ /^-?\d+(\.\d*(e[+-]?\d+)?)?$/ or # -1. or 1.0 - $value =~ /^-[a-zA-Z]([\w])*$/ # -option1 or -option-1 - ) { - return $value; - } elsif ($value eq '' - or $value =~ /\s/ - or $value =~ /^[a-zA-Z]/ - or $value =~ /^[\W]/ - ) { - return "'$value'"; - } else { - return $value; - } - } else { - return "_undef"; - } - } else { # some class instance - return $value; - } - -} # end Item - - -### to print a list of something -sub Array { - my (@values) = @_; - if (! scalar @values) { - return "[]"; - } - else { # the list is not empty - my $res = "["; - while (@values) { - my $value = shift @values; - $res .= &Item ($value); - $res .= ", " if (@values); - } - return $res. "]" ; - } - -} # end Array - - -sub List { - my $res = "("; - while (@_) { - my $v = shift @_; - $res .= Item ($v); - if (@_ > 0) { - ## still some elements - if ($v =~ /^-\d+$/) { - $res .= ", "; - } elsif ($v =~ /^-\w+$/) { - $res .= " => "; - } else { - $res .= ", "; - } - } - } - return $res. ")"; - -} # end List - - -1; - - - |