Sarnold 15May2005
Here is the code of a little mathematic curves tracer. It draws the following equations :
x=f(t) y=g(t)
where t, x and y are reals.
What you can test :
x($t)= cos($t*6) y($t)= sin($t*9)
The coordinates formulas are parsed by expr, with the only $t variable.
TODO : (if I have the time) - use a slave interpreter to compute the formulas (for safety)
package require Tk
proc isNumber {x} {
if {[catch {expr {double($x)}}]} {
return 0
}
return 1
}
# french language
set francais 0
if {$francais} {
array set i18n {Tracer Tracer Quitter Quitter "Zoom avant" "Zoom avant"
"Zoom arrière" "Zoom arrière" ErreurFormule "Erreur dans la formule"
ErreurTrace "Erreur dans le tracé" NombreInvalide "Nombre invalide"
}
} else {
array set i18n {Tracer Trace Quitter Exit "Zoom avant" "Zoom in"
"Zoom arrière" "Zoom out" ErreurFormule "Error in formula"
ErreurTrace "An error has occured while tracing the curve" NombreInvalide "Invalid number"
}
}
proc gt {x y} {return [expr {$x>$y && ![Fequal $x $y]}]}
array set widget {}
if {[winfo screenwidth .]>1000} {
array set wopt {canvaspadding 60 wpadding 8 innerpadding 8}
} else {
array set wopt {canvaspadding 40 wpadding 2 innerpadding 2}
}
array set param {x1 -10 y1 -10 x2 10 y2 10 t1 -10 t2 10 dt 0.1}
set eqx "\$t*3"
set eqy "\$t+2"
proc main {} {
# tableau contenant les chemins des widgets
global widget param wopt
# graphique principal
set widget(graph) [frame .frame1]
pack $widget(graph) -side top
set widget(canvas) [canvas $widget(graph).cangraph \
-height [expr {400+$wopt(canvaspadding)*2}] \
-width [expr {600+$wopt(canvaspadding)*2}]]
# on a une surface utile de 400 par 400 pixels, le reste est là
# pour permettre d'inscrire les axes d'abscisse et d'ordonnée
pack $widget(canvas) -in $widget(graph)
# boutons de paramètrage
set widget(param) [frame .frame2]
pack $widget(param) -side bottom
set inPad $wopt(innerpadding)
set outPad $wopt(wpadding)
# spécifique aux variables 'x', 'y' et 't'
set widget(vars) [frame $widget(param).vars]
pack $widget(vars) -in $widget(param) -side left
# ordre de placement des widgets : j: 0 -> n, de haut en bas et de gauche à droite
set j 0
foreach i {x1 x2 y1 y2 t1 t2 dt} name {xOrig xEnd yOrig yEnd tOrig tEnd deltaT} {
set widget($i) [frame $widget(vars).$i]
grid $widget($i) -row [expr {$j%2}] -column [expr {$j/2}]
set widget(lbl$i) [label $widget($i).lbl -text $name]
set widget($name) [entry $widget($i).saisie -width 6 -textvariable param($i)]
pack $widget(lbl$i) $widget($name) -in $widget($i) -padx $outPad -pady $outPad\
-side left
incr j
}
unset i name j
set widget(eqs) [frame $widget(param).eqs]
pack $widget(eqs) -in $widget(param) -side left
foreach i {x y} name {eqx eqy} ligne {0 1} {
set widget(frame$i) [frame $widget(eqs).$i]
grid $widget(frame$i) -in $widget(eqs) -row $ligne -column 0
set widget(lbl$i) [label $widget(frame$i).lbl -text "${i}\(\$t\) ="]
set widget($name) [entry $widget(frame$i).eq -width 10 -textvariable ::$name]
pack $widget(lbl$i) $widget($name) -in $widget(frame$i) -padx $outPad\
-pady $outPad -side left
}
global i18n
set widget(tracer) [button $widget(param).tracer -text $i18n(Tracer) -command {Tracer}\
-padx $inPad -pady $inPad -default active]
# bouton quitter
set widget(quitter) [button $widget(param).quitter -text $i18n(Quitter) -command {exit} \
-padx $inPad -pady $inPad]
# zoom in
set widget(zoomin) [button $widget(param).zoomin -text $i18n(Zoom avant) -command {ZoomIn}\
-padx $inPad -pady $inPad]
# zoom out
set widget(zoomout) [button $widget(param).zoomout -text $i18n(Zoom arrière) -command {ZoomOut}\
-padx $inPad -pady $inPad]
pack $widget(tracer) $widget(quitter) $widget(zoomin) $widget(zoomout) -in $widget(param) -padx $outPad -pady $outPad -side right
bind . <KeyPress-Return> {Tracer}
}
# Vérifie que les deux formules sont justes
# Retourne 1 si tout est OK, 0 si KO
proc ControleFormules {} {
global widget i18n
set t $::param(t1)
global eqx eqy
if {[catch {eval expr $eqx} msg]} {
tk_messageBox -message "$i18n(ErreurFormule) : x=$eqx"
return 0
}
if {[catch {eval expr $eqy} msg]} {
tk_messageBox -message "$i18n(ErreurFormule) : y=$eqy"
return 0
}
return 1
}
proc Tracer {} {
if {![ControleOrigines]} {return}
ControleFormules
global widget i18n
# calcul des coordonnées
if {[catch {set coords [Coordonnees]}] || [llength $coords]==0} {
tk_messageBox -message $i18n(ErreurTrace)
# effacer tout tracé antérieur
$widget(canvas) delete all
return
}
# effacer tout tracé antérieur
$widget(canvas) delete all
TracerAxes $widget(canvas)
# pour chaque partie de la courbe
foreach partie $coords {
# on détermine les segments inclus dans la surface balayée
set segments [Valider [Grouper $partie 2]]
foreach seg $segments {
if {[llength $seg]<2} {
continue
}
$widget(canvas) create line [normalize [Degrouper $seg]]
}
}
return
}
# comme la commande concat : {{1 2 3} {4 5 6}} devient {1 2 3 4 5 6}
# cette commande rend une liste imbriquée (nested) un niveau de moins imbriquée
proc Degrouper {liste} {
foreach elt $liste {
foreach sousElt $elt {
lappend result $sousElt
}
}
return $result
}
# à partir de coordonnées (de points suivant la courbe)
# retourne les différentes parties de la courbe appartenant aux intervalles choisis
# pour le tracé
proc Valider {coords} {
set segments [Segments $coords]
set result [list]
set temp [list]
# coords est une liste de couple (x,y) : une liste de $point
for {set i 0} {$i<[llength $coords]} {incr i} {
set point [lindex $coords $i]
if {![AppCanvas $point]} {
# le point est situé hors du graphique
# si le point précédent ne l'était pas, tracer qd même le segment en
# calculant son intersection avec les bornes du graphique
if {[llength $temp]>0} {
lappend temp [Avancer [lindex $segments [expr {$i-1}]]]
lappend result $temp
}
set temp [list]
}
if {[AppCanvas $point]} {
# si le point précédent est en dehors des bornes,
# il faut tracer le segment formé du point courant et du point précédent
# en calculant ses coordonnées (intersection)
if {[llength $temp]==0 && $i>0} {
lappend temp [Reculer [lindex $segments [expr {$i-1}]]]
}
lappend temp $point
}
}
if {[llength $temp]!=0} {
lappend result $temp
}
return $result
}
# détermine l'intersection de $segment avec les bords du dessin
proc Reculer {segment} {
lassign $segment a b
return [Avancer [list $b $a]]
}
# détermine si deux flottants sont égaux
proc Fequal {x y} {
expr {abs(double($x)-double($y))<1e-10}
}
# Intersection :
# Trouve les coordonnées de l'intersection de deux segments
# Arguments :
# {x1 y1 x2 y2} - les coordonnées du premier segment
# {x3 y3 x4 y4} - les coordonnées du deuxième segment
# Retour :
# x y - les coordonnées de l'intersection
# Effets de bords : aucun
proc Intersection {segment1 segment2} {
lassign $segment1 x1 y1 x2 y2
lassign $segment2 x3 y3 x4 y4
if {[set eq1 [Fequal $x1 $x2]] || [Fequal $x4 $x3]} {
# si les deux segments sont parallèle et perpendiculaire à l'axe des abscisses,
# il faut donner l'intersection sans calculer les coefficients directeurs
# des droites prolongeants les segments
if {[set eqy1 [Fequal $y1 $y2]] || [Fequal $y3 $y4]} {
set x [expr {$eq1?($x1):($x3)}]
set y [expr {$eqy1?($y1):($y3)}]
return [list $x $y]
}
# coefficients directeurs des deux segments (x et y sont échangés)
set c1 [expr {double($x2-$x1)/($y2-$y1)}]
set c3 [expr {double($x4-$x3)/($y4-$y3)}]
# l'équation de la droite 1,2 est : x=c1*(y-y1)+x1
# l'équation de la droite 3,4 est : x=c3*(y-y3)+x3
# si l'on cherche un 'yi' vérifiant les deux équations
# ce sera l'ordonnée de l'intersection, et ce nombre vérifiera l'équation :
# (y1-yi)*c1 -x1 = (y3-yi)*c3 - x3
# dont la solution est calculée ici :
set yInter [expr {double($x3-$x1+$y1*$c1-$y3*$c3)/($c1-$c3)}]
set xInter [expr {double($x1)+$c1*($yInter-$y1)}]
} else {
# même chose en inversant abscisse et ordonnée :
set c1 [expr {double($y2-$y1)/($x2-$x1)}]
set c3 [expr {double($y4-$y3)/($x4-$x3)}]
set xInter [expr {double($y3-$y1+$x1*$c1-$x3*$c3)/($c1-$c3)}]
set yInter [expr {double($y1)+$c1*($xInter-$x1)}]
}
return [list $xInter $yInter]
}
# vérifie :
# 1- xInter,yInter appartient à $segmentCoupe (en tant que segment)
# 2- que xInter,yInter est dans la succession du segmentDirecteur
# (p. ex. xInter>x4>x3 ou xInter<x4<x3, idem pour yInter)
proc ValiderIntersection {xInter yInter segmentCoupe segmentDirecteur} {
lassign $segmentCoupe x1 y1 x2 y2
lassign $segmentDirecteur x3 y3 x4 y4
if {[EstComprisEntre $xInter $x1 $x2] && [EstComprisEntre $yInter $y1 $y2]} {
if {[EstComprisEntre $xInter $x3 $x4] && [EstComprisEntre $yInter $y3 $y4]} {
return 1
}
return 0
}
return 0
}
# détermine l'intersection d'un segment avec les bornes de la surface parcourue
proc Avancer {segment} {
global param
set segmentDirecteur [Degrouper $segment]
# itère suivant les segments de limite du tracé
foreach {x1 y1 x2 y2} {x1 y1 x2 y1 x2 y1 x2 y2 x2 y2 x1 y2 x1 y2 x1 y1} {
set segmentTest [list $param($x1) $param($y1) $param($x2) $param($y2)]
lassign [Intersection $segmentTest $segmentDirecteur] xInter yInter
if {[ValiderIntersection $xInter $yInter $segmentTest $segmentDirecteur]} {
return [list $xInter $yInter]
}
}
error "impossible de trouver une limite"
}
# détermine si $x appartient à l'intervalle (de nb flottant) compris entre $inf et $sup
proc EstComprisEntre {x inf sup} {
if {$inf>$sup} {
# on peut avoir une inversion des bornes inférieure et supérieure
return [EstComprisEntre $x $sup $inf]
}
if {[gt $x $sup] || [gt $inf $x]} {
return 0
}
return 1
}
# à partir d'une liste de points, fournit les segments correspondant
# {{1 0} {2 1} {3 2}} devient {{{1 0} {2 1}} {{2 1} {3 2}}}
proc Segments {coords} {
set segments {}
for {set pt 0} {$pt+1<[llength $coords]} {incr pt} {
lappend segments [lrange $coords $pt [expr {$pt+1}]]
}
return $segments
}
# tracé des axes et des coordonnées, en superposant ceux-ci aux figures déjà présentes
proc TracerAxes {cheminCanvas} {
global param wopt
set coords [Range $param(x1) $param(x2) 11]
if {[gt 0 $param(x1)] && [gt $param(x2) 0]} {
lappend coords 0
}
foreach x $coords {
lassign [normalize [list $x $param(y1)]] x1 y1
lassign [normalize [list $x $param(y2)]] dummy y2
$cheminCanvas create text $x1 $y1 -text [format %.2f $x] \
-anchor n
$cheminCanvas create line $x1 $y1 $x1 $y2 -dash .
}
# SA le 8 mai 05 : Range...11 à la place de 10 pour obtenir un plus beau tracé
set coords [Range $param(y1) $param(y2) 11]
if {[gt 0 $param(y1)] && [gt $param(y2) 0]} {
lappend coords 0
}
foreach y $coords {
lassign [normalize [list $param(x1) $y]] x1 y1
lassign [normalize [list $param(x2) $y]] x2 dummy
$cheminCanvas create text [expr {$x1-$wopt(canvaspadding)/2}] $y1 \
-text [format %.2f $y] -anchor w
$cheminCanvas create line $x1 $y1 $x2 $y1 -dash .
}
return
}
# a partir de coordonnées réelles correspondant aux valeurs de la fonction paramétrique
# fournit des coordonnées entières correspondant à des pixels du canvas
# il s'agit de 2 transformations affines
proc normalize {coords} {
global param wopt
foreach {x y} $coords {
# coordonnée x : (abscisse) la surface est comprise entre 2pad+0 et 2pad+400
lappend l [expr {int(($x-$param(x1))*600/double($param(x2)-$param(x1)))+$wopt(canvaspadding)}]
# coordonnée y : (ordonnée) la surface est comprise entre pad+0 et pad+400
lappend l [expr {int(($param(y2)-$y)*400/double($param(y2)-$param(y1)))+$wopt(canvaspadding)}]
}
return $l
}
# construit une liste de $ini à $dest en $steps points
proc Range {ini dest steps} {
for {set i 0} {$i<$steps} {incr i} {
lappend l [expr {$ini+double($dest-$ini)*$i/($steps-1)}]
}
return $l
}
# calcule les coordonnées des points successifs de la courbe paramétrique :
# x=f(t) et y=g(t)
proc Coordonnees {} {
global param
set resultat {}
set temp {}
for {set t $param(t1)} {$t<=$param(t2)} {set t [expr {$t+$param(dt)}]} {
if {[catch {
lappend temp [eval expr $::eqx] [eval expr $::eqy]
}]} {
if {[llength $temp]} {lappend resultat $temp}
set temp {}
}
}
if {[llength $temp]} {lappend resultat $temp}
return $resultat
}
# vérifie si un point donné appartient au canvas
proc AppCanvas {point} {
global param
lassign $point x y
if {[gt $x $param(x2)] || [gt $param(x1) $x]} {
return 0
}
if {[gt $y $param(y2)] || [gt $param(y1) $y]} {
return 0
}
return 1
}
# grouper les éléments d'une liste
proc Grouper {liste nb} {
for {set i 0} {$i<[llength $liste]} {incr i $nb} {
set interieur {}
lappend l [lrange $liste $i [expr {$i-1+$nb}]]
}
return $l
}
proc swap {a b} {
list $b $a
}
# ControleOrigines :
# vérifie que origine et destination des courbes soient correctement paramétrées
# Arguments : aucun
# Retour :
# vrai si tout est OK, 0 (faux) sinon
# Effets de bord : utilise le tableau global param
proc ControleOrigines {} {
global param
foreach i [array names param] {
if {![isNumber $param($i)]} {
tk_messageBox -message "$i18n(NombreInvalide) : $i"
return 0
}
}
foreach {a b} {x1 x2 y1 y2 t1 t2} {
if {[gt $param($a) $param($b)]} {
lassign [swap $param($a) $param($b)] param($a) param($b)
}
}
return 1
}
proc ZoomIn {} {Zoomer +50}
proc ZoomOut {} {Zoomer -50}
# Zoomer :
# rétrécit ou étire la zone de tracé
# args :
# pourcentage - le pourcentage de rétrécissement de la zone (passer par exemple
# de [-10,10] à [-5,5]
proc Zoomer {pourcentage} {
global param
lassign [Retrecir $param(x1) $param(x2) $pourcentage] param(x1) param(x2)
lassign [Retrecir $param(y1) $param(y2) $pourcentage] param(y1) param(y2)
Tracer
}
# rétrécit un segment [a,b] de $pourcentage %
proc Retrecir {a b pourcentage} {
set distance [expr {$b-$a}]
set milieu [expr {$a+$distance/2}]
set distance [expr {$distance*(100-$pourcentage)/200}]
return [list [expr {$milieu-$distance}] [expr {$milieu+$distance}]]
}
main
Tracer