From 4704520a838e976ea08a55546cf5753feb631dab Mon Sep 17 00:00:00 2001 From: lecoanet Date: Fri, 20 Feb 2004 15:47:56 +0000 Subject: First version of this new package ported from Perl --- library/zincGraphics.tcl | 1322 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1322 insertions(+) create mode 100644 library/zincGraphics.tcl diff --git a/library/zincGraphics.tcl b/library/zincGraphics.tcl new file mode 100644 index 0000000..c580b82 --- /dev/null +++ b/library/zincGraphics.tcl @@ -0,0 +1,1322 @@ +# +#----------------------------------------------------------------------------------- +# +# Graphics.tcl +# some graphic design functions +# +#----------------------------------------------------------------------------------- +# Functions to create complexe graphic component : +# ------------------------------------------------ +# BuildZincItem (realize a zinc item from description hash table) +# +# 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) +# PolygonCoords (return curve coords of regular polygon) +# RoundedCurveCoords (return curve coords of rounded curve) +# PolylineCoords (return curve coords of polyline) +# TabBoxCoords (return curve coords of tabBox's pages) +# PathLineCoords (return triangles coords of pathline) +# +# Geometrical basic Functions : +# ----------------------------- +# PerpendicularPoint +# LineAngle +# VertexAngle +# ArcPts +# RadPoint +# +# Pictorial Functions : +# ---------------------- +# SetGradients +# GetPattern +# GetTexture +# GetImage +# InitPixmaps +# HexaRGBcolor +# CreateGraduate +# +#----------------------------------------------------------------------------------- +# Authors: Jean-Luc Vinot +# Patrick Lecoanet (Straight translation +# to Tcl, based on perl revision ) +# $Id: +#----------------------------------------------------------------------------------- + +namespace eval ::zincGraphics { + + package provide zincGraphics 1.0 + + namespace export BuildZincItem RoundedRectangleCoords HippodromeCoords \ + PolygonCoords RoundedCurveCoords PolylineCoords TabBoxCoords PathLineCoords \ + PerpendicularPoint SetGradients GetPattern GetTexture GetImage InitPixmaps \ + HexaRGBcolor CreateGraduate + + namespace eval v { + # constante facteur point directeur + variable constPtdFactor 0.5523 + variable Gradients {} + variable textures {} + variable images {} + variable bitmaps {} + variable pi 3.14159 + } + + if { ![info exists zinc_library] } { + set zinc_library [file dirname [info script]] + } + + set imagePath [file join $zinc_library .. demos images] + + proc deg2rad {angle} { + return [expr {$angle * $v::pi / 180.0}] + } + + proc TLGet {list tag {default ""}} { + foreach {key val} $list { + if { [string compare $key $tag] == 0 } { + return $val + } + } + return $default + } + + #proc TLGet {assoc tag {default ""}} { + # array set temp $assoc + # if { [info exists temp($tag)] } { + # return $temp($tag) + # } + # return $default + #} + + proc PointX {point} { + return [lindex $point 0] + } + + proc PointY {point} { + return [lindex $point 1] + } + + #----------------------------------------------------------------------------------- + # Graphics::BuildZincItem + # Création d'un objet Zinc de représentation + # paramètres : + # widget : + # parentGroup : + # style : {hash table options} + # specificTags : [list of specific tags] to add to params -tags + # name : nom de l'item + #----------------------------------------------------------------------------------- + # type d'item valide : + # 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 + # -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) + #----------------------------------------------------------------------------------- + proc BuildZincItem {zinc parentGroup styleTL specificTags name} { + array set style $styleTL + if { [info exists style(-params)] } { + array set params $style(-params) + } + + if { ! $parentGroup } { + set parentGroup 1 + } + + if { [llength $specificTags] } { + if { [info exists params(-tags)] } { + set params(-tags) [concat $specificTags $params(-tags)] + } else { + set params(-tags) $specificTags + } + } + + set itemType $style(-itemtype) + set coords {} + if { [info exists style(-coords)] } { + set coords $style(-coords) + } + # gestion des polygones particuliers et à coin arrondi + switch -- $itemType { + roundedrectangle { + set itemType curve + set params(-closed) 1 + set coords [RoundedRectangleCoords $coords $styleTL] + } + hippodrome { + set itemType curve + set params(-closed) 1 + set coords [HippodromeCoords $coords $styleTL] + } + polygone { + set itemType curve + set params(-closed) 1 + set coords [PolygonCoords $coords $styleTL] + } + roundedcurve - + polyline { + set itemType curve + if { $itemType eq "roundedcurve" } { + set params(-closed) 1 + set coords [RoundedCurveCoords $coords $styleTL] + } else { + set coords [PolylineCoords $coords $styleTL] + } + # + # multi-contours + if { [info exists style(-contours)] } { + set contours $style(-contours) + set numContours [llength $contours] + for {set i 0} {$i < $numContours} {incr i} { + # radius et corners peuvent être défini spécifiquement + # pour chaque contour + foreach {type way inCoords radius corners cornersRadius} \ + [lindex $contours $i] break + + if { $radius eq "" } { + set radius $style(-radius) + } + if { $itemType eq "roundedcurve" } { + set newCoords [RoundedCurveCoords $inCoords [list -radius $radius \ + -corners $corners]] + } else { + set newCoords [PolylineCoords $inCoords \ + [list -radius $radius -corners $corners \ + -cornersradius $cornersRadius]] + } + lset style(-contours) $i [list $type $way $newCoords] + } + } + } + pathline { + set itemType triangles + if { [info exists style(-metacoords)] } { + set coords [MetaCoords $style(-metacoords)] + } + + if { [info exists style(-graduate)] } { + set numColors [llength $coords] + set params(-colors) [PathGraduate $numColors $style(-graduate)] + } + set coords [PathLineCoords $coords $styleTL] + } + } + + switch -- $itemType { + group { + set item [eval {$zinc add $itemType $parentGroup} [array get params]] + if { [llength $coords] } { + $zinc coords $item $coords + } + + } + text - + icon { + set imageFile "" + if { $itemType eq "icon" } { + set imageFile $params(-image) + if { $imageFile ne "" } { + set params(-image) [InitPixmap $imageFile] + } + } + + set item [eval {$zinc add $itemType $parentGroup -position $coords} [array get params]] + if { $imageFile ne "" } { + set params(-image) $imageFile + } + } + default { + set item [eval {$zinc add $itemType $parentGroup $coords} [array get params]] + if { $itemType eq "curve" && [info exists style(-contours)] } { + foreach contour $style(-contours) { + eval $zinc contour $item $contour + } + } + + # gestion du mode norender + if { [info exists style(-texture)] } { + set texture [GetTexture $style(-texture)] + if { $texture ne "" } { + $zinc itemconfigure $item -tile $texture + } + } + + if { [info exists style(-fillpattern)] } { + set bitmap [GetBitmap $style(-fillpattern)] + if { $bitmap ne "" } { + $zinc itemconfigure $item -fillpattern $bitmap + } + } + } + } + + # transformation scale de l'item si nécessaire + if { [info exists style(-scale)] } { + $zinc scale $item $style(-scale) + } + + # transformation rotate de l'item si nécessaire + if { [info exists style(-rotate)] } { + $zinc rotate $item [deg2rad $style(-rotate)] + } + # transformation scale de l'item si nécessaire + if { [info exists style(-translate)] } { + $zinc translate $item $style(-translate) + } + + return $item + } + + #----------------------------------------------------------------------------------- + # FONCTIONS GEOMETRIQUES + #----------------------------------------------------------------------------------- + + #----------------------------------------------------------------------------------- + # Graphics::MetaCoords + # retourne une liste de coordonnées en utilisant la fonction d'un autre type d'item + # paramètres : (options) + # -type : type de primitive utilisée + # -coords : coordonnées nécessitée par la fonction [type]Coords + # + options spécialisées passés à la fonction [type]Coords + #----------------------------------------------------------------------------------- + proc MetaCoords {options} { + set pts {} + set type [TLGet $options -type] + set coords [TLGet $options -coords] + + switch -- $type { + polygone { + set pts [PolygonCoords $coords $options] + } + hippodrome { + set pts [HippodromeCoords $coords $options] + } + polyline { + set pts [PolylineCoords $coords $options] + } + } + + return $pts + } + + #----------------------------------------------------------------------------------- + # Graphics::RoundedRectangleCoords + # calcul des coords du rectangle à coins arrondis + # paramètres : + # coords : point centre du polygone + # options : + # -radius : rayon de raccord d'angle + # -corners : liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1] + #----------------------------------------------------------------------------------- + proc RoundedRectangleCoords {coords optionsTL} { + foreach {p0 p1} $coords break + foreach {x0 y0} $p0 break + foreach {xn yn} $p1 break + + set radius [TLGet $optionsTL -radius] + set corners [TLGet $optionsTL -corners] + if { [llength $corners] == 0 } { + set corners [list 1 1 1 1] + } + + # attention aux formes 'négatives' + if { $xn < $x0 } { + set xs $x0 + set x0 $xn + set xn $xs + } + if { $yn < $y0 } { + set ys $y0 + set y0 $yn + set yn $ys + } + + set height [_min [expr {$xn - $x0}] [expr {$yn - $y0}]] + + if { $radius eq "" } { + set radius [expr {int($height/10.0)}] + if { $radius < 3 } { + set radius 3 + } + } + + if { $radius < 2 } { + return [list [list $x0 $y0] [list $x0 $yn] \ + [list $xn $yn] [list $xn $y0]] + } + + + # correction de radius si necessaire + set maxRad $height + if { $corners eq "" } { + set maxRad [expr {$maxRad / 2.0}] + } + if { $radius > $maxRad } { + set radius $maxRad + } + + # points remarquables + set ptdDelta [expr {$radius * $v::constPtdFactor}] + set x2 [expr {$x0 + $radius}] + set x3 [expr {$xn - $radius}] + set x1 [expr {$x2 - $ptdDelta}] + set x4 [expr {$x3 + $ptdDelta}] + set y2 [expr {$y0 + $radius}] + set y3 [expr {$yn - $radius}] + set y1 [expr {$y2 - $ptdDelta}] + set y4 [expr {$y3 + $ptdDelta}] + + # liste des 4 points sommet du rectangle : angles sans raccord circulaire + set anglePts [list [list $x0 $y0] [list $x0 $yn] \ + [list $xn $yn] [list $xn $y0]] + + # liste des 4 segments quadratique : raccord d'angle = radius + set roundeds [list \ + [list [list $x2 $y0] [list $x1 $y0 c] \ + [list $x0 $y1 c] [list $x0 $y2]] \ + [list [list $x0 $y3] [list $x0 $y4 c] \ + [list $x1 $yn c] [list $x2 $yn]] \ + [list [list $x3 $yn] [list $x4 $yn c] \ + [list $xn $y4 c] [list $xn $y3]] \ + [list [list $xn $y2] [list $xn $y1 c] \ + [list $x4 $y0 c] [list $x3 $y0]]] + + set pts [list] + set previous 0 + foreach seg $roundeds aPt $anglePts corner $corners { + set px 0 + set py 0 + if { $corner } { + # on teste si non duplication de point + foreach {nx ny} [lindex $seg 0] break + if { $previous && ($px == $nx && $py == $ny) } { + eval lappend pts [lrange $seg 1 end] + } else { + eval lappend pts $seg + } + foreach {px py} [lindex $seg 3] break + set previous 1 + } else { + lappend pts $aPt + } + } + return $pts + } + + #----------------------------------------------------------------------------------- + # Graphics::HippodromeCoords + # calcul des coords d'un hippodrome + # paramètres : + # coords : coordonnées du rectangle exinscrit + # options : + # -orientation : orientation forcée de l'ippodrome [horizontal|vertical] + # -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] + # -trunc : troncatures [left|right|top|bottom|both] + #----------------------------------------------------------------------------------- + proc HippodromeCoords {coords optionsTL} { + foreach {p0 p1} $coords break + foreach {x0 y0} $p0 break + foreach {xn yn} $p1 break + + set orientation [TLGet $optionsTL -orientation none] + + # orientation forcée de l'hippodrome (sinon hippodrome sur le plus petit coté) + switch -- $orientation { + horizontal { set height [expr {abs($yn - $y0)}] } + vertical { set height [expr {abs($xn - $x0)}] } + default { set height [_min [expr {abs($xn - $x0)}] [expr {abs($yn - $y0)}]] } + } + + set radius [expr {$height/2.0}] + + set corners [TLGet $optionsTL -corners] + set trunc [TLGet $optionsTL -trunc] + if { [llength $corners] == 0 } { + switch -- $trunc { + both { return [list [list $x0 $y0] [list $x0 $yn] \ + [list $xn $yn] [list $xn $y0]] } + left { set corners [list 0 0 1 1] } + right { set corners [list 1 1 0 0] } + top { set corners [list 0 1 1 0] } + bottom { set corners [list 1 0 0 1] } + default { set corners [list 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 [list -radius [expr {$height/2.0}] -corners $corners]] + } + + + #----------------------------------------------------------------------------------- + # Graphics::PolygonCoords + # calcul des coords d'un polygone régulier + # paramètres : + # coords : point centre du polygone + # options : + # -numsides : nombre de cotés + # -radius : rayon de définition du polygone (distance centre-sommets) + # -innerradius : rayon interne (polygone type étoile) + # -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] + # -cornerradius : rayon de raccord des cotés + # -startangle : angle de départ du polygone + #----------------------------------------------------------------------------------- + proc PolygonCoords {coords optionsTL} { + set numSides [TLGet $optionsTL -numsides 0] + set radius [TLGet $optionsTL -radius 0] + if { $numSides < 3 || !$radius } { + puts "Vous devez au moins spécifier un nombre de cotés >= 3 et un rayon..." + return {}; + } + + if { [llength $coords] } { + foreach {cx cy} $coords break + } else { + set cx 0 + set cy 0 + } + + set startAngle [TLGet $optionsTL -startangle 0] + set angleStep [expr {360.0/$numSides}] + set innerRadius [TLGet $optionsTL -innerradius 0] + set pts [list] + + # points du polygone + for {set i 0} {$i < $numSides} {incr i} { + set p [RadPoint $cx $cy $radius [expr {$startAngle + ($angleStep*$i)}]] + lappend pts $p + + # polygones 'étoiles' + if { $innerRadius } { + set p [RadPoint $cx $cy $innerRadius [expr {$startAngle + ($angleStep*($i+ 0.5))}]] + lappend pts $p + } + } + + set cornerRadius [TLGet $optionsTL -cornerradius {}] + if { $cornerRadius ne "" } { + set pts [RoundedCurveCoords $pts [list -radius $cornerRadius -corners \ + [TLGet $optionsTL -corners {}]]] + } + return $pts + } + + #----------------------------------------------------------------------------------- + # Graphics::RoundedAngle + # THIS FUNCTION IS NO MORE USED, NEITHER EXPORTED + # curve d'angle avec raccord circulaire + # paramètres : + # zinc : widget + # parentGroup : group zinc parent + # coords : les 3 points de l'angle + # radius : rayon de raccord + #----------------------------------------------------------------------------------- + proc RoundedAngle {zinc parentGroup coords radius} { + foreach {pt0 pt1 pt2} $coords break + + foreach {cornerPts centerPts} [RoundedAngleCoords $coords $radius] break + foreach {cx0 cy0} $centerPts break + + # valeur d'angle et angle formé par la bisectrice + # set angle [VertexAngle $pt0 $pt1 $pt2] + + if { $parentGroup eq "" } { + set parentGroup 1 + } + + set cornerPts [linsert $cornerPts 0 $pt0] + lappend cornerPts $pt2 + $zinc add curve $parentGroup $cornerPts -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 + #----------------------------------------------------------------------------------- + proc RoundedAngleCoords {coords radius} { + foreach {pt0 pt1 pt2} $coords break + foreach {pt1x pt1y} $pt1 break + + # valeur d'angle et angle formé par la bisectrice + foreach {angle bisecAngle} [VertexAngle $pt0 $pt1 $pt2] break + + # distance au centre du cercle inscrit : rayon/sinus demi-angle + set sin [expr {sin([deg2rad $angle] / 2.0)}] + set delta [expr {$sin ? abs($radius / $sin) : $radius}] + + # point centre du cercle inscrit de rayon $radius + set refAngle [expr {($angle < 180) ? $bisecAngle+90 : $bisecAngle-90}] + set c0 [RadPoint $pt1x $pt1y $delta $refAngle] + + # points de tangeance : pts perpendiculaires du centre aux 2 droites + set p1 [PerpendicularPoint $c0 [list $pt0 $pt1]] + set p2 [PerpendicularPoint $c0 [list $pt1 $pt2]] + foreach {p1x p1y} $p1 break + foreach {p2x p2y} $p2 break + + # point de controle de la quadratique + # facteur de positionnement sur le vecteur pt.tangence, sommet + set ptdFactor $v::constPtdFactor + if { $angle < 90 || $angle > 270 } { + set diffAngle [expr {($angle < 90) ? $angle : 360 - $angle}] + if { $diffAngle > 15 } { + set ptdFactor [expr {$ptdFactor - (((90.0 - $diffAngle)/90.0) * ($ptdFactor/4.0))}] + } + set ptdFactor [expr {($diffAngle/90.0) * \ + ($ptdFactor + ((1.0 - $ptdFactor) * (90.0 - $diffAngle)/90.0))}] + } else { + set diffAngle [expr {abs(180.0 - $angle)}] + if { $diffAngle > 15 } { + set ptdFactor [expr {$ptdFactor + (((90.0 - $diffAngle)/90.0) * ($ptdFactor/3.0))}] + } + } + + # delta xy aux pts de tangence + set d1x [expr {($pt1x - $p1x) * $ptdFactor}] + set d1y [expr {($pt1y - $p1y) * $ptdFactor}] + set d2x [expr {($pt1x - $p2x) * $ptdFactor}] + set d2y [expr {($pt1y - $p2y) * $ptdFactor}] + + # les 4 points de l'arc 'quadratique' et le centre du cercle inscrit + set cornerPts [list $p1 \ + [list [expr {$p1x + $d1x}] [expr {$p1y + $d1y}] c] \ + [list [expr {$p2x + $d2x}] [expr {$p2y + $d2y}] c] \ + $p2] + + return [list $cornerPts $c0] + } + + #----------------------------------------------------------------------------------- + # Graphics::RoundedCurveCoords + # retourne les coordonnées d'une curve à coins arrondis + # paramètres : + # coords : points de la curve + # options : + # -radius : rayon de raccord d'angle + # -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] + #----------------------------------------------------------------------------------- + proc RoundedCurveCoords {coords options} { + set numFaces [llength $coords] + set curvePts {} + set radius [TLGet $options -radius 0] + set corners [TLGet $options -corners {}] + + for {set index 0} {$index < $numFaces} {incr index} { + if { ([llength $corners] > $index) && ([lindex $corners $index] == 0) } { + lappend curvePts [lindex $coords $index] + } else { + set prev [expr {$index ? $index - 1 : $numFaces - 1}] + set next [expr {($index > $numFaces - 2) ? 0 : $index + 1}] + set angleCoords [list [lindex $coords $prev] \ + [lindex $coords $index] \ + [lindex $coords $next]] + foreach {quadPts centerPts} [RoundedAngleCoords $angleCoords $radius] break + set curvePts [concat $curvePts $quadPts] + } + } + return $curvePts + } + + #----------------------------------------------------------------------------------- + # Graphics::PolylineCoords + # retourne les coordonnées d'une polyline + # paramètres : + # coords : sommets de la polyline + # options : + # -radius : rayon global de raccord d'angle + # -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1], + # -cornersradius : liste des rayons de raccords de sommets + #----------------------------------------------------------------------------------- + proc PolylineCoords {coords options} { + set numFaces [llength $coords] + set curvePts {} + + set radius [TLGet $options -radius 0] + set cornersRadius [TLGet $options -cornersradius] + + if { [llength $cornersRadius] } { + set corners $cornersRadius + } else { + set corners [TLGet $options -corners] + } + + set numCorners [llength $corners] + for {set index 0} {$index < $numFaces} {incr index} { + if { $numCorners && (($index >= $numCorners) || ![lindex $corners $index]) } { + foreach {x y} [lindex $coords $index] { lappend curvePts [list $x $y] } + } else { + set prev [expr {$index ? $index - 1 : $numFaces - 1}] + set next [expr {($index > $numFaces - 2) ? 0 : $index + 1}] + set angleCoords [list [lindex $coords $prev] [lindex $coords $index] \ + [lindex $coords $next]] + + if { [llength $cornersRadius] } { + set rad [lindex $cornersRadius $index] + } else { + set rad $radius + } + foreach {cornerPts centerPts} [RoundedAngleCoords $angleCoords $rad] break + set curvePts [concat $curvePts $cornerPts] + } + } + + return $curvePts + } + + #----------------------------------------------------------------------------------- + # Graphics::PathLineCoords + # retourne les coordonnées d'une pathLine + # paramètres : + # coords : points de path + # options : + # -closed : ligne fermée + # -shifting : sens de décalage [both|left|right] par défaut both + # -linewidth : epaisseur de la ligne + #----------------------------------------------------------------------------------- + proc PathLineCoords {coords options} { + set numFaces [llength $coords] + set pts {} + + set closed [TLGet $options -closed] + set lineWidth [TLGet $options -linewidth 0] + set shifting [TLGet $options -shifting both] + + if { ! $numFaces || $lineWidth < 2 } { + return {} + } + + set previous {} + if { $closed } { + set previous [lindex $coords [expr $numFaces - 1]] + } + set next [lindex $coords 1] + if { $shifting eq "both" } { + set lineWidth [expr {$lineWidth / 2.0}] + } + + for {set i 0} {$i < $numFaces} {incr i} { + set pt [lindex $coords $i] + foreach {ptX ptY} $pt break + foreach {nextX nextY} $next break + + if { [llength $previous] == 0 } { + # extrémité de curve sans raccord -> angle plat + set previous [list [expr {$ptX + ($ptX - $nextX)}] \ + [expr {$ptY + ($ptY - $nextY)}]] + } + + foreach {angle bisecAngle} [VertexAngle $previous $pt $next] break + + # distance au centre du cercle inscrit : rayon/sinus demi-angle + set sin [expr {sin([deg2rad [expr $angle/2.0]])}] + set delta [expr {$sin ? abs($lineWidth / $sin) : $lineWidth}] + + if { $shifting eq "left" || $shifting eq "right" } { + set adding [expr {($shifting eq "left") ? 90 : -90}] + foreach {x y} [RadPoint $ptX $ptY $delta [expr {$bisecAngle + $adding}]] { + lappend pts $x $y + } + lappend pts $ptX $ptY + + } else { + foreach {x y} [RadPoint $ptX $ptY $delta [expr {$bisecAngle + 90}]] { + lappend pts $x $y + } + foreach {x y} [RadPoint $ptX $ptY $delta [expr {$bisecAngle - 90}]] { + lappend pts $x $y + } + } + + if { $i == [expr $numFaces - 2] } { + if { $closed } { + set next [lindex $coords 0] + } else { + set nextI [expr $i + 1] + set next [list [expr {2 * [PointX [lindex $coords $nextI]] - [PointX $pt]}] \ + [expr {2 * [PointY [lindex $coords $nextI]] - [PointY $pt]}]] + } + } else { + set next [lindex $coords [expr {$i + 2}]] + } + set previous [lindex $coords $i] + } + + if { $closed } { + lappend pts [lindex $pts 0] [lindex $pts 1] [lindex $pts 2] [lindex $pts 3] + } + + return $pts + } + + #----------------------------------------------------------------------------------- + # Graphics::PerpendicularPoint + # retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne + #----------------------------------------------------------------------------------- + proc PerpendicularPoint {point line} { + foreach {x y} $point {p1 p2} $line break + foreach {x1 y1} $p1 {x2 y2} $p2 break + + # cas particulier de lignes ortho. + set minDist .01 + if { abs($y2 - $y1) < $minDist } { + # la ligne de référence est horizontale + return [list $x $y1] + } elseif { abs($x2 - $x1) < $minDist } { + # la ligne de référence est verticale + return [list $x1 $y] + } + + set a1 [expr {double($y2 - $y1) / double($x2 - $x1)}] + set b1 [expr {$y1 - $a1 * $x1}] + + set a2 [expr {-1.0 / $a1}] + set b2 [expr {$y - $a2 * $x}] + + set xRet [expr {double($b2 - $b1) / double($a1 - $a2)}] + set yRet [expr {$a1 * $xRet + $b1}] + + return [list $xRet $yRet] + } + + #----------------------------------------------------------------------------------- + # Graphics::LineAngle + # retourne l'angle d'un point par rapport à un centre de référence + #----------------------------------------------------------------------------------- + proc LineAngle {p center} { + foreach {x y} $p {xref yref} $center break + set angle [expr {(atan2($y - $yref, $x - $xref) + $v::pi/2.0) * 180.0 / $v::pi}] + if { $angle < 0 } { + set angle [expr {$angle + 360}] + } + return $angle + } + + #----------------------------------------------------------------------------------- + # Graphics::VertexAngle + # retourne la valeur de l'angle formée par 3 points + # ainsi que l'angle de la bisectrice + #----------------------------------------------------------------------------------- + proc VertexAngle {pt0 pt1 pt2} { + set angle1 [LineAngle $pt1 $pt0] + set angle2 [LineAngle $pt1 $pt2] + + if { $angle2 < $angle1 } { + set angle2 [expr $angle2 + 360] + } + set alpha [expr {$angle2 - $angle1}] + set bisectrice [expr {$angle1 + ($alpha/2.0)}] + + return [list $alpha $bisectrice] + } + + #----------------------------------------------------------------------------------- + # Graphics::ArcPts + # calcul des points constitutif d'un arc + # params : x,y centre, rayon, angle départ, delta angulaire, pas en degré + #----------------------------------------------------------------------------------- + proc ArcPts {x y rad angle extent step debug} { + set pts {} + + if { $extent > 0 } { + for {set alpha $angle} {$alpha <= ($angle + $extent)} {incr $alpha $step} { + foreach {xn yn} [RadPoint $x $y $rad $alpha] {} + lappend pts $xn $yn + } + } else { + for {set alpha $angle} {$alpha >= ($angle + $extent)} {incr $alpha $step} { + lappend pts [RadPoint $x $y $rad $alpha] + } + } + return $pts + } + + #----------------------------------------------------------------------------------- + # Graphics::RadPoint + # retourne le point circulaire défini par centre-rayon-angle + #----------------------------------------------------------------------------------- + proc RadPoint {x y rad angle} { + set alpha [deg2rad $angle] + + set xpt [expr {$x + ($rad * cos($alpha))}] + set ypt [expr {$y + ($rad * sin($alpha))}] + + return [list $xpt $ypt] + } + + + #----------------------------------------------------------------------------------- + # TabBoxCoords + # Calcul des shapes de boites à onglets + # + # coords : coordonnées rectangle de la bounding box + # + # options + # -numpages : nombre de pages (onglets) de la boite + # -anchor [n|e|s|w] : ancrage des onglets + # -alignment [left|center|right] : alignement des onglets sur le coté d'ancrage + # -tabwidth [|[,,...]|auto] : largeur des onglets + # -tabheight [|auto] : hauteur des onglets + # -tabshift : décalage onglet + # -radius : rayon des arrondis d'angle + # -overlap : distance de recouvrement des onglets + #----------------------------------------------------------------------------------- + proc TabBoxCoords args { + set coords [lindex $args 0] + set options [lrange $args 1 end] + foreach {p0 p1} $coords break + foreach {x0 y0} $p0 {xn yn} $p1 break + set numPages [TLGet $options -numpages 0] + + if { $x0 eq "" || $y0 eq "" || $xn eq "" || $yn eq "" || !$numPages } { + puts "Vous devez au minimum spécifier le rectangle englobant et le nombre de pages" + return {} + } + + set anchor [TLGet $options -anchor n] + set alignment [TLGet $options -alignment left] + set len [TLGet $options -tabwidth auto] + set thick [TLGet $options -tabheight auto] + set biso [TLGet $options -tabshift auto] + set radius [TLGet $options -radius 0] + set overlap [TLGet $options -overlap 0] + set orientation [expr {($anchor eq "n" || $anchor eq "s") ? "horizontal" : "vertical"}] + set maxwidth [expr {($orientation eq "horizontal") ? ($xn - $x0) : ($yn - $y0)}] + set tabswidth 0 + set align 1 + + if { $len eq "auto" } { + set tabswidth $maxwidth + set len [expr {($tabswidth + ($overlap * ($numPages - 1)))/$numPages}] + } else { + if { [llength $len] > 1 } { + foreach w $len { + set tabswidth [expr {$tabswidth + ($w - $overlap)}] + } + set tabswidth [expr {$tabswidth + $overlap}] + } else { + set tabswidth [expr {($len * $numPages) - ($overlap * ($numPages - 1))}] + } + if { $tabswidth > $maxwidth } { + set tabswidth $maxwidth + set len [expr {($tabswidth + ($overlap * ($numPages - 1)))/$numPages}] + } + if { $alignment eq "center" && (($maxwidth - $tabswidth) > $radius) } { + set align 0 + } + } + if { $thick eq "auto" } { + set thick [expr {($orientation eq "horizontal") ? \ + int(($yn - $y0)/10.0) : int(($xn - $y0)/10.0)}] + if {$thick < 10 } { + set thick 10 + } elseif {$thick > 40} { + set thick 40 + } + } + if { $biso eq "auto" } { + set biso [expr {int($thick/2.0)}] + } + if { ($alignment eq "right" && $anchor ne "w") || \ + ($anchor eq "w" && $alignment ne "right") } { + if { [llength $len] > 1 } { + for {set p 0} {$p < $numPages} {incr p} { + lset len $p [expr {-[lindex $len $p]}] + } + } else { + set len [expr {-$len}] + } + set biso [expr {-$biso}] + set overlap [expr {-$overlap}] + } + + if { $alignment eq "center" } { + set biso1 [expr {$biso / 2.0}] + set biso2 $biso1 + } else { + set biso1 0 + set biso2 $biso + } + + if { $orientation eq "vertical" } { + if { $anchor eq "w" } { + set thick [expr {-$thick}] + set startx $x0 + set endx $xn + } else { + set startx $xn + set endx $x0 + } + if { ($anchor eq "w" && $alignment ne "right") || \ + ($anchor eq "e" && $alignment eq "right") } { + set starty $yn + set endy $y0 + } else { + set starty $y0 + set endy $yn + } + + set xref [expr {$startx - $thick}] + set yref $starty + if { $alignment eq "center" } { + set ratio [expr {($anchor eq "w") ? -2 : 2}] + set yref [expr {$yref + (($maxwidth - $tabswidth)/$ratio)}] + } + + set cadre [list [list $xref $endy] [list $endx $endy] \ + [list $endx $starty] [list $xref $starty]] + # + # flag de retournement de la liste des pts de + # curve si nécessaire -> sens anti-horaire + set inverse [expr {$alignment ne "right"}] + } else { + if { $anchor eq "s" } { + set thick [expr {-$thick}] + } + if { $alignment eq "right" } { + set startx $xn + set endx $x0 + } else { + set startx $x0 + set endx $xn + } + if { $anchor eq "s" } { + set starty $yn + set endy $y0 + } else { + set starty $y0 + set endy $yn + } + + set yref [expr {$starty + $thick}] + if { $alignment eq "center" } { + set xref [expr {$x0 + (($maxwidth - $tabswidth)/2.0)}] + } else { + set xref $startx + } + + set cadre [list [list $endx $yref] [list $endx $endy] \ + [list $startx $endy] [list $startx $yref]] + # + # flag de retournement de la liste des pts de + # curve si nécessaire -> sens anti-horaire + set inverse [expr {($anchor eq "n" && $alignment ne "right") || \ + ($anchor eq "s" && $alignment eq "right")}] + } + + for {set i 0} {$i < $numPages} {incr i} { + set pts {} + # + # décrochage onglet + #push (@pts, ([$xref, $yref])) if $i > 0; + # + # cadre + set pts [lrange $cadre 0 end] + # + # points onglets + if { $i > 0 || ! $align } { + lappend pts [list $xref $yref] + } + set tw [expr {([llength $len] > 1) ? [lindex $len $i] : $len}] + if { $orientation eq "vertical" } { + set tabdxy [list $thick $biso1 $thick [expr {$tw - $biso2}] 0 $tw] + } else { + set tabdxy [list $biso1 [expr {-$thick}] [expr {$tw - $biso2}] [expr {-$thick}] $tw 0] + } + foreach {dx dy} $tabdxy { + lappend pts [list [expr {$xref + $dx}] [expr {$yref + $dy}]] + } + + if { $radius } { + if { $i > 0 || ! $align } { + set corners [list 0 1 1 1 0 1 1 0] + } else { + set corners [list 0 1 1 0 1 1 0 0 0] + } + set curvePts [RoundedCurveCoords $pts [list -radius $radius -corners $corners]] + if { $inverse } { + set curvePts [lreverse $curvePts] + } + lappend shapes $curvePts + } else { + if { $inverse } { + set pts [lreverse $pts] + } + lappend shapes $pts + } + + if { $orientation eq "horizontal" } { + lappend titlesCoords [list [expr {$xref + ($tw - ($biso2 - $biso1))/2.0}] \ + [expr {$yref - ($thick/2.0)}]] + set xref [expr {$xref + ($tw - $overlap)}] + } else { + lappend titlesCoords [list [expr {$xref + ($thick/2.0)}] \ + [expr {$yref + ($len - (($biso2 - $biso1)/2.0))/2.0}]] + set yref [expr {$yref + ($len - $overlap)}] + } + } + + return [list $shapes $titlesCoords $inverse] + } + + #----------------------------------------------------------------------------------- + # RESOURCES GRAPHIQUES GRADIENTS, PATTERNS, TEXTURES, IMAGES... + #----------------------------------------------------------------------------------- + #----------------------------------------------------------------------------------- + # Graphics::SetGradients + # création de gradient nommés Zinc + #----------------------------------------------------------------------------------- + proc SetGradients {zinc grads} { + # initialise les gradients de taches + if { ! [llength $v::Gradients] } { + foreach {name gradient} $grads { + # création des gradients nommés + $zinc gname $gradient $name + lappend v::Gradients $name + } + } + } + + #----------------------------------------------------------------------------------- + # Graphics::GetPattern + # retourne la ressource bitmap en l'initialisant si première utilisation + #----------------------------------------------------------------------------------- + proc GetPattern {name} { + global bitmaps imagePath + + if { ![info exists bitmaps($name)] } { + set bitmap "@[file join $imagePath $name]" + set bitmaps($name) $bitmap + return $bitmap + } + return $bitmaps($name) + } + + #----------------------------------------------------------------------------------- + # Graphics::GetTexture + # retourne l'image de texture en l'initialisant si première utilisation + #----------------------------------------------------------------------------------- + proc GetTexture {name} { + global imagePath + + if { ![info exists v::textures($name)] } { + set texture [image create photo -file [file join $imagePath $name]] + if { $texture ne "" } { + set v::textures($name) $texture + } + return $texture + } + return $v::textures($name) + } + + #----------------------------------------------------------------------------------- + # Graphics::GetImage + # retourne la ressource image en l'initialisant si première utilisation + #----------------------------------------------------------------------------------- + proc GetImage {name} { + global imagePath + + if { ![info exists v::images($name)] } { + set image [image create photo -file [file join $imagePath $name]] + if { $image ne "" } { + set v::images($name) $image + } + return $image + } + return $v::images($name) + } + + #----------------------------------------------------------------------------------- + # Graphics::InitPixmaps + # initialise une liste de fichier image + #----------------------------------------------------------------------------------- + proc InitPixmaps {pixFiles} { + set imgs {} + foreach f $pixFiles { + lappend imgs [GetImage $f] + } + return $imgs + } + + + proc _min {n1 n2} { + return [expr {($n1 > $n2) ? $n2 : $n1}] + } + + proc _max {n1 n2} { + return [expr {($n1 > $n2) ? $n1 : $n2}] + } + + #----------------------------------------------------------------------------------- + # Graphics::_trunc + # fonction interne de troncature des nombres: n = position décimale + #----------------------------------------------------------------------------------- + proc _trunc {val n} { + regexp {([0-9]+)\.?([0-9]*)} $val match ent dec + set str [expr {($val < 0) ? -$ent : $ent}] + if { ($dec ne "") && ($n != 0) } { + set dec [string range $dec 0 [expr {$n-1}]] + if { $dec != 0 } { + set str "$str.$dec" + } + } + return $str; + } + + #----------------------------------------------------------------------------------- + # Graphics::RGBdec2hex + # conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff' + #----------------------------------------------------------------------------------- + proc RGBdec2hex {rgb} { + return [eval "format {#%04x%04x%04x} $rgb"] + } + + #----------------------------------------------------------------------------------- + # zincGraphics::PathGraduate + # création d'un jeu de couleurs dégradées pour item pathLine + #----------------------------------------------------------------------------------- + proc PathGraduate {numColors style} { + set type [TLGet $style -type] + set colors [TLGet $style -colors] + + if { $type eq "linear" } { + return [CreateGraduate $numColors $colors 2] + + } elseif { $type eq "double" } { + set colors1 [CreateGraduate [expr {$numColors/2+1}] [lindex $colors 0]] + set colors2 [CreateGraduate [expr {$numColors/2+1}] [lindex $colors 1]] + set clrs {} + for {set i 0} {$i <= $numColors} {incr i} { + lappend clrs [lindex $colors1 $i] [lindex $colors2 $i] + } + return $clrs + + } elseif { $type eq "transversal" } { + foreach {c1 c2} $colors break + set clrs [list $c1 $c2] + for {set i 0} {$i < $numColors} {incr i} { + lappend clrs $c1 $c2 + } + return $clrs; + } + } + + #----------------------------------------------------------------------------------- + # Graphics::CreateGraduate + # création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs + #----------------------------------------------------------------------------------- + proc CreateGraduate {totalSteps refColors {repeat 1}} { + set colors {} + set numGraduates [expr {[llength $refColors] - 1}] + + if { $numGraduates < 1 } { + puts "Le dégradé necessite au minimum 2 couleurs de référence..." + return {} + } + + set steps [expr {($numGraduates > 1) ? ($totalSteps/($numGraduates - 1.0)) : $totalSteps}] + + for {set c 0} {$c < $numGraduates} {incr c} { + set c1 [lindex $refColors $c] + set c2 [lindex $refColors [expr {$c+1}]] + + # + # Pas de duplication de la couleur de raccord entre + # deux segments + set thisSteps $steps + if { $c < [expr $numGraduates - 1] } { + set thisSteps [expr $thisSteps - 1] + } + for {set i 0} {$i < $thisSteps} {incr i} { + set color [ComputeColor $c1 $c2 [expr {$i/($steps-1.0)}]] + for {set k 0} {$k < $repeat} {incr k} { + lappend colors $color + } + } + } + + return $colors + } + + #----------------------------------------------------------------------------------- + # Graphics::computeColor + # calcul d'une couleur intermédiaire défini par un ratio ($ratio) entre 2 couleurs + #----------------------------------------------------------------------------------- + proc ComputeColor {color0 color1 ratio} { + if { $ratio > 1.0 } { + set ratio 1 + } elseif { $ratio < 0 } { + set ratio 0 + } + + foreach {r0 g0 b0 a0} [ZnColorToRGB $color0] break + foreach {r1 g1 b1 a1} [ZnColorToRGB $color1] break + + set r [expr {$r0 + int(($r1 - $r0) * $ratio)}] + set g [expr {$g0 + int(($g1 - $g0) * $ratio)}] + set b [expr {$b0 + int(($b1 - $b0) * $ratio)}] + set a [expr {$a0 + int(($a1 - $a0) * $ratio)}] + return [HexaRGBcolor $r $g $b $a] + } + + proc ZnColorToRGB {znColor} { + foreach {color alpha} [split $znColor ";"] break + set pattern [expr {[string length $color] > 8 ? {#%4x%4x%4x} : {#%2x%2x%2x}}] + scan $color $pattern r g b + + if {$alpha eq ""} { + set alpha 100 + } + + return [list $r $g $b $alpha] + } + + #----------------------------------------------------------------------------------- + # Graphics::hexaRGBcolor + # conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff' + #----------------------------------------------------------------------------------- + proc HexaRGBcolor {r g b args} { + if { [llength $args] } { + return [format {#%02x%02x%02x;%d} $r $g $b [lindex $args 0]] + } else { + return [format {#%02x%02x%02x} $r $g $b] + } + } +} + +proc lreverse {l} { + set res {} + set i [llength $l] + while {$i} { + lappend res [lindex $l [incr i -1]] + } + return $res +} -- cgit v1.1