path: root/library/zincGraphics.tcl

#
#-----------------------------------------------------------------------------------
#
#      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 <vinot@cena.fr>
#		Patrick Lecoanet <lecoanet@cena.fr> (Straight translation
#		to Tcl, based on Graphics.pm revision 1.9)
# $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 : <widget>
  # parentGroup : <group>
  # style : {hash table options}
  # specificTags : [list of specific tags] to add to params -tags
  # name : <str> 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 <n> : nombre de pages (onglets) de la boite
  #              -anchor [n|e|s|w] : ancrage des onglets
  # -alignment [left|center|right] : alignement des onglets sur le coté d'ancrage
  # -tabwidth [<n>|[<n1>,<n2>,<n3>...]|auto] : largeur des onglets
  #          -tabheight [<n>|auto] : hauteur des onglets
  #                  -tabshift <n> : décalage onglet
  #                    -radius <n> : rayon des arrondis d'angle
  #                   -overlap <n> : distance de recouvrement des onglets
  #-----------------------------------------------------------------------------------
  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
}