diff options
Diffstat (limited to 'Perl/Zinc/Graphics.pm')
| -rw-r--r-- | Perl/Zinc/Graphics.pm | 3067 |
1 files changed, 0 insertions, 3067 deletions
diff --git a/Perl/Zinc/Graphics.pm b/Perl/Zinc/Graphics.pm deleted file mode 100644 index 8305c81..0000000 --- a/Perl/Zinc/Graphics.pm +++ /dev/null @@ -1,3067 +0,0 @@ -#----------------------------------------------------------------------------------- -# -# Graphics.pm -# some graphic design functions -# -#----------------------------------------------------------------------------------- -# Functions to create complexe graphic component : -# ------------------------------------------------ -# buildZincItem (realize a zinc item from description hash table -# management of enhanced graphics functions) -# -# repeatZincItem (duplication of given zinc item) -# -# Function to compute complexe geometrical forms : -# (text header of functions explain options for each form, -# function return curve coords using control points of cubic curve) -# ----------------------------------------------------------------- -# roundedRectangleCoords (return curve coords of rounded rectangle) -# hippodromeCoords (return curve coords of circus form) -# ellipseCoords (return curve coords of ellipse form) -# polygonCoords (return curve coords of regular polygon) -# roundedCurveCoords (return curve coords of rounded curve) -# polylineCoords (return curve coords of polyline) -# shiftPathCoords (return curve coords of shifting path) -# tabBoxCoords (return curve coords of tabBox's pages) -# pathLineCoords (return triangles coords of pathline) -# -# Function to compute 2D 1/2 relief and shadow : -# function build zinc items (triangles and curve) to simulate this -# ----------------------------------------------------------------- -# graphicItemRelief (return triangle items simulate relief of given item) -# polylineReliefParams (return triangle coords and lighting triangles color list) -# graphicItemShadow (return triangles and curve items simulate shadow of given item)) -# polylineShadowParams (return triangle and curve coords and shadow triangles color list)) -# -# Geometrical basic Functions : -# ----------------------------- -# perpendicularPoint -# lineAngle -# lineNormal -# vertexAngle -# arc_pts -# rad_point -# bezierCompute -# bezierSegment -# bezierPoint -# -# Pictorial Functions : -# ---------------------- -# setGradients -# getPattern -# getTexture -# getImage -# init_pixmaps -# zincItemPredominantColor -# ZnColorToRGB -# hexaRGBcolor -# createGraduate -# pathGraduate -# MedianColor -# LightingColor -# RGBtoLCH -# LCHtoRGB -# RGBtoHLS -# HLStoRGB -# -#----------------------------------------------------------------------------------- -# Authors: Jean-Luc Vinot <vinot@cena.fr> -# -# $Id$ -#----------------------------------------------------------------------------------- -package Tk::Zinc::Graphics; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(&buildZincItem &repeatZincItem &buidTabBoxItem - - &roundedRectangleCoords &hippodromeCoords &polygonCoords &ellipseCoords - &roundedCurveCoords &polylineCoords &tabBoxCoords &pathLineCoords &shiftPathCoords - - &perpendicularPoint &lineAngle &vertexAngle &rad_point &arc_pts &lineNormal - &curve2polylineCoords &curveItem2polylineCoords &bezierSegment &bezierCompute - - &graphicItemRelief &graphicItemShadow - - &setGradients &getPattern &getTexture &getImage &init_pixmaps - - &hexaRGBcolor &createGraduate &lightingColor &zincItemPredominantColor - &MedianColor &RGBtoLCH &LCHtoRGB &RGBtoHLS &HLStoRGB - ); - -use strict; -use Carp; -use Tk; -use Tk::PNG; -use Tk::JPEG; -use Math::Trig; - -# constante facteur point directeur (conique -> quadratique) -my $const_ptd_factor = .5523; - -# constante white point (conversion couleur espace CIE XYZ) -my ($Xw, $Yw, $Zw) = (95.047, 100.0, 108.883); - -# limite globale d'approximation courbe bezier -my $bezierClosenessThreshold = .2; - -# initialisation et partage de ressources couleurs et images -my @Gradients; -my %textures; -my %images; -my %bitmaps; - - - -#----------------------------------------------------------------------------------- -# Graphics::buildZincItem -# Création d'un objet Zinc de représentation -#----------------------------------------------------------------------------------- -# types d'items valides : -# les items natifs zinc : group, rectangle, arc, curve, text, icon -# les items ci-après permettent de spécifier des curves 'particulières' : -# -roundedrectangle : rectangle à coin arrondi -# -hippodrome : hippodrome -# -ellipse : ellipse un centre 2 rayons -# -polygone : polygone régulier à n cotés (convexe ou en étoile) -# -roundedcurve : curve multicontours à coins arrondis (rayon unique) -# -polyline : curve multicontours à coins arrondis (le rayon pouvant être défini -# spécifiquement pour chaque sommet) -# -pathline : création d'une ligne 'épaisse' avec l'item Zinc triangles -# décalage par rapport à un chemin donné (largeur et sens de décalage) -# dégradé de couleurs de la ligne (linéaire, transversal ou double) -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget Zinc -# parentgroup : <tagOrId> identifiant du group parent -# -# options : -# -itemtype : type de l'item à construire (type zinc ou metatype) -# -coords : <coords|coordsList> coordonnées de l'item -# -metacoords : <hastable> calcul de coordonnées par type d'item différent de -itemtype -# -contours : <contourList> paramètres multi-contours -# -params : <hastable> arguments spécifiques de l'item à passer au widget -# -addtags : [list of specific tags] to add to params -tags -# -texture : <imagefile> ajout d'une texture à l'item -# -pattern : <imagefile> ajout d'un pattern à l'item -# -relief : <hastable> création d'un relief à l'item invoque la fonction &graphicItemRelief() -# -shadow : <hastable> création d'une ombre portée à l'item invoque la fonction &graphicItemShadow() -# -scale : <scale_factor|[xscale_factor,yscale_factor]> application d'une transformation zinc->scale à l'item -# -translate : <[dx,dy]> application d'un transformation zinc->translate à l'item. -# -rotate : <angle> application d'une transformation zinc->rotate (en degré) à l'item -# -name : <str> nom de l'item -# spécifiques item group : -# -clip : <coordList|hashtable> paramètres de clipping d'un item group (coords ou item) -# -items : <hashtable> appel récursif de la fonction permettant d'inclure des items au groupe -#----------------------------------------------------------------------------------- -# -#----------------------------------------------------------------------------------- -sub buildZincItem { - my ($widget, $parentgroup, %options) = @_; - $parentgroup = 1 if !$parentgroup; - - my $itemtype = $options{'-itemtype'}; - my $coords = $options{'-coords'}; - my $params = $options{'-params'}; - - return unless ($widget and $itemtype and ($coords or $options{'-metacoords'})); - - my $name = ($options{'-name'}) ? $options{'-name'} : 'none'; - - my $item; - my $metatype; - my (@items, @reliefs, @shadows); - my @tags; - - - #-------------------- - # GEOMETRIE DES ITEMS - - # gestion des types d'items particuliers et à raccords circulaires - if ($itemtype eq 'roundedrectangle' - or $itemtype eq 'hippodrome' - or $itemtype eq 'polygone' - or $itemtype eq 'ellipse' - or $itemtype eq 'roundedcurve' - or $itemtype eq 'polyline' - or $itemtype eq 'curveline') { - - # par défaut la curve sera fermée -closed = 1 - $params->{'-closed'} = 1 if (!defined $params->{'-closed'}); - $metatype = $itemtype; - $itemtype = 'curve'; - - # possibilité de définir les coordonnées initiales par metatype - if ($options{'-metacoords'}) { - $options{'-coords'} = &metaCoords(%{$options{'-metacoords'}}); - - } - - # création d'une pathline à partir d'item zinc triangles - } elsif ($itemtype eq 'pathline') { - - $itemtype = 'triangles'; - if ($options{'-metacoords'}) { - $coords = &metaCoords(%{$options{'-metacoords'}}); - - } - - if ($options{'-graduate'}) { - my $numcolors = scalar(@{$coords}); - $params->{'-colors'} = &pathGraduate($widget, $numcolors, $options{'-graduate'}); - } - - $coords = &pathLineCoords($coords, %options); - - - # création d'une boite à onglet - } elsif ($itemtype eq 'tabbox') { - return &buildTabBoxItem($widget, $parentgroup, %options); - - } - - # calcul des coordonnées finales de la curve - $coords = &metaCoords(-type => $metatype, %options) if ($metatype); - - - # gestion du multi-contours (accessible pour tous les types d'items géometriques) - if ($options{'-contours'} and $metatype) { - my @contours = @{$options{'-contours'}}; - my $numcontours = scalar(@contours); - for (my $i = 0; $i < $numcontours; $i++) { - # radius et corners peuvent être défini spécifiquement pour chaque contour - my ($type, $way, $addcoords, $radius, $corners, $corners_radius) = @{$contours[$i]}; - $radius = $options{'-radius'} if (!defined $radius); - - my $newcoords = &metaCoords(-type => $metatype, - -coords => $addcoords, - -radius => $radius, - -corners => $corners, - -corners_radius => $corners_radius - ); - - $options{'-contours'}->[$i] = [$type, $way, $newcoords]; - } - } - - - #---------------------- - # REALISATION DES ITEMS - - # ITEM GROUP - # gestion des coordonnées et du clipping - if ($itemtype eq 'group') { - $item = $widget->add($itemtype, - $parentgroup, - %{$params}); - - $widget->coords($item, $coords) if $coords; - - # clipping du groupe par item ou par géometrie - if ($options{'-clip'}) { - my $clipbuilder = $options{'-clip'}; - my $clip; - - # création d'un item de clipping - if ($clipbuilder->{'-itemtype'}) { - $clip = &buildZincItem($widget, $item, %{$clipbuilder}); - - } elsif (ref($clipbuilder) eq 'ARRAY' or $widget->type($clipbuilder)) { - $clip = $clipbuilder; - } - - $widget->itemconfigure($item, -clip => $clip) if ($clip); - } - - # créations si besoin des items contenus dans le groupe - if ($options{'-items'} and ref($options{'-items'}) eq 'HASH') { - while (my ($itemname, $itemstyle) = each(%{$options{'-items'}})) { - $itemstyle->{'-name'} = $itemname if (!$itemstyle->{'-name'}); - &buildZincItem($widget, $item, %{$itemstyle}); - } - } - - - # ITEM TEXT ou ICON - } elsif ($itemtype eq 'text' or $itemtype eq 'icon') { - my $imagefile; - if ($itemtype eq 'icon') { - $imagefile = $params->{'-image'}; - my $image = &getImage($widget, $imagefile); - $params->{'-image'} = ($image) ? $image : ""; - } - - $item = $widget->add($itemtype, - $parentgroup, - -position => $coords, - %{$params}, - ); - - $params->{'-image'} = $imagefile if $imagefile; - - - # ITEMS GEOMETRIQUES -> CURVE - } else { - - $item = $widget->add($itemtype, - $parentgroup, - $coords, - %{$params}, - ); - - if ($itemtype eq 'curve' and $options{'-contours'}) { - foreach my $contour (@{$options{'-contours'}}) { - $widget->contour($item, @{$contour}); - } - } - - # gestion du mode norender - if ($options{'-texture'}) { - my $texture = &getTexture($widget, $options{'-texture'}); - $widget->itemconfigure($item, -tile => $texture) if $texture; - } - - if ($options{'-pattern'}) { - my $bitmap = &getBitmap($options{'-pattern'}); - $widget->itemconfigure($item, -fillpattern => $bitmap) if $bitmap; - } - - } - - - # gestion des tags spécifiques - if ($options{'-addtags'}) { - my @tags = @{$options{'-addtags'}}; - - my $params_tags = $params->{'-tags'}; - push (@tags, @{$params_tags}) if $params_tags; - - $widget->itemconfigure($item, -tags => \@tags); - - } - - - #------------------------------- - # TRANSFORMATIONS ZINC DE L'ITEM - - # transformation scale de l'item si nécessaire - if ($options{'-scale'}) { - my $scale = $options{'-scale'}; - $scale = [$scale, $scale] if (ref($scale) ne 'ARRAY'); - $widget->scale($item, @{$scale}) ; - } - - # transformation rotate de l'item si nécessaire - $widget->rotate($item, deg2rad($options{'-rotate'})) if ($options{'-rotate'}); - - # transformation translate de l'item si nécessaire - $widget->translate($item, @{$options{'-translate'}}) if ($options{'-translate'}); - - - # répétition de l'item - if ($options{'-repeat'}) { - push (@items, $item, - &repeatZincItem($widget, $item, %{$options{'-repeat'}})); - } - - - #----------------------- - # RELIEF ET OMBRE PORTEE - - # gestion du relief - if ($options{'-relief'}) { - my $target = (@items) ? \@items : $item; - push (@reliefs, &graphicItemRelief($widget, $target, %{$options{'-relief'}})); - } - - # gestion de l'ombre portée - if ($options{'-shadow'}) { - my $target = (@items) ? \@items : $item; - push (@shadows, &graphicItemShadow($widget, $target, %{$options{'-shadow'}})); - } - - push(@items, @reliefs) if @reliefs; - push(@items, @shadows) if @shadows; - - return (@items) ? @items : $item; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::repeatZincItem -# Duplication (clonage) d'un objet Zinc de représentation -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item source -# options : -# -num : <n> nombre d'item total (par defaut 2) -# -dxy : <[dx, dy]> translation entre 2 duplications (par defaut [0,0]) -# -angle : <angle> rotation entre 2 duplications -# -copytag : <sting> ajout d'un tag indexé pour chaque copie -# -params : <hashtable> {clef => [value list]}> valeur de paramètre de chaque copie -#----------------------------------------------------------------------------------- -sub repeatZincItem { - my ($widget, $item, %options) = @_; - my @clones; - - # duplication d'une liste d'items -> appel récursif - if (ref($item) eq 'ARRAY') { - foreach my $part (@{$item}) { - push (@clones, &repeatZincItem($widget, $part, %options)); - } - - return wantarray ? @clones : \@clones; - } - - my $num = ($options{'-num'}) ? $options{'-num'} : 2; - my ($dx, $dy) = (defined $options{'-dxy'}) ? @{$options{'-dxy'}} : (0, 0); - my $angle = $options{'-angle'}; - my $params = $options{'-params'}; - my $copytag = $options{'-copytag'}; - my @tags; - - if ($copytag) { - @tags = $widget->itemcget($item, -tags); - unshift (@tags, $copytag."0"); - $widget->itemconfigure($item, -tags => \@tags); - } - - for (my $i = 1; $i < $num; $i++) { - my $clone; - - if ($copytag) { - $tags[0] = $copytag.$i; - $clone = $widget->clone($item, -tags => \@tags); - - } else { - $clone = $widget->clone($item); - } - - push(@clones, $clone); - $widget->translate($clone, $dx*$i, $dy*$i); - $widget->rotate($clone, deg2rad($angle*$i)) if $angle; - - if ($params) { - while (my ($attrib, $value) = each(%{$params})) { - $widget->itemconfigure($clone, $attrib => $value->[$i]); - } - } - } - - return wantarray ? @clones : \@clones; - -} - - -#----------------------------------------------------------------------------------- -# FONCTIONS GEOMETRIQUES -#----------------------------------------------------------------------------------- - -#----------------------------------------------------------------------------------- -# Graphics::metaCoords -# retourne une liste de coordonnées en utilisant la fonction du type d'item spécifié -#----------------------------------------------------------------------------------- -# paramètres : (passés par %options) -# -type : <string> type de primitive utilisée -# -coords : <coordsList> coordonnées nécessitée par la fonction [type]Coords -# -# les autres options spécialisées au type seront passés à la fonction [type]coords -#----------------------------------------------------------------------------------- -sub metaCoords { - my (%options) = @_; - my $pts; - - my $type = delete $options{'-type'}; - my $coords = delete $options{'-coords'}; - - if ($type eq 'roundedrectangle') { - $pts = &roundedRectangleCoords($coords, %options); - - } elsif ($type eq 'hippodrome') { - $pts = &hippodromeCoords($coords, %options); - - } elsif ($type eq 'ellipse') { - $pts = &ellipseCoords($coords, %options); - - } elsif ($type eq 'roundedcurve') { - $pts = &roundedCurveCoords($coords, %options); - - } elsif ($type eq 'polygone') { - $pts = &polygonCoords($coords, %options); - - } elsif ($type eq 'polyline') { - $pts = &polylineCoords($coords, %options); - - } elsif ($type eq 'curveline') { - $pts = &curveLineCoords($coords, %options); - } - - return $pts; -} - - -#----------------------------------------------------------------------------------- -# Graphics::ZincItem2CurveCoords -# retourne une liste des coordonnées 'Curve' d'un l'item Zinc -# rectangle, arc ou curve -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item source -# options : -# -linear : <boolean> réduction à des segments non curviligne (par défaut 0) -# -realcoords : <boolean> coordonnées à transformer dans le groupe père (par défaut 0) -# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1) -#----------------------------------------------------------------------------------- -sub ZincItem2CurveCoords { - my ($widget, $item, %options) = @_; - - my $itemtype = $widget->type($item); - return unless ($itemtype); - - my $linear = $options{-linear}; - my $realcoords = $options{-realcoords}; - my $adjust = (defined $options{-adjust}) ? $options{-adjust} : 1; - - my @itemcoords = $widget->coords($item); - - my $coords; - my @multi; - - if ($itemtype eq 'rectangle') { - $coords = &roundedRectangleCoords(\@itemcoords, -radius => 0); - - } elsif ($itemtype eq 'arc') { - $coords = &ellipseCoords(\@itemcoords); - $coords = &curve2polylineCoords($coords, $adjust) if $linear; - - } elsif ($itemtype eq 'curve') { - my $numcontours = $widget->contour($item); - - if ($numcontours < 2) { - $coords = \@itemcoords; - $coords = &curve2polylineCoords($coords, $adjust) if $linear; - - - } else { - if ($linear) { - @multi = &curveItem2polylineCoords($widget, $item); - - } else { - for (my $contour = 0; $contour < $numcontours; $contour++) { - my @points = $widget->coords($item, $contour); - push (@multi, \@points); - } - } - - $coords = \@multi; - } - } - - if ($realcoords) { - my $parentgroup = $widget->group($item); - if (@multi) { - my @newcoords; - foreach my $points (@multi) { - my @transcoords = $widget->transform($item, $parentgroup, $points); - push(@newcoords, \@transcoords); - } - - $coords = \@newcoords; - - } else { - my @transcoords = $widget->transform($item, $parentgroup, $coords); - $coords = \@transcoords; - } - - } - - if (@multi) { - return (wantarray) ? @{$coords} : $coords; - } else { - return (wantarray) ? ($coords) : $coords; - } -} - -#----------------------------------------------------------------------------------- -# Graphics::roundedRectangleCoords -# calcul des coords du rectangle à coins arrondis -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> coordonnées bbox (haut-gauche et bas-droite) du rectangle -# options : -# -radius : <dimension> rayon de raccord d'angle -# -corners : <booleanList> liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1] -#----------------------------------------------------------------------------------- -sub roundedRectangleCoords { - my ($coords, %options) = @_; - my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], - $coords->[1]->[0], $coords->[1]->[1]); - - my $radius = $options{'-radius'}; - my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1]; - - # attention aux formes 'négatives' - if ($xn < $x0) { - my $xs = $x0; - ($x0, $xn) = ($xn, $xs); - } - if ($yn < $y0) { - my $ys = $y0; - ($y0, $yn) = ($yn, $ys); - } - - my $height = &_min($xn -$x0, $yn - $y0); - - if (!defined $radius) { - $radius = int($height/10); - $radius = 3 if $radius < 3; - } - - if (!$radius or $radius < 2) { - return [[$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]]; - - } - - - # correction de radius si necessaire - my $max_rad = $height; - $max_rad /= 2 if (!defined $corners); - $radius = $max_rad if $radius > $max_rad; - - # points remarquables - my $ptd_delta = $radius * $const_ptd_factor; - my ($x2, $x3) = ($x0 + $radius, $xn - $radius); - my ($x1, $x4) = ($x2 - $ptd_delta, $x3 + $ptd_delta); - my ($y2, $y3) = ($y0 + $radius, $yn - $radius); - my ($y1, $y4) = ($y2 - $ptd_delta, $y3 + $ptd_delta); - - # liste des 4 points sommet du rectangle : angles sans raccord circulaire - my @angle_pts = ([$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]); - - # liste des 4 segments quadratique : raccord d'angle = radius - my @roundeds = ([[$x2, $y0],[$x1, $y0, 'c'],[$x0, $y1, 'c'],[$x0, $y2],], - [[$x0, $y3],[$x0, $y4, 'c'],[$x1, $yn, 'c'],[$x2, $yn],], - [[$x3, $yn],[$x4, $yn, 'c'],[$xn, $y4, 'c'],[$xn, $y3],], - [[$xn, $y2],[$xn, $y1, 'c'],[$x4, $y0, 'c'],[$x3, $y0],]); - - my @pts = (); - my $previous; - for (my $i = 0; $i < 4; $i++) { - if ($corners->[$i]) { - if ($previous) { - # on teste si non duplication de point - my ($nx, $ny) = @{$roundeds[$i]->[0]}; - if ($previous->[0] == $nx and $previous->[1] == $ny) { - pop(@pts); - } - } - push(@pts, @{$roundeds[$i]}); - $previous = $roundeds[$i]->[3]; - - } else { - push(@pts, $angle_pts[$i]); - } - } - - return \@pts; -} - -#----------------------------------------------------------------------------------- -# Graphics::ellipseCoords -# calcul des coords d'une ellipse -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> coordonnées bbox du rectangle exinscrit -# options : -# -corners : <booleanList> liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1] -#----------------------------------------------------------------------------------- -sub ellipseCoords { - my ($coords, %options) = @_; - my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], - $coords->[1]->[0], $coords->[1]->[1]); - - my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1]; - - # attention aux formes 'négatives' - if ($xn < $x0) { - my $xs = $x0; - ($x0, $xn) = ($xn, $xs); - } - if ($yn < $y0) { - my $ys = $y0; - ($y0, $yn) = ($yn, $ys); - } - - # points remarquables - my $dx = ($xn - $x0)/2 * $const_ptd_factor; - my $dy = ($yn - $y0)/2 * $const_ptd_factor; - my ($x2, $y2) = (($x0+$xn)/2, ($y0+$yn)/2); - my ($x1, $x3) = ($x2 - $dx, $x2 + $dx); - my ($y1, $y3) = ($y2 - $dy, $y2 + $dy); - - # liste des 4 points sommet de l'ellipse : angles sans raccord circulaire - my @angle_pts = ([$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]); - - # liste des 4 segments quadratique : raccord d'angle = arc d'ellipse - my @roundeds = ([[$x2, $y0],[$x1, $y0, 'c'],[$x0, $y1, 'c'],[$x0, $y2],], - [[$x0, $y2],[$x0, $y3, 'c'],[$x1, $yn, 'c'],[$x2, $yn],], - [[$x2, $yn],[$x3, $yn, 'c'],[$xn, $y3, 'c'],[$xn, $y2],], - [[$xn, $y2],[$xn, $y1, 'c'],[$x3, $y0, 'c'],[$x2, $y0],]); - - my @pts = (); - my $previous; - for (my $i = 0; $i < 4; $i++) { - if ($corners->[$i]) { - if ($previous) { - # on teste si non duplication de point - my ($nx, $ny) = @{$roundeds[$i]->[0]}; - if ($previous->[0] == $nx and $previous->[1] == $ny) { - pop(@pts); - } - } - push(@pts, @{$roundeds[$i]}); - $previous = $roundeds[$i]->[3]; - - } else { - push(@pts, $angle_pts[$i]); - } - } - - return \@pts; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::hippodromeCoords -# calcul des coords d'un hippodrome -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> coordonnées bbox du rectangle exinscrit -# options : -# -orientation : orientation forcée de l'hippodrome [horizontal|vertical] -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] -# -trunc : troncatures [left|right|top|bottom|both] -#----------------------------------------------------------------------------------- -sub hippodromeCoords { - my ($coords, %options) = @_; - my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1], - $coords->[1]->[0], $coords->[1]->[1]); - - my $orientation = ($options{'-orientation'}) ? $options{'-orientation'} : 'none'; - - # orientation forcée de l'hippodrome (sinon hippodrome sur le plus petit coté) - my $height = ($orientation eq 'horizontal') ? abs($yn - $y0) - : ($orientation eq 'vertical') ? abs($xn - $x0) : &_min(abs($xn - $x0), abs($yn - $y0)); - my $radius = $height/2; - my $corners = [1, 1, 1, 1]; - - if ($options{'-corners'}) { - $corners = $options{'-corners'}; - - } elsif ($options{'-trunc'}) { - my $trunc = $options{'-trunc'}; - if ($trunc eq 'both') { - return [[$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]]; - - } else { - $corners = ($trunc eq 'left') ? [0, 0, 1, 1] : - ($trunc eq 'right') ? [1, 1, 0, 0] : - ($trunc eq 'top') ? [0, 1, 1, 0] : - ($trunc eq 'bottom') ? [1, 0, 0, 1] : [1, 1, 1, 1]; - - } - } - - # l'hippodrome est un cas particulier de roundedRectangle - # on retourne en passant la 'configuration' à la fonction générique roundedRectangleCoords - return &roundedRectangleCoords($coords, -radius => $radius, -corners => $corners); -} - - -#----------------------------------------------------------------------------------- -# Graphics::polygonCoords -# calcul des coords d'un polygone régulier -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coords> point centre du polygone -# options : -# -numsides : <integer> nombre de cotés -# -radius : <dimension> rayon de définition du polygone (distance centre-sommets) -# -inner_radius : <dimension> rayon interne (polygone type étoile) -# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1] -# -corner_radius : <dimension> rayon de raccord des cotés -# -startangle : <angle> angle de départ en degré du polygone -#----------------------------------------------------------------------------------- -sub polygonCoords { - my ($coords, %options) = @_; - - my $numsides = $options{'-numsides'}; - my $radius = $options{'-radius'}; - if ($numsides < 3 or !$radius) { - print "Vous devez au moins spécifier un nombre de cotés >= 3 et un rayon...\n"; - return undef; - } - - $coords = [0, 0] if (!defined $coords); - my $startangle = ($options{'-startangle'}) ? $options{'-startangle'} : 0; - my $anglestep = 360/$numsides; - my $inner_radius = $options{'-inner_radius'}; - my @pts; - - # points du polygone - for (my $i = 0; $i < $numsides; $i++) { - my ($xp, $yp) = &rad_point($coords, $radius, $startangle + ($anglestep*$i)); - push(@pts, ([$xp, $yp])); - - # polygones 'étoiles' - if ($inner_radius) { - ($xp, $yp) = &rad_point($coords, $inner_radius, $startangle + ($anglestep*($i+ 0.5))); - push(@pts, ([$xp, $yp])); - } - } - - - @pts = reverse @pts; - - if ($options{'-corner_radius'}) { - return &roundedCurveCoords(\@pts, -radius => $options{'-corner_radius'}, -corners => $options{'-corners'}); - } else { - return \@pts; - } -} - - - -#----------------------------------------------------------------------------------- -# Graphics::roundedAngle -# THIS FUNCTION IS NO MORE USED, NEITHER EXPORTED -# curve d'angle avec raccord circulaire -#----------------------------------------------------------------------------------- -# paramètres : -# widget : identifiant du widget Zinc -# parentgroup : <tagOrId> identifiant de l'item group parent -# coords : <coordsList> les 3 points de l'angle -# radius : <dimension> rayon de raccord -#----------------------------------------------------------------------------------- -sub roundedAngle { - my ($widget, $parentgroup, $coords, $radius) = @_; - my ($pt0, $pt1, $pt2) = @{$coords}; - - my ($corner_pts, $center_pts) = &roundedAngleCoords($coords, $radius); - my ($cx0, $cy0) = @{$center_pts}; - - # valeur d'angle et angle formé par la bisectrice - my ($angle) = &vertexAngle($pt0, $pt1, $pt2); - - $parentgroup = 1 if (!defined $parentgroup); - - $widget->add('curve', $parentgroup, - [$pt0,@{$corner_pts},$pt2], - -closed => 0, - -linewidth => 1, - -priority => 20, - ); - -} - -#----------------------------------------------------------------------------------- -# Graphics::roundedAngleCoords -# calcul des coords d'un raccord d'angle circulaire -#----------------------------------------------------------------------------------- -# le raccord circulaire de 2 droites sécantes est traditionnellement réalisé par un -# arc (conique) du cercle inscrit de rayon radius tangent à ces 2 droites -# -# Quadratique : -# une approche de cette courbe peut être réalisée simplement par le calcul de 4 points -# spécifiques qui définiront - quelle que soit la valeur de l'angle formé par les 2 -# droites - le segment de raccord : -# - les 2 points de tangence au cercle inscrit seront les points de début et de fin -# du segment de raccord -# - les 2 points de controle seront situés chacun sur le vecteur reliant le point de -# tangence au sommet de l'angle (point secant des 2 droites) -# leur position sur ce vecteur peut être simplifiée comme suit : -# - à un facteur de 0.5523 de la distance au sommet pour un angle >= 90° et <= 270° -# - à une 'réduction' de ce point vers le point de tangence pour les angles limites -# de 90° vers 0° et de 270° vers 360° -# ce facteur sera légérement modulé pour recouvrir plus précisement l'arc correspondant -#----------------------------------------------------------------------------------- -# coords : <coordsList> les 3 points de l'angle -# radius : <dimension> rayon de raccord -#----------------------------------------------------------------------------------- -sub roundedAngleCoords { - my ($coords, $radius) = @_; - my ($pt0, $pt1, $pt2) = @{$coords}; - - # valeur d'angle et angle formé par la bisectrice - my ($angle, $bisecangle) = &vertexAngle($pt0, $pt1, $pt2); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($radius / $sin) : $radius; - - # point centre du cercle inscrit de rayon $radius - my $refangle = ($angle < 180) ? $bisecangle+90 : $bisecangle-90; - my ($cx0, $cy0) = rad_point($pt1, $delta, $refangle); - - # points de tangeance : pts perpendiculaires du centre aux 2 droites - my ($px1, $py1) = &perpendicularPoint([$cx0, $cy0], [$pt0, $pt1]); - my ($px2, $py2) = &perpendicularPoint([$cx0, $cy0], [$pt1, $pt2]); - - # point de controle de la quadratique - # facteur de positionnement sur le vecteur pt.tangence, sommet - my $ptd_factor = $const_ptd_factor; - if ($angle < 90 or $angle > 270) { - my $diffangle = ($angle < 90) ? $angle : 360 - $angle; - $ptd_factor -= (((90 - $diffangle)/90) * ($ptd_factor/4)) if $diffangle > 15 ; - $ptd_factor = ($diffangle/90) * ($ptd_factor + ((1 - $ptd_factor) * (90 - $diffangle)/90)); - } else { - my $diffangle = abs(180 - $angle); - $ptd_factor += (((90 - $diffangle)/90) * ($ptd_factor/3)) if $diffangle > 15; - } - - # delta xy aux pts de tangence - my ($d1x, $d1y) = (($pt1->[0] - $px1) * $ptd_factor, ($pt1->[1] - $py1) * $ptd_factor); - my ($d2x, $d2y) = (($pt1->[0] - $px2) * $ptd_factor, ($pt1->[1] - $py2) * $ptd_factor); - - # les 4 points de l'arc 'quadratique' - my $corner_pts = [[$px1, $py1],[$px1+$d1x, $py1+$d1y, 'c'], - [$px2+$d2x, $py2+$d2y, 'c'],[$px2, $py2]]; - - - # retourne le segment de quadratique et le centre du cercle inscrit - return ($corner_pts, [$cx0, $cy0]); - -} - - -#----------------------------------------------------------------------------------- -# Graphics::roundedCurveCoords -# retourne les coordonnées d'une curve à coins arrondis -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points de la curve -# options : -# -radius : <dimension> rayon de raccord d'angle -# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1] -#----------------------------------------------------------------------------------- -sub roundedCurveCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @curve_pts; - - my $radius = (defined $options{'-radius'}) ? $options{'-radius'} : 0; - my $corners = $options{'-corners'}; - - for (my $index = 0; $index < $numfaces; $index++) { - if ($corners and !$corners->[$index]) { - push(@curve_pts, $coords->[$index]); - - } else { - my $prev = ($index) ? $index - 1 : $numfaces - 1; - my $next = ($index > $numfaces - 2) ? 0 : $index + 1; - my $anglecoords = [$coords->[$prev], $coords->[$index], $coords->[$next]]; - - my ($quad_pts) = &roundedAngleCoords($anglecoords, $radius); - push(@curve_pts, @{$quad_pts}); - } - } - - return \@curve_pts; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::polylineCoords -# retourne les coordonnées d'une polyline -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des sommets de la polyline -# options : -# -radius : <dimension> rayon global de raccord d'angle -# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1], -# -corners_radius : <dimensionList> liste des rayons de raccords de sommets -#----------------------------------------------------------------------------------- -sub polylineCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @curve_pts; - - my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0; - my $corners_radius = $options{'-corners_radius'}; - my $corners = ($corners_radius) ? $corners_radius : $options{'-corners'}; - - for (my $index = 0; $index < $numfaces; $index++) { - if ($corners and !$corners->[$index]) { - push(@curve_pts, $coords->[$index]); - - } else { - my $prev = ($index) ? $index - 1 : $numfaces - 1; - my $next = ($index > $numfaces - 2) ? 0 : $index + 1; - my $anglecoords = [$coords->[$prev], $coords->[$index], $coords->[$next]]; - - my $rad = ($corners_radius) ? $corners_radius->[$index] : $radius; - my ($quad_pts) = &roundedAngleCoords($anglecoords, $rad); - push(@curve_pts, @{$quad_pts}); - } - } - - return \@curve_pts; - -} - -#----------------------------------------------------------------------------------- -# Graphics::pathLineCoords -# retourne les coordonnées d'une pathLine -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points du path -# options : -# -closed : <boolean> ligne fermée -# -shifting : <out|center|in> sens de décalage du path (par défaut center) -# -linewidth : <dimension> epaisseur de la ligne -#----------------------------------------------------------------------------------- -sub pathLineCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @pts; - - my $closed = $options{'-closed'}; - my $linewidth = ($options{'-linewidth'}) ? $options{'-linewidth'} : 2; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'center'; - - return undef if (!$numfaces or $linewidth < 2); - - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - $linewidth /= 2 if ($shifting eq 'center'); - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth; - - if ($shifting eq 'out' or $shifting eq 'in') { - my $adding = ($shifting eq 'out') ? -90 : 90; - push (@pts, &rad_point($pt, $delta, $bisecangle + $adding)); - push (@pts, @{$pt}); - - } else { - push (@pts, &rad_point($pt, $delta, $bisecangle-90)); - push (@pts, &rad_point($pt, $delta, $bisecangle+90)); - - } - - if ($i == $numfaces - 2) { - $next = ($closed) ? $coords->[0] : - [$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - if ($closed) { - push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3])); - } - - return \@pts; -} - -#----------------------------------------------------------------------------------- -# Graphics::curveLineCoords -# retourne les coordonnées d'une curveLine -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points de la ligne -# options : -# -closed : <boolean> ligne fermée -# -shifting : <out|center|in> sens de décalage du contour (par défaut center) -# -linewidth : <dimension> epaisseur de la ligne -#----------------------------------------------------------------------------------- -sub curveLineCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - my @gopts; - my @backpts; - my @pts; - - my $closed = $options{'-closed'}; - my $linewidth = (defined $options{'-linewidth'}) ? $options{'-linewidth'} : 2; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'center'; - - return undef if (!$numfaces or $linewidth < 2); - - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - $linewidth /= 2 if ($shifting eq 'center'); - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth; - - if ($shifting eq 'out' or $shifting eq 'in') { - my $adding = ($shifting eq 'out') ? -90 : 90; - push (@pts, &rad_point($pt, $delta, $bisecangle + $adding)); - push (@pts, @{$pt}); - - } else { - @pts = &rad_point($pt, $delta, $bisecangle+90); - push (@gopts, \@pts); - @pts = &rad_point($pt, $delta, $bisecangle-90); - unshift (@backpts, \@pts); - } - - if ($i == $numfaces - 2) { - $next = ($closed) ? $coords->[0] : - [$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - push(@gopts, @backpts); - - if ($closed) { - push (@gopts, ($gopts[0], $gopts[1])); - } - - return \@gopts; -} - - -#----------------------------------------------------------------------------------- -# Graphics::shiftPathCoords -# retourne les coordonnées d'un décalage de path -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste de coordonnées des points du path -# options : -# -closed : <boolean> ligne fermée -# -shifting : <'out'|'in'> sens de décalage du path (par défaut out) -# -width : <dimension> largeur de décalage (par défaut 1) -#----------------------------------------------------------------------------------- -sub shiftPathCoords { - my ($coords, %options) = @_; - my $numfaces = scalar(@{$coords}); - - my $closed = $options{'-closed'}; - my $width = (defined $options{'-width'}) ? $options{'-width'} : 1; - my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'out'; - - return $coords if (!$numfaces or !$width); - - my @pts; - - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($width / $sin) : $width; - - my $adding = ($shifting eq 'out') ? -90 : 90; - my ($x, $y) = &rad_point($pt, $delta, $bisecangle + $adding); - push (@pts, [$x, $y]); - - - if ($i > $numfaces - 3) { - my $j = $numfaces - 1; - $next = ($closed) ? $coords->[0] : - [$pt->[0] + ($pt->[0] - $previous->[0]), $pt->[1] + ($pt->[1] - $previous->[1])]; - - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - return \@pts; -} - -#----------------------------------------------------------------------------------- -# Graphics::perpendicularPoint -# retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne -#----------------------------------------------------------------------------------- -# paramètres : -# point : <coords> coordonnées du point de référence -# line : <coordsList> coordonnées des 2 points de la ligne de référence -#----------------------------------------------------------------------------------- -sub perpendicularPoint { - my ($point, $line) = @_; - my ($p1, $p2) = @{$line}; - - # cas partiuculier de lignes ortho. - my $min_dist = .01; - if (abs($p2->[1] - $p1->[1]) < $min_dist) { - # la ligne de référence est horizontale - return ($point->[0], $p1->[1]); - - } elsif (abs($p2->[0] - $p1->[0]) < $min_dist) { - # la ligne de référence est verticale - return ($p1->[0], $point->[1]); - } - - my $a1 = ($p2->[1] - $p1->[1]) / ($p2->[0] - $p1->[0]); - my $b1 = $p1->[1] - ($a1 * $p1->[0]); - - my $a2 = -1.0 / $a1; - my $b2 = $point->[1] - ($a2 * $point->[0]); - - my $x = ($b2 - $b1) / ($a1 - $a2); - my $y = ($a1 * $x) + $b1; - - return ($x, $y); - -} - - -#----------------------------------------------------------------------------------- -# Graphics::lineAngle -# retourne l'angle d'un point par rapport à un centre de référence -#----------------------------------------------------------------------------------- -# paramètres : -# startpoint : <coords> coordonnées du point de départ du segment -# endpoint : <coords> coordonnées du point d'extremité du segment -#----------------------------------------------------------------------------------- -sub lineAngle { - my ($startpoint, $endpoint) = @_; - my $angle = atan2($endpoint->[1] - $startpoint->[1], $endpoint->[0] - $startpoint->[0]); - - $angle += pi/2; - $angle *= 180/pi; - $angle += 360 if ($angle < 0); - - return $angle; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::lineNormal -# retourne la valeur d'angle perpendiculaire à une ligne -#----------------------------------------------------------------------------------- -# paramètres : -# startpoint : <coords> coordonnées du point de départ du segment -# endpoint : <coords> coordonnées du point d'extremité du segment -#----------------------------------------------------------------------------------- -sub lineNormal { - my ($startpoint, $endpoint) = @_; - my $angle = &lineAngle($startpoint, $endpoint) + 90; - - $angle -= 360 if ($angle > 360); - return $angle; - -} - - - -#----------------------------------------------------------------------------------- -# Graphics::vertexAngle -# retourne la valeur de l'angle formée par 3 points -# ainsi que l'angle de la bisectrice -#----------------------------------------------------------------------------------- -# paramètres : -# pt0 : <coords> coordonnées du premier point de définition de l'angle -# pt1 : <coords> coordonnées du deuxième point de définition de l'angle -# pt2 : <coords> coordonnées du troisième point de définition de l'angle -#----------------------------------------------------------------------------------- -sub vertexAngle { - my ($pt0, $pt1, $pt2) = @_; - my $angle1 = &lineAngle($pt0, $pt1); - my $angle2 = &lineAngle($pt2, $pt1); - - $angle2 += 360 if $angle2 < $angle1; - my $alpha = $angle2 - $angle1; - my $bisectrice = $angle1 + ($alpha/2); - - return ($alpha, $bisectrice); -} - - -#----------------------------------------------------------------------------------- -# Graphics::arc_pts -# calcul des points constitutif d'un arc -#----------------------------------------------------------------------------------- -# paramètres : -# center : <coordonnées> centre de l'arc, -# radius : <dimension> rayon de l'arc, -# options : -# -angle : <angle> angle de départ en degré de l'arc (par défaut 0) -# -extent : <angle> delta angulaire en degré de l'arc (par défaut 360), -# -step : <dimension> pas de progresion en degré (par défaut 10) -#----------------------------------------------------------------------------------- -sub arc_pts { - my ($center, $radius, %options) = @_; - return unless ($radius); - - $center = [0, 0] if (!defined $center); - my $angle = (defined $options{'-angle'}) ? $options{'-angle'} : 0; - my $extent = (defined $options{'-extent'}) ? $options{'-extent'} : 360; - my $step = (defined $options{'-step'}) ? $options{'-step'} : 10; - my @pts = (); - - if ($extent > 0) { - for (my $alpha = $angle; $alpha <= ($angle + $extent); $alpha += $step) { - my ($xn, $yn) = &rad_point($center, $radius,$alpha); - push (@pts, ([$xn, $yn])); - } - } else { - for (my $alpha = $angle; $alpha >= ($angle + $extent); $alpha += $step) { - push (@pts, &rad_point($center, $radius, $alpha)); - } - } - - return @pts; -} - - -#----------------------------------------------------------------------------------- -# Graphics::rad_point -# retourne le point circulaire défini par centre-rayon-angle -#----------------------------------------------------------------------------------- -# paramètres : -# center : <coordonnée> coordonnée [x,y] du centre de l'arc, -# radius : <dimension> rayon de l'arc, -# angle : <angle> angle du point de circonférence avec le centre du cercle -#----------------------------------------------------------------------------------- -sub rad_point { - my ($center, $radius, $angle) = @_; - my $alpha = deg2rad($angle); - - my $xpt = $center->[0] + ($radius * cos($alpha)); - my $ypt = $center->[1] + ($radius * sin($alpha)); - - return ($xpt, $ypt); -} - - -#----------------------------------------------------------------------------------- -# Graphics::curveItem2polylineCoords -# Conversion des coordonnées ZnItem curve (multicontours) en coordonnées polyline(s) -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item source -# options : -# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20) -# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1) -#----------------------------------------------------------------------------------- -sub curveItem2polylineCoords { - my ($widget, $item, %options) = @_; - return unless ($widget and $widget->type($item)); - - my @coords; - my $numcontours = $widget->contour($item); - my $parentgroup = $widget->group($item); - - for (my $contour = 0; $contour < $numcontours; $contour++) { - my @points = $widget->coords($item, $contour); - my @contourcoords = &curve2polylineCoords(\@points, %options); - - push(@coords, \@contourcoords); - - } - - return wantarray ? @coords : \@coords; -} - -#----------------------------------------------------------------------------------- -# Graphics::curve2polylineCoords -# Conversion curve -> polygone -#----------------------------------------------------------------------------------- -# paramètres : -# points : <coordsList> liste des coordonnées curve à transformer -# options : -# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20) -# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1) -#----------------------------------------------------------------------------------- -sub curve2polylineCoords { - my ($points, %options) = @_; - - my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20; - my $adjust = (defined $options{'-adjust'}) ? $options{'-adjust'} : 1; - - my @poly; - my $previous; - my @bseg; - my $numseg = 0; - my $prevtype; - - foreach my $point (@{$points}) { - my ($x, $y, $c) = @{$point}; - if ($c eq 'c') { - push(@bseg, $previous) if (!@bseg); - push(@bseg, $point); - - } else { - if (@bseg) { - push(@bseg, $point); - - if ($adjust) { - my @pts = &bezierCompute(\@bseg, -skipend => 1); - shift @pts; - shift @pts; - push(@poly, @pts); - - } else { - my @pts = &bezierSegment(\@bseg, -tunits => $tunits, -skipend => 1); - shift @pts; - shift @pts; - push(@poly, @pts); - - } - - @bseg = (); - $numseg++; - $prevtype = 'bseg'; - - } else { - push(@poly, ([$x, $y])); - $prevtype = 'line'; - } - } - - $previous = $point; - } - - - return wantarray ? @poly : \@poly; -} - - -#----------------------------------------------------------------------------------- -# Graphics::buildTabBoxItem -# construit les items de représentations Zinc d'une boite à onglets -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# parentgroup : <tagOrId> identifiant de l'item group parent -# -# options : -# -coords : <coordsList> coordonnées haut-gauche et bas-droite du rectangle -# englobant du TabBox -# -params : <hastable> arguments spécifiques des items curve à passer au widget -# -texture : <imagefile> ajout d'une texture aux items curve -# -tabtitles : <hashtable> table de hash de définition des titres onglets -# -pageitems : <hashtable> table de hash de définition des pages internes -# -relief : <hashtable> table de hash de définition du relief de forme -# -# (options de construction géometrique passées à tabBoxCoords) -# -numpages : <integer> nombre de pages (onglets) de la boite -# -anchor : <'n'|'e'|'s'|'w'> ancrage (positionnement) de la ligne d'onglets -# -alignment : <'left'|'center'|'right'> alignement des onglets sur le coté d'ancrage -# -tabwidth : <'auto'>|<dimension>|<dimensionList> : largeur des onglets -# 'auto' largeur répartie, les largeurs sont auto-ajustée si besoin. -# -tabheight : <'auto'>|<dimension> : hauteur des onglets -# -tabshift : <'auto'>|<dimension> offset de 'biseau' entre base et haut de l'onglet (défaut auto) -# -radius : <dimension> rayon des arrondis d'angle -# -overlap : <'auto'>|<dimension> offset de recouvrement/séparation entre onglets -# -corners : <booleanList> liste 'spécifique' des raccords de sommets [0|1] -#----------------------------------------------------------------------------------- -sub buildTabBoxItem { - my ($widget, $parentgroup, %options) = @_; - my $coords = $options{'-coords'}; - my $params = $options{'-params'}; - my @tags = @{$params->{'-tags'}}; - my $texture; - - if ($options{'-texture'}) { - $texture = &getTexture($widget, $options{'-texture'}); - } - - my $titlestyle = $options{'-tabtitles'}; - my $titles = ($titlestyle) ? $titlestyle->{'-text'} : undef ; - - return undef if (!$coords); - - my @tabs; - my ($shapes, $tcoords, $invert) = &tabBoxCoords($coords, %options); - my $k = ($invert) ? scalar @{$shapes} : -1; - foreach my $shape (reverse @{$shapes}) { - $k += ($invert) ? -1 : +1; - my $group = $widget->add('group', $parentgroup); - $params->{'-tags'} = [@tags, $k, 'intercalaire']; - my $form = $widget->add('curve', $group, $shape, %{$params}); - $widget->itemconfigure($form, -tile => $texture) if $texture; - - if ($options{'-relief'}) { - &graphicItemRelief($widget, $form, %{$options{'-relief'}}); - } - - if ($options{'-page'}) { - my $page = &buildZincItem($widget, $group, %{$options{'-page'}}); - } - - if ($titles) { - my $tindex = ($invert) ? $k : $#{$shapes} - $k; - $titlestyle->{'-itemtype'} = 'text'; - $titlestyle->{'-coords'} = $tcoords->[$tindex]; - $titlestyle->{'-params'}->{'-text'} = $titles->[$tindex],; - $titlestyle->{'-params'}->{'-tags'} = [@tags, $tindex, 'titre']; - &buildZincItem($widget, $group, %{$titlestyle}); - - } - - - } - - return @tabs; -} - - -#----------------------------------------------------------------------------------- -# tabBoxCoords -# Calcul des shapes de boites à onglets -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordList> coordonnées haut-gauche bas-droite du rectangle englobant -# de la tabbox -# options -# -numpages : <integer> nombre de pages (onglets) de la boite -# -anchor : <'n'|'e'|'s'|'w'> ancrage (positionnement) de la ligne d'onglets -# -alignment : <'left'|'center'|'right'> alignement des onglets sur le coté d'ancrage -# -tabwidth : <'auto'>|<dimension>|<dimensionList> : largeur des onglets -# 'auto' largeur répartie, les largeurs sont auto-ajustée si besoin. -# -tabheight : <'auto'>|<dimension> : hauteur des onglets -# -tabshift : <'auto'>|<dimension> offset de 'biseau' entre base et haut de l'onglet (défaut auto) -# -radius : <dimension> rayon des arrondis d'angle -# -overlap : <'auto'>|<dimension> offset de recouvrement/séparation entre onglets -# -corners : <booleanList> liste 'spécifique' des raccords de sommets [0|1] -#----------------------------------------------------------------------------------- -sub tabBoxCoords { - my ($coords, %options) = @_; - - my ($x0, $y0, $xn, $yn) = (@{$coords->[0]}, @{$coords->[1]}); - my (@shapes, @titles_coords); - my $inverse; - - my @options = keys(%options); - my $numpages = $options{'-numpages'}; - - if (!defined $x0 or !defined $y0 or !defined $xn or !defined $yn or !$numpages) { - print "Vous devez au minimum spécifier le rectangle englobant et le nombre de pages\n"; - return undef; - - } - - my $anchor = ($options{'-anchor'}) ? $options{'-anchor'} : 'n'; - my $alignment = ($options{'-alignment'}) ? $options{'-alignment'} : 'left'; - my $len = ($options{'-tabwidth'}) ? $options{'-tabwidth'} : 'auto'; - my $thick = ($options{'-tabheight'}) ? $options{'-tabheight'} : 'auto'; - my $biso = ($options{'-tabshift'}) ? $options{'-tabshift'} : 'auto'; - my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0; - my $overlap = ($options{'-overlap'}) ? $options{'-overlap'} : 0; - my $corners = $options{'-corners'}; - my $orientation = ($anchor eq 'n' or $anchor eq 's') ? 'horizontal' : 'vertical'; - my $maxwidth = ($orientation eq 'horizontal') ? ($xn - $x0) : ($yn - $y0); - my $tabswidth = 0; - my $align = 1; - - if ($len eq 'auto') { - $tabswidth = $maxwidth; - $len = ($tabswidth + ($overlap * ($numpages - 1)))/$numpages; - - } else { - if (ref($len) eq 'ARRAY') { - foreach my $w (@{$len}) { - $tabswidth += ($w - $overlap); - } - $tabswidth += $overlap; - } else { - $tabswidth = ($len * $numpages) - ($overlap * ($numpages - 1)); - } - - if ($tabswidth > $maxwidth) { - $tabswidth = $maxwidth; - $len = ($tabswidth + ($overlap * ($numpages - 1)))/$numpages; - } - - $align = 0 if ($alignment eq 'center' and (($maxwidth - $tabswidth) > $radius)); - } - - - if ($thick eq 'auto') { - $thick = ($orientation eq 'horizontal') ? int(($yn - $y0)/10) : int(($xn - $y0)/10); - $thick = 10 if ($thick < 10); - $thick = 40 if ($thick > 40); - } - - if ($biso eq 'auto') { - $biso = int($thick/2); - } - - if (($alignment eq 'right' and $anchor ne 'w') or - ($anchor eq 'w' and $alignment ne 'right')) { - - if (ref($len) eq 'ARRAY') { - for (my $p = 0; $p < $numpages; $p++) { - $len->[$p] *= -1; - } - } else { - $len *= -1; - } - $biso *= -1; - $overlap *= -1; - } - - my ($biso1, $biso2) = ($alignment eq 'center') ? ($biso/2, $biso/2) : (0, $biso); - - my (@cadre, @tabdxy); - my ($xref, $yref); - if ($orientation eq 'vertical') { - $thick *= -1 if ($anchor eq 'w'); - my ($startx, $endx) = ($anchor eq 'w') ? ($x0, $xn) : ($xn, $x0); - my ($starty, $endy) = (($anchor eq 'w' and $alignment ne 'right') or - ($anchor eq 'e' and $alignment eq 'right')) ? - ($yn, $y0) : ($y0, $yn); - - $xref = $startx - $thick; - $yref = $starty; - if ($alignment eq 'center') { - my $ratio = ($anchor eq 'w') ? -2 : 2; - $yref += (($maxwidth - $tabswidth)/$ratio); - } - - @cadre = ([$xref, $endy], [$endx, $endy], [$endx, $starty], [$xref, $starty]); - - # flag de retournement de la liste des pts de curve si nécessaire -> sens anti-horaire - $inverse = ($alignment ne 'right'); - - } else { - $thick *= -1 if ($anchor eq 's'); - my ($startx, $endx) = ($alignment eq 'right') ? ($xn, $x0) : ($x0, $xn); - my ($starty, $endy) = ($anchor eq 's') ? ($yn, $y0) : ($y0, $yn); - - - $yref = $starty + $thick; - $xref = ($alignment eq 'center') ? $x0 + (($maxwidth - $tabswidth)/2) : $startx; - - @cadre = ([$endx, $yref], [$endx, $endy], [$startx, $endy], [$startx, $yref]); - - # flag de retournement de la liste des pts de curve si nécessaire -> sens anti-horaire - $inverse = (($anchor eq 'n' and $alignment ne 'right') or ($anchor eq 's' and $alignment eq 'right')); - } - - for (my $i = 0; $i < $numpages; $i++) { - my @pts = (); - - # décrochage onglet - #push (@pts, ([$xref, $yref])) if $i > 0; - - # cadre - push (@pts, @cadre); - - # points onglets - push (@pts, ([$xref, $yref])) if ($i > 0 or !$align); - - my $tw = (ref($len) eq 'ARRAY') ? $len->[$i] : $len; - @tabdxy = ($orientation eq 'vertical') ? - ([$thick, $biso1],[$thick, $tw - $biso2],[0, $tw]) : ([$biso1, -$thick],[$tw - $biso2, -$thick],[$tw, 0]); - foreach my $dxy (@tabdxy) { - push (@pts, ([$xref + $dxy->[0], $yref + $dxy->[1]])); - } - - if ($radius) { - if (!defined $options{'-corners'}) { - $corners = ($i > 0 or !$align) ? [0, 1, 1, 0, 0, 1, 1, 0] : [0, 1, 1, 0, 1, 1, 0, 0, 0]; - } - my $curvepts = &roundedCurveCoords(\@pts, -radius => $radius, -corners => $corners); - @{$curvepts} = reverse @{$curvepts} if ($inverse); - push (@shapes, $curvepts); - } else { - @pts = reverse @pts if ($inverse); - push (@shapes, \@pts); - } - - if ($orientation eq 'horizontal') { - push (@titles_coords, [$xref + ($tw - ($biso2 - $biso1))/2, $yref - ($thick/2)]); - $xref += ($tw - $overlap); - - } else { - push (@titles_coords, [$xref + ($thick/2), $yref + ($len - (($biso2 - $biso1)/2))/2]); - $yref += ($len - $overlap); - } - - } - - return (\@shapes, \@titles_coords, $inverse); - -} - - -#----------------------------------------------------------------------------------- -# Graphics::graphicItemRelief -# construit un relief à l'item Zinc en utilisant des items Triangles -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item zinc -# options : <hash> table d'options -# -closed : <boolean> le relief assure la fermeture de forme (défaut 1) -# -profil : <'rounded'|'flat'> type de profil (defaut 'rounded') -# -relief : <'raised'|'sunken'> (défaut 'raised') -# -side : <'inside'|'outside'> relief interne ou externe à la forme (défaut 'inside') -# -color : <color> couleur du relief (défaut couleur de la forme) -# -smoothed : <boolean> facettes relief lissées ou non (défaut 1) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -width : <dimension> 'épaisseur' du relief en pixel -# -fine : <boolean> mode précision courbe de bezier (défaut 0 : auto-ajustée) -#----------------------------------------------------------------------------------- -sub graphicItemRelief { - my ($widget, $item, %options) = @_; - my @items; - - # relief d'une liste d'items -> appel récursif - if (ref($item) eq 'ARRAY') { - foreach my $part (@{$item}) { - push(@items, &graphicItemRelief($widget, $part, %options)); - } - - } else { - my $itemtype = $widget->type($item); - - return unless ($itemtype); - - my $parentgroup = $widget->group($item); - my $priority = (defined $options{'-priority'}) ? $options{'-priority'} : - $widget->itemcget($item, -priority)+1; - - # coords transformés (polyline) de l'item - my $adjust = !$options{'-fine'}; - foreach my $coords (&ZincItem2CurveCoords($widget, $item, -linear => 1, - -realcoords => 1,-adjust => $adjust)) { - my ($pts, $colors) = &polylineReliefParams($widget, $item, $coords, %options); - - push(@items, $widget->add('triangles', $parentgroup, $pts, - -priority => $priority, - -colors => $colors)); - } - - - # renforcement du contour - if ($widget->itemcget($item, -linewidth)) { - push(@items, $widget->clone($item, -filled => 0, -priority => $priority+1)); - } - } - - return \@items; -} - - -#----------------------------------------------------------------------------------- -# Graphics::polylineReliefParams -# retourne la liste des points et des couleurs nécessaires à la construction -# de l'item Triangles du relief -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant widget Zinc -# item : <tagOrId> identifiant item Zinc -# options : <hash> table d'options -# -closed : <boolean> le relief assure la fermeture de forme (défaut 1) -# -profil : <'rounded'|'flat'> type de profil (defaut 'rounded') -# -relief : <'raised'|'sunken'> (défaut 'raised') -# -side : <'inside'|'outside'> relief interne ou externe à la forme (défaut 'inside') -# -color : <color> couleur du relief (défaut couleur de la forme) -# -smoothed : <boolean> facettes relief lissées ou non (défaut 1) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -width : <dimension> 'épaisseur' du relief en pixel -#----------------------------------------------------------------------------------- -sub polylineReliefParams { - my ($widget, $item, $coords, %options) = @_; - - my $closed = (defined $options{'-closed'}) ? $options{'-closed'} : 1; - my $profil = ($options{'-profil'}) ? $options{'-profil'} : 'rounded'; - my $relief = ($options{'-relief'}) ? $options{'-relief'} : 'raised'; - my $side = ($options{'-side'}) ? $options{'-side'} : 'inside'; - my $basiccolor = ($options{'-color'}) ? $options{'-color'} : &zincItemPredominantColor($widget, $item); - my $smoothed = (defined $options{'-smooth'}) ? $options{'-smooth'} : 1; - my $lightangle = (defined $options{'-lightangle'}) ? $options{'-lightangle'} - : $widget->cget('-lightangle'); - - my $width = $options{'-width'}; - if (!$width or $width < 1) { - my ($x0, $y0, $x1, $y1) = $widget->bbox($item); - $width = &_min($x1 -$x0, $y1 - $y0)/10; - $width = 2 if ($width < 2); - } - - my $numfaces = scalar(@{$coords}); - my $previous = ($closed) ? $coords->[$numfaces - 1] : undef; - my $next = $coords->[1]; - - my @pts; - my @colors; - my $alpha = 100; - if ($basiccolor =~ /;/) { - ($basiccolor, $alpha) = split /;/, $basiccolor; - - } - - $alpha /= 2 if (!($options{'-color'} =~ /;/) and $profil eq 'flat'); - - my $reliefalphas = ($profil eq 'rounded') ? [0,$alpha] : [$alpha, $alpha]; - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($width / $sin) : $width; - my $decal = ($side eq 'outside') ? -90 : 90; - - my @shift_pt = &rad_point($pt, $delta, $bisecangle+$decal); - push (@pts, @shift_pt); - push (@pts, @{$pt}); - - if (!$smoothed and $i) { - push (@pts, @shift_pt); - push (@pts, @{$pt}); - } - - my $faceangle = 360 -(&lineNormal($previous, $next)+90); - - my $light = abs($lightangle - $faceangle); - $light = 360 - $light if ($light > 180); - $light = 1 if $light < 1; - - my $lumratio = ($relief eq 'sunken') ? (180-$light)/180 : $light/180; - - if (!$smoothed and $i) { - push(@colors, ($colors[-2],$colors[-1])); - } - - if ($basiccolor) { - # création des couleurs dérivées - my $shade = &LightingColor($basiccolor, $lumratio); - my $color0 = $shade.";".$reliefalphas->[0]; - my $color1 = $shade.";".$reliefalphas->[1]; - push(@colors, ($color0, $color1)); - - } else { - my $c = (255*$lumratio); - my $color0 = &hexaRGBcolor($c, $c, $c, $reliefalphas->[0]); - my $color1 = &hexaRGBcolor($c, $c, $c, $reliefalphas->[1]); - push(@colors, ($color0, $color1)); - } - - if ($i == $numfaces - 2) { - $next = ($closed) ? $coords->[0] : - [$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - if ($closed) { - push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3])); - push (@colors, ($colors[0], $colors[1])); - - if (!$smoothed) { - push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3])); - push (@colors, ($colors[0], $colors[1])); - } - - } - - - return (\@pts, \@colors); -} - - -#----------------------------------------------------------------------------------- -# Graphics::graphicItemShadow -# Création d'une ombre portée à l'item -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant widget Zinc -# item : <tagOrId> identifiant item Zinc -# options : <hash> table d'options -# -opacity : <percent> opacité de l'ombre (défaut 50) -# -filled : <boolean> remplissage totale de l'ombre (hors bordure) (defaut 1) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -distance : <dimension> distance de projection de l'ombre en pixel -# -enlarging : <dimension> grossi de l'ombre portée en pixels (defaut 0) -# -width : <dimension> taille de diffusion/diffraction (défaut 4) -# -color : <color> couleur de l'ombre portée (défaut black) -#----------------------------------------------------------------------------------- -sub graphicItemShadow { - my ($widget, $item, %options) = @_; - my @items; - - # relief d'une liste d'items -> appel récursif - if (ref($item) eq 'ARRAY') { - foreach my $part (@{$item}) { - push(@items, &graphicItemShadow($widget, $part, %options)); - } - - return \@items; - - } else { - - my $itemtype = $widget->type($item); - - return unless ($itemtype); - - # création d'un groupe à l'ombre portée - my $parentgroup = ($options{'-parentgroup'}) ? $options{'-parentgroup'} : - $widget->group($item); - my $priority = (defined $options{'-priority'}) ? $options{'-priority'} : - ($widget->itemcget($item, -priority))-1; - $priority = 0 if ($priority < 0); - - my $shadow = $widget->add('group', $parentgroup, -priority => $priority); - - if ($itemtype eq 'text') { - my $opacity = (defined $options{'-opacity'}) ? $options{'-opacity'} : 50; - my $color = ($options{'-color'}) ? $options{'-color'} : '#000000'; - - my $clone = $widget->clone($item, -color => $color.";".$opacity); - $widget->chggroup($clone, $shadow); - - } else { - - # création des items (de dessin) de l'ombre - my $filled = (defined $options{'-filled'}) ? $options{'-filled'} : 1; - - # coords transformés (polyline) de l'item - foreach my $coords (&ZincItem2CurveCoords($widget, $item, -linear => 1, -realcoords => 1)) { - my ($t_pts, $i_pts, $colors) = &polylineShadowParams($widget, $item, $coords, %options); - - # option filled : remplissage hors bordure de l'ombre portée (item curve) - if ($filled) { - if (@items) { - $widget->contour($items[0], 'add', 0, $i_pts); - - } else { - push(@items, $widget->add('curve', $shadow, $i_pts, - -linewidth => 0, - -filled => 1, - -fillcolor => $colors->[0], - )); - } - } - - # bordure de diffusion de l'ombre (item triangles) - push(@items, $widget->add('triangles', $shadow, $t_pts, - -colors => $colors)); - } - } - - # positionnement de l'ombre portée - my $distance = (defined $options{'-distance'}) ? $options{'-distance'} : 10; - my $lightangle = (defined $options{'-lightangle'}) ? $options{'-lightangle'} - : $widget->cget('-lightangle'); - - my ($dx, $dy) = &rad_point([0, 0], $distance, $lightangle+180); - $widget->translate($shadow, $dx, -$dy); - - return $shadow; - - } - -} - - -#----------------------------------------------------------------------------------- -# Graphics::polylineShadowParams -# retourne les listes des points et de couleurs nécessaires à la construction des -# items triangles (bordure externe) et curve (remplissage interne) de l'ombre portée -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant widget Zinc -# item : <tagOrId> identifiant item Zinc -# options : <hash> table d'options -# -opacity : <percent> opacité de l'ombre (défaut 50) -# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget) -# -distance : <dimension> distance de projection de l'ombre en pixel (défaut 10) -# -enlarging : <dimension> grossi de l'ombre portée en pixels (defaut 2) -# -width : <dimension> taille de diffusion/diffraction (défaut distance -2) -# -color : <color> couleur de l'ombre portée (défaut black) -#----------------------------------------------------------------------------------- -sub polylineShadowParams { - my ($widget, $item, $coords, %options) = @_; - - my $distance = (defined $options{'-distance'}) ? $options{'-distance'} : 10; - my $width = (defined $options{'-width'}) ? $options{'-width'} : $distance-2; - my $opacity = (defined $options{'-opacity'}) ? $options{'-opacity'} : 50; - my $color = ($options{'-color'}) ? $options{'-color'} : '#000000'; - my $enlarging = (defined $options{'-enlarging'}) ? $options{'-enlarging'} : 2; - - if ($enlarging) { - $coords = &shiftPathCoords($coords, -width => $enlarging, -closed => 1, -shifting => 'out'); - } - - my $numfaces = scalar(@{$coords}); - my $previous = $coords->[$numfaces - 1]; - my $next = $coords->[1]; - - my @t_pts; - my @i_pts; - my @colors; - my ($color0, $color1) = ($color.";$opacity", $color.";0"); - - for (my $i = 0; $i < $numfaces; $i++) { - my $pt = $coords->[$i]; - - if (!$previous) { - # extrémité de curve sans raccord -> angle plat - $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])]; - } - - my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next); - - # distance au centre du cercle inscrit : rayon/sinus demi-angle - my $sin = sin(deg2rad($angle/2)); - my $delta = ($sin) ? abs($width / $sin) : $width; - my $decal = 90; - - my @shift_pt = &rad_point($pt, $delta, $bisecangle+$decal); - push (@i_pts, @shift_pt); - push (@t_pts, @shift_pt); - push (@t_pts, @{$pt}); - - push(@colors, ($color0, $color1)); - - if ($i == $numfaces - 2) { - $next = $coords->[0]; - } else { - $next = $coords->[$i+2]; - } - - $previous = $coords->[$i]; - } - - # fermeture - push(@t_pts, ($t_pts[0], $t_pts[1],$t_pts[2],$t_pts[3])); - push(@i_pts, ($t_pts[0], $t_pts[1])); - push(@colors, ($color0, $color1,$color0,$color1)); - - return (\@t_pts, \@i_pts, \@colors); -} - - -#----------------------------------------------------------------------------------- -# Graphics::bezierSegment -# Calcul d'une approximation de segment (Quadratique ou Cubique) de bezier -#----------------------------------------------------------------------------------- -# paramètres : -# points : <[P1, C1, <C1>, P2]> liste des points définissant le segment de bezier -# -# options : -# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20) -# -skipend : <boolean> : ne pas retourner le dernier point du segment (chainage) -#----------------------------------------------------------------------------------- -sub bezierSegment { - my ($coords, %options) = @_; - my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20; - my $skipendpt = $options{'-skipend'}; - - my @pts; - - my $lastpt = ($skipendpt) ? $tunits-1 : $tunits; - foreach (my $i = 0; $i <= $lastpt; $i++) { - my $t = ($i) ? ($i/$tunits) : $i; - push(@pts, &bezierPoint($t, $coords)); - } - - return wantarray ? @pts : \@pts; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::bezierPoint -# calcul d'un point du segment (Quadratique ou Cubique) de bezier -# params : -# t = <n> (représentation du temps : de 0 à 1) -# coords = (P1, C1, <C1>, P2) liste des points définissant le segment de bezier -# P1 et P2 : extémités du segment et pts situés sur la courbe -# C1 <C2> : point(s) de contrôle du segment -#----------------------------------------------------------------------------------- -# courbe bezier niveau 2 sur (P1, P2, P3) -# P(t) = (1-t)²P1 + 2t(1-t)P2 + t²P3 -# -# courbe bezier niveau 3 sur (P1, P2, P3, P4) -# P(t) = (1-t)³P1 + 3t(1-t)²P2 + 3t²(1-t)P3 + t³P4 -#----------------------------------------------------------------------------------- -sub bezierPoint { - my ($t, $coords) = @_; - my ($p1, $c1, $c2, $p2) = @{$coords}; - - # quadratique - if (!defined $p2) { - $p2 = $c2; - $c2 = undef; - } - - # extrémités : points sur la courbe - return wantarray ? @{$p1} : $p1 if (!$t); - return wantarray ? @{$p2} : $p2 if ($t >= 1.0); - - - my $t2 = $t * $t; - my $t3 = $t2 * $t; - my @pt; - - # calcul pour x et y - foreach my $i (0, 1) { - - if (defined $c2) { - my $r1 = (1 - (3*$t) + (3*$t2) - $t3) * $p1->[$i]; - my $r2 = ( (3*$t) - (6*$t2) + (3*$t3)) * $c1->[$i]; - my $r3 = ( (3*$t2) - (3*$t3)) * $c2->[$i]; - my $r4 = ( $t3) * $p2->[$i]; - - $pt[$i] = ($r1 + $r2 + $r3 + $r4); - - } else { - my $r1 = (1 - (2*$t) + $t2) * $p1->[$i]; - my $r2 = ( (2*$t) - (2*$t2)) * $c1->[$i]; - my $r3 = ( $t2) * $p2->[$i]; - - $pt[$i] = ($r1 + $r2 + $r3); - } - } - - #return wantarray ? @pt : \@pt; - return \@pt; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::bezierCompute -# Retourne une liste de coordonnées décrivant un segment de bezier -#----------------------------------------------------------------------------------- -# paramètres : -# coords : <coordsList> liste des points définissant le segment de bezier -# -# options : -# -precision : <dimension> seuil limite du calcul d'approche de la courbe -# -skipend : <boolean> : ne pas retourner le dernier point du segment (chaînage bezier) -#----------------------------------------------------------------------------------- -sub bezierCompute { - my ($coords, %options) = @_; - my $precision = ($options{'-precision'}) ? $options{'-precision'} : $bezierClosenessThreshold; - my $lastit = []; - - &subdivideBezier($coords, $lastit, $precision); - - push(@{$lastit}, $coords->[3]) if (!$options{'-skipend'}); - - return wantarray ? @{$lastit} : $lastit; -} - -#------------------------------------------------------------------------------------ -# Graphics::smallEnought -# intégration code Stéphane Conversy : calcul points bezier (précision auto ajustée) -#------------------------------------------------------------------------------------ -# distance is something like num/den with den=sqrt(something) -# what we want is to test that distance is smaller than precision, -# so we have distance < precision ? eq. to distance^2 < precision^2 ? -# eq. to (num^2/something) < precision^2 ? -# eq. to num^2 < precision^2*something -# be careful with huge values though (hence 'long long') -# with common values: 9add 9mul -#------------------------------------------------------------------------------------ -sub smallEnoughBezier { - my ($bezier, $precision) = @_; - my ($x, $y) = (0, 1); - my ($A, $B) = ($bezier->[0], $bezier->[3]); - - my $den = (($A->[$y]-$B->[$y])*($A->[$y]-$B->[$y])) + (($B->[$x]-$A->[$x])*($B->[$x]-$A->[$x])); - my $p = $precision*$precision; - - # compute distance between P1|P2 and P0|P3 - my $M = $bezier->[1]; - my $num1 = (($M->[$x]-$A->[$x])*($A->[$y]-$B->[$y])) + (($M->[$y]-$A->[$y])*($B->[$x]-$A->[$x])); - - $M = $bezier->[2]; - my $num2 = (($M->[$x]-$A->[$x])*($A->[$y]-$B->[$y])) + (($M->[$y]-$A->[$y])*($B->[$x]-$A->[$x])); - - # take the max - $num1 = $num2 if ($num2 > $num1); - - return ($p*$den > ($num1*$num1)) ? 1 : 0; - -} - -#----------------------------------------------------------------------------------- -# Graphics::subdivideBezier -# subdivision d'une courbe de bezier -#----------------------------------------------------------------------------------- -sub subdivideBezier { - my ($bezier, $it, $precision, $integeropt) = @_; - my ($b0, $b1, $b2, $b3) = @{$bezier}; - - if (&smallEnoughBezier($bezier, $precision)) { - push(@{$it}, ([$b0->[0],$b0->[1]])); - - } else { - my ($left, $right); - - foreach my $i (0, 1) { - - if ($integeropt) { - # int optimized (6+3=9)add + (5+3=8)shift - - $left->[0][$i] = $b0->[$i]; - $left->[1][$i] = ($b0->[$i] + $b1->[$i]) >> 1; - $left->[2][$i] = ($b0->[$i] + $b2->[$i] + ($b1->[$i] << 1)) >> 2; # keep precision - my $tmp = ($b1->[$i] + $b2->[$i]); - $left->[3][$i] = ($b0->[$i] + $b3->[$i] + ($tmp << 1) + $tmp) >> 3; - - $right->[3][$i] = $b3->[$i]; - $right->[2][$i] = ($b3->[$i] + $b2->[$i]) >> 1; - $right->[1][$i] = ($b3->[$i] + $b1->[$i] + ($b2->[$i] << 1) ) >> 2; # keep precision - $right->[0][$i] = $left->[3]->[$i]; - - } else { - # float - - $left->[0][$i] = $b0->[$i]; - $left->[1][$i] = ($b0->[$i] + $b1->[$i]) / 2; - $left->[2][$i] = ($b0->[$i] + (2*$b1->[$i]) + $b2->[$i]) / 4; - $left->[3][$i] = ($b0->[$i] + (3*$b1->[$i]) + (3*$b2->[$i]) + $b3->[$i]) / 8; - - $right->[3][$i] = $b3->[$i]; - $right->[2][$i] = ($b3->[$i] + $b2->[$i]) / 2; - $right->[1][$i] = ($b3->[$i] + (2*$b2->[$i]) + $b1->[$i]) / 4; - $right->[0][$i] = ($b3->[$i] + (3*$b2->[$i]) + (3*$b1->[$i]) + $b0->[$i]) / 8; - - } - } - - &subdivideBezier($left, $it, $precision, $integeropt); - &subdivideBezier($right, $it, $precision, $integeropt); - - } -} - - - -#----------------------------------------------------------------------------------- -# RESOURCES GRAPHIQUES PATTERNS, TEXTURES, IMAGES, GRADIENTS, COULEURS... -#----------------------------------------------------------------------------------- -#----------------------------------------------------------------------------------- -# Graphics::getPattern -# retourne la ressource bitmap en l'initialisant si première utilisation -#----------------------------------------------------------------------------------- -# paramètres : -# filename : nom du fichier bitmap pattern -# options -# -storage : <hastable> référence de la table de stockage de patterns -#----------------------------------------------------------------------------------- -sub getPattern { - my ($filename, %options) = @_; - my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? - $options{'-storage'} : \%bitmaps; - - if (!exists($table->{$filename})) { - my $bitmap = '@'.Tk::findINC($filename); - $table->{$filename} = $bitmap if $bitmap; - - } - - return $table->{$filename}; -} - -#----------------------------------------------------------------------------------- -# Graphics::getTexture -# retourne l'image de texture en l'initialisant si première utilisation -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# filename : nom du fichier texture -# options -# -storage : <hastable> référence de la table de stockage de textures -#----------------------------------------------------------------------------------- -sub getTexture { - my ($widget, $filename, %options) = @_; - my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? - $options{'-storage'} : \%textures; - - return &getImage($widget, $filename, -storage => $table); - -} - -#----------------------------------------------------------------------------------- -# Graphics::getImage -# retourne la ressource image en l'initialisant si première utilisation -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# filename : nom du fichier image -# options -# -storage : <hastable> référence de la table de stockage d'images -#----------------------------------------------------------------------------------- -sub getImage { - my ($widget, $filename, %options) = @_; - my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? - $options{'-storage'} : \%images; - - if (!exists($table->{$filename})) { - my $image; - if ($filename =~ /.png|.PNG/) { - $image = $widget->Photo(-format => 'png', -file => Tk::findINC($filename)); - - } elsif ($filename =~ /.jpg|.JPG|.jpeg|.JPEG/) { - $image = $widget->Photo(-format => 'jpeg', -file => Tk::findINC($filename)); - - } else { - $image = $widget->Photo(-file => Tk::findINC($filename)); - } - - $table->{$filename} = $image if $image; - - } - - return $table->{$filename}; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::init_pixmaps -# initialise une liste de fichier image -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# filenames : <filenameList> list des noms des fichier image -# options -# -storage : <hastable> référence de la table de stockage d'images -#----------------------------------------------------------------------------------- -sub init_pixmaps { - my ($widget, $filenames, %options) = @_; - my @imgs = (); - - my @files = (ref($filenames) eq 'ARRAY') ? @{$filenames} : ($filenames); - - foreach (@files) { - push(@imgs, &getImage($widget, $_, %options)); - } - - return @imgs; -} - - -#----------------------------------------------------------------------------------- -# Graphics::_min -# retourne la plus petite valeur entre 2 valeurs -#----------------------------------------------------------------------------------- -sub _min { - my ($n1, $n2) = @_; - my $mini = ($n1 > $n2) ? $n2 : $n1; - return $mini; - -} - -#----------------------------------------------------------------------------------- -# Graphics::_max -# retourne la plus grande valeur entre 2 valeurs -#----------------------------------------------------------------------------------- -sub _max { - my ($n1, $n2) = @_; - my $maxi = ($n1 > $n2) ? $n1 : $n2; - return $maxi; - -} - -#----------------------------------------------------------------------------------- -# Graphics::_trunc -# fonction interne de troncature des nombres: n = position décimale -#----------------------------------------------------------------------------------- -sub _trunc { - my ($val, $n) = @_; - my $str; - my $dec; - - ($val) =~ /([0-9]+)\.?([0-9]*)/; - $str = ($val < 0) ? "-$1" : $1; - - if (($2 ne "") && ($n != 0)) { - $dec = substr($2, 0, $n); - if ($dec != 0) { - $str = $str . "." . $dec; - } - } - return $str; -} - -#----------------------------------------------------------------------------------- -# Graphics::setGradients -# création de gradient nommés Zinc -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# grads : <hastable> table de hash de définition de couleurs zinc -#----------------------------------------------------------------------------------- -sub setGradients { - my ($widget, $grads) = @_; - - # initialise les gradients de taches - unless (@Gradients) { - while (my ($name, $gradient) = each( %{$grads})) { - # création des gradients nommés - $widget->gname($gradient, $name); - push(@Gradients, $name); - } - } -} - - -#----------------------------------------------------------------------------------- -# Graphics::RGB_dec2hex -# conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff' -#----------------------------------------------------------------------------------- -# paramètres : -# rgb : <rgbColorList> liste de couleurs au format RGB -#----------------------------------------------------------------------------------- -sub RGB_dec2hex { - my (@rgb) = @_; - return (sprintf("#%04x%04x%04x", @rgb)); -} - -#----------------------------------------------------------------------------------- -# Graphics::pathGraduate -# création d'un jeu de couleurs dégradées pour item pathLine -#----------------------------------------------------------------------------------- -sub pathGraduate { - my ($widget, $numcolors, $style) = @_; - - my $type = $style->{'-type'}; - my $triangles_colors; - - if ($type eq 'linear') { - return &createGraduate($widget, $numcolors, $style->{'-colors'}, 2); - - } elsif ($type eq 'double') { - my $colors1 = &createGraduate($widget, $numcolors/2+1, $style->{'-colors'}->[0]); - my $colors2 = &createGraduate($widget, $numcolors/2+1, $style->{'-colors'}->[1]); - my @colors; - for (my $i = 0; $i <= $numcolors; $i++) { - push(@colors, ($colors1->[$i], $colors2->[$i])); - } - - return \@colors; - - } elsif ($type eq 'transversal') { - my ($c1, $c2) = @{$style->{'-colors'}}; - my @colors = ($c1, $c2); - for (my $i = 0; $i < $numcolors; $i++) { - push(@colors, ($c1, $c2)); - } - - return \@colors; - } -} - -#----------------------------------------------------------------------------------- -# Graphics::createGraduate -# création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs -#----------------------------------------------------------------------------------- -sub createGraduate { - my ($widget, $totalsteps, $refcolors, $repeat) = @_; - my @colors; - - $repeat = 1 if (!$repeat); - my $numgraduates = scalar @{$refcolors} - 1; - - if ($numgraduates < 1) { - print "Le dégradé necessite au minimum 2 couleurs de référence...\n"; - return undef; - } - - my $steps = ($numgraduates > 1) ? $totalsteps/($numgraduates -1) : $totalsteps; - - for (my $c = 0; $c < $numgraduates; $c++) { - my ($c1, $c2) = ($refcolors->[$c], $refcolors->[$c+1]); - - for (my $i = 0 ; $i < $steps ; $i++) { - my $color = MedianColor($c1, $c2, $i/($steps-1)); - for (my $k = 0; $k < $repeat; $k++) { - push (@colors, $color); - } - } - - if ($c < $numgraduates - 1) { - for (my $k = 0; $k < $repeat; $k++) { - pop @colors; - } - } - } - - return \@colors; -} - -#----------------------------------------------------------------------------------- -# Graphics::LightingColor -# modification d'une couleur par sa composante luminosité -#----------------------------------------------------------------------------------- -# paramètres : -# color : <color> couleur au format zinc -# newL : <pourcent> (de 0 à 1) nouvelle valeur de luminosité -#----------------------------------------------------------------------------------- -sub LightingColor { - my ($color, $newL) = @_; - my ($H, $L, $S); - - if ($color and $newL) { - my ($RGB) = &hexa2RGB($color); - ($H, $L, $S) = @{&RGBtoHLS(@{$RGB})}; - - - $newL = 1 if $newL > 1; - my ($nR, $nG, $nB) = @{&HLStoRGB($H, $newL, $S)}; - return &hexaRGBcolor($nR*255, $nG*255, $nB*255); - - } - - return undef; -} - - -#----------------------------------------------------------------------------------- -# Graphics::zincItemPredominantColor -# retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor) -#----------------------------------------------------------------------------------- -# paramètres : -# widget : <widget> identifiant du widget zinc -# item : <tagOrId> identifiant de l'item zinc -#----------------------------------------------------------------------------------- -sub zincItemPredominantColor { - my ($widget, $item) = @_; - my $type = $widget->type($item); - - if ($type eq 'text' or '$type' eq 'icon') { - return $widget->itemcget($item, -color); - - } elsif ($type eq 'triangles' or - $type eq 'rectangle' or - $type eq 'arc' or - $type eq 'curve') { - - my @colors; - - if ($type eq 'triangles') { - @colors = $widget->itemcget($item, -colors); - - } else { - my $grad = $widget->itemcget($item, -fillcolor); - - return $grad if (scalar (my @unused = (split / /, $grad)) < 2); - - my @colorparts = split /\|/, $grad; - foreach my $section (@colorparts) { - if ($section !~ /=/) { - my ($color, $director, $position) = split / /, $section; - push (@colors, $color); - } - } - } - - - my ($Rs, $Gs, $Bs, $As, $numcolors) = (0, 0, 0, 0, 0); - foreach my $color (@colors) { - my ($r, $g, $b, $a) = ZnColorToRGB($color); - $Rs += $r; - $Gs += $g; - $Bs += $b; - $As += $a; - $numcolors++; - } - - my $newR = int($Rs/$numcolors); - my $newG = int($Gs/$numcolors); - my $newB = int($Bs/$numcolors); - my $newA = int($As/$numcolors); - - my $newcolor = &hexaRGBcolor($newR, $newG, $newB, $newA); - - return $newcolor - - } else { - return '#777777'; - } -} - -#----------------------------------------------------------------------------------- -# Graphics::MedianColor -# calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleurs -#----------------------------------------------------------------------------------- -# paramètres : -# color1 : <color> première couleur zinc -# color2 : <color> seconde couleur zinc -# rate : <pourcent> (de 0 à 1) position de la couleur intermédiaire -#----------------------------------------------------------------------------------- -sub MedianColor { - my ($color1, $color2, $rate) = @_; - $rate = 1 if ($rate > 1); - $rate = 0 if ($rate < 0); - - my ($r0, $g0, $b0, $a0) = &ZnColorToRGB($color1); - my ($r1, $g1, $b1, $a1) = &ZnColorToRGB($color2); - - my $r = $r0 + int(($r1 - $r0) * $rate); - my $g = $g0 + int(($g1 - $g0) * $rate); - my $b = $b0 + int(($b1 - $b0) * $rate); - my $a = $a0 + int(($a1 - $a0) * $rate); - - return &hexaRGBcolor($r, $g, $b, $a); -} - - -#----------------------------------------------------------------------------------- -# Graphics::ZnColorToRGB -# conversion d'une couleur Zinc au format RGBA (255,255,255,100) -#----------------------------------------------------------------------------------- -# paramètres : -# zncolor : <color> couleur au format hexa zinc (#ffffff ou #ffffffffffff) -#----------------------------------------------------------------------------------- -sub ZnColorToRGB { - my ($zncolor) = @_; - - my ($color, $alpha) = split /;/, $zncolor; - my $ndigits = (length($color) > 8) ? 4 : 2; - my $R = hex(substr($color, 1, $ndigits)); - my $G = hex(substr($color, 1+$ndigits, $ndigits)); - my $B = hex(substr($color, 1+($ndigits*2), $ndigits)); - - $alpha = 100 if (!defined $alpha or $alpha eq ""); - - return ($R, $G, $B, $alpha); - -} - -#----------------------------------------------------------------------------------- -# ALGORYTHMES DE CONVERSION ENTRE ESPACES DE COULEURS -#----------------------------------------------------------------------------------- -#----------------------------------------------------------------------------------- -# Graphics::RGBtoLCH -# Algorythme de conversion RGB -> CIE LCH° -#----------------------------------------------------------------------------------- -# paramètres : -# r : <pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB -# g : <pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB -# b : <pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB -#----------------------------------------------------------------------------------- -sub RGBtoLCH { - my ($r, $g, $b) = @_; - - # Conversion RGBtoXYZ - my $gamma = 2.4; - my $rgblimit = 0.03928; - - - $r = ($r > $rgblimit) ? (($r + 0.055)/1.055)**$gamma : $r / 12.92; - $g = ($g > $rgblimit) ? (($g + 0.055)/1.055)**$gamma : $g / 12.92; - $b = ($b > $rgblimit) ? (($b + 0.055)/1.055)**$gamma : $b / 12.92; - - $r *= 100; - $g *= 100; - $b *= 100; - - my $X = (0.4124 * $r) + (0.3576 * $g) + (0.1805 * $b); - my $Y = (0.2126 * $r) + (0.7152 * $g) + (0.0722 * $b); - my $Z = (0.0193 * $r) + (0.1192 * $g) + (0.9505 * $b); - - - # Conversion XYZtoLab - $gamma = 1/3; - my ($L, $A, $B); - - if ($Y == 0) { - ($L, $A, $B) = (0, 0, 0); - - } else { - - my ($Xs, $Ys, $Zs) = ($X/$Xw, $Y/$Yw, $Z/$Zw); - - $Xs = ($Xs > 0.008856) ? $Xs**$gamma : (7.787 * $Xs) + (16/116); - $Ys = ($Ys > 0.008856) ? $Ys**$gamma : (7.787 * $Ys) + (16/116); - $Zs = ($Zs > 0.008856) ? $Zs**$gamma : (7.787 * $Zs) + (16/116); - - $L = (116.0 * $Ys) - 16.0; - - $A = 500 * ($Xs - $Ys); - $B = 200 * ($Ys - $Zs); - - } - - # conversion LabtoLCH - my ($C, $H); - - - if ($A == 0) { - $H = 0; - - } else { - - $H = atan2($B, $A); - - if ($H > 0) { - $H = ($H / pi) * 180; - - } else { - $H = 360 - ( abs($H) / pi) * 180 - } - } - - - $C = sqrt($A**2 + $B**2); - - return [$L, $C, $H]; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::LCHtoRGB -# Algorythme de conversion CIE L*CH -> RGB -#----------------------------------------------------------------------------------- -# paramètres : -# L : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH -# C : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH -# H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur CIE LCH -#----------------------------------------------------------------------------------- -sub LCHtoRGB { - my ($L, $C, $H) = @_; - my ($a, $b); - - # Conversion LCHtoLab - $a = cos( deg2rad($H)) * $C; - $b = sin( deg2rad($H)) * $C; - - # Conversion LabtoXYZ - my $gamma = 3; - my ($X, $Y, $Z); - - my $Ys = ($L + 16.0) / 116.0; - my $Xs = ($a / 500) + $Ys; - my $Zs = $Ys - ($b / 200); - - - $Ys = (($Ys**$gamma) > 0.008856) ? $Ys**$gamma : ($Ys - 16 / 116) / 7.787; - $Xs = (($Xs**$gamma) > 0.008856) ? $Xs**$gamma : ($Xs - 16 / 116) / 7.787; - $Zs = (($Zs**$gamma) > 0.008856) ? $Zs**$gamma : ($Zs - 16 / 116) / 7.787; - - - $X = $Xw * $Xs; - $Y = $Yw * $Ys; - $Z = $Zw * $Zs; - - # Conversion XYZtoRGB - $gamma = 1/2.4; - my $rgblimit = 0.00304; - my ($R, $G, $B); - - - $X /= 100; - $Y /= 100; - $Z /= 100; - - $R = (3.2410 * $X) + (-1.5374 * $Y) + (-0.4986 * $Z); - $G = (-0.9692 * $X) + (1.8760 * $Y) + (0.0416 * $Z); - $B = (0.0556 * $X) + (-0.2040 * $Y) + (1.0570 * $Z); - - $R = ($R > $rgblimit) ? (1.055 * ($R**$gamma)) - 0.055 : (12.92 * $R); - $G = ($G > $rgblimit) ? (1.055 * ($G**$gamma)) - 0.055 : (12.92 * $G); - $B = ($B > $rgblimit) ? (1.055 * ($B**$gamma)) - 0.055 : (12.92 * $B); - - $R = ($R < 0) ? 0 : ($R > 1.0) ? 1.0 : &_trunc($R, 5); - $G = ($G < 0) ? 0 : ($G > 1.0) ? 1.0 : &_trunc($G, 5); - $B = ($B < 0) ? 0 : ($B > 1.0) ? 1.0 : &_trunc($B, 5); - - return [$R, $G, $B]; - -} - -#----------------------------------------------------------------------------------- -# Graphics::RGBtoHLS -# Algorythme de conversion RGB -> HLS -#----------------------------------------------------------------------------------- -# r : <pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB -# g : <pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB -# b : <pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB -#----------------------------------------------------------------------------------- -sub RGBtoHLS { - my ($r, $g, $b) = @_; - my ($H, $L, $S); - my ($min, $max, $diff); - - - $max = &max($r,$g,$b); - $min = &min($r,$g,$b); - - # calcul de la luminosité - $L = ($max + $min) / 2; - - # calcul de la saturation - if ($max == $min) { - # couleur a-chromatique (gris) $r = $g = $b - $S = 0; - $H = undef; - - return [$H, $L, $S]; - } - - # couleurs "Chromatiques" -------------------- - - # calcul de la saturation - if ($L <= 0.5) { - $S = ($max - $min) / ($max + $min); - - } else { - $S = ($max - $min) / (2 - $max - $min); - - } - - # calcul de la teinte - $diff = $max - $min; - - if ($r == $max) { - # couleur entre jaune et magenta - $H = ($g - $b) / $diff; - - } elsif ($g == $max) { - # couleur entre cyan et jaune - $H = 2 + ($b - $r) / $diff; - - } elsif ($b == $max) { - # couleur entre magenta et cyan - $H = 4 + ($r - $g) / $diff; - } - - # Conversion en degrés - $H *= 60; - - # pour éviter une valeur négative - if ($H < 0.0) { - $H += 360; - } - - return [$H, $L, $S]; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::HLStoRGB -# Algorythme de conversion HLS -> RGB -#----------------------------------------------------------------------------------- -# paramètres : -# H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur HLS -# L : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur HLS -# S : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur HLS -#----------------------------------------------------------------------------------- -sub HLStoRGB { - my ($H, $L, $S) = @_; - my ($R, $G, $B); - my ($p1, $p2); - - - if ($L <= 0.5) { - $p2 = $L + ($L * $S); - - } else { - $p2 = $L + $S - ($L * $S); - - } - - $p1 = 2.0 * $L - $p2; - - if ($S == 0) { - # couleur a-chromatique (gris) - # $R = $G = $B = $L - $R = $L; - $G = $L; - $B = $L; - - } else { - # couleurs "Chromatiques" - $R = &hlsValue($p1, $p2, $H + 120); - $G = &hlsValue($p1, $p2, $H); - $B = &hlsValue($p1, $p2, $H - 120); - - } - - return [$R, $G, $B]; - -} - -#----------------------------------------------------------------------------------- -# Graphics::hlsValue (sous fonction interne HLStoRGB) -#----------------------------------------------------------------------------------- -sub hlsValue { - my ($q1, $q2, $hue) = @_; - my $value; - - $hue = &r_modp($hue, 360); - - if ($hue < 60) { - $value = $q1 + ($q2 - $q1) * $hue / 60; - - } elsif ($hue < 180) { - $value = $q2; - - } elsif ($hue < 240) { - $value = $q1 + ($q2 - $q1) * (240 - $hue) / 60; - - } else { - $value = $q1; - - } - - return $value; - -} - - -#----------------------------------------------------------------------------------- -# Graphics::hexaRGBcolor -# conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff' -#----------------------------------------------------------------------------------- -sub hexaRGBcolor { - my ($r, $g, $b, $a) = @_; - - if (defined $a) { - my $hexacolor = sprintf("#%02x%02x%02x", ($r, $g, $b)); - return ($hexacolor.";".$a); - } - - return (sprintf("#%02x%02x%02x", ($r, $g, $b))); -} - - - -sub hexa2RGB { - my ($hexastr) = @_; - my ($r, $g, $b); - - if ($hexastr =~ /(\w\w)(\w\w)(\w\w)/) { - $r = hex($1); - $g = hex($2); - $b = hex($3); - - return [$r/255, $g/255, $b/255] if (defined $r and defined $g and defined $b); - - } - - return undef; -} - -#----------------------------------------------------------------------------------- -# Graphics::max -# renvoie la valeur maximum d'une liste de valeurs -#----------------------------------------------------------------------------------- -sub max { - my (@values) = @_; - return undef if !scalar(@values); - - my $max = undef; - - foreach my $val (@values) { - if (!defined $max or $val > $max) { - $max = $val; - } - } - - return $max; -} - - -#----------------------------------------------------------------------------------- -# Graphics::min -# renvoie la valeur minimum d'une liste de valeurs -#----------------------------------------------------------------------------------- -sub min { - my (@values) = @_; - return undef if !scalar(@values); - - my $min = undef; - - foreach my $val (@values) { - if (!defined $min or $val < $min) { - $min = $val; - } - } - - return $min; -} - - -#----------------------------------------------------------------------------------- -# Graphics::r_modp -# fonction interne : renvoie le résultat POSITIF du modulo m d'un nombre x -#----------------------------------------------------------------------------------- -sub r_modp { - my ($x, $m) = @_; - - return undef if $m == 0; - - my $value = $x%$m; - - if ($value < 0.0) { - $value = $value + abs($m); - } - - return $value; - -} - - -1; - - -__END__ - |