[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} {
     foreach {a b} $segment {break}
     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} {
     foreach {x1 y1 x2 y2} $segment1 {break}
     foreach {x3 y3 x4 y4} $segment2 {break}
     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} {
     foreach {x1 y1 x2 y2} $segmentCoupe {break}
     foreach {x3 y3 x4 y4} $segmentDirecteur {break}
     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)]
         foreach {xInter yInter} [Intersection $segmentTest $segmentDirecteur] {break}
         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 {
         foreach {x1 y1} [normalize [list $x $param(y1)]] {break}
         foreach {dummy y2} [normalize [list $x $param(y2)]] {break}
         $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 {
         foreach {x1 y1} [normalize [list $param(x1) $y]] {break}
         foreach {x2 dummy} [normalize [list $param(x2) $y]] {break}
         $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
     foreach {x y} $point {
         break
     }
     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)]} {
             foreach {param($a) param($b)} [swap $param($a) $param($b)] {break}
         }
     }
     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
     foreach {param(x1) param(x2)} [Retrecir $param(x1) $param(x2) $pourcentage] {break}
     foreach {param(y1) param(y2)} [Retrecir $param(y1) $param(y2) $pourcentage] {break}
     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

----
 
[Category Mathematics] | [Category Plotting]
[http://www.jifamark.com/ 线号机]