diff options
Diffstat (limited to 'Perl/Zinc/Graphics.pm')
-rw-r--r-- | Perl/Zinc/Graphics.pm | 2329 |
1 files changed, 2036 insertions, 293 deletions
diff --git a/Perl/Zinc/Graphics.pm b/Perl/Zinc/Graphics.pm index 5495cb5..e8ae2c2 100644 --- a/Perl/Zinc/Graphics.pm +++ b/Perl/Zinc/Graphics.pm @@ -7,7 +7,10 @@ #----------------------------------------------------------------------------------- # Functions to create complexe graphic component : # ------------------------------------------------ -# buildZincItem (realize a zinc item from description hash table) +# 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, @@ -15,19 +18,33 @@ # ----------------------------------------------------------------- # 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 : # ---------------------- @@ -36,60 +53,77 @@ # 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+)/); +package Graphics; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(&buildZincItem +@EXPORT = qw(&buildZincItem &repeatZincItem &buidTabBoxItem - &roundedRectangleCoords &hippodromeCoords &polygonCoords - &roundedCurveCoords &polylineCoords &tabBoxCoords &pathLineCoords + &roundedRectangleCoords &hippodromeCoords &polygonCoords &ellipseCoords + &roundedCurveCoords &polylineCoords &tabBoxCoords &pathLineCoords &shiftPathCoords - &perpendicularPoint &lineAngle &vertexAngle &rad_point &arc_pts + &perpendicularPoint &lineAngle &vertexAngle &rad_point &arc_pts &lineNormal + &curve2polylineCoords &curveItem2polylineCoords &bezierSegment &bezierCompute - &setGradients &getPattern &getTexture &getImage &init_pixmaps &hexaRGBcolor &createGraduate + &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 +# 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 -# paramètres : -# widget : <widget> -# parentgroup : <group> -# style : {hash table options} -# specific_tags : [list of specific tags] to add to params -tags -# name : <str> nom de l'item #----------------------------------------------------------------------------------- -# type d'item valide : +# 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 @@ -98,201 +132,475 @@ my %bitmaps; # 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 ($zinc, $parentgroup, $style, $specific_tags, $name) = @_; + my ($widget, $parentgroup, %options) = @_; $parentgroup = 1 if !$parentgroup; - my @tags = ($specific_tags) ? @{$specific_tags} : (); - my $params_tags; + my $itemtype = $options{'-itemtype'}; + my $coords = $options{'-coords'}; + my $params = $options{'-params'}; - if ($style->{'-params'}->{'-tags'}) { - $params_tags = delete $style->{'-params'}->{'-tags'}; - push (@tags, @{$params_tags}) if $params_tags; - } + return unless ($widget and $itemtype and ($coords or $options{'-metacoords'})); - my $itemtype = $style->{'-itemtype'}; - my $coords = $style->{'-coords'}; + my $name = ($options{'-name'}) ? $options{'-name'} : 'none'; - # création de l'item Zinc my $item; - - # gestion des polygones particuliers et à coin arrondi - if ($itemtype eq 'roundedrectangle') { - $itemtype = 'curve'; - $style->{'-params'}->{'-closed'} = 1; - $coords = &roundedRectangleCoords($coords, %{$style}); - - } elsif ($itemtype eq 'hippodrome') { + 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'; - $style->{'-params'}->{'-closed'} = 1; - $coords = &hippodromeCoords($coords, %{$style}); - } elsif ($itemtype eq 'polygone') { - $itemtype = 'curve'; - $style->{'-params'}->{'-closed'} = 1; - $coords = &polygonCoords($coords, %{$style}); + # possibilité de définir les coordonnées initiales par metatype + if ($options{'-metacoords'}) { + $options{'-coords'} = &metaCoords(%{$options{'-metacoords'}}); - } elsif ($itemtype eq 'roundedcurve' or $itemtype eq 'polyline') { - $itemtype = 'curve'; - if ($itemtype eq 'roundedcurve') { - $style->{'-params'}->{'-closed'} = 1; - $coords = &roundedCurveCoords($coords, %{$style}); + } - } else { - $coords = &polylineCoords($coords, %{$style}); - } - - # multi-contours - if ($style->{'-contours'}) { - my @contours = @{$style->{'-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, $coords, $radius, $corners, $corners_radius) = @{$contours[$i]}; - $radius = $style->{'-radius'} if (!defined $radius); - my $newcoords; - if ($itemtype eq 'roundedcurve') { - $newcoords = &roundedCurveCoords($coords, -radius => $radius, -corners => $corners); - } else { - $newcoords = &polylineCoords($coords, -radius => $radius, -corners => $corners, -corners_radius => $corners_radius); - } + # création d'une pathline à partir d'item zinc triangles + } elsif ($itemtype eq 'pathline') { - $style->{'-contours'}->[$i] = [$type, $way, $newcoords]; - } - } - } elsif ($itemtype eq 'pathline') { $itemtype = 'triangles'; - if ($style->{'-metacoords'}) { - $coords = &metaCoords(%{$style->{'-metacoords'}}); + if ($options{'-metacoords'}) { + $coords = &metaCoords(%{$options{'-metacoords'}}); } - if ($style->{'-graduate'}) { + if ($options{'-graduate'}) { my $numcolors = scalar(@{$coords}); - $style->{'-params'}->{'-colors'} = &pathGraduate($zinc, $numcolors, $style->{'-graduate'}); + $params->{'-colors'} = &pathGraduate($widget, $numcolors, $options{'-graduate'}); } - $coords = &pathLineCoords($coords, %{$style}); + $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 = $zinc->add($itemtype, - $parentgroup, - %{$style->{'-params'}}, - -tags => \@tags, - ); + $item = $widget->add($itemtype, + $parentgroup, + %{$params}); - $zinc->coords($item, $coords) if $coords; + $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 = $style->{'-params'}->{'-image'}; - $style->{'-params'}->{'-image'} = &init_pixmap($zinc, $imagefile) if $imagefile; + $imagefile = $params->{'-image'}; + my $image = &getImage($widget, $imagefile); + $params->{'-image'} = ($image) ? $image : ""; } - $item = $zinc->add($itemtype, + $item = $widget->add($itemtype, $parentgroup, -position => $coords, - %{$style->{'-params'}}, - -tags => \@tags, + %{$params}, ); - $style->{'-params'}->{'-image'} = $imagefile if $imagefile; + $params->{'-image'} = $imagefile if $imagefile; + + # ITEMS GEOMETRIQUES -> CURVE } else { - $item = $zinc->add($itemtype, - $parentgroup, - $coords, - %{$style->{'-params'}}, - -tags => \@tags, - ); - if ($itemtype eq 'curve' and $style->{'-contours'}) { - foreach my $contour (@{$style->{'-contours'}}) { - $zinc->contour($item, @{$contour}); + $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 ($style->{'-texture'}) { - my $texture = &getTexture($zinc, $style->{'-texture'}); - $zinc->itemconfigure($item, -tile => $texture) if $texture; + if ($options{'-texture'}) { + my $texture = &getTexture($widget, $options{'-texture'}); + $widget->itemconfigure($item, -tile => $texture) if $texture; } - if ($style->{'-fillpattern'}) { - my $bitmap = &getBitmap($style->{'-fillpattern'}); - $zinc->itemconfigure($item, -fillpattern => $bitmap) if $bitmap; + 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 - $zinc->scale($item, @{$style->{'-scale'}}) if ($style->{'-scale'}); + 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 - $zinc->rotate($item, deg2rad($style->{'-rotate'})) if ($style->{'-rotate'}); + $widget->rotate($item, deg2rad($options{'-rotate'})) if ($options{'-rotate'}); - # transformation scale de l'item si nécessaire - $zinc->translate($item, @{$style->{'-translate'}}) if ($style->{'-translate'}); + # 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; - # remise étét initial de la table de hash - $style->{'-params'}->{'-tags'} = $params_tags if ($params_tags); + if ($copytag) { + $tags[0] = $copytag.$i; + $clone = $widget->clone($item, -tags => \@tags); - return $item; + } 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 d'un autre type d'item -# paramètres : (options) -# -type : type de primitive utilisée -# -coords : coordonnées nécessitée par la fonction [type]Coords -# + options spécialisées passés à la fonction [type]Coords +# 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 @options = keys(%options); my $type = delete $options{'-type'}; my $coords = delete $options{'-coords'}; - if ($type eq 'polygone') { - $pts = &polygonCoords($coords, %options); + if ($type eq 'roundedrectangle') { + $pts = &roundedRectangleCoords($coords, %options); - } elsif ($type eq 'hyppodrome') { + } 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 : point centre du polygone +# coords : <coordsList> coordonnées bbox (haut-gauche et bas-droite) du rectangle # options : -# -radius : rayon de raccord d'angle -# -corners : liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1] +# -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 @options = keys(%options); my $radius = $options{'-radius'}; my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1]; @@ -362,14 +670,80 @@ sub roundedRectangleCoords { 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 : coordonnées du rectangle exinscrit +# coords : <coordsList> coordonnées bbox du rectangle exinscrit # options : -# -orientation : orientation forcée de l'ippodrome [horizontal|vertical] +# -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] #----------------------------------------------------------------------------------- @@ -378,7 +752,6 @@ sub hippodromeCoords { my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], $coords->[1]->[0], $coords->[1]->[1]); - my @options = keys(%options); my $orientation = ($options{'-orientation'}) ? $options{'-orientation'} : 'none'; # orientation forcée de l'hippodrome (sinon hippodrome sur le plus petit coté) @@ -413,20 +786,20 @@ sub hippodromeCoords { #----------------------------------------------------------------------------------- # Graphics::polygonCoords # calcul des coords d'un polygone régulier +#----------------------------------------------------------------------------------- # paramètres : -# coords : point centre du polygone +# coords : <coords> point centre du polygone # options : -# -numsides : nombre de cotés -# -radius : rayon de définition du polygone (distance centre-sommets) -# -inner_radius : rayon interne (polygone type étoile) -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] -# -corner_radius : rayon de raccord des cotés -# -startangle : angle de départ du polygone +# -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 @options = keys(%options); my $numsides = $options{'-numsides'}; my $radius = $options{'-radius'}; if ($numsides < 3 or !$radius) { @@ -434,7 +807,7 @@ sub polygonCoords { return undef; } - my ($cx, $cy) = ($coords) ? @{$coords} : (0, 0); + $coords = [0, 0] if (!defined $coords); my $startangle = ($options{'-startangle'}) ? $options{'-startangle'} : 0; my $anglestep = 360/$numsides; my $inner_radius = $options{'-inner_radius'}; @@ -442,17 +815,19 @@ sub polygonCoords { # points du polygone for (my $i = 0; $i < $numsides; $i++) { - my ($xp, $yp) = &rad_point($cx, $cy, $radius, $startangle + ($anglestep*$i)); + my ($xp, $yp) = &rad_point($coords, $radius, $startangle + ($anglestep*$i)); push(@pts, ([$xp, $yp])); # polygones 'étoiles' if ($inner_radius) { - ($xp, $yp) = &rad_point($cx, $cy, $inner_radius, $startangle + ($anglestep*($i+ 0.5))); + ($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 { @@ -466,14 +841,15 @@ sub polygonCoords { # Graphics::roundedAngle # THIS FUNCTION IS NO MORE USED, NEITHER EXPORTED # curve d'angle avec raccord circulaire +#----------------------------------------------------------------------------------- # paramètres : -# zinc : widget -# parentgroup : group zinc parent -# coords : les 3 points de l'angle -# radius : rayon de raccord +# 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 ($zinc, $parentgroup, $coords, $radius) = @_; + my ($widget, $parentgroup, $coords, $radius) = @_; my ($pt0, $pt1, $pt2) = @{$coords}; my ($corner_pts, $center_pts) = &roundedAngleCoords($coords, $radius); @@ -484,7 +860,7 @@ sub roundedAngle { $parentgroup = 1 if (!defined $parentgroup); - $zinc->add('curve', $parentgroup, + $widget->add('curve', $parentgroup, [$pt0,@{$corner_pts},$pt2], -closed => 0, -linewidth => 1, @@ -514,6 +890,9 @@ sub roundedAngle { # 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}; @@ -527,7 +906,7 @@ sub roundedAngleCoords { # point centre du cercle inscrit de rayon $radius my $refangle = ($angle < 180) ? $bisecangle+90 : $bisecangle-90; - my ($cx0, $cy0) = rad_point($pt1->[0], $pt1->[1], $delta, $refangle); + 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]); @@ -563,19 +942,19 @@ sub roundedAngleCoords { #----------------------------------------------------------------------------------- # Graphics::roundedCurveCoords # retourne les coordonnées d'une curve à coins arrondis +#----------------------------------------------------------------------------------- # paramètres : -# coords : points de la curve +# coords : <coordsList> liste de coordonnées des points de la curve # options : -# -radius : rayon de raccord d'angle -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] +# -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 @options = keys(%options); - my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0; + my $radius = (defined $options{'-radius'}) ? $options{'-radius'} : 0; my $corners = $options{'-corners'}; for (my $index = 0; $index < $numfaces; $index++) { @@ -600,19 +979,19 @@ sub roundedCurveCoords { #----------------------------------------------------------------------------------- # Graphics::polylineCoords # retourne les coordonnées d'une polyline +#----------------------------------------------------------------------------------- # paramètres : -# coords : sommets de la polyline +# coords : <coordsList> liste de coordonnées des sommets de la polyline # options : -# -radius : rayon global de raccord d'angle -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1], -# -corners_radius : liste des rayons de raccords de sommets +# -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 @options = keys(%options); my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0; my $corners_radius = $options{'-corners_radius'}; my $corners = ($corners_radius) ? $corners_radius : $options{'-corners'}; @@ -639,28 +1018,28 @@ sub polylineCoords { #----------------------------------------------------------------------------------- # Graphics::pathLineCoords # retourne les coordonnées d'une pathLine +#----------------------------------------------------------------------------------- # paramètres : -# coords : points de path +# coords : <coordsList> liste de coordonnées des points du path # options : -# -closed : ligne fermée -# -shifting : sens de décalage [both|left|right] par défaut both -# -linewidth : epaisseur de la ligne +# -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 @options = keys(%options); my $closed = $options{'-closed'}; - my $linewidth = ($options{'-linewidth'}) ? $options{'-linewidth'} : 0; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'both'; + 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 'both'); + $linewidth /= 2 if ($shifting eq 'center'); for (my $i = 0; $i < $numfaces; $i++) { my $pt = $coords->[$i]; @@ -676,14 +1055,14 @@ sub pathLineCoords { my $sin = sin(deg2rad($angle/2)); my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth; - if ($shifting eq 'left' or $shifting eq 'right') { - my $adding = ($shifting eq 'left') ? 90 : -90; - push (@pts, &rad_point($pt->[0], $pt->[1], $delta, $bisecangle + $adding)); + 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->[0], $pt->[1], $delta, $bisecangle+90)); - push (@pts, &rad_point($pt->[0], $pt->[1], $delta, $bisecangle-90)); + push (@pts, &rad_point($pt, $delta, $bisecangle-90)); + push (@pts, &rad_point($pt, $delta, $bisecangle+90)); } @@ -705,9 +1084,147 @@ sub pathLineCoords { } #----------------------------------------------------------------------------------- +# 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}; @@ -741,9 +1258,13 @@ sub perpendicularPoint { # 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 ($x, $y, $xref, $yref) = @_; - my $angle = atan2($y - $yref, $x - $xref); + my ($startpoint, $endpoint) = @_; + my $angle = atan2($endpoint->[1] - $startpoint->[1], $endpoint->[0] - $startpoint->[0]); $angle += pi/2; $angle *= 180/pi; @@ -754,16 +1275,39 @@ sub lineAngle { } +#----------------------------------------------------------------------------------- +# 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(@{$pt1}, @{$pt0}); - my $angle2 = &lineAngle(@{$pt1}, @{$pt2}); + my $angle1 = &lineAngle($pt0, $pt1); + my $angle2 = &lineAngle($pt2, $pt1); $angle2 += 360 if $angle2 < $angle1; my $alpha = $angle2 - $angle1; @@ -776,21 +1320,33 @@ sub vertexAngle { #----------------------------------------------------------------------------------- # Graphics::arc_pts # calcul des points constitutif d'un arc -# params : x,y centre, rayon, angle départ, delta angulaire, pas en degré +#----------------------------------------------------------------------------------- +# 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 ($x, $y, $rad, $angle, $extent, $step, $debug) = @_; - my @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($x, $y, $rad,$alpha); + 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($x, $y, $rad,$alpha)); + push (@pts, &rad_point($center, $radius, $alpha)); } } @@ -802,105 +1358,218 @@ sub arc_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 ($x, $y, $rad, $angle) = @_; + my ($center, $radius, $angle) = @_; my $alpha = deg2rad($angle); - my $xpt = $x + ($rad * cos($alpha)); - my $ypt = $y + ($rad * sin($alpha)); + my $xpt = $center->[0] + ($radius * cos($alpha)); + my $ypt = $center->[1] + ($radius * sin($alpha)); return ($xpt, $ypt); } #----------------------------------------------------------------------------------- -# Graphics::buildTabBox -# création des items Zinc d'un ensemble de page à onglet +# Graphics::curveItem2polylineCoords +# Conversion des coordonnées ZnItem curve (multicontours) en coordonnées polyline(s) #----------------------------------------------------------------------------------- -sub buidTabBox { - my ($zinc, $group, $style, $specific_tags,) = @_; +# 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)); - # création d'un groupe principal si besoin - my $groupstyle = delete $style->{'-group'}; - if ($groupstyle) { - $group = &buildZincItem($zinc, $group, $groupstyle); + 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); - } else { - $group = 1 if (!defined $group); } - # calcul des shapes - my $coords = $style->{'-coords'}; - my $params = $style->{'-params'}; - my $multi = $style->{'-multi'}; - my $titles = $style->{'-titles'}; + 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 ($shapes, $title_coords) = &computeDividers($coords,%{$style}); + my @poly; + my $previous; + my @bseg; + my $numseg = 0; + my $prevtype; - # création des intercalaires - my $i = scalar(@{$shapes}) - 1; - foreach my $shape (reverse @{$shapes}) { - if ($multi) { - while (my ($key, $values) = each(%{$multi})) { - $params->{$key} = $values->[$i]; + 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'; } } - # item zinc enveloppe intercalaire - my $intergroup = $zinc->add('group', $group); - my %interstyle = (-itemtype => 'curve', - -closed => 1, - -coords => $shape, - -params => $params, - ); - $interstyle{-texture} = $style->{'-texture'} if ($style->{'-texture'}); - my $inter = &buildZincItem($zinc, $intergroup, \%interstyle, $specific_tags); + $previous = $point; + } - # titre de l'onglet - if ($titles) { - my $params = $titles->{'-params'}; - $coords = ($titles->{'-coords'}) ? $titles->{'-coords'}->[$i] : $title_coords->[$i]; - $params->{'-text'} = $titles->{'-text'}->[$i]; - $zinc->add('text', $intergroup, - -position => $coords, - %{$params}, - ); - } - # zone page interne à l'intercalaire - if ($style->{'-page'}) { - &buildZincItem($zinc, $intergroup, $style->{'-page'}); + 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'}}); } - # items complémentaires - if ($style->{'-decos'}) { - while (my ($itemname, $itemstyle) = each(%{$style->{'-decos'}})) { - &buildZincItem($zinc, $intergroup, $itemstyle); - } + 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}); + } - $i--; + } + + return @tabs; } + #----------------------------------------------------------------------------------- # tabBoxCoords # Calcul des shapes de boites à onglets -# -# coords : coordonnées rectangle de la bounding box -# +#----------------------------------------------------------------------------------- +# paramètres : +# coords : <coordList> coordonnées haut-gauche bas-droite du rectangle englobant +# de la tabbox # options -# -numpages <n> : nombre de pages (onglets) de la boite -# -anchor [n|e|s|w] : ancrage des onglets -# -alignment [left|center|right] : alignement des onglets sur le coté d'ancrage -# -tabwidth [<n>|[<n1>,<n2>,<n3>...]|auto] : largeur des onglets -# -tabheight [<n>|auto] : hauteur des onglets -# -tabshift <n> : décalage onglet -# -radius <n> : rayon des arrondis d'angle -# -overlap <n> : distance de recouvrement des onglets +# -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; @@ -921,6 +1590,7 @@ sub tabBoxCoords { 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; @@ -1030,9 +1700,10 @@ sub tabBoxCoords { push (@pts, ([$xref + $dxy->[0], $yref + $dxy->[1]])); } - if ($radius) { - my $corners = ($i > 0 or !$align) ? [0, 1, 1, 1, 0, 1, 1, 0] : [0, 1, 1, 0, 1, 1, 0, 0, 0]; + 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); @@ -1057,80 +1728,643 @@ sub tabBoxCoords { } +#----------------------------------------------------------------------------------- +# 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; + + } + +} + #----------------------------------------------------------------------------------- -# RESOURCES GRAPHIQUES GRADIENTS, PATTERNS, TEXTURES, IMAGES... +# 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 #----------------------------------------------------------------------------------- -# Graphics::setGradients -# création de gradient nommés Zinc +# 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 setGradients { - my ($zinc, $grads) = @_; +sub bezierSegment { + my ($coords, %options) = @_; + my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20; + my $skipendpt = $options{'-skipend'}; - # initialise les gradients de taches - unless (@Gradients) { - while (my ($name, $gradient) = each( %{$grads})) { - # création des gradients nommés - $zinc->gname($gradient, $name); - push(@Gradients, $name); + 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 ($name) = @_; - my $bitmap; + my ($filename, %options) = @_; + my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? + $options{'-storage'} : \%bitmaps; - if (!exists($bitmaps{$name})) { - $bitmap = '@'.Tk::findINC($name); - $bitmaps{$name} = $bitmap; + if (!exists($table->{$filename})) { + my $bitmap = '@'.Tk::findINC($filename); + $table->{$filename} = $bitmap if $bitmap; - } else { - $bitmap = $bitmaps{$name}; } - return $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 ($zinc, $name) = @_; - my $texture; + my ($widget, $filename, %options) = @_; + my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? + $options{'-storage'} : \%textures; - if (!exists($textures{$name})) { - $texture = $zinc->Photo(-file => Tk::findINC($name)); - $textures{$name} = $texture; - - } else { - $texture = $textures{$name}; - } + return &getImage($widget, $filename, -storage => $table); - return $texture; } #----------------------------------------------------------------------------------- # 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, $imagefile) = @_; + 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; - if (!exists($images{$imagefile})) { - my $image = $widget->Photo(-file => Tk::findINC($imagefile)); - $images{$imagefile} = $image if $image; - return $image; } - return $images{$imagefile}; + return $table->{$filename}; } @@ -1139,19 +2373,30 @@ sub getImage { # 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, @pixfiles) = @_; - my @imgs = (); + my ($widget, $filenames, %options) = @_; + my @imgs = (); + my @files = (ref($filenames) eq 'ARRAY') ? @{$filenames} : ($filenames); - foreach (@pixfiles) { - push(@imgs, &getImage($widget, $_)); - } + foreach (@files) { + push(@imgs, &getImage($widget, $_, %options)); + } - return @imgs; + return @imgs; } +#----------------------------------------------------------------------------------- +# Graphics::_min +# retourne la plus petite valeur entre 2 valeurs +#----------------------------------------------------------------------------------- sub _min { my ($n1, $n2) = @_; my $mini = ($n1 > $n2) ? $n2 : $n1; @@ -1159,6 +2404,10 @@ sub _min { } +#----------------------------------------------------------------------------------- +# Graphics::_max +# retourne la plus grande valeur entre 2 valeurs +#----------------------------------------------------------------------------------- sub _max { my ($n1, $n2) = @_; my $maxi = ($n1 > $n2) ? $n1 : $n2; @@ -1187,11 +2436,35 @@ sub _trunc { 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)); @@ -1202,17 +2475,17 @@ sub RGB_dec2hex { # création d'un jeu de couleurs dégradées pour item pathLine #----------------------------------------------------------------------------------- sub pathGraduate { - my ($zinc, $numcolors, $style) = @_; + my ($widget, $numcolors, $style) = @_; my $type = $style->{'-type'}; my $triangles_colors; if ($type eq 'linear') { - return &createGraduate($zinc, $numcolors, $style->{'-colors'}, 2); + return &createGraduate($widget, $numcolors, $style->{'-colors'}, 2); } elsif ($type eq 'double') { - my $colors1 = &createGraduate($zinc, $numcolors/2+1, $style->{'-colors'}->[0]); - my $colors2 = &createGraduate($zinc, $numcolors/2+1, $style->{'-colors'}->[1]); + 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])); @@ -1253,7 +2526,7 @@ sub createGraduate { my ($c1, $c2) = ($refcolors->[$c], $refcolors->[$c+1]); for (my $i = 0 ; $i < $steps ; $i++) { - my $color = computeColor($widget, $c1, $c2, $i/($steps-1)); + my $color = MedianColor($c1, $c2, $i/($steps-1)); for (my $k = 0; $k < $repeat; $k++) { push (@colors, $color); } @@ -1265,21 +2538,117 @@ sub createGraduate { } } } + 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::computeColor -# calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleur +# Graphics::zincItemPredominantColor +# retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor) #----------------------------------------------------------------------------------- -sub computeColor { - my ($widget, $color0, $color1, $rate) = @_; +# 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 (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($color0); - my ($r1, $g1, $b1, $a1) = &ZnColorToRGB($color1); + 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); @@ -1289,6 +2658,14 @@ sub computeColor { 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) = @_; @@ -1305,6 +2682,290 @@ sub ZnColorToRGB { } #----------------------------------------------------------------------------------- +# 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' #----------------------------------------------------------------------------------- @@ -1316,8 +2977,90 @@ sub hexaRGBcolor { return ($hexacolor.";".$a); } - return (sprintf("#%02x%02x%02x ", ($r, $g, $b))); + 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) = @_; + my $value; + + return undef if $m == 0; + + my $value = $x%$m; + + if ($value < 0.0) { + $value = $value + abs($m); + } + + return $value; + +} + + 1; + +__END__ + |