#-----------------------------------------------------------------------------------
#
# 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: Graphics.pm,v 1.12 2004/04/16 09:06:55 mertz Exp $
#-----------------------------------------------------------------------------------
package Tk::Zinc::Graphics;
use vars qw( $VERSION );
($VERSION) = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\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__