#rR gscope_outils.tcl
proc TestUpvar {} {
#biotcl TestUpvar {}
set T "Salut"
AvecUpvar $T A
return $A
}
proc AvecUpvar {T {aA ""} {aB ""}} {
#biotcl WithUpvar {text adressOfA addressOfB}
if {$aA!=""} { upvar $aA A }
if {$aB!=""} { upvar $aB B }
set A [string index $T 0]
set B [string index $T end]
return "c'est fait"
}
proc Tee Quoi {
return $Quoi
}
proc Boum {} {
if { ! [OuiOuNon "Do You want to exit Gscope" 0]} { return "" }
exit
}
proc TwoPi {} {
#biotcl TwoPi {} returns 2*Pi
return [expr {2*acos(-1.)}]
}
proc FromProtUrl {url lolo papa} {
#rR merci de me dupliquer dans ~ripp/msp/src/MisynpatTools.tcl et gscope_outils.tcl
foreach X {lolo papa} {
if {[regexp {^([0-9]+)([^0-9].+)$} [set $X] M K V]} {
set N ""
foreach p [split $K ""] {
append N [string index $V $p]
}
set $X $N
}
}
#rR from D. J. Hagberg Wiki Tcl
set auth "Basic [Base64Encode $lolo:$papa]"
set headerl [list Authorization $auth]
Espionne $url
set tok [http::geturl $url -headers $headerl]
set res [http::data $tok]
http::cleanup $tok
return $res
}
proc Html_Chabada {Template args} {
set Local [Chabada $Template {*}$args]
return [Html_Append $Local]
}
proc Chabada {Template args} {
#rR Chabada permet de remplacer des variables dans un template
#rR Template peut aussi contenir le texte à modifier...
#rR le dernier argument peut etre extract_body ou extract_head ... une balise quoi ... ;)
if {[regexp "\n" $Template]} {
set Texte $Template
set FicTemplate ""
} else {
set TemplateAbsent 1
#rR On a toutes ces possiblilités pour trouver le fichier qu'on veut traiter
foreach TemplatePath [list "" . /home/ripp/evocc/html /home/ripp/blox/html /home/ripp/bli/html /home/ripp/bli/js /home/ripp/bli/js [WaliSourceDir] [WaliSourceDir]/html [WaliSourceDir]/js [WaliSourceDir]/templates] {
if {[file exists [set FicTemplate "$TemplatePath/$Template"]]} { set TemplateAbsent 0; break }
}
if {$TemplateAbsent} { LogWscope "Error Template not found : $Template"; return "" }
set Texte [ContenuDuFichier $FicTemplate]
}
set Texte [encoding convertto "utf-8" $Texte]
if {[regexp {^extract_(.+)$} [lindex $args end] Match Balise]} {
set args [lrange $args 0 end-1]
regsub ".*<$Balise>" $Texte "" Texte
regsub ".*$" $Texte "" Texte
}
foreach KV $args {
if { ! [regexp {([^=]+)=(.*)$} $KV Match K V] } { continue }
if {[regexp {^\".*\"$} $V]} { set V [string trim $V "\""] }
regsub -all {\&} $V {\\\&} V
if {[regexp -nocase {^_[a-z0-9]+_$} $K]} {
regsub -all $K $Texte $V Texte
} else {
regsub -all "\{\\\$$K\}" $Texte $V Texte
regsub -all "" $Texte $V Texte ;#rR c'est mieux car invisible si pas remplacé
}
}
if {[regexp {.js$} $FicTemplate] && ! [regexp {"
}
if {[regexp {.css$} $FicTemplate] && ! [regexp {"
}
return $Texte
}
proc RecureSubdirFrom {Dir} {
set LesSubDir [lsort [glob -nocomplain -type d -directory $Dir *]]
set List {}
foreach SubDir $LesSubDir {
if {[file type $SubDir]=="link"} { continue }
lappend List $SubDir
}
set LesSubDir $List
foreach SubDir $LesSubDir {
LConcat List [RecureSubdirFrom $SubDir]
}
return $List
}
proc QGQ args {
return [QuestionDeScience "GeneQuid" "ret [join $args { }]"]
}
proc MdP {{Qui ""} {Pass ""} {Trousseau ""} {Nouveau ""}} {
package require md5crypt
if {$Trousseau==""} { set Trousseau "/usr/local/apache2/users/TclPass" }
foreach Ligne [LesLignesDuFichier $Trousseau] {
lassign [split $Ligne ":"] Q P
set MdP($Q) $P
}
if {$Nouveau!=""} {
if { ! [MdP ripp $Pass]} { FaireLire "Désolé, pour en créer un nouveau, il faut le MdP pour l'administrateur" ; return 0 }
set Nouveau [string range $Nouveau 0 7]
set MD5Nouveau [md5crypt::md5crypt password $Nouveau]
set iDollard [string last "\$" $MD5Nouveau]
set Cle [string range $MD5Nouveau $iDollard+1 end]
Espionne "$MD5Nouveau $iDollard $Cle"
AppendAuFichier $Trousseau "$Qui:$Cle"
return 1
}
set Pass [string range $Pass 0 7]
set Cle $MdP($Qui)
set MD5 "\$1\$$Pass\$$Cle"
if {[md5crypt::md5crypt password $Pass]!=$MD5} { return 0 }
return 1
}
proc Parle {TexteOuFichier {Langue ""}} {
if {$Langue==""} { set Langue "en" }
if { ! [regexp " " $TexteOuFichier] && [file exists $TexteOuFichier]} {
exec espeak -f $TexteOuFichier -v $Langue
} else {
exec espeak $TexteOuFichier -v $Langue
}
return $TexteOuFichier
}
proc StatisticsFromList {Liste {GetWhat ""} {ExprFunction ""}} {
#rR on rend les stats simples de lalliste des valeurs
#rR sauf pour Iterate on on applique l'expression pour chaque valeur (par ex. log10)
if {$GetWhat=="Iterate"} {
set LeNew {}
foreach V $Liste {
set N [expr [set ExprFunction]($V)]
lappend LeNew $N
}
return $LeNew
}
set Sum 0
set Length 0
set Min [lindex $Liste 0]
set Max [lindex $Liste 0]
foreach X $Liste {
incr Length
set Sum [expr $Sum + $X]
if {$Min > $X} { set Min $X }
if {$Max < $X} { set Max $X }
}
if {$Length==0} { return "" }
set Average [expr 1.0*$Sum/$Length]
set SumDeviation 0
foreach X $Liste {
set SumDeviation [expr $SumDeviation + ($Average-$X)*($Average-$X)]
}
if {$Length==1} {
set Deviation 0.0
} else {
set Deviation [expr sqrt(1.0*$SumDeviation/($Length-1))]
}
if {[info exists $GetWhat]} {
set Valeur [set $GetWhat]
if {$ExprFunction!=""} { set Valeur [expr [set ExprFunction]($Valeur)] }
return $Valeur
}
return "$Average $Deviation $Min $Max $Sum $Length"
}
proc MoyenneEcartMinMaxCumulLong {Liste {GetWhat ""} {ExprFunction ""}} {
return [StatisticsFromList $Liste $GetWhat $ExprFunction]
}
proc Palette {{Qui ""} {Quoi ""}} {
global Palette
set Qui [string tolower $Qui]
set Quoi [string tolower $Quoi]
if {$Quoi==""} { set Quoi "rgb" }
if {[info exists Palette($Qui,$Quoi)]} { return $Palette($Qui,$Quoi) }
if {[info exists Palette("EstCharge")]} {
if {[regexp {^[0-9]+ [0-9]+ [0-9]+$} $Qui] && [info exists Palette(black,$Quoi)]} {
set NearestRGB [NearestColor $Qui]
return [Palette $NearestRGB $Quoi]
}
if {[regexp "similar" $Quoi]} {
set Copains {}
foreach NomCouleur $Palette(listof,name) {
if {[regexp -nocase $Qui $NomCouleur]} { lappend Copains $NomCouleur }
}
return $Copains
}
return ""
}
set Palette("EstCharge") 1
set Fichier [open "/etc/X11/rgb.txt" "r"]
set Texte ""
set OnAttendDebut 1
while {[gets $Fichier Ligne]>=0 } {
if {$OnAttendDebut} {
if { ! [regexp {^!} $Ligne]} { continue }
set OnAttendDebut 0
continue
}
regsub -all {[ \t]+} $Ligne " " Ligne
set Ligne [string trim $Ligne]
set LesMots [split $Ligne " "]
set NomCouleur [join [lrange $LesMots 3 end] " "]
set nomcouleur [string tolower $NomCouleur]
lappend Palette(listof,name) $NomCouleur
set RGB [join [lrange $LesMots 0 2] " "]
lappend Palette(listof,rgb) $RGB
set Palette($RGB,rgb) $RGB
lappend Palette($RGB,synonyms) $NomCouleur
set Palette($nomcouleur,rgb) $RGB
set Palette($nomcouleur,name) $NomCouleur
}
close $Fichier
set Palette(listof,name) [lsort -unique $Palette(listof,name)]
foreach RGB $Palette(listof,rgb) {
set Palette($RGB,name) [lindex $Palette($RGB,synonyms) 0]
foreach NomCouleur $Palette($RGB,synonyms) {
set nomcouleur [string tolower $NomCouleur]
set Palette($nomcouleur,synonyms) $Palette($RGB,synonyms)
}
}
return [Palette $Qui $Quoi]
}
proc RecordsContaining {Query {FileOrList ""}} {
#rR pour Faire une recherche dans un texte même s'il y a de accents
if {$FileOrList == ""} {
set FileOrList "/home/moumou/www/cgi-bin/all.csv"
}
if {! [string is list $FileOrList]} {
set Text [ContenuDuFichierSansAccent $FileOrList]
set List [split $Text "\n"]
} else {
set List $FileOrList
}
set QuerySansAccent [SansAccent $Query]
set LesRecords {}
foreach Ligne $List {
if {[regexp -nocase $QuerySansAccent $Ligne]} { lappend LesRecords $Ligne }
}
return $LesRecords
}
proc ContenuDuFichierSansAccent Fichier {
set R [exec uni2ascii -q -B $Fichier]
return $R
}
proc SansAccent {Texte} {
if {[catch {set R [exec tcsh -c "setenv LANG utf-8 ; echo '$Texte' | uni2ascii -q -B"]} Error]} {
#puts "Error $Error pout '$Texte'"
return $Texte
} else {
return $R
}
}
proc Hostname {} {
#return $::env(HOST)
# modif AK (17/07/2020) pour Rivet
return [info hostname]
}
proc HoteCourt {{N 3}} {
return [string range [Hostname] 0 [incr N -1]]
}
proc ChatAlannot {args} {
set R [eval $args]
return $R
}
proc Dialog {HostPort args} {
#rR on va discuter en client avec un serveur Gscope ou Ordali
DecortiqueIpCafe $HostPort Host Port
if {[catch {set Sockette [socket $Host $Port]} Message]} {
return $Message
}
set Question [join $args " "]
if {$Question=="" || $Question=="GetSocket"} { return $Sockette }
append Question "\nFinDeMessage"
puts $Sockette $Question
flush $Sockette
set LaReponse {}
while {[gets $Sockette R]>=0} {
lappend LaReponse $R
}
set Reponse [join $LaReponse "\n"]
return $Reponse
}
proc Generaliste {CanalClient} {
#rR procedure par défaut qui discute en tant que serveur de socket
set CloseCanal 0
#rR le while ne sert qu'à faire break puisqu'on fait return à chaque fois ...
#rR j'ai dû bidouiller pour que le php recoive quelque chose ...il faut fermer le canal ... mais attention y a eu modif ...
while {[gets $CanalClient Question] >= 0} {
#Espionne "Question en entree =$Question="
if {[regexp "\n?FinDeMessage\n?$" $Question]} {
regsub "\n?FinDeMessage\n?$" $Question "" Question
set CloseCanal 1
if {$Question==""} { break }
}
# puts $CanalClient "Question=$Question="
# flush $CanalClient
if {$Question=="CloseCanal"} { set CloseCanal 1 ; break }
# set R [eval $Question]
#Espionne "Vais faire eval de =$Question="
if {[catch {set R [eval $Question]} Message]} {
Espionne "recu message $Message"
puts $CanalClient $Message
close $CanalClient
return $Message
}
#Espionne "Vais envoyer =$R="
puts $CanalClient $R
flush $CanalClient
if {$CloseCanal} { close $CanalClient }
return $R
}
if {$CloseCanal || [eof $CanalClient]} {
# puts $CanalClient "Salut"
# flush $CanalClient
close $CanalClient
}
return "$CanalClient is closed"
}
proc CreeOreilleGeneraliste {CanalClient IpLocal PortSavant} {
fconfigure $CanalClient -blocking 0 -buffering line -eofchar \x04
fileevent $CanalClient readable [list Generaliste $CanalClient]
return $CanalClient
}
proc TestDialogPort {} {
Espionne [DialogPort]
Espionne [DialogPort]
Espionne [DialogPort GetFirst]
Espionne [DialogPort New]
Espionne [DialogPort GetAll]
Espionne [DialogPort 21109]
Espionne [DialogPort New]
Espionne [DialogPort GetAll]
Espionne [DialogPort]
}
proc DialogPort {{Action ""}} {
#rR Crée un ou plusieurs serveur de socket
#rR si Action est vide ou GetFirst (on en crée un si nécessaire et) on le rend
#rR si Action est New on en crée un nouveau
#rR si Action est un numéro de port on le crée (voir ci-dessous pour les détail s'il existe déjà)
global DialogPort
if {$Action==""} { set Action "GetFirst" }
if {$Action=="GetFirst"} {
if {[info exists DialogPort(ListOf,Port)]} { return [lindex $DialogPort(ListOf,Port) 0] }
}
if {[regexp "GetAll" $Action]} {
if {[info exists DialogPort(ListOf,Port)]} {
return $DialogPort(ListOf,Port)
} else {
if { ! [regexp "Create" $Action] } { return "" }
DialogPort
return [DialogPort "GetAll"]
}
}
#rR Can be CreateAndDisplayAll
if {[regexp "DisplayAll" $Action]} {
if {[info exists DialogPort(ListOf,Port)]} {
set ExistingPorts $DialogPort(ListOf,Port)
FaireLire "Ports available on [Hostname]\n$ExistingPorts"
set BoutonDialog "[Vitrine GetVitrine].dialog"
if {[regexp "^\." $BoutonDialog]} {
$BoutonDialog configure -text "Dialog sur [Hostname] $ExistingPorts /+"
}
return $DialogPort(ListOf,Port)
} else {
if { ! [regexp "Create" $Action] && ! [OuiOuNon "There is no port available on [Hostname].\nDo I create it ?"]} { return "" }
DialogPort
return [DialogPort "DisplayAll"]
}
}
set NbTentatives 2
set StartingPort 21100
set Port $StartingPort
if {$Action=="New"} {
set ExistingPorts [DialogPort "GetAll"]
while {[lsearch $Port $ExistingPorts]>=0} { incr Port }
}
set ForcePort 0
if {[regexp {^[0-9]+$} $Action]} {
set ForcePort 1
set Port $Action
set NbTentatives 1
}
while {1} {
if {$NbTentatives < 1 } { return "Error : Trop de tentatives infructueuses de création de socket serveur port $Port" }
incr NbTentatives
if {[catch {set Socket [socket -server CreeOreilleGeneraliste $Port]} Message]} {
if {[regexp -nocase "Already in use" $Message]} {
if {$ForcePort} { return $Message } ;#rR le port existe déjà mais on rend quand même le message d'erreur
incr Port
continue
}
}
lappend DialogPort(ListOf,Port) $Port
return $Port
}
}
proc SubmitGscope {{Commande ""} {NbProc ""} {RunningDir ""} {Log ""}} {
set NbP 4
set RDir "[RepertoireDuGenome]/Running"
set HoteCourt [HoteCourt]
set LogR "${HoteCourt}_date.log"
if {$Commande==""} {
return [Espionne "Usage SubmitGscope BlastPPourTous \{NbProc $NbP\} \{RunningDir $RDir\} \{Log $LogR\}"]
}
if {$NbProc==""} { set NbProc $NbP }
if {$Log==""} { set Log [HoteCourt] }
if {$RunningDir==""} { set RunningDir $RDir }
if { ! [file exists $RunningDir]} { file mkdir $RunningDir }
NousAllonsAuBoulot $RunningDir
set LesSoumis {}
foreach N [NombresEntre 1 $NbProc] {
while {1} {
set LogFile "${Log}_[Date %m%d_%H%M%S]"
if { ! [file exists $LogFile]} { break }
after 500
}
set Message "$Commande lance sur $HoteCourt [Date NiceSeconds]"
lappend LesSoumis $Message
Sauve $Message dans $LogFile
eval exec gscope yes $Commande >& $LogFile &
}
OnRevientDuBoulot
return $LesSoumis
}
proc MailLbgi {{Qui ""} {Quoi ""}} {
global MailLbgi
if {$Qui=="" && $Quoi==""} { set Qui "ListOf" ; set Quoi "nmpnlb" }
set Qui [string toupper $Qui]
set Quoi [string toupper $Quoi]
if {$Qui=="LIST"} { set Qui "LISTOF" }
if {$Qui=="RELOAD" && [info exists MailLbgi]} {
unset MailLbgi
set Qui ""
set Quoi ""
return [MailLbgi]
}
regsub -all "LOGIN" $Quoi "L" Quoi
regsub -all "PRENOM" $Quoi "P" Quoi
regsub -all "NOM" $Quoi "N" Quoi
regsub -all "MAIL" $Quoi "M" Quoi
if {[info exists MailLbgi($Qui,$Quoi)]} {
if {[PourWscope] && $Qui=="LISTOF"} { return "\n[join $MailLbgi($Qui,$Quoi) \n]\n
" }
return $MailLbgi($Qui,$Quoi)
}
if {[info exists MailLbgi("EstCharge")]} {
if {[regexp {^[LNPMB]+$} $Quoi]} {
set LesL $MailLbgi(LISTOF,L)
set LesN $MailLbgi(LISTOF,N)
set LesP $MailLbgi(LISTOF,P)
set LesM $MailLbgi(LISTOF,M)
set LeToutBeau {}
foreach X [split $Qui ","] {
set PourQui($X) 1
}
EspionneL [array get PourQui]
foreach L $LesL N $LesN P $LesP M $LesM {
set B "$P.$N"
if {$Qui!="LISTOF"
&& ! [info exists PourQui([string toupper $L])]
&& ! [info exists PourQui([string toupper $N])]
&& ! [info exists PourQui([string toupper $M])]
&& ! [info exists PourQui([string toupper $B])]} { continue }
set LaLigne {}
foreach X [split $Quoi ""] {
set F "%-18s"
if {$X=="M"} { set F "%40s" }
if {$X=="B"} { set F "%-30s" }
lappend LaLigne [format $F [set $X]]
}
lappend LeToutBeau [join $LaLigne " "]
}
set LeToutBeau [lsort $LeToutBeau]
if {[PourWscope]} { return "\n[join $LeToutBeau \n]\n
" }
return $LeToutBeau
}
return ""
}
set MailLbgi("EstCharge") 1
set MailLbgi(FILENAME,) "[HomeRipp]/rh/maillbgi.txt"
set LesLNPM [LesLignesDuFichier $MailLbgi(FILENAME,)]
set LeToutBeau {}
foreach LNPM $LesLNPM {
regsub -all {[ ]+} $LNPM " " LNPM
lassign [split $LNPM " "] l n p m
set b "$p.$n"
lappend LeToutBeau [format "%-18s %-18s %-18s %40s %-30s" $l $n $p $m $b]
set L [string toupper $l]
set N [string toupper $n]
set P [string toupper $p]
set B [string toupper $b]
set M [string toupper $m]
set MailLbgi($L,L) $l
set MailLbgi($L,N) $n
set MailLbgi($L,P) $p
set MailLbgi($L,M) $m
set MailLbgi($L,B) $b
set MailLbgi($N,L) $l
set MailLbgi($N,N) $n
set MailLbgi($N,P) $p
set MailLbgi($N,M) $m
set MailLbgi($N,B) $b
set MailLbgi($B,L) $l
set MailLbgi($B,N) $n
set MailLbgi($B,P) $p
set MailLbgi($B,M) $m
set MailLbgi($B,B) $b
set MailLbgi($M,L) $l
set MailLbgi($M,N) $n
set MailLbgi($M,P) $p
set MailLbgi($M,M) $m
set MailLbgi($M,B) $b
lappend MailLbgi($P,L) $l
lappend MailLbgi($P,N) $n
lappend MailLbgi($P,P) $p
lappend MailLbgi($P,B) $b
lappend MailLbgi($P,M) $m
lappend MailLbgi(LISTOF,L) $l
lappend MailLbgi(LISTOF,N) $n
lappend MailLbgi(LISTOF,P) $p
lappend MailLbgi(LISTOF,B) $b
lappend MailLbgi(LISTOF,M) $m
}
set MailLbgi(LISTOF,ALL) $LeToutBeau
return [MailLbgi $Qui $Quoi]
}
proc NOp args {
#rR No Operation : la proc qui ne fait rien
}
proc Which {Exe {AsRealpath ""}} {
set AsRealpath [string equal -nocase "AsRealpath" $AsRealpath ]
if {[catch {set Path [exec which $Exe]} ] } { return "" }
Espionne $Path
if {$AsRealpath} { return [Realpath $Path] }
return $Path
}
proc Realpath Path {
#rR suit tous les liens et enleve les ..
#rR on essaye realpath
if { ! [catch { set P [exec realpath $Path] }] } { return $P }
#rR sinon on le fait nous meme
while {[file type $Path]=="link"} {
Espionne $Path
set Li [file readlink $Path]
if {[regexp "^/" $Li]} { set Path $Li; continue }
set PathDir [file dirname $Path]
set Path $PathDir/$Li
}
while {[regexp {/[^/]+/../} $Path]} {
Espionne $Path
regsub {/[^/]+/../} $Path "/" Path
}
return $Path
}
proc FindTcl {fic {dir "."}} {
set LesTrouves {}
set LesF [lsort [glob -nocomplain -- [file join $dir $fic]]]
foreach F $LesF {
lappend LesTrouves $F
}
set Ld [lsort [glob -directory $dir -type d -nocomplain -- *]]
foreach d $Ld {
if {[file type $d]=="link"} { continue }
set LesR [FindTcl $fic $d]
foreach R $LesR {
lappend LesTrouves $R
}
}
return $LesTrouves
}
proc RecupereR_AEffacer {} {
set rep ""
if {! [eof $::CnlR]} {
gets $::CnlR rep
}
if {[string first "TURLUTUTU" $rep] != -1} {
set ::ReponseR $::tmp_RepR
set ::tmp_RepR {}
} else {
lappend ::tmp_RepR $rep
}
return
}
proc Rpipe_AEffacer {Commande} {
global CnlR ReponseR
if {! [info exists CnlR]} {
set CnlR [open "|R_surf --vanilla " r+]
fconfigure $CnlR -blocking 0 -buffering none
fileevent $CnlR readable RecupereR
puts $CnlR "# TURLUTUTU"
flush $CnlR
vwait ReponseR
set ReponseR ""
}
puts $CnlR $Commande
puts $CnlR "# TURLUTUTU"
flush $CnlR
vwait ReponseR
return $ReponseR
}
proc LesFichiersDe {Rep {RegExp ""}} {
if {$RegExp==""} { set RegExp "*" }
regsub -all "@" $RegExp "*" RegExp
if { ! [regexp "^/" $Rep]} { set Rep "[RepertoireDuGenome]/$Rep" }
return [glob -nocomplain "$Rep/$RegExp"]
}
proc Phix args {
catch {[eval exec phix $args]} Message
set Retour $Message
regsub {\n\-*\nNe pas tenir compte .*} $Retour "" Retour
return $Retour
}
proc Base64Test {{Texte "TRULULU"}} {
Espionne "Texte >>>$Texte<<<"
set B64 [Base64Encode $Texte]
Espionne "B64 >>>$B64<<< [string length $B64]"
set D64 [Base64Decode $B64]
Espionne "DecB64 >>>$D64<<<"
set B64 [Base64Encode $Texte KeepEqual]
Espionne "B64 >>>$B64<<< KeepEqual [string length $B64]"
set D64 [Base64Decode $B64]
Espionne "DecB64 >>>$D64<<< KeepEqual"
}
proc Base64Encode {Texte {KeepEqual ""}} {
#rR depuis 20150310 le defaut est d'enlever les trailing =
#rR les = sont rajoutes pour qu'il y ait un mltiple de 4 octets
set KeepEqual [string equal -nocase "KeepEqual" $KeepEqual]
package require base64
set B64 [::base64::encode -wrapchar "" $Texte]
if { ! $KeepEqual } { set B64 [string trim $B64 "="] }
return $B64
}
proc Base64Decode Texte {
package require base64
return [::base64::decode $Texte]
}
proc TestIt {} {
set Name [Iterator New "Init" {a b c} {1 2 3}]
Espionne "name=$Name"
Espionne [Iterator $Name Get Total Iter]
while {[Iterator $Name "Next" A N]} {
Espionne "$A $N"
}
Iterator $Name Reset
while {[Iterator $Name "Next" A N]} {
Espionne "$A $N"
}
set Name [Iterator New "Init" {A B C D} {1 2 3}]
Espionne "Iterator New Init {A B C D} {1 2 3} = $Name"
Espionne "while \{\[Iterator $Name Next A N\]\} \{ Espionne \$A \$N \}"
while {[Iterator $Name "Next" A N]} {
Espionne "$A $N"
}
Espionne "Iterator $Name Reset"
Iterator $Name Reset
while {[Iterator $Name "Next" A N]} {
Espionne "$A $N"
if {$A=="C" && $N==2} { Espionne "break pour C et 2"; break }
}
Espionne "Iterator $Name Get Current All = [Iterator $Name Get Current All]"
Espionne "Iterator $Name Get Current 2 = [Iterator $Name Get Current 2]"
Espionne "Iterator $Name Get Current 0 = [Iterator $Name Get Current 0]"
Espionne "Iterator Iterator Get ListOf Name = [Iterator Iterator Get ListOf Name]"
exit
}
proc Iterator {Name Action args} {
global Iterator
#rR Il arrive qu'on veuille imbriquer des boucles ... c'est fastidieux ...
#rR Iterator permet de la faire en deux lignes
#rR Il faut d'abord le créer :
#rR set Name [Iterator New Init $L0 $L1 $L2]
#rR Puis l'utiliser :
#rR while {[Iterator $Name Next v0 v1 v2]} { ... } #rR attention les v sont sans $
#rR Le dernier indice (v2) va le plus vite !!!!!!!!!!!!!!!!!!!!
#rR Attention les listes sont numerotees de 0 a 2 a l'exterieur (pour le user)
#rR mais elles sont indexees de 2 a 0 dans la proc (en interne)
#rR Iterator $Name Reset
#rR Iterator $Name Destroy
#rR set Info [Iterator Iterator Get ListOf Name]
#rR set Info [Iterator $Name Get Current 2] #rR current index de L2
#rR set Info [Iterator $Name Get Current All] #rR tous les current L0 L1 L2
#rR set Info [Iterator $Name Get Max 0]
#rR set Info [Iterator $Name Get Max All]
#rR set Info [Iterator $Name Get Total Iter]
#rR Pour les puristes on pourrait le faire en une ligne ... :
#rR while {[Iterator [Iterator New Init $L0 $L1 $L2] Next v0 v1 v2]} { ... }
if {$Action=="Get"} {
set Qui [lindex $args 0]
set Quoi [lindex $args 1]
if {[regexp {^[0-9]+$} $Quoi]} { set Quoi [expr [llength $Iterator($Name,ListOf,Index)] - $Quoi -1] }
if {[info exists Iterator($Name,$Qui,$Quoi)]} {
return $Iterator($Name,$Qui,$Quoi)
}
if {$Quoi=="All"} {
set LeAll {}
foreach iL [RetourneLaListe $Iterator($Name,ListOf,Index)] {
lappend LeAll $Iterator($Name,$Qui,$iL)
}
return $LeAll
}
return ""
}
if {$Action=="Next"} {
set LesP $args
set LesP [RetourneLaListe $LesP]
set iP 0
if {$Iterator($Name,WaitsFor,Start)} {
set incrNext 0
} else {
set incrNext 1
}
set Iterator($Name,WaitsFor,Start) 0
foreach aP $LesP {
upvar $aP P
set k $Iterator($Name,Current,$iP)
incr k $incrNext
set incrNext 0
if {$k>$Iterator($Name,Max,$iP)} { set k 0 ; set incrNext 1 }
set P [lindex $Iterator($Name,List,$iP) $k]
set Iterator($Name,Current,$iP) $k
incr iP
}
if { $incrNext==0 } { return 1 }
foreach iP Iterator($Name,ListOf,Index) {
set Iterator($Name,Current,$iP) 0
}
return 0
}
if {$Name=="New"} {
set Name [NomDe "iterator"]
set Action "Init"
}
if { $Action=="Init"} {
set LesL $args
set LesL [RetourneLaListe $LesL]
if {[info exists Iterator($Name,ListOf,Index)]} {
foreach L $Iterator($Name,ListOf,Index) {
unset Iterator($Name,List,$iL)
unset Iterator($Name,Max,$iL)
unset Iterator($Name,Current,$iL)
}
unset Iterator($Name,ListOf,Index)
}
set iL 0
set Total 1
foreach L $LesL {
lappend Iterator($Name,ListOf,Index) $iL
set Iterator($Name,List,$iL) $L
set Iterator($Name,Max,$iL) [expr [llength $L] - 1]
set Iterator($Name,Current,$iL) 0
set Total [expr $Total * [llength $L]]
incr iL
}
set Iterator($Name,Total,Iter) $Total
lappend Iterator(Iterator,ListOf,Name) $Name
set Iterator($Name,WaitsFor,Start) 1
return $Name
}
if { $Action=="Reset"} {
foreach iP $Iterator($Name,ListOf,Index) {
set Iterator($Name,Current,$iP) 0
}
set Iterator($Name,WaitsFor,Start) 1
return $Name
}
if { $Action=="Destroy"} {
if {[info exists Iterator($Name,ListOf,Index)]} {
foreach iL $Iterator($Name,ListOf,Index) {
unset Iterator($Name,List,$iL)
unset Iterator($Name,Max,$iL)
unset Iterator($Name,Current,$iL)
}
unset Iterator($Name,ListOf,Index)
unset Iterator($Name,WaitsFor,Start)
return ""
}
set i [lsearch $Iterator(Iterator,ListOf,Name) $Name]
set Iterator(Iterator,ListOf,Name) [lreplace $Iterator(Iterator,ListOf,Name) $i $i]
return 1
}
return ""
}
proc KeyList K {
global KeyList
if {$K=="PleaseReset"} {
if {[info exists KeyList]} { unset KeyList }
return ""
}
if {$K=="PleaseGetKeys"} {
if {[info exists KeyList]} { return $KeyList }
return {}
}
lappend KeyList $K
return $K
}
# Splits the text into words
# @param 1 text to split
# @param 2 separator
# @return list of words
proc LesMotsDeLaLigneTabulee {Ligne {Tab ""}} {
#biotcl wordsFromTextWithTab {line tab} extracts words from ntext and joins them with the tab (, default)
if {$Tab==""} { set Tab "," }
set LesC [split $Ligne ""]
set LesP [concat [list " "] [lrange $LesC 0 end-1]]
set InQuote 0
set Mot ""
lappend LesP " "
lappend LesC $Tab
set LesMots {}
foreach P $LesP C $LesC {
if {$C=="\"" && $P!="\\"} {
if {$InQuote} { set InQuote 0 } else { set InQuote 1 }
continue
}
if {$C==$Tab && ! $InQuote} { lappend LesMots $Mot ; set Mot "" ; continue }
append Mot $C
}
return $LesMots
}
proc TabulonsSansQuote {Fichier {TabIn ""} {TabOut ""} {ReplaceTabOut ""} {GetWhat ""}} {
if {$GetWhat==""} { set Getwhat "GetFilename" }
if {[regexp -nocase "Tab" $TabIn]} { set TabIn "\t" }
if {$TabOut==""} { set TabOut ";" }
if {$ReplaceTabOut==""} { set ReplaceTabOut " " }
set Nouveau "$Fichier.NEW"
set Export "$Fichier.EXPORT"
foreach Ligne [LesLignesDuFichier $Fichier] {
if {[regexp "^#" $Ligne]} {continue}
set LesMots [LesMotsDeLaLigneTabulee $Ligne $TabIn]
set LesBons {}
foreach Mot $LesMots {
if {0 && [regexp $TabOut $Mot]} { FaireLire $Mot }
regsub -all $TabOut $Mot $ReplaceTabOut Bon
lappend LesBons $Bon
}
set Bons [join $LesBons $TabOut]
lappend LeNouveau $Bons
}
if {$GetWhat=="GetListOfHeaderValues"} { return $LeNouveau }
set Headers [lindex $LeNouveau 0]
if {$GetWhat=="GetHeaders"} { return $Headers }
if {$GetWhat=="GetListOfHeaders"} { return [split $Headers $TabOut] }
set LesNouvellesValeurs [lrange $LeNouveau 1 end]
if {$GetWhat=="GetListOfValues"} { return $LesNouvellesValeurs }
SauveLesLignes $LesNouvellesValeurs dans $Export
return [SauveLesLignes $LeNouveau dans $Nouveau]
}
proc GenomicsFree {{Qui ""}} {
set LesDisques [GenomicsPossibles]
lappend LesDisques "/"
foreach GG $LesDisques {
if {[FileAbsent $GG]} { continue }
set G [file tail $GG]
if {$G==""} { set G "/" }
if {$GG!="/" && ! [regexp {^g[0-9]+$} $G]} {continue }
set df [exec df -P -k $GG]
set LesMots [LesMotsDeLaLigne $df]
set LesBons [lrange $LesMots end-4 end]
set g "/"
ScanLaListe $LesBons T U F g
set FF [format "%5.1f" [expr (1.0*$F)/1000000]]
if {$Qui==$G} { return $FF }
lappend LesFree "$GG $FF"
}
set Free [join $LesFree "\n"]
if {[PourWscope]} { return "$Free
" }
if {$Qui=="GetText"} { return $Free }
return $LesFree
}
proc GlobRecursif {{Pattern ""} {Directory ""} {DirOnly ""} {FollowLinks ""}} {
#biotcl recursiveGlob {} returns the list of all directories
set FollowLinks [string equal -nocase $FollowLinks "FollowLinks"]
if {$Directory==""} { set Directory "." }
if {$Pattern==""} { set Pattern "*" }
set GlobRecursif {}
if {$DirOnly=="DirOnly"} {
foreach Dir [glob -nocomplain -type "d" -- [file join $Directory $Pattern]] {
Espionne $Dir
if { ! $FollowLinks && [file type $Dir]=="link"} { continue }
lappend GlobRecursif $Dir
}
} else {
#ici on peut aussi choper les dir si pattern matche une dir
foreach Local [lsort -unique [glob -nocomplain -- [file join $Directory $Pattern]]] {
if {! $FollowLinks && [file type $Local]=="link"} { continue }
set Local [encoding convertto [encoding system] $Local]
lappend GlobRecursif $Local
}
}
foreach Dir [lsort -unique [glob -nocomplain -type "d" -- [file join $Directory *]]] {
if { ! $FollowLinks && [file type $Dir]=="link"} { continue }
set Dir [encoding convertto [encoding system] $Dir]
foreach SousLocal [GlobRecursif $Pattern $Dir $DirOnly] {
lappend GlobRecursif $SousLocal
}
}
return $GlobRecursif
}
proc TestListMix {} {
set A [list 1 2 3 4 5 6 7 8 9]
set B [list 2 4 6 8]
set C [list 3 6]
Espionne [MixLists $A No $C In $B]
}
proc ListMix {MainList args} {
if {[lindex $args 0]=="WithLists"} { set args [lindex $args 1] }
set Nu 0
foreach {Op Li} $args {
incr Nu
foreach E $Li {
set IsIn($Nu,$E) 1
}
}
set LesBons $MainList
set Nu 0
foreach {Op Li} $args {
incr Nu
set LesNouveaux {}
foreach E $LesBons {
if {$Op=="In" && [info exists IsIn($Nu,$E)]} { lappend LesNouveaux $E }
if {$Op=="No" && ! [info exists IsIn($Nu,$E)]} { lappend LesNouveaux $E }
}
set LesBons [lsort -unique $LesNouveaux]
}
return $LesBons
}
proc SauveTDom {IdXML EnteteXML Fichier} {
set f [open $Fichier w]
puts $f $EnteteXML
puts $f [$IdXML asXML -doctypeDeclaration 1 -indent 2]
close $f
return $Fichier
}
proc AllGlobals {{Show ""}} {
set Show [string equal -nocase $Show "Show"]
set LeTexte {}
foreach G [lsort [info globals]] {
global $G
if {[array exists $G]} {
lappend LeTexte "****************************** array $G"
foreach {C V} [lrange [array get $G] 0 19] {
lappend LeTexte " $C [string range $V 0 60]"
}
lappend LeTexte "************************************ $G"
} else {
lappend LeTexte "$G [string range [set $G] 0 60]"
}
}
set Texte [join $LeTexte "\n"]
if {$Show} { return [AfficheVariable $Texte "" "AllGlobals"] }
return $Texte
}
proc Delimite {} {
Espionne [string repeat "\n[Date NiceSeconds]" 10]
}
proc RenaissanceDuWidget {K Id {Action ""}} {
global BufferMainLevee
set Type [$K type $Id]
set LesOptions {}
foreach OptionValeurs [$K itemconfigure $Id] {
set Option [lindex $OptionValeurs 0]
set Valeur [lindex $OptionValeurs 4]
if {$Valeur=={}} { set Valeur "\{\}" }
if {[regexp " " $Valeur]} { set Valeur "\{$Valeur\}" }
lappend LesOptions "$Option $Valeur"
}
set Ancien "$K create $Type [$K coords $Id] [join $LesOptions " "]"
if {$Action=="Copy"} {
set BufferMainLevee $Ancien
return $Ancien
}
while 1 {
set Nouveau [Entre $Ancien]
if {$Nouveau==$Ancien} { return $Id }
if {$Nouveau==""} { return "" }
catch {set NouveauId [eval $Nouveau]} Message
if { ! [regexp {[^0-9]} $Message]} { break }
FaireLire "I got this message : \n$Message"
if {[OuiOuNon "Do I keep the widget ?"]} { return $Id }
}
if {[OuiOuNon "Do I delete the old Widget ? "]} { $K delete $Id }
return $Nouveau
}
proc CreerUnWidget {K} {
set Type [ChoixParmi {"Arc" "Line" "Oval" "Polygon" "Rectangle" "Text" "Fleche"}]
switch $Type {
"Arc" {
}
"Line" {
return [$K create line 50 50 100 100 100 200]
}
"Oval" {
}
"Polygon" {
return [$K create polygon 50 50 100 100 100 200 50 50]
}
"Rectangle" {
return [$K create rectangle 50 50 100 100]
}
"Text" {
set Texte [Entre "Your text"]
return [$K create text 100 100 -text $Texte]
}
}
return $Nouveau
}
proc UneTaillePourMainLevee {{TailleParDefaut ""}} {
global LesTaillesPourMainLevee
JeMeSignale
set TailleParDefautParDefaut 1.1
if { ! [info exists LesTaillesPourMainLevee] } {
set LesTaillesPourMainLevee [list 0.1 0.5 0.9 1.0 1.1 2.0 10. -1 "Other" "Default"]
}
if {$TailleParDefaut=="LaListe"} { return $LesTaillesPourMainLevee }
if {$TailleParDefaut==""} {
set TailleParDefaut $TailleParDefautParDefaut
}
set Taille [ChoixParmi $LesTaillesPourMainLevee]
if {$Taille == ""} { return "" }
if {$Taille == "Default"} { return $TailleParDefaut }
if {$Taille == "Other"} {
set Taille [Entre $TailleParDefaut]
if {$Taille == ""} { return "" }
lappend LesTaillesPourMainLevee $Taille
return $Taille
}
return $Taille
}
proc UneCouleurPourMainLevee {{CouleurParDefaut ""}} {
global CouleurDuFond
global LesCouleursPourMainLevee
set CouleurParDefautParDefaut "grey"
if { ! [info exists LesCouleursPourMainLevee]} {
if {[info exists CouleurDuFond]} { set CdF $CouleurDuFond } else { set CdF "white" }
set LesCouleursPourMainLevee [list "black" "grey" "white" "blue" \
"lightblue" "yellow" "green" "orange" "red" "purple" $CdF "-Transparent-" "-NewColor-" "-Default-"]
}
if {$CouleurParDefaut=="LaListe"} { return $LesCouleursPourMainLevee }
if {$CouleurParDefaut==""} {
set CouleurParDefaut $CouleurParDefautParDefaut
}
foreach C $LesCouleursPourMainLevee {
if {$C=="-Default-"} { set C $CouleurParDefaut }
if {[regexp {^\-} $C]} { set C "grey" }
lappend LesCouleursColorees $C
}
set Couleur [ChoixParmi $LesCouleursPourMainLevee $LesCouleursColorees]
if {$Couleur == ""} { return "Cancel" }
if {$Couleur == "-Transparent-"} { return "" }
if {$Couleur == "-Default-"} { return $CouleurParDefaut }
if {$Couleur == "-NewColor-"} {
set Couleur [PaletteDeCouleurs]
if {$Couleur == ""} { return "" }
lappend LesCouleursPourMainLevee $Couleur
return $Couleur
}
return $Couleur
}
proc MainLevee {K x y Action} {
global IdScrollRectangle
global LesCouleursPourMainLevee
global LesTaillesPourMainLevee
global DernierXDuTouche DernierYDuTouche
global BufferMainLevee
set X [$K canvasx $x]
set Y [$K canvasy $y]
set Touche [$K find withtag current]
if {[info exists IdScrollRectangle($K)] && $Touche==[set IdScrollRectangle($K)]} {
if {[regexp "Point|Motion" $Action]} { return }
}
set ItemType [$K type $Touche]
if {$Action == "Motion"} {
$K move $Touche [expr $x-$DernierXDuTouche] [expr $y-$DernierYDuTouche]
set DernierXDuTouche $x
set DernierYDuTouche $y
return
}
if {$Action == "Point"} {
set DernierXDuTouche $x
set DernierYDuTouche $y
return
}
if {$Action=="Modif"} {
set LesActions {"Erase" "Size" "Color" "Raise" "Lower" "Copy" "Paste" "EditWidget" "New"}
if {$ItemType=="text"} { lappend $LesActions "Text" }
set Action [ChoixParmi $LesActions]
if {$Action == "" } { return }
}
if {$Action == "Erase"} {
if { ! [OuiOuNon "Do you really want to erase this $ItemType"]} {
return 0
}
$K delete $Touche
return 1
}
if {$Action == "Raise"} {
$K raise $Touche
return "Raise"
}
if {$Action == "Lower"} {
$K lower $Touche
if {[info exists IdScrollRectangle($K)]} { $K lower [set IdScrollRectangle($K)]}
return "Lower"
}
if {$Action == "Color"} {
set OldCouleurFill [$K itemcget $Touche -fill]
if {[set CouleurFill [UneCouleurPourMainLevee $OldCouleurFill]]=="Cancel"} { return "" }
$K itemconfigure $Touche -fill $CouleurFill
if { ! [regexp "arc|polygon|rectangle" $ItemType] || \
! [OuiOuNon "Do You want to change the Outline Color ?"]} { return $CouleurFill }
set OldCouleurOutline [$K itemcget $Touche -outline]
if {[set CouleurOutline [UneCouleurPourMainLevee $OldCouleurOutline]]=="Cancel"} { return "" }
$K itemconfigure $Touche -outline $CouleurOutline
return $CouleurFill
}
if {$Action == "Size"} {
if {[set Taille [UneTaillePourMainLevee]]==""} { return }
ScanLaListe [Barycentre [$K coords $Touche]] CX CY
$K scale $Touche $CX $CY $Taille $Taille
if {$ItemType == "arc" && $Taille == "Copy"} {
set Extent [$K itemcget $Touche -extent]
$K itemconfigure $Touche -extent [expr $Extent*[Entre 0.9]]
return
}
if {$ItemType == "arc" && $Taille == "Extent"} {
set Extent [$K itemcget $Touche -extent]
$K itemconfigure $Touche -extent [expr $Extent*[Entre 0.9]]
return
}
if {$ItemType == "line" && $Taille == "Arrow"} {
set AvAr [$K itemcget $Touche -arrow]
if {$AvAr=="first"} { set AvAr "last" } else { set AvAr "first" }
$K itemconfigure $Touche -arrow $AvAr
return
}
if {$Taille == "Other"} {
set Taille [Entre 21]
if {$Taille == ""} { return "" }
lappend LesTaillesPourMainLevee $Taille
}
if { $ItemType=="arc" || $ItemType=="line" } {
$K itemconfigure $Touche -width $Taille
return $Taille
}
if { $ItemType=="text"} {
$K itemconfigure $Touche -font [list Courier $Taille]
return $Taille
}
}
if {$Action == "Text"} {
set Texte [Entre [$K itemcget $Touche -text]]
if {$Texte == ""} { return "" }
if { $ItemType=="text"} {
$K itemconfigure $Touche -text $Texte
return $Texte
}
}
if {$Action == "Copy"} {
set Nouveau [RenaissanceDuWidget $K $Touche "Copy"]
return $Nouveau
}
if {$Action == "Paste"} {
if { ! [info exists BufferMainLevee]} {
FaireLire "You never made a Copy"
return ""
}
regsub {^[^ ]+ } $BufferMainLevee "$K " Nouveau
catch {set NouveauId [eval $Nouveau]} Message
if {[regexp {[^0-9]} $Message]} {
FaireLire "I got this message : \n$Message"
return ""
}
return $NouveauId
}
if {$Action == "EditWidget"} {
set Nouveau [RenaissanceDuWidget $K $Touche]
return $Nouveau
}
if {$Action == "New"} {
set Nouveau [CreerUnWidget $K]
return $Nouveau
}
}
proc MainLeveeSurUnCanva K {
global IdScrollRectangle
$K bind "all" <1> "MainLevee $K %x %y Point"
$K bind "all" "MainLevee $K %x %y Motion"
$K bind "all" "MainLevee $K %x %y Relache"
$K bind "all" "MainLevee $K %x %y Modif"
regsub {\.[a-z_0-9]+$} $K "" w
set Bouton [BoutonneLaFenetre $w "Save/Restore/Erase"]
$Bouton configure -background "green"
bind $Bouton <1> "SauveLeCanva $K all"
bind $Bouton <2> "RestaureLeCanva $K"
bind $Bouton <3> "EraseLeCanva $K"
set Bouton [BoutonneLaFenetre $w "Paste"]
$Bouton configure -background "orange"
bind $Bouton <1> "MainLevee $K 0 0 Paste"
}
proc ShowListbox {Page args} {
global ShowListbox
Wup "Cette proc est issue de AfficheVariable ... en plus simple"
if { ! [info exists ShowListbox]} {
set ShowListbox(wNumber) 0
}
foreach {A B} $args {
regsub -- {^\-} $A "" A
eval set $A $B
}
if { ! [info exists w]} { set w ".slb[incr ShowListbox(wNumber)]" }
if { ! [info exists Titre]} { set Titre "$w" }
if { ! [info exists Maniere]} { set Maniere "" }
toplevel $w
wm title $w "$Titre"
wm iconname $w "$Titre"
regsub -all {\t} $Page " " PagePropre
set ShowListbox(Page,$w) $PagePropre
label $w.msg -wraplength 4i -justify left -text "$Titre"
pack $w.msg -side top
set Clavier $w.buttons
frame $Clavier
pack $Clavier -side bottom -fill x -padx 3m -pady 1m
TouchePour $Clavier NouvelleGamme
TouchePour $Clavier NouvelleCouleur "red"
TouchePour $Clavier "Dismiss" "unset ShowListbox(Page,$w) ; after 10 destroy $w"
TouchePour $Clavier NouvelleCouleur "grey"
TouchePour $Clavier "Save all" "SaveAs \[set ShowListbox(Page,$w)\]"
TouchePour <2> "/sel." "SaveAs \[selection get\]"
TouchePour <3> " /Edit" "EditAndShow \[set ShowListbox(Page,$w)\]"
TouchePour $Clavier NouvelleGamme
TouchePour $Clavier NouvelleCouleur "yellow"
TouchePour $Clavier "Next" "Focalise $w"
TouchePour <2> "/Top" "Focalise $w top"
TouchePour <3> "/New" "Focalise $w ask"
TouchePour $Clavier "High word" "Illumine \[Entre\] $w"
frame $w.frame -borderwidth 10
pack $w.frame -side top -expand yes -fill both
scrollbar $w.frame.yscroll -command "$w.frame.list yview"
scrollbar $w.frame.xscroll -command "$w.frame.list xview" \
-orient horizontal
set Largeur 80
set Hauteur 35
if { [regexp "GrandeLargeur" $Maniere] } { set Largeur 128 }
listbox $w.frame.list -width $Largeur -height $Hauteur -setgrid 1 \
-yscroll "$w.frame.yscroll set" \
-xscroll "$w.frame.xscroll set" \
-selectmode extended \
-background "LightGrey" \
-foreground "Black" \
-selectbackground "LightYellow" \
-selectforeground "Black" \
-font [list Courier [PolicePourListBox]]
grid $w.frame.list -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky nsew
grid $w.frame.yscroll -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky nsew
grid $w.frame.xscroll -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky nsew
grid rowconfig $w.frame 0 -weight 1 -minsize 0
grid columnconfig $w.frame 0 -weight 1 -minsize 0
set nLignes 0
foreach Ligne [split [set ShowListbox(Page,$w)] "\n"] {
incr nLignes
$w.frame.list insert end $Ligne
}
if {$nLignes<30} { $w.frame.list configure -height [expr $nLignes+3] }
bind $w.frame.list <3> "DecrisLaLigne %W %x %y"
bind $w.frame.list "DecrisLaLigne %W %x %y Efface"
return $w
}
proc IllumineLaListe {Liste Fenetre} {
set BonneListe {}
foreach Element $Liste {
regsub -all {\|} $Element "\\|" Element
lappend BonneListe $Element
}
set Mot [join $BonneListe "|"]
Illumine $Mot $Fenetre
}
proc Illumine {Mot Fenetre} {
if {[PourWscope]} { return }
if {[regexp ".list$" $Fenetre]} {
set FenetreListBox $Fenetre
} else {
set FenetreListBox $Fenetre.frame.list
}
set i 0
set AttendDebutDeSequence 1
foreach Ligne [$FenetreListBox get 0 end] {
if { [regexp $Mot $Ligne] } {
if {$AttendDebutDeSequence && [regexp "$Mot\[ \.\]+\[A-Z\]" $Ligne]} {
set Position $i
set AttendDebutDeSequence 0
}
$FenetreListBox selection set $i
$FenetreListBox see $i
}
incr i
}
if {[info exists Position]} {
set Position [Maxi 0 [expr $Position-20]]
$FenetreListBox see $Position
}
}
proc Month1to12 Texte {
#biotcl month1to12 {text} returns the index of the month (english or french)
set Mois ""
scan $Texte "%s" Mois
set Mois [string toupper $Mois]
set LesMoisA [list JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER]
set LesMoisF [list JANVIER FEVRIER MARS AVRIL MAI JUIN JUILLET AOUT SEPTEMBRE OCTOBRE NOVEMBRE DECEMBRE]
set I 0
foreach MoisA $LesMoisA MoisF $LesMoisF {
incr I
if {[regexp "^$Mois" $MoisA]} { return $I }
if {[regexp "^$Mois" $MoisF]} { return $I }
}
return 0
}
proc CompareDate {D1 D2} {
#biotcl compareDate {}
regsub -all {[\-\.\:/]} $D1 " " D1
regsub -all { +} [string trim $D1] " " D1
regsub -all {[\-\.\:/]} $D2 " " D2
regsub -all { +} [string trim $D2] " " D2
set J1 0; set M1 0; set A1 0
regexp {^([^ ]+)$} $D1 Match A1
regexp {^([^ ]+) ([^ ]+)$} $D1 Match M1 A1
regexp {^([^ ]+) ([^ ]+) ([^ ]+)$} $D1 Match J1 M1 A1
set J2 0; set M2 0; set A2 0
regexp {^([^ ]+)$} $D2 Match A2
regexp {^([^ ]+) ([^ ]+)$} $D2 Match M2 A2
regexp {^([^ ]+) ([^ ]+) ([^ ]+)$} $D2 Match J2 M2 A2
set Mois1 $M1
set Mois2 $M2
if {$A1<$A2} { return -1 }
if {$A1>$A2} { return 1 }
if {[regexp {^[0-9]+$} $Mois1]} {set M1 $Mois1} else { set M1 [Month1to12 $Mois1] }
if {[regexp {^[0-9]+$} $Mois2]} {set M2 $Mois2} else { set M2 [Month1to12 $Mois2] }
set M1 [Base10 $M1]
set M2 [Base10 $M2]
if {$M1<$M2} { return -1 }
if {$M1>$M2} { return 1 }
set J1 [Base10 $J1]
set J2 [Base10 $J2]
if {$J1<$J2} { return -1 }
if {$J1>$J2} { return 1 }
return 0
}
proc GoodUnixFileNames {{Rep ""}} {
if {$Rep==""} { set Rep "./" }
foreach F [lsort [glob -nocomplain "$Rep/*"]] {
regsub -nocase -all {[^A-Z0-9_\-\.\+\#\~\\]} $F "_" G
Espionne "$F\n$G"
file rename $F $G
}
return
}
proc ModifyGlobalArray Tab {
global $Tab
set Elem [ChoixParmi [array names $Tab]]
if {$Elem==""} { return "" }
while {1} {
set NouvelleValeur [Entre [set [set Tab]($Elem)]]
if {$NouvelleValeur!="" || [OuiOuNon "Do you want to set it to empty value ?"]} { break }
}
set [set Tab]($Elem) $NouvelleValeur
return $Elem
}
proc ModifyGlobalVariables {{Var ""}} {
if {$Var==""} {
set LesGlobales [lsort [info globals]]
set Var [ChoixParmi $LesGlobales]
}
if {$Var==""} { return "" }
global $Var
if {[array exists $Var]} { return [ModifyGlobalArray $Var] }
while {1} {
set NouvelleValeur [Entre [set $Var]]
if {$NouvelleValeur!="" || [OuiOuNon "Do you want to set it to empty value ?"]} { break }
}
set $Var $NouvelleValeur
return $Var
}
proc RequireOnce args {
set LesPacks $args
global RequireOnce
foreach Pack $LesPacks {
if {[info exists RequireOnce($Pack)]} {continue}
set RequireOnce($Pack) 1
package require $Pack
if {$Pack=="BLT"} {namespace import blt::*}
}
}
proc PolicePourListBox {{PoliceOuAsk ""} {W ""}} {
global PolicePourListBox
Wup "returns or sets the current fontsize, asks if PoliceOuAsk is 'Ask' "
if { ! [info exists PolicePourListBox]} {
set PolicePourListBox 10
}
if {[regexp {^[0-9]+$} $PoliceOuAsk]} {
set PolicePourListBox $PoliceOuAsk
} elseif {[regexp -nocase {^Ask$} $PoliceOuAsk]} {
set Police [ChoixParmi {6 8 10 12 14 16 18 20 22 24}]
if {$Police!=""} { set PolicePourListBox $Police }
}
if {$W!=""} { $W.frame.list configure -font [list Courier $PolicePourListBox] }
return $PolicePourListBox
}
proc PolicePourEntreTexte {{PoliceOuAsk ""} {W ""}} {
global PolicePourEntreTexte
Wup "returns or sets the current fontsize, asks if PoliceOuAsk is 'Ask' "
if { ! [info exists PolicePourEntreTexte]} { set PolicePourEntreTexte 10 }
if {[regexp {^[0-9]+$} $PoliceOuAsk]} {
set PolicePourEntreTexte $PoliceOuAsk
} elseif {[regexp -nocase {^Ask$} $PoliceOuAsk]} {
set Police [ChoixParmi {6 8 10 12 14 16 18 20 22 24}]
if {$Police!=""} { set PolicePourEntreTexte $Police }
}
set Objet "$W.text"
if {[winfo exists $Objet]} { $Objet configure -font [list Courier $PolicePourEntreTexte] }
return $PolicePourEntreTexte
}
proc CopieVersFichierBienNommePourLeRep {} {
foreach F [glob -nocomplain "./*"] {
Espionne [CopieVersFichierBienNomme $F]
}
}
proc CopieVersFichierBienNomme F {
if {[regexp {\#} $F]} {
regsub -all {\#} $F "_" BonF
if {[file exists $BonF] && [OuiOuNon "$F\nwill be copied to\n$BonF\n\nIt already exists. Do I skipp ?"]} {
return ""
}
if { ! [OuiOuNon "$F\nOk to copy it to\n$BonF"]} { return "" }
file copy -force $F $BonF
return $BonF
}
return $F
}
proc EstUnFichierImage Fichier {
return [regexp -nocase {\.jpe?g$|\.gif$|.tif$|\.tiff$|\.pnm$|\.pbm$|\.tga$} $Fichier]
}
proc GetGlobal Var {
global $Var
if { ! [info exists $Var]} { return "NotExists" }
return [set $Var]
}
proc FileExists Fichier {
#biotcl fileExists {file}
return [file exists $Fichier]
}
proc FileAbsent Fichier {
#biotcl fileAbsent {file}
if {[FileExists $Fichier]} { return 0 } else { return 1 }
}
proc DirExists Dir {
#biotcl dirExists {dir}
return [file exists $Dir]
}
proc DirAbsent Dir {
#bioTcl dirAbsent {dir}
if {[DirExists $Dir]} { return 0 } else { return 1 }
}
proc CreateDirIfAbsent Dir {
if {[DirExists $Dir]} { return "" }
file mkdir $Dir
return $Dir
}
proc GscopeSubDir SousRep {
return "[RepertoireDuGenome]/$SousRep"
}
proc GscopeFile {Nom {SousRep ""}} {
#rR Si Nom est vide onrend repertoire avec / a la fin
if {$SousRep==""} {
if {[OnTraiteDesProteines]} {
set SousRep "prottfa"
} else {
set SousRep "nuctfa"
}
}
return "[GscopeSubDir $SousRep]/$Nom"
}
proc GscopeFileExists {Nom {SousRep ""}} {
return [file exists [GscopeFile $Nom $SousRep]]
}
proc GscopeFileContent {Nom {SousRep ""} {EnPre ""} {I ""} {J ""}} {
#rR on peut lire de la ligne I à J
set EnPre [regexp -nocase "Pre" $EnPre]
if {$Nom==""} { return "" }
if {[regexp -nocase "^fiche" $Nom]} {
set Fichier "[RepertoireDuGenome]/fiches/$SousRep"
} else {
set Fichier [GscopeFile $Nom $SousRep]
}
if {[FileAbsent $Fichier]} { return "" }
set Contenu [ContenuDuFichier $Fichier]
if {[regexp {^[0-9]+$} $I]} {
if { ! [regexp {^[0-9]+$} $J]} { set J $I }
set Contenu [join [lrange [split $Contenu "\n"] $I $J] "\n"]
}
if {$EnPre} { return "$Contenu
" }
return $Contenu
}
proc AllerRetour {In {Out ""} {N ""}} {
if {$Out==""} { set Out "${In}_new" }
if {$N==""} { set N 1 }
set Liste [LesLignesDuFichier $In]
set ListeRetourne [RetourneLaListe $Liste]
set LiiL [concat $Liste $ListeRetourne]
set Finale {}
foreach i [NombresEntre 1 $N] {
set Finale [concat $Finale $LiiL]
}
return [SauveLesLignes $Finale dans $Out]
}
proc AllToTitle Texte {
set AlphAvant 0
foreach C [split $Texte ""] {
if {$AlphAvant} {
append Nouveau [string tolower $C]
} else {
append Nouveau [string toupper $C]
}
set AlphAvant [regexp -nocase {[a-z]} $C]
}
return $Nouveau
}
proc BonParenthesageDuFichier {Fichier} {
return [BonParenthesage [ContenuDuFichier $Fichier]]
}
proc BonParenthesage {Texte {What ""}} {
if {$What==""} { set What "GetOk" }
if {[regexp -nocase "GetAll|GetX" $What]} {
set What "GetX_GetC_GetA_GetP"
}
set GetC [regexp -nocase "GetC" $What]
set GetA [regexp -nocase "GetA" $What]
set GetP [regexp -nocase "GetP" $What]
set GetX [regexp -nocase "GetX" $What]
set LesC {}
set LesA {}
set LesP {}
set iC 0
set iA 0
set iP 0
set DejaLu ""
set YaBackSlash 0
set x -1
foreach C [split $Texte ""] {
incr x
append DejaLu $C
if {$YaBackSlash} { set YaBackSlash 0 ; continue }
if {$C=="\\"} { set YaBackSlash 1 ; continue}
if {$C=="\["} { incr iC ; PushOnStack $x C ; continue}
if {$C=="\{"} { incr iA ; PushOnStack $x A ; continue}
if {$C=="\("} { incr iP ; PushOnStack $x P ; continue }
if {$C=="\]"} { incr iC -1 ; lappend LesC "[set pC [PullFromStack C]] $x" ; lappend All "C $pC $x" }
if {$C=="\}"} { incr iA -1 ; lappend LesA "[set pA [PullFromStack A]] $x" ; lappend All "A $pA $x" }
if {$C=="\)"} { incr iP -1 ; lappend LesP "[set pP [PullFromStack P]] $x" ; lappend All "P $pP $x" }
if {$iC<0} { return "Unexpected '\]' at [string range $DejaLu end-40 end]" }
if {$iA<0} { return "Unexpected '\}' at [string range $DejaLu end-40 end]" }
if {$iP<0} { return "Unexpected '\)' at [string range $DejaLu end-40 end]" }
}
if {$iC>0} { return "Missing '\]' at [string range $DejaLu end-40 end]" }
if {$iA>0} { return "Missing '\}' at [string range $DejaLu end-40 end]" }
if {$iP>0} { return "Missing '\)' at [string range $DejaLu end-40 end]" }
if {[regexp -nocase "GetX" $What]} { return $All }
if {[regexp -nocase "GetC" $What]} { return $LesC }
if {[regexp -nocase "GetA" $What]} { return $LesA }
if {[regexp -nocase "GetP" $What]} { return $LesP }
return ""
}
proc AutorisationPourPsy {} {
global AutorisationPourPsy
if { ! [info exists AutorisationPourPsy]} {
set AutorisationPourPsy -3
}
if { $AutorisationPourPsy==1 } { return 1 }
if { $AutorisationPourPsy==0 } { return 0 }
set Cou [Entre "Donnez la plus belle couleur pour une 2cv : "]
incr AutorisationPourPsy
if { ! [regexp -nocase "rouge" $Cou] } { return 0 }
set AutorisationPourPsy 1
return 1
}
proc InteractiveMode {{Mode ""}} {
global InteractiveMode
if { ! [info exists InteractiveMode]} { set InteractiveMode 1 }
if {$Mode==""} { return $InteractiveMode }
set InteractiveMode 1
if {[regexp -nocase {(Batch|Off|0)} $Mode]} { set InteractiveMode 0 }
set Chut [expr ! $InteractiveMode]
global OuiOuNonToujoursParDefaut ; set OuiOuNonToujoursParDefaut $Chut
global EspionneNon ; set EspionneNon $Chut
global FaireLireNon ; set FaireLireNon $Chut
global EntreToujoursDefaut ; set EntreToujoursDefaut $Chut
return $InteractiveMode
}
proc GscopeEvaluates {LesMotsDeLaCommande {Master ""}} {
LogWscope "dans GscopeEvaluates $LesMotsDeLaCommande"
LogWscope [lindex $LesMotsDeLaCommande 0]
if {$Master==""} { set Master "Gscope" }
set UseTk 1
if {[lindex $LesMotsDeLaCommande 0]=="-notk"} {
set UseTk 0
set LesMotsDeLaCommande [lreplace $LesMotsDeLaCommande 0 0]
}
if {[lindex $LesMotsDeLaCommande 0]=="data"} {
set RG [lindex $LesMotsDeLaCommande 1]
RepertoireDuGenome $RG
set LesMotsDeLaCommande [lreplace $LesMotsDeLaCommande 0 1]
}
if {[lindex $LesMotsDeLaCommande 0]=="PourWscope"} {
PourWscope 1
set UseTk 0
set LesMotsDeLaCommande [lreplace $LesMotsDeLaCommande 0 0 yes]
}
if {[regexp -nocase {[a-z]} $LesMotsDeLaCommande]} {
set QuoiFaire [lindex $LesMotsDeLaCommande 0]
if { ! [regexp "CreeLaCollection|CreeFichierMiniConfig|InitProject" [lrange $LesMotsDeLaCommande 0 1]]} { ChargeConfig }
if {$QuoiFaire == "only"} {
set Sortie [eval [lrange $LesMotsDeLaCommande 1 end]]
return $Sortie
}
if {$UseTk} {
set Commande [join $LesMotsDeLaCommande " "]
set PreFixe ""
if {[info procs "PreFixe"]!=""} { set PreFixe [PreFixe] }
set Process "$Master $PreFixe on [info hostname]\n pid [pid] since [Date Nice]"
package require Tk
if { ! [winfo exists .] } {
wm title . "$PreFixe [string range $Commande 0 20]"
button .kill -text "$Process\n\nStop execution of : \n\n$Commande\n\nby pressing Me or killing this window" \
-background "yellow" -command "exit"
pack .kill -fill both
}
}
if {[regexp "^yes" $QuoiFaire]} {
InteractiveMode "Off"
regsub "^yes" $QuoiFaire "" QuoiFaire
if {$QuoiFaire==""} { set QuoiFaire "exe" }
if {$QuoiFaire=="con"} {
set QuoiFaire ""
set LesMotsDeLaCommande [lrange $LesMotsDeLaCommande 1 end]
}
}
set GoAhead 0
if {[regexp -nocase "(and)*continue(and)*" $QuoiFaire]} {
regsub -nocase "(and)*continue(and)*" $QuoiFaire "" QuoiFaire
set GoAhead 1
}
if {$QuoiFaire == "puts" || $QuoiFaire == "putb" || $QuoiFaire == "putl" || $QuoiFaire == "exe"} {
set Sortie [eval [lrange $LesMotsDeLaCommande 1 end]]
if {$QuoiFaire == "putb" } { fconfigure stdout -translation binary; puts stdout $Sortie ; exit }
if {$QuoiFaire == "putl" && $Sortie!=""} {
if {[string is list $Sortie]} {
set Sortie [join $Sortie "\n"]
set QuoiFaire "puts"
}
}
if {$QuoiFaire == "puts" } { puts $Sortie }
if {$GoAhead} { return }
exit
}
eval $LesMotsDeLaCommande
}
return
}
proc NucOuProt Sequence {
#biotcl sequenceIsNucOrProt {} returns Prot or Nuc
if {[regexp "^>" $Sequence]} { set Sequence [QueLaSequenceDuTexteTFA $Sequence] }
if {[regexp -nocase {[^ATGCNXMKRSYWVHDB]} $Sequence]} { return "Prot" }
return "Nuc"
}
proc JeCommenceABosser {} {
set LesBoulots [list \
"FantomisePourTous {} AskWhereToBegin" \
"EtudeCodonStart AskWhereToBegin" \
"CoupeAuBonMetPourTous AskWhereToBegin" \
]
set Boulot [ChoixParmi $LesBoulots]
if {$Boulot==""} { return "" }
JeVaisBosser $Boulot
eval $Boulot
}
proc JeVaisBosser {Texte} {
global Bosseurs
set Moi [TmpFile Bosse]
set Bosseurs($Texte) $Moi
set Bosseurs($Moi) $Texte
return $Moi
}
proc JArreteDeBosser Moi {
global Bosseurs
if { ! [file exists $Moi]} { return 0 }
file delete -force $Moi
set Texte [set Bosseurs($Moi)]
unset Bosseurs($Moi)
unset Bosseurs($Texte)
return 1
}
proc TuArretesDeBosser {} {
global Bosseurs
set LesTextes [list "Select the process you want to stop"]
foreach Texte [array names Bosseurs] {
if {[regexp "/" $Texte]} { continue }
lappend LesTextes $Texte
}
set Texte [ChoixParmi $LesTextes]
if {$Texte=="" || ! [info exists Bosseurs($Texte)]} { return "" }
set Toi [set Bosseurs($Texte)]
if {$Toi==""} { return "" }
Sauve $Texte dans $Toi
return $Toi
}
proc RenumeroteLesPABs {} {
foreach Fichier [glob "[RepertoireDuGenome]/*/MSME*"] {
if {[regexp {MSME[0-9]{4}$} $Fichier]} {
set Nom [file tail $Fichier]
set Rep [file dirname $Fichier]
regsub "MSME" $Nom "MSME0" Bon
file rename $Fichier "$Rep/$Bon"
Espionne "[file tail $Rep] $Nom $Bon"
}
}
exit
}
proc MailFichier {Fichier {Destinataire ""} {Sujet ""}} {
global env
if {$Destinataire==""} {
set MySelf [set env(USER)]
set Destinataire "$MySelf@lbgi.fr"
}
if { ! [file exists $Fichier]} {
FaireLire "$Fichier doesn't exist. Sorry"
return ""
}
if {$Sujet==""} {
set Sujet [file tail $Fichier]
regsub ".txt$" $Sujet "" Sujet
set Subject "Commande oligos $Sujet"
} else {
set Subject $Sujet
}
set Message ""
set CommandeMail "mail"
if {[info exists env(HOSTTYPE)] && $env(HOSTTYPE)=="alpha"} { set CommandeMail "mailx" }
if {[catch {exec $CommandeMail -s $Subject $Destinataire < $Fichier} Message]} {
FaireLire "Error during mail. \nI got following error message :\n$Message"
return $Message
}
return $Fichier
}
proc PlusProcheCodon {Ref LesPossibles} {
#biotcl nearestCodon {ref possibleCodons}
foreach Rare [CodonsRares LaListeMerci] {
set EstRare($Rare) 1
}
set Ref [string toupper $Ref]
set PlusProche ""
set OldEgaux -2
foreach Codon $LesPossibles {
set Codon [string toupper $Codon]
if {[info exists EstRare($Codon)]} {
set nEgaux -1
} else {
set nEgaux 0
foreach A [split $Ref ""] B [split $Codon ""] {
if {$A==$B} { incr nEgaux }
}
}
if {$nEgaux > $OldEgaux} {
set OldEgaux $nEgaux
set PlusProche $Codon
}
}
return $PlusProche
}
proc LesCodesGenetiques P {
global LesCodesGenetiques
Wup "We replace O (the coding of STOP in MutaSequence) by * (O is not used as aa code)"
if {$P=="O"} { set P "*" }
set P [string toupper $P]
if {$P=="STOP"} { set P "*" }
if {[string length $P]==3} { set P [UT $P] }
if {[info exists LesCodesGenetiques($P)]} { return [set LesCodesGenetiques($P)] }
if {[info exists LesCodesGenetiques("EstCharge")]} { return "NNN" }
set LesCodesGenetiques("EstCharge") 1
foreach A {A T G C} {
foreach B {A T G C} {
foreach C {A T G C} {
set Codon "$A$B$C"
set AA [AAduCodon $Codon]
lappend LesCodesGenetiques($AA) $Codon
lappend LesCodesGenetiques(LALISTEMERCI) "$Codon $AA"
}
}
}
return [LesCodesGenetiques $P]
}
proc TesteTouteLaBalise {} {
Espionne [TouteLaBalise protein match.xml]
Espionne [TouteLaBalise protein]
Espionne [TouteLaBalise protein match.xml "CloseFileAfterRead"]
Espionne [TouteLaBalise protein match.xml]
Espionne [TouteLaBalise protein "" "CloseFileAfterRead"]
Espionne [TouteLaBalise protein match.xml]
}
proc TouteLaBalise {Bal {Fichier ""} {Close ""}} {
global CanalPourTouteLaBalise FichierPourTouteLaBalise
if {$Bal=="CloseFilePlease"} {
if {[info exists CanalPourTouteLaBalise]} {
close $CanalPourTouteLaBalise
unset CanalPourTouteLaBalise
unset FichierPourTouteLaBalise
}
}
set CloseFileIfEmpty [string equal $Close "CloseFileIfEmpty"]
set CloseFileAfterRead [string equal $Close "CloseFileAfterRead"]
if {[info exists FichierPourTouteLaBalise]} {
if {$Fichier!="" && $FichierPourTouteLaBalise != $Fichier} {
close $CanalPourTouteLaBalise
unset CanalPourTouteLaBalise
}
}
if { ! [info exists CanalPourTouteLaBalise] } {
set FichierPourTouteLaBalise $Fichier
set CanalPourTouteLaBalise [open $FichierPourTouteLaBalise "r"]
}
if {$Bal=="OpenFilePlease"} { return $CanalPourTouteLaBalise }
set LesLignes {}
while {[gets $CanalPourTouteLaBalise Ligne] >= 0} {
if {[regexp "\<$Bal " $Ligne] || [regexp "\<$Bal *\>" $Ligne]} { set LesLignes [list $Ligne] ; break }
}
if {$LesLignes=={}} {
if {$CloseFileIfEmpty} {
if {[info exists CanalPourTouteLaBalise]} {
close $CanalPourTouteLaBalise
unset CanalPourTouteLaBalise
unset FichierPourTouteLaBalise
}
}
return ""
}
while {[gets $CanalPourTouteLaBalise Ligne] >= 0} {
lappend LesLignes $Ligne
if {[regexp "" $Ligne]} { break }
}
if {$CloseFileAfterRead} {
if {[info exists CanalPourTouteLaBalise]} {
close $CanalPourTouteLaBalise
unset CanalPourTouteLaBalise
unset FichierPourTouteLaBalise
}
}
return [join $LesLignes "\n"]
}
proc LesBoutsDeLaLigneAvecTexteSeparateur {Ligne {Sep ""} {Trim ""}} {
set LesBouts {}
set LongSep [string length $Sep]
while 1 {
if {$Ligne=="" } { break }
set i [string first $Sep $Ligne]
if {$i<0} {
set Bout $Ligne
} else {
set Bout [string range $Ligne 0 [expr $i - 1]]
}
if {$Trim!=""} { set Bout [string $Trim $Bout] }
lappend LesBouts $Bout
if {$i<0} { break }
set Ligne [string range $Ligne [expr $i + $LongSep] end]
}
return $LesBouts
}
proc LesMotsDuTexte Texte {
#biotcl wordsFromText {text}
regsub -all {[ \t\,\;\n\r]+} $Texte " " Texte
set Texte [string trim $Texte]
set LesMots [split $Texte " "]
return $LesMots
}
proc LigneDesMots {Ligne {REX ""}} {
if {$REX==""} { set REX "\;" }
regsub -all "$REX|\t" $Ligne " " Ligne
if {$REX!=" "} { while {[regexp " " $Ligne]} { regsub -all " " $Ligne " " Ligne } }
set Ligne [string trim $Ligne]
return $Ligne
}
proc LesMotsDeLaLigne {Ligne {REX ""}} {
return [split [LigneDesMots $Ligne $REX] " "]
}
proc IntegerToAscii I {
#biotcl integerToAscii {}
set Ascii [format "%c" $I]
return $Ascii
}
proc AsciiToInteger A {
#biotcl asciiToInteger {}
set I -1
scan $A "%c" I
return $I
}
proc HexaToAscii Hex {
#biotcl hexaToAscii {}
regsub "^%" $Hex "" Hex
regsub -nocase "^ox" $Hex "" Hex
set Ascii [format "%c" 0x$Hex]
return $Ascii
}
proc LesCaracteresAscii {} {
#biotcl asciiCharacters {}
foreach n [NombresEntre 32 256] {
lappend LesCars "[IntegerToAscii $n] $n"
}
return $LesCars
}
proc TexteAscii Texte {
#biotcl textToAscii {text}
regsub -all {\+} $Texte " " Texte
regsub -all "%0D" $Texte "%0A" Texte
while {[regexp -nocase {%[0-9a-h]{2}} $Texte Hexa]} {
set Car [HexaToAscii $Hexa]
if {$Car=="&"} { set Car "\\&" }
regsub -all $Hexa $Texte $Car Texte
}
regsub -all "\<" $Texte "<" Texte
regsub -all "\>" $Texte ">" Texte
return $Texte
}
proc SousListe ListeDepart {
set ListeDepart [ListeDesPABs]
if {$ListeDepart=={}} { return {} }
FaireLire "Please select two elements within following elements"
while 1 {
set BornesSubList [Entre "[lindex $ListeDepart 0] [lindex $ListeDepart end]"]
if {$BornesSubList==""} { return "" }
scan $BornesSubList "%s %s" Prems Derns
set D [lsearch -exact $ListeDepart $Prems]
set F [lsearch -exact $ListeDepart $Derns]
if {$D<0 || $F<0} {
FaireLire "Please select two elements within\n$ListeDeDepart"
continue
}
set Liste [lrange $ListeDepart $D $F]
if {$Liste!={} || [OuiOuNon "I got an empty list ... is it OK ?"]} { break }
}
return $Liste
}
proc TouchePour {Clavier {Texte ""} {Commande ""} {Action ""} {Couleur ""}} {
global TouchePour
if {[regexp -nocase "GetPostpone" $Clavier]} {
if { ! [info exists TouchePour(Postpone)]} { set TouchePour(Postpone) {} }
set Memo $TouchePour(Postpone)
if {[regexp -nocase "Reset" $Clavier]} {
set TouchePour(Postpone) {}
set TouchePour(ClavierCourant) ""
}
return $Memo
}
if { ! [info exists TouchePour(ClavierCourant)]} { set TouchePour(ClavierCourant) "" }
set CC $Clavier
if {[regexp "^<" $CC]} {
set CC $TouchePour(ClavierCourant)
} else {
set TouchePour(ClavierCourant) $CC
}
if {$CC=="Postpone"} {
if {[regexp "^<" $Clavier]} {
lappend TouchePour(Postpone) [list $Clavier $Texte $Commande $Action $Couleur]
} else {
lappend TouchePour(Postpone) [list $Texte $Commande $Action $Couleur]
}
return $TouchePour(Postpone)
}
if {$Texte=="ReAcceptAll" && [info exists TouchePour($CC,RefuseAll)]} {
unset TouchePour($CC,RefuseAll)
return ""
}
if {$Texte=="RefuseAll"} { set TouchePour($CC,RefuseAll) 1 }
if {[info exists TouchePour($CC,RefuseAll)]} { return "" }
#rR
if {[PourWscope]} { return [TouchePourWscope $Clavier $Texte $Commande $Action $Couleur] }
#rR
#????? if {[regexp "NoWeb" $Action]} { return "" }
if {[regexp "^<" $Clavier]} {
set Bouton [set TouchePour(BoutonCourant)]
set NewTexte [lindex [$Bouton configure -text] 4]
append NewTexte $Texte
$Bouton configure -text $NewTexte
bind $Bouton $Clavier $Commande
return $Bouton
}
if {$Texte=="NouvelleCouleur"} {
set TouchePour($Clavier,Couleur) $Commande
return [set TouchePour($Clavier,Couleur)]
}
if {$Texte=="NouvelleGamme"} {
if {[PourWscope]} { return }
if { ! [info exists TouchePour($Clavier,Gamme)]} {
set TouchePour($Clavier,Gamme) -1
}
set Gamme [incr TouchePour($Clavier,Gamme)]
set DestFrame "$Clavier.gamme$Gamme"
frame $DestFrame
pack $DestFrame -side "left" -fill x -pady 0 -anchor "n"
set TouchePour($Clavier,DestFrame) $DestFrame
return $DestFrame
}
if {$Action=="NoWeb"} { set NoWeb 1 } else { set NoWeb 0 }
if {$NoWeb && [PourWscope]} { return "" }
if { ! [info exists TouchePour($Clavier,nTouches)]} {
set TouchePour($Clavier,nTouches) -1
}
if { ! [info exists TouchePour($Clavier,Couleur)]} {
set TouchePour($Clavier,Couleur) "grey"
}
set B [incr TouchePour($Clavier,nTouches)]
if {$Couleur==""} {
set Couleur [set TouchePour($Clavier,Couleur)]
}
set Bouton "$Clavier.touche$B"
set WidthButton 15
if {[regexp "\.board\." $Bouton]} { set WidthButton 25 }
button $Bouton -text $Texte -background $Couleur -foreground black -relief raise -width $WidthButton -height 1 -pady 0
bind $Bouton <1> $Commande
if { ! [PourWscope]} {
pack $Bouton -in [set TouchePour($Clavier,DestFrame)] -side "top" -expand 1
}
set TouchePour(BoutonCourant) $Bouton
return $Bouton
}
proc CreeLeRepertoire Rep {
if {$Rep=="" || [file exists $Rep]} { return $Rep }
set Parent [file dirname $Rep]
if { ! [file exists $Parent]} { set Parent [CreeLeRepertoire $Parent] }
if {$Parent=="" || ! [file exists $Parent]} { return "" }
file mkdir $Rep
if {[file exists $Rep]} { return $Rep }
return ""
}
proc ChoixDuRepertoire {{RepInitial ""}} {
global OuiOuNonToujoursParDefaut
if {[info exists OuiOuNonToujoursParDefaut] && $OuiOuNonToujoursParDefaut} {
if {$RepInitial!="" && [file exists $RepInitial]} { return $RepInitial }
}
if {$RepInitial==""} { set RepInitial "./" }
# BUG dans Tk ... initialdir n'est pas pris
set Rep [tk_chooseDirectory -initialdir $RepInitial]
if {$Rep==""} { return "" }
if {[file exists $Rep]} { return $Rep }
if { ! [OuiOuNon "Do I create the directory\n$Rep ?"]} { FaireLire "Tant pis" ; return $Rep }
set RepCree [CreeLeRepertoire $Rep]
if {$RepCree!=""} {
FaireLire "I created $Rep"
return $RepCree
}
FaireLire "I couldn't create $Rep\nWe'll try again"
return [ChoixDuRepertoire $RepInitial]
}
proc LesFichiersQuiCommencentPar {Texte {Rep ""} {Extension ""}} {
if {$Rep!="" && [regexp "/$" $Rep]} { append Rep "/" }
set LesBons {}
foreach Fichier [glob -nocomplain "${Rep}*$Extension"] {
if {[regexp -nocase -- "^$Texte" [file tail $Fichier]]} { lappend LesBons $Fichier }
}
return "$LesBons"
}
proc Tx {{D ""} {F ""}} {
global Tx TxD TxF
if {$D==""} { set D $TxD }
if {$F==""} { set F $TxF }
return [string range $Tx $D $F]
}
proc PrintEnv Variable {
global env
if {$Variable=="all"} {
return [array get env]
}
if {[info exists env($Variable)]} { return $env($Variable) }
return "$Variable iiiiiiiiiiiiiiiiiiiiinconnu"
}
proc LesBoutonsDeLaFrame F {
set LesBoutons {}
foreach Bouton [winfo children $F] {
if {[winfo class $Bouton]!="Button"} { continue }
lappend LesBoutons $Bouton
}
return $LesBoutons
}
proc PourWscope {{NouvelleValeur ""}} {
global PourWscope
if {$NouvelleValeur!=""} {
set PourWscope $NouvelleValeur
}
if { ! [info exists PourWscope]} { set PourWscope 0 }
return $PourWscope
}
proc thtml {} {
set T [ContenuDuFichier trp7_human.blastp]
set B [ProchaineBalise T Attrib "Rogner"]
Espionne "Attributs de $B : $Attrib"
set B [ProchaineBalise T Attrib "Rogner"]
Espionne "Attributs de $B : $Attrib"
set Iter [ValeurDeLaBalise "Iteration" T]
set Num [ValeurDeLaBalise "Iteration_iter-num" Iter]
set Hits [ValeurDeLaBalise "Iteration_hits" Iter]
set Stat [ValeurDeLaBalise "Iteration_stat" Iter]
Espionne "Num =$Num="
Espionne $Stat
while 1 {
set Hit [ValeurDeLaBalise "Hit" Hits "" "Rogner"]
set Hit_def [ValeurDeLaBalise "Hit_def" Hit "NePasRogner"]
set Hit_id [ValeurDeLaBalise "Hit_id" Hit "NePasRogner"]
Espionne "$Hit_id $Hit_def"
while 1 {
set BH [ProchaineBalise Hit "" "Rogner"]
if {$BH==""} { break }
Espionne " $BH"
}
}
exit
exit
foreach BornesDuHit [LesSousChamps $Hits] {
scan $BornesDuHit "%d %d" D F
set Hit [string range $Hits $D $F]
Espionne [string range $Hit 0 300]
set Hit_def [ValeurDeLaBalise "Hit_def" Hit "NePasRogner"]
set Hit_id [ValeurDeLaBalise "Hit_id" Hit "NePasRogner"]
Espionne "$Hit_id $Hit_def"
while 1 {
set BH [ProchaineBalise Hit "" "Rogner"]
if {$BH==""} { break }
Espionne " $BH"
}
}
exit
Recure $T
while 1 {
set Bal [ProchaineBalise T Attrib]
if {$Bal==""} { break }
set Val [ValeurDeLaBalise $Bal T]
Espionne "=$Bal=[string range $Val 0 50]"
}
exit
}
proc LesSousChamps {T {Champ ""}} {
set Balise [ProchaineBalise T]
if {$Champ!="" && ! [string equal -nocase $Balise $Champ]} { return {}}
Espionne $Balise
set LesValeurs {}
set i 5
while 1 {
if {[incr i -1]==0} { break }
set Valeur [ValeurDeLaBalise $Balise T]
if {$Valeur==""} { break }
lappend LesValeurs $Valeur
# Espionne [string range $Valeur 0 300]
}
return $LesValeurs
}
proc Recure W {
global Indentation
while 1 {
set B [ProchaineBalise W]
if {$B==""} { Espionne "[string repeat " " $Indentation] $W" ; break }
set V [ValeurDeLaBalise $B W]
if { ! [info exists Indentation]} { set Indentation 1 }
Espionne "[string repeat " " $Indentation] ($B)"
if {$V==""} { continue }
incr Indentation
Recure $V
incr Indentation -1
}
return ""
}
proc RRGardeLesEucaryotes {Fichier} {
set LesEucaryotes {}
set Texte [ContenuDuFichier $Fichier]
while {[set BH [ValeurDeLaBalise "BlastHit" Texte]]!=""} {
set AC [ValeurDeLaBalise AC BH NePasRogner]
set OX [ValeurDeLaBalise OX BH NePasRogner]
set DE [ValeurDeLaBalise DE BH NePasRogner]
Espionne "OX $OX"
set HasEuka 0
foreach TaxId [split $OX " "] {
regsub {[^0-9]} $TaxId "" TaxId
if { ! [EstUnEucaryote $TaxId]} { continue }
set HasEuka 1
break
}
Espionne "$HasEuka $BH"
if {$OX!="" && ! $HasEuka} { continue }
# AppendAuFichier les_eucaryotes $Ligne
lappend LesEucaryotes $BH
}
return $LesEucaryotes
}
proc TesteValeurDeLaBalise {} {
set Texte " "
set V [ValeurDeLaBalise BlastHit Texte "NePasRogner" A]
Espionne "Valeur >$V<"
Espionne "Attrib >$A<"
Espionne "/$Texte/"
set V [ValeurDeLaBalise DE Texte "NePasRogner" A]
Espionne "Valeur >$V<"
Espionne "Attrib >$A<"
Espionne "/$Texte/"
set V [ValeurDeLaBalise AC Texte "NePasRogner" A]
Espionne "Valeur >$V<"
Espionne "Attrib >$A<"
Espionne "/$Texte/"
Espionne [AttributsDeLaBalise DE Texte]
exit
}
proc ValeurDeLaBalise {Item aTexte {Rogner "Rogner"} {aAttributs ""} {Vide ""}} {
upvar $aTexte Texte
if {$aAttributs!=""} { upvar $aAttributs Attributs }
set Rogner [expr ! [string equal -nocase $Rogner "NePasRogner"]]
regsub -all -- "-" $Item "\-" ItemX
if { ! [regexp -indices -nocase "<${ItemX}(>| )" $Texte Indices]} { return $Vide }
set FinItem [lindex $Indices 1]
set NouveauTexte [string range $Texte [expr $FinItem] end]
set iChevronFermant [string first ">" $NouveauTexte]
if {$iChevronFermant<0} { return "" }
set Attributs [string range $NouveauTexte 0 $iChevronFermant]
set LongAttributs [string length $Attributs]
regsub ">" $Attributs "" Attributs
set Attributs [string trim $Attributs]
set NouveauTexte [string trim [string range $NouveauTexte $LongAttributs end]]
set Fermant [ItemHTMLFermant $Item]
if {$Fermant==">"} {
set Valeur $Attributs
set Derriere 0
} else {
regsub -all -- "-" $Fermant "\-" FermantX
if { ! [regexp -indices -nocase "$FermantX" $NouveauTexte Indices]} { return $Vide }
set iFin [lindex $Indices 0]
if {[regexp {<[^/]} $FermantX]} {
set Derriere [expr $iFin - 1]
} else {
set Derriere [expr [lindex $Indices 1] + 1]
}
set Valeur [string range $NouveauTexte 0 [expr $iFin - 1]]
}
if {$Rogner} { set Texte [string range $NouveauTexte $Derriere end] }
if {$Valeur==""} { set Valeur $Vide }
return $Valeur
}
proc ProchaineBalise {aTexte {aAttributs ""} {Rogner "NePasRogner"}} {
upvar $aTexte Texte
if {$aAttributs!=""} { upvar $aAttributs Attributs ; set Attributs ""}
set Rogner [expr ! [string equal $Rogner "NePasRogner"]]
if { ! [regexp -indices -nocase {<[^ >]+} $Texte Indices]} { return "" }
set DebItem [lindex $Indices 0]
set FinItem [lindex $Indices 1]
set Balise [string range $Texte [incr DebItem] $FinItem]
set NouveauTexte [string range $Texte $FinItem+1 end]
set iChevronFermant [string first ">" $NouveauTexte]
if {$iChevronFermant<0} { return "" }
set Attributs [string range $NouveauTexte 0 $iChevronFermant]
set LongAttributs [string length $Attributs]
set Attributs [string trim $Attributs " />"]
set NouveauTexte [string range $NouveauTexte $LongAttributs-1 end]
set Fermant [ItemHTMLFermant $Balise]
regsub -all -- "-" $Fermant "\-" FermantX
if { ! [regexp -indices -nocase "$FermantX" $NouveauTexte Indices]} { return "" }
set iFin [lindex $Indices 0]
set Derriere [expr [lindex $Indices 1] + 1]
set Valeur [string range $NouveauTexte 0 [expr $iFin - 1]]
if {$Rogner} { set Texte [string range $NouveauTexte $Derriere end] }
return $Balise
}
proc ItemHTMLFermant Item {
global ItemHTMLFermant
if {[info exists ItemHTMLFermant($Item)]} { return $ItemHTMLFermant($Item) }
set Item [string tolower $Item]
set LesSimples {area img ox os oc ac de gn id pn rect polyline path}
if {[lsearch -exact $LesSimples $Item]>=0} { return ">" }
# if {[string equal -nocase $Item "LI"]} { return "" }
return ""
}
proc AttributsDeLaBalise {Item aTexte {Rogner "NePasRogner"}} {
upvar $aTexte Texte
ValeurDeLaBalise $Item $aTexte $Rogner A
return $A
}
proc Garde {Fichier {Granularity "Seconde"} {AndDelete ""} {GetName ""}} {
#biotcl keepFile {}
if { ! [file exists $Fichier]} { return "" }
#rR on peut ne demander que le nom
if {[regexp -nocase "=GetName=" "=$Granularity=$AndDelete=$GetName="]} { set GetName "GetName" }
if {[regexp -nocase "AndDelete" $Granularity]} {
set AndDelete $Granularity
set Ganularity ""
}
if {$Granularity=="Minute"} {
set Time 60000
set Extension [Date]
} else {
set Time 1000
set Extension [Date "Seconds"]
}
set Nouveau "$Fichier.$Extension"
if {[file exists $Nouveau]} { after $Time ; return [Garde $Fichier $Granularity $AndDelete $GetName] }
if {$GetName=="GetName"} { return $Nouveau }
File copy -force $Fichier $Nouveau
if {[file exists $Nouveau]} {
if {[regexp -nocase "AndDelete" $AndDelete] && [file exists $Fichier]} { file delete $Fichier }
return $Nouveau
}
return ""
}
proc Zippe {ListeA ListeB} {
set LongPetite [Mini [llength $ListeA] [llength $ListeB]]
foreach A [lrange $ListeA 0 $LongPetite] B [lrange $ListeB 0 $LongPetite] {
lappend ListeAB $A $B
}
incr LongPetite
if {[llength $ListeA] > $LongPetite} { return [concat $ListeAB [lrange $ListeA $LongPetite end]] }
if {[llength $ListeB] > $LongPetite} { return [concat $ListeAB [lrange $ListeB $LongPetite end]] }
return $ListeAB
}
proc LesLignesVitales {Fichier {SansVide ""} {SansBlanc ""}} {
#biotcl validLinesFromFile {file withoutEmpty withoutSpace}
set SansVide [string equal -nocase $SansVide "SansVide"]
set SansBlanc [string equal -nocase $SansBlanc "SansBlanc"]
Wup "Returns the lists of the lines from Fichier, accepts continuation and ignores # or empty lines"
set LesVitales {}
set Lu ""
foreach Ligne [LesLignesDuFichier $Fichier] {
if {$SansBlanc} { regsub -all " " $Ligne "" Ligne }
if {[regexp {\#} $Ligne]} {
regsub {\#.*$} $Ligne "" Ligne
}
if {$SansVide && [string trim $Ligne]==""} { continue }
if { ! [regexp -nocase {[^ ]} $Ligne]} { continue }
if {[regexp {\\$} $Ligne]} {
regsub {\\$} $Ligne "" Ligne
append Lu $Ligne
} else {
append Lu $Ligne
lappend LesVitales $Lu
set Lu ""
}
}
return $LesVitales
}
proc AttendreLeFichier {Fichier {TimeOut ""}} {
set Attente 1000
while { 1 } {
if {[file exists $Fichier]} { return $Fichier }
if {$TimeOut != "" } {
set TimeOut [expr $TimeOut-$Attente]
if {$TimeOut<0} { return "" }
}
after $Attente
}
}
proc PourGscopeServer {} {
return [PourWscope]
}
proc NextALPHA S {
#biotcl nextAlpha {}
if {$S==""} { return "A" }
set F [string index $S end]
if {$F < "A" || "Z" < $F} { return "${S}A" }
if {$F < "Z"} {
scan $F "%c" I
set N [format "%c" [incr I]]
return [string replace $S end end $N]
}
set Avant [string range $S 0 end-1]
return "[NextALPHA $Avant]A"
}
proc Echange {aA aB} {
upvar $aA A
upvar $aB B
set W $A
set A $B
set B $W
return
}
proc ImprimeLeTexte {Texte {Commande ""}} {
set Fichier "[TmpFile].txt"
set Fichier [Sauve $Texte dans $Fichier]
if {$Fichier==""} {
FaireLire "I couldn't create $Fichier for printing"
return ""
}
if {$Commande==""} { set Commande "renoir" }
return [ImprimeLeFichier $Fichier $Commande]
}
proc ImprimeLeFichier {Fichier {Commande ""}} {
global CommandePrint
Gs "Ignorer"
if { ! [info exists CommandePrint]} { set CommandePrint "renoir" }
if {$Commande==""} { set Commande $CommandePrint }
set CommandePrint "$Commande $Fichier"
if {[OuiOuNon "$CommandePrint\n\nDo You want to edit this print command ?" 0]} {
set CommandePrint [Entre $CommandePrint]
}
eval exec $CommandePrint
return $Fichier
}
proc SubstitueAvecBlancsDevant {Texte A B} {
regexp -indices $A $Texte Indices
scan $Indices "%d %d" d f
incr d -1
while {$d>0 && [string index $Texte $d]==" "} { incr d -1 }
incr d 2
set LongBlancAvant [expr $f-$d+1-[string length $B]]
set Platre "[string repeat " " $LongBlancAvant]$B"
set NouveauTexte [string replace $Texte $d $f $Platre]
return $NouveauTexte
}
proc ChoixParmiJoliDansListe Liste {
set LesClefs {}
set LesCouleurs {}
set LesTextes {}
foreach {Clef Couleur Texte} $Liste {
lappend LesClefs $Clef
lappend LesCouleurs $Couleur
if {$Texte==""} { set Texte $Clef }
lappend LesTextes $Texte
}
return [ChoixParmiJoli $LesClefs $LesCouleurs $LesTextes]
}
proc TCPJ {} {
set L {a b c d}
set A {Arnaud Bob Claude Denis}
set C {red blue yellow green}
return [ChoixParmiJoli $L $C $A]
}
proc ChoixParmiJoli {Liste {ListeDeCouleurs {}} {ListeAAfficher {}}} {
global retourChoixParmi
if {[llength $Liste] == 0 } { return "" }
if {[llength $Liste] == 1 && [lindex $Liste 0]!="Other"} { return [lindex $Liste 0] }
global ChoixParmiDansListBox
if {([info exists ChoixParmiDansListBox] && $ChoixParmiDansListBox) || [llength $Liste]>40} {
return [ChoixParmiDansListBox $Liste $ListeAAfficher]
}
set w [NomDe fenetre]
catch {destroy $w}
catch {unset retourChoixParmi}
toplevel $w
wm geometry $w +300+100
set Invite "Choose ..."
set InListBox "Same display in a listbox"
set Salut "... DISMISS"
if {$ListeAAfficher=={}} { set ListeAAfficher $Liste }
tk_optionMenu $w.o retourChoixParmi $Invite
$w.o.menu add radiobutton -label $InListBox -background "orange" -variable retourChoixParmi
$w.o configure -background "Seagreen" -foreground "black" -bd 20
foreach Element $Liste Couleur $ListeDeCouleurs Affiche $ListeAAfficher {
while {[info exists MonRetour($Affiche)]} { append Affiche "_" }
set MonRetour($Affiche) $Element
if { $Couleur == "" } {
set Couleur "Seagreen"
}
$w.o.menu add radiobutton -background $Couleur -foreground "black" \
-label $Affiche -variable retourChoixParmi
}
$w.o.menu add radiobutton -label $Salut -background "red" -variable retourChoixParmi
pack $w.o
tkwait variable retourChoixParmi
destroy $w
if { $retourChoixParmi == $InListBox } {
set retourChoixParmi [ChoixParmiDansListBox $ListeAAfficher]
}
if { $retourChoixParmi == $Invite || $retourChoixParmi == $Salut } {
set retourChoixParmi ""
}
if {$retourChoixParmi==""} { return "" }
set Retour [set MonRetour($retourChoixParmi)]
return $Retour
}
proc ChoixParmi {Liste {ListeDeCouleurs {}}} {
global retourChoixParmi
if {[llength $Liste] == 0 } { return "" }
if {[llength $Liste] == 1 && [lindex $Liste 0]!="Other"} { return [lindex $Liste 0] }
global ChoixParmiDansListBox
if {[PourWscope] \
|| [info exists ChoixParmiDansListBox] && $ChoixParmiDansListBox \
|| [llength $Liste]>40} {
return [ChoixParmiDansListBox $Liste]
}
set w [NomDe fenetre]
catch {destroy $w}
catch {unset retourChoixParmi}
set GW 300
set GH 100
set SW [winfo screenwidth .]
set SH [winfo screenheight .]
set OffX [expr ($SW - $GW)/2]
set OffY [expr ($SH - $GH)/4]
toplevel $w -borderwidth 20
wm geometry $w ${GW}x${GH}+${OffX}+${OffY}
$w configure -background orange
set Invite " Please select within the list ... "
set InListBox "Same display in a listbox"
set Salut "... DISMISS (select nothing)"
tk_optionMenu $w.o retourChoixParmi $Invite
$w.o.menu add radiobutton -label $InListBox -background "orange" -variable retourChoixParmi
$w.o configure -background "Seagreen" -foreground "black" -bd 10 -width 30 -height 2
foreach Element $Liste Couleur $ListeDeCouleurs {
if { $Couleur=="" } {
set Couleur "Seagreen"
}
$w.o.menu add radiobutton -background $Couleur -foreground "black" \
-label $Element -variable retourChoixParmi
}
$w.o.menu add radiobutton -label $Salut -background "red" -variable retourChoixParmi
pack $w.o
tkwait variable retourChoixParmi
destroy $w
if { $retourChoixParmi == $InListBox } { return [ChoixParmiDansListBox $Liste] }
if { $retourChoixParmi == $Invite || $retourChoixParmi == $Salut } {
set retourChoixParmi ""
}
return $retourChoixParmi
}
proc ChoixParmiDansListBox {Liste {ListeAAfficher {}}} {
set Choose "Select ONE of the following lines and press ACCEPT. Press DISMISS to cancel."
if {$ListeAAfficher=={}} {
set ListeA $Liste
} else {
set ListeA $ListeAAfficher
}
set ListeE [concat [list ""] $Liste]
set ListeA [concat [list $Choose] $ListeA]
foreach E $ListeE A $ListeA {
while {[info exist ARetourner($A)]} {
set A "$A (bis)"
}
set ARetourner($A) $E
lappend BonneListeA $A
}
set Texte [join $BonneListeA "\n"]
set Retour [Affiche $Texte "AvecRienSansFetchAvecRetour" "SelectAndAccept"]
if {$Retour==$Choose || $Retour==""} { return "" }
if { ! [info exists ARetourner($Retour)]} { error $Retour } ;#rR ... error le transmet directement a Wscope
return $ARetourner($Retour)
}
proc WrapLeTexte {Texte {Largeur 50}} {
if {[string length $Texte]<=$Largeur} { return [list $Texte] }
set Entamme [string range $Texte 0 [expr $Largeur-1]]
set DernierBlanc [string last " " $Entamme]
if {$DernierBlanc<0} { set DernierBlanc $Largeur }
set Entamme [string range $Texte 0 [expr $DernierBlanc - 1]]
set Reste [string trim [string range $Texte $DernierBlanc end]]
return [concat [list $Entamme] [WrapLeTexte $Reste $Largeur]]
}
proc LesLignesEntreExpressionsDuFichier {Fichier A B {BExclu "SecondExcluded"}} {
if {$BExclu=="SecondIncluded"} {
set BExclu 1
} else {
set BExclu 0
}
set OnYEst 0
set LesBonnes {}
foreach Ligne [LesLignesDuFichier $Fichier] {
if {[regexp $A $Ligne]} {
set OnYEst 1
}
if {[regexp $B $Ligne] && $BExclu} { break }
if {$OnYEst} { lappend LesBonnes $Ligne }
if {[regexp $B $Ligne]} { break }
}
return $LesBonnes
}
proc SqueletteDeProc {} {
lappend LeSquel "proc ChangeMyName \{\} \{"
lappend LeSquel " global RepertoireDuGenome"
lappend LeSquel " "
lappend LeSquel " "
lappend LeSquel "\}"
return [join $LeSquel "\n"]
}
proc CreeUneNouvelleProcedure {{Texte ""}} {
global LesProceduresExistantes
regsub {^[ \t]*} $Texte "" Texte
if {$Texte==""} {
set Texte [SqueletteDeProc]
} else {
if { ! [regexp "^proc " $Texte]} { set Texte "proc $Texte" }
}
set Nouveau [EntreTexte $Texte]
if {$Nouveau==""} { return "" }
scan $Nouveau "%s %s" P N
source [Sauve $Nouveau dans [TmpFile ".tcl"]]
set LesProceduresExistantes [linsert $LesProceduresExistantes 0 $N]
AfficheLaProc $N
}
proc ModeInteractif {} {
global RepertoireDuGenome
global GscopeDir
set Fin 0
while {!$Fin} {
if {[gets stdin Ligne]==-1} {
set Fin 1
} else {
if {[catch {puts [eval $Ligne]} Message]} {
puts stderr $Message
}
}
}
}
proc SplitOrgas Organismes {
set OrgaJoinCar ":"
return [split $Organismes $OrgaJoinCar]
}
proc ContenuSubstitueDuFichier {Fichier args} {
if { $Fichier == "" } {return ""}
set f [open $Fichier r]
set Texte [read -nonewline $f]
close $f
set I 0
foreach argument $args {
set VariableN "(\[^\\\\])\\$${I}(\[^0-9\])"
regsub -all {&} $argument {\\&} argument
regsub -all $VariableN $Texte "\\1$argument\\2" Texte
incr I
}
regsub -all {\\(\$[0-9])} $Texte "\\1" Texte
return $Texte
}
proc PaqTexte {Label Texte} {
return "Text: $Label $Texte"
}
proc PaqListe {Label Liste} {
return "List: $Label [SeriaList $Liste]"
}
proc PaqArray {Label {aArray ""}} {
if {$aArray==""} { set aArray $Label }
upvar $aArray Array
set Liste [array get Array]
return "Array: $Label [SeriaList $Liste]"
}
proc SeriaList args {
return "$args"
}
proc ListSeria Texte {
return [eval list $Texte]
}
proc AffecteLesVariablesDeReponse {Reponse {Level ""}} {
if {$Level==""} {
set Level 2
} else {
if { ! [regexp {^\#} $Level]} {
incr Level
}
}
return [AffecteLesVariablesDeLaListe [split $Reponse "\n"] $Level]
}
proc AffecteLesVariablesDeLaListe {Liste {Level 1}} {
# JeMeSignale
foreach Ligne $Liste {
if { ! [regexp {^(Text|List|Array): } $Ligne]} { continue }
set Type ""
set NomDeVariable ""
scan $Ligne "%s %s" Type NomDeVariable
if { ! [regexp -nocase {^[a-z_]} $NomDeVariable] } { continue }
lappend LesVariables $NomDeVariable
regsub {\(} $NomDeVariable {\\(} NomDeVariable
regsub {\)} $NomDeVariable {\\)} NomDeVariable
regsub "^$Type $NomDeVariable " $Ligne "" Ligne
# puts stderr [string range $Ligne 0 80]
set Commande ""
switch $Type {
"Text:" {
set Commande "set $NomDeVariable $Ligne"
}
"List:" {
set Commande "set $NomDeVariable [ListSeria $Ligne]"
}
"Array:" {
regsub "^_x_" $NomDeVariable "" NomDeVariable
set Commande "array set $NomDeVariable [ListSeria $Ligne]"
}
}
if {[regexp bonjour $Commande]} { Espionne $Commande }
if {$Commande!=""} { uplevel $Level $Commande }
}
return $LesVariables
}
proc EtendAuxPremiersTermes LesTermes {
if {[llength $LesTermes]<=1} { return $LesTermes }
if {[lindex $LesTermes 0]!=""} { return $LesTermes }
set LaSuite [EtendAuxPremiersTermes [lrange $LesTermes 1 end]]
set Premier [lindex $LaSuite 0]
return [concat [list $Premier] $LaSuite]
}
proc EtendAuxDerniersTermes LesTermes {
if {[llength $LesTermes]<=1} { return $LesTermes }
set Premier [lindex $LesTermes 0]
foreach Terme $LesTermes {
if {$Terme==""} { set Terme $Premier }
lappend LesBonsTermes $Terme
}
return $LesBonsTermes
}
proc GscopeLangue {{Langue ""}} {
set Langue [string tolower $Langue]
global GscopeLangue
if {$Langue!=""} {
set LesPossibles [list gscope english francais elsassich]
if {[lsearch $LesPossibles $Langue]<0} { set Langue "" }
set GscopeLangue $Langue
}
if { ! [info exists GscopeLangue] || $GscopeLangue==""} { set GscopeLangue "english" }
return $GscopeLangue
}
proc Teste_LaTraduction {} {
set Liste [ColorationsPossibles]
foreach X $Liste T [LaTraduction $Liste "english" "SansBlanc"] {
Espionne "$X $T"
}
exit
}
proc LaTraduction {Liste {Sortie ""} {SansBlanc ""}} {
global GscopeDico
if {$Sortie==""} { set Sortie [GscopeLangue] }
set SansBlanc [string equal -nocase $SansBlanc "SansBlanc"]
if { ! [info exists GscopeDico]} {
foreach FichierDico [glob -nocomplain "[GscopeEtc]/gscope_*.dic"] {
if {[file exists $FichierDico]} {
if {[info exists LesLangues]} { unset LesLangues }
foreach Ligne [LesLignesDuFichier $FichierDico] {
if {[regexp {^[ \t]*\#} $Ligne]} { continue }
set LesTermes {}
foreach Terme [split $Ligne ":"] {
regsub -all {^[ \t]+} $Terme "" Terme
regsub -all {[ \t]+$} $Terme "" Terme
lappend LesTermes $Terme
}
if { ! [info exists LesLangues]} {
set LesLangues $LesTermes
set NombreDeLangues [llength $LesLangues]
continue
}
while {[llength $LesTermes] < $NombreDeLangues} {
lappend LesTermes ""
}
set LesTermes [EtendAuxPremiersTermes $LesTermes]
set LesTermes [lrange $LesTermes 0 [expr $NombreDeLangues-1]]
set LesTermes [EtendAuxDerniersTermes $LesTermes]
foreach Terme $LesTermes {
foreach Langue $LesLangues TermeTraduit $LesTermes {
if {$Terme==""} { continue }
if {$SansBlanc} { regsub -all " " $TermeTraduit "_" TermeTraduit }
set GscopeDico($Terme:$Langue) $TermeTraduit
}
}
}
}
}
}
foreach Terme $Liste {
if {[info exists GscopeDico($Terme:$Sortie)]} {
lappend LaTraduction [set GscopeDico($Terme:$Sortie)]
} else {
lappend LaTraduction $Terme
}
}
return $LaTraduction
}
proc Traduction {Terme {Sortie ""}} {
return [lindex [LaTraduction [list $Terme] $Sortie] 0]
}
proc NombresEntre {D F {Pas 1}} {
#biotcl numbersBetween {start end step}
if {$D==$F} { return [list $D] }
set LesX {}
for {set X $D} {[expr $Pas*$X <= $Pas*$F]} { set X [expr $X+$Pas]} {
lappend LesX $X
}
return $LesX
}
proc Base10 Texte {
#biotcl base10 {text}
regsub " " $Texte "" Texte
if {[regexp "^\-" $Texte]} { set PlusOuMoins "-" } else { set PlusOuMoins "" }
regsub {^[\-0]*} $Texte "" Texte
if {$Texte==""} { set Texte 0 }
return "$PlusOuMoins$Texte"
}
proc FilenameWithDate {File {Format ""} {WhichTime ""}} {
#biotcl fileNameWithDate {}
if {[FileAbsent $File]} { return -1 }
set DoF [DateOfFile $File $Format $WhichTime]
set NewName "$File.$DoF"
set N 1
while {[file exists $NewName]} {
set NewName "$File.$DoF.$N"
incr N
}
return $NewName
}
proc DateOfFile {File {Format ""} {WhichTime ""}} {
#biotcl dateOfFile {}
if {[FileAbsent $File]} { return -1 }
if {$WhichTime==""} { set WhichTime "mtime" }
set TopChrono [file $WhichTime $File]
return [Date $Format $TopChrono]
}
proc Date {{Format ""} {TopChrono ""}} {
#biotcl date {}
if {$Format==""} { set Format "%Y%m%d%H%M" }
if {$Format=="_"} { set Format "YMD_HMS" }
if {[string equal -nocase "YMD" $Format]} { set Format "%Y%m%d" }
if {[string equal -nocase "YMD_HM" $Format]} { set Format "%Y%m%d_%H%M" }
if {[string equal -nocase "YMD_HMS" $Format]} { set Format "%Y%m%d_%H%M%S" }
if {[string equal -nocase $Format "Nice_"]} {
set Format "%Y_%m_%d_%H_%M"
}
if {[string equal -nocase $Format "Nice_H"]} {
set Format "%Y_%m_%d_%Hh%M"
}
if {[string equal -nocase $Format "Nice"]} {
set Format "%Y/%m/%d %H:%M"
}
if {[string equal -nocase $Format "NiceSeconds"]} {
set Format "%Y/%m/%d %H:%M:%S"
}
if {[string equal -nocase $Format "NiceSeconds-"]} {
set Format "%Y/%m/%d-%H:%M:%S"
}
if {[string equal -nocase $Format "NiceYMD"]} {
set Format "%Y/%m/%d"
}
if {[string equal -nocase $Format "Seconds"]} { set Format "%Y%m%d%H%M%S" }
if {$TopChrono==""} { set TopChrono [clock scan now] }
if {$Format=="TimeStamp"} { return $TopChrono }
return [clock format $TopChrono -format $Format]
}
proc LesLigneesUsageUnique {} {
foreach AppeleeAppelante [LesProceduresUsageUnique] {
scan $AppeleeAppelante "%s %s" Appelee Appelante
set AppelanteDe($Appelee) $Appelante
lappend AppeleePar($Appelante) $Appelee
# Espionne "set AppelanteDe($Appelee) $Appelante"
# Espionne "lappend AppeleePar($Appelante) $Appelee > [set AppeleePar($Appelante)]"
lappend LesUsageUnique $Appelee
}
foreach Procedure $LesUsageUnique {
if {[info exists AppeleePar($Procedure)]} {
# Espionne "j'abandonne $Procedure car appelante de [set AppeleePar($Procedure)]"
continue
}
set LaLignee {}
lappend LaLignee $Procedure
while 1 {
if {[info exists AppelanteDe($Procedure)]} {
set Procedure [set AppelanteDe($Procedure)]
lappend LaLignee $Procedure
} else {
break
}
}
Espionne "[llength $LaLignee] [join $LaLignee " "]"
}
}
proc LesProceduresUsageUnique {} {
global GscopeDir
set FichierLesProceduresUsageUnique "$GscopeDir/lesproceduresusageunique"
if {[file exists $FichierLesProceduresUsageUnique]} {
return [LesLignesDuFichier $FichierLesProceduresUsageUnique]
}
foreach Procedure [LesProceduresExistantes] {
set LesAppelantes [QuiMAppel $Procedure "LaListeMerci"]
if {[llength $LesAppelantes] > 1} { continue }
if {[llength $LesAppelantes] == 0} {
set Appelante "PERSONNE"
} else {
set Appelante [lindex $LesAppelantes 0]
}
lappend LesProceduresUsageUnique "$Procedure $Appelante"
}
SauveLesLignes $LesProceduresUsageUnique dans $FichierLesProceduresUsageUnique
return $LesProceduresUsageUnique
}
proc LesProceduresNonAppelantes {} {
foreach Procedure [LesProceduresExistantes] {
set LesAppelees [QuiJAppel $Procedure "LaListeMerci"]
if {$LesAppelees != {}} { continue }
lappend LesProceduresNonAppelantes $Procedure
}
return $LesProceduresNonAppelantes
}
proc AppendAuFichier {Fichier Ligne} {
#biotcl appendToFile {file text}
set Canal [open $Fichier "a"]
puts $Canal $Ligne
close $Canal
return $Fichier
}
proc Barycentre LesXY {
#biotcl centerOfMass {listOfXY}
set SX 0
set SY 0
set N [expr [llength $LesXY]/2]
if {$N<1} { return {0. 0.} }
foreach {X Y} $LesXY {
set SX [expr $SX+$X]
set SY [expr $SY+$Y]
}
return [list [expr 1.0*$SX/$N] [expr 1.0*$SY/$N]]
}
proc Teste_ScanLaListe {} {
set L {1 2 3 4 5 6 7 }
puts [ScanLaListe $L a b c]
puts $a
puts $b
puts $c
exit
}
proc ScanLaListe {Liste args} {
set i 0
set Long [llength $Liste]
foreach aV $args {
upvar $aV V
if {$i >= $Long} { break }
set V [lindex $Liste $i]
incr i
}
return $i
}
proc FouR {Debut Fin} {
if {$Debut <= $Fin} {
return "F"
} else {
return "R"
}
}
proc Teste_Fleche {} {
set K [UnCanva 600 600]
Fleche $K 200 100 430 100 -width 50 -outlinewidth 1 -fill "red" -outline "blue" -arrowdirection "both" -flatside "left"
Fleche $K 200 300 230 300 -width 50 -outlinewidth 1 -outline "green" -arrowdirection "both"
Fleche $K 200 400 230 400 -width 50 -outlinewidth 1 -fill "" -outline "orange" -arrowdirection "start"
Fleche $K 200 500 230 500 -width 50 -outlinewidth 1 -fill "red" -outline "grey" -arrowdirection "none"
$K create oval 10 10 100 200
MainLeveeSurUnCanva $K
regsub ".canvas" $K "" w
Gonfle $w all 1. 1.
set K [UnCanva 600 600]
Fleche $K 200 100 230 100 -width 50 -outlinewidth 1 -fill "red" -outline "blue" -arrowdirection "end"
Fleche $K 200 300 230 300 -width 50 -outlinewidth 1 -fill "red" -outline "blue" -arrowdirection "both"
Fleche $K 200 400 230 400 -width 50 -outlinewidth 1 -fill "red" -outline "blue" -arrowdirection "start"
Fleche $K 200 500 230 500 -width 50 -outlinewidth 1 -fill "red" -outline "blue" -arrowdirection "none"
$K create oval 10 10 100 200
MainLeveeSurUnCanva $K
regsub ".canvas" $K "" w
Gonfle $w all 1. 1.
}
proc Fleche {K DebX DebY FinX FinY args} {
Wup "Je crains que Fleche demande un canvas avec X et Y de meme nature ... isotropes"
Wup " => meme facteurs d'echelle sur X et Y."
set Width 6.
set Fill "grey"
set OutLineWidth 1
set OutLine "black"
set ArrowWidth 2
set ArrowDirection "end"
set FlatSide "none"
foreach {Option Valeur} $args {
if {$Valeur==""} { set Valeur "\"\"" }
switch -regexp -- $Option {
"-width$" { set Width $Valeur }
"-outlinewidth$" { set OutLineWidth $Valeur }
"-outline$" { set OutLine $Valeur }
"-fill$" { set Fill $Valeur }
"-arrowwidth$" { set ArrowWidth $Valeur }
"-arrowwidthstart$" { set ArrowWidthStart $Valeur }
"-arrowwidthend$" { set ArrowWidthEnd $Valeur }
"-arrowdirection$" { set ArrowDirection $Valeur }
"-flatside$" { set FlatSide $Valeur }
}
}
if { ! [info exists ArrowWidthStart]} {
if {[regexp "both|start" $ArrowDirection]} {
set ArrowWidthStart $ArrowWidth
} else {
set ArrowWidthStart 0
}
}
if { ! [info exists ArrowWidthEnd]} {
if {[regexp "both|end" $ArrowDirection]} {
set ArrowWidthEnd $ArrowWidth
} else {
set ArrowWidthEnd 0
}
}
set w [expr $Width/2.]
set fStart [expr -$ArrowWidthStart*$w]
set fEnd [expr $ArrowWidthEnd*$w]
set Long [expr sqrt(($FinX-$DebX)*($FinX-$DebX) + ($FinY-$DebY)*($FinY-$DebY))]
if {$Long==0} { return "" }
if {[expr abs($fStart)] > $Long} { set fStart [expr $Long*$fStart/abs($fStart)] }
if {[expr abs($fEnd)] > $Long} { set fEnd [expr $Long*$fEnd /abs($fEnd)] }
if {[expr abs($fEnd)+abs($fStart)] > $Long} {
set fEnd [expr $Long*$fEnd /(2*abs($fEnd)) ]
set fStart [expr $Long*$fStart/(2*abs($fStart))]
set w [expr abs($fEnd)]
}
set AxeX [expr ($FinX-$DebX)/$Long]
set AxeY [expr ($FinY-$DebY)/$Long]
set PerX [expr -$AxeY]
set PerY [expr $AxeX]
set MemoPerY $PerY
set aX [expr $DebX+$w*$PerX]
set aY [expr $DebY+$w*$PerY]
set GardeS 0
Wup "Si on fait une fleche arriere et si ... "
set sX [expr ($DebX+$FinX)/2]
set sY [expr ($DebY+$FinY)/2]
set mX [expr $DebX-$fStart*$AxeX]
set mY [expr $DebY-$fStart*$AxeY]
if {[expr ($DebX-$sX)*($DebX-$sX)+($DebY-$sY)*($DebY-$sY)] < \
[expr ($DebX-$mX)*($DebX-$mX)+($DebY-$mY)*($DebY-$mY)]} {
set sX $mX
set sY $mY
set GardeS 1
}
set f $fEnd
set mX [expr $FinX-$f*$AxeX]
set mY [expr $FinY-$f*$AxeY]
if { ! $GardeS } {
set sX [expr ($DebX+$FinX)/2]
set sY [expr ($DebY+$FinY)/2]
if {[expr ($FinX-$sX)*($FinX-$sX)+($FinY-$sY)*($FinY-$sY)] < \
[expr ($FinX-$mX)*($FinX-$mX)+($FinY-$mY)*($FinY-$mY)]} {
set sX $mX
set sY $mY
set GardeS 1
}
}
if {[regexp "right$" $FlatSide]} { set PerY 0 }
lappend Trace [expr $sX+$w*$PerX]
lappend Trace [expr $sY+$w*$PerY]
lappend Trace [expr $mX+$w*$PerX]
lappend Trace [expr $mY+$w*$PerY]
lappend Trace [expr $mX+$f*$PerX]
lappend Trace [expr $mY+$f*$PerY]
lappend Trace $FinX
lappend Trace $FinY
set PerY $MemoPerY
if {[regexp "left$" $FlatSide]} { set PerY 0 }
lappend Trace [expr $mX-$f*$PerX]
lappend Trace [expr $mY-$f*$PerY]
lappend Trace [expr $mX-$w*$PerX]
lappend Trace [expr $mY-$w*$PerY]
set f [expr $fStart]
set w [expr -$w]
set mX [expr $DebX-$f*$AxeX]
set mY [expr $DebY-$f*$AxeY]
if { ! $GardeS} {
set sX [expr ($DebX+$FinX)/2]
set sY [expr ($DebY+$FinY)/2]
if {[expr ($DebX-$sX)*($DebX-$sX)+($DebY-$sY)*($DebY-$sY)] < \
[expr ($DebX-$mX)*($DebX-$mX)+($DebY-$mY)*($DebY-$mY)]} {
set sX $mX
set sY $mY
}
}
set PerY $MemoPerY
if {[regexp "^left" $FlatSide]} { set PerY 0 }
lappend Trace [expr $sX+$w*$PerX]
lappend Trace [expr $sY+$w*$PerY]
lappend Trace [expr $mX+$w*$PerX]
lappend Trace [expr $mY+$w*$PerY]
lappend Trace [expr $mX+$f*$PerX]
lappend Trace [expr $mY+$f*$PerY]
lappend Trace $DebX
lappend Trace $DebY
set PerY $MemoPerY
if {[regexp "^right" $FlatSide]} { set PerY 0 }
lappend Trace [expr $mX-$f*$PerX]
lappend Trace [expr $mY-$f*$PerY]
lappend Trace [expr $mX-$w*$PerX]
lappend Trace [expr $mY-$w*$PerY]
lappend Trace [lindex $Trace 0]
lappend Trace [lindex $Trace 1]
return [eval $K create polygon $Trace \
-width $OutLineWidth -fill $Fill -outline $OutLine]
}
proc TestUnCanva {} {
set K [UnCanva 600 400 300 200]
$K configure -background red
$K create rectangle 100 100 200 250 -fill green
set G [Graphe {10 20}]
$G configure -background red
return $K
}
proc UnCanva {{LargeurMaxi ""} {HauteurMaxi ""} {LargeurVoulue ""} {HauteurVoulue ""} {GonfleAussiY ""} {Titre ""} {AvecMainLevee ""} } {
if {$LargeurVoulue==""} { set LargeurVoulue 512 }
if {$HauteurVoulue==""} { set HauteurVoulue [expr ($LargeurVoulue*3)/4] }
if {$LargeurMaxi==""} { set LargeurMaxi 512 }
if {$HauteurMaxi==""} { set HauteurMaxi [expr ($LargeurMaxi*3)/4] }
if {$GonfleAussiY==""} { set GonfleAussiY "GonfleAussiY" }
Espionne "$LargeurMaxi $HauteurMaxi $LargeurVoulue $HauteurVoulue"
global ScrollRectangleOriginal IdScrollRectangle
global CouleurDuFondDeUnCanva
if { ! [info exists CouleurDuFondDeUnCanva]} {
set CouleurDuFondDeUnCanva "white"
}
if {[regexp "MainLevee" $AvecMainLevee]} { set AvecMainLevee 1 } else { set AvecMainLevee 0 }
if {$GonfleAussiY=="NoY"} {
set GonfleY 1.0
set DegonfleY 1.0
} else {
set GonfleY "gonfle"
set DegonfleY "degonfle"
}
set w [NomDe canva]
if {$Titre==""} { set Titre $w }
catch {destroy $w}
toplevel $w
wm title $w $Titre
wm iconname $w $Titre
set CanvaScroMinX 0
set CanvaScroMinY 0
set CanvaScroMaxX $LargeurMaxi
set CanvaScroMaxY $HauteurMaxi
set K $w.canvas
set ScroHor $w.hscroll
set ScroVer $w.vscroll
set KShSv $w.grid
set Boutons $w.buttons
frame $Boutons
pack $Boutons -side bottom -fill x -pady 2m
button $Boutons.dismiss -text "Dismiss" -background "red" -command "destroy $w"
bind $Boutons.dismiss "MainLeveeSurUnCanva $K"
bind $Boutons.dismiss "FaireLire \[$KShSv configure\]"
pack $Boutons.dismiss -side left -expand 1
button $Boutons.postscript -text "Zoom/UnZoom/Reset\nPNG/Postscript/Print\nFull PNG/Postscript/Print" -background "yellow"
if { ! [string equal -nocase "NoZoom" $GonfleAussiY]} {
bind $Boutons.postscript <1> "Gonfle $w all gonfle $GonfleY"
bind $Boutons.postscript <2> "Gonfle $w all degonfle $DegonfleY"
bind $Boutons.postscript <3> "Gonfle $w all reset reset"
}
bind $Boutons.postscript "CanvaEnPNG $K Visible"
bind $Boutons.postscript "CanvaEnPostscript $K Visible AskForFile"
bind $Boutons.postscript "CanvaEnImpression $K Visible"
bind $Boutons.postscript "CanvaEnPNG $K OnVeutTout"
bind $Boutons.postscript "CanvaEnPostscript $K OnVeutTout AskForFile"
bind $Boutons.postscript "CanvaEnImpression $K OnVeutTout"
pack $Boutons.postscript -side left -expand 1
button $Boutons.jpg -text "Create Jpg file" -background "yellow"
bind $Boutons.jpg <1> "CanvaEnJpg $K \[FichierPourSaveAs\]"
pack $Boutons.jpg -side left -expand 1
frame $KShSv
scrollbar $ScroHor -orient horiz -command "$K xview"
scrollbar $ScroVer -command "$K yview"
canvas $K \
-width $LargeurVoulue \
-height $HauteurVoulue
Espionne "$LargeurVoulue $HauteurVoulue"
$K configure \
-scrollregion [list $CanvaScroMinX $CanvaScroMinY $CanvaScroMaxX $CanvaScroMaxY] \
-xscrollcommand "$ScroHor set" \
-yscrollcommand "$ScroVer set" \
-background $CouleurDuFondDeUnCanva
set IdScrollRectangle($K) [$K create rect $CanvaScroMinX $CanvaScroMinY $CanvaScroMaxX $CanvaScroMaxY \
-tags [list "Cadre"] -outline $CouleurDuFondDeUnCanva]
set ScrollRectangleOriginal($K) "[$K coords [set IdScrollRectangle($K)]]"
grid rowconfig $KShSv 0 -weight 1 -minsize 0
grid columnconfig $KShSv 0 -weight 1 -minsize 0
grid $K -in $KShSv -padx 1 -pady 1 -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky nsew
grid $ScroVer -in $KShSv -padx 1 -pady 1 -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky nsew
grid $ScroHor -in $KShSv -padx 1 -pady 1 -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky nsew
pack $KShSv -expand yes -fill both -padx 1 -pady 1
if {$AvecMainLevee} { MainLeveeSurUnCanva $K }
return $K
}
proc Gonfle {w Tag {ScaleX "gonfle"} {ScaleY 1.0}} {
global ScaleCumuleDeGonfle OrigXCumuleDeGonfle OrigYCumuleDeGonfle
global ScrollRectangleOriginal IdScrollRectangle
Gs "UpdateK"
if {[regexp "rond" $w]} {
FaireLire "Sorry, the Zoom doesn't work for Rosace."
return
}
set K $w.canvas
set ScroHor $w.hscroll
set ScroVer $w.vscroll
scan "[$ScroHor get]" "%f %f" g d
scan "[$ScroVer get]" "%f %f" b h
set RatioHor [expr ($g + $d)/2]
set RatioVer [expr ($b + $h)/2]
scan [$K cget -scrollregion] "%f %f %f %f" xMin yMin xMax yMax
set CentreHor [expr $xMin + $RatioHor*($xMax-$xMin)]
set CentreVer [expr $yMin + $RatioVer*($yMax-$yMin)]
if {[regexp "expo" $K]} {
set CentreHor 0
set CentreVer 0
}
if {[PourWscope]} {
set ScaleGonfle 2.0
} else {
set ScaleGonfle 1.1
}
if { $ScaleY == "gonfle" } {
set Scaley $ScaleGonfle
}
if { $ScaleY == "degonfle" } {
set Scaley [expr 1./$ScaleGonfle]
}
if { $ScaleX == "gonfle" } {
set Scalex $ScaleGonfle
set Scaley 1.0
} else {
set Scalex $ScaleX
set Scaley 1.0
}
if { $ScaleX == "degonfle" } {
set Scalex [expr 1./$ScaleGonfle]
set Scaley 1.0
}
if { $ScaleY != "1.0"} {
set Scaley $ScaleY
}
if { $ScaleY == "gonfle" } {
set Scaley $ScaleGonfle
}
if { $ScaleY == "degonfle" } {
set Scaley [expr 1./$ScaleGonfle]
}
if { $ScaleX == "reset" } {
scan [$K coords [set IdScrollRectangle($K)]] "%f %f %f %f" xMin yMin xMax yMax
scan [set ScrollRectangleOriginal($K)] "%f %f %f %f" xMinO yMinO xMaxO yMaxO
set Scalex [expr ($xMaxO-$xMinO)*1.0/($xMax-$xMin)]
set Scaley [expr ($yMaxO-$yMinO)*1.0/($yMax-$yMin)]
}
$K scale $Tag $CentreHor $CentreVer $Scalex $Scaley
$K configure -scrollregion [$K coords [set IdScrollRectangle($K)]]
return $K
}
proc ListeSansDoublon {Liste {NoCase ""} {NoEmpty ""}} {
set NoEmpty [string equal -nocase $NoEmpty "NoEmpty"]
set NoCase [string equal -nocase $NoCase "NoCase"]
set SansDoublon {}
set I -1
foreach Element $Liste {
if {$NoEmpty && [string trim $Element]==""} { continue }
set ELEMENT $Element
if {$NoCase} { set ELEMENT [string toupper $Element] }
if { [info exists DejaVu($ELEMENT)] } {
set Ancien $DejaVu($ELEMENT)
if {[regexp {[a-z]} $Element]} { set SansDoublon [lreplace $SansDoublon $Ancien $Ancien $Element] }
continue
}
set DejaVu($ELEMENT) [incr I]
lappend SansDoublon $Element
}
return $SansDoublon
}
proc QuiJAppelRecursif Procedure {
global DejaVuCetteProcedure
global Tabulation
if { ! [info exists Tabulation]} { set Tabulation "" }
set LesAppelees [QuiJAppel $Procedure "LaListeMerci"]
if {$LesAppelees == {}} { return }
foreach Appelee $LesAppelees {
if {[info exists DejaVuCetteProcedure($Appelee)]} { continue }
Espionne "$Tabulation $Appelee"
set DejaVuCetteProcedure($Appelee) 1
set Tabulation "$Tabulation "
QuiJAppelRecursif $Appelee
set Tabulation [string range $Tabulation 4 end]
}
}
proc TestNousAllonsAuBoulot {} {
Espionne on demarre en [pwd]
OnRevientDuBoulot ; #si on n'y était pas ca marche quand meme
Espionne [pwd]
NousAllonsAuBoulot /home/ripp
Espionne 1 [pwd]
NousAllonsAuBoulot /genomics
Espionne 22 [pwd]
OnRevientDuBoulot
Espionne 1 [pwd]
NousAllonsAuBoulot
Espionne 22 [pwd]
NousAllonsAuBoulot /usr/local
Espionne 333 [pwd]
OnRevientDuBoulot
Espionne 22 [pwd]
OnRevientDuBoulot
Espionne 1 [pwd]
OnRevientDuBoulot
Espionne [pwd]
}
proc OnRevientDuBoulot {} {
return [NousAllonsAuBoulot "DepileRep"]
}
proc NousAllonsAuBoulot {{RepTrav ""}} {
global MemorisePWD
#rR depuis 20200120 j'empile les pwd et j'ai mis DepileRep ici
if {$RepTrav==""} { set RepTrav [RepertoireDeTravail] }
if { ! [info exists MemorisePWD]} { set MemorisePWD {} }
if {$RepTrav=="DepileRep"} {
set RepPrecedent [lindex $MemorisePWD end]
set MemorisePWD [lrange $MemorisePWD 0 end-1]
if {$RepPrecedent!=""} { cd $RepPrecedent }
return $RepPrecedent
}
#rR il se peut qu'il n'y ait pas de wd
if {[catch {set PWD [pwd]}]} { set PWD $RepTrav }
lappend MemorisePWD $PWD
cd $RepTrav
return $RepTrav
}
proc RetourneLaListe Liste {
#lM change le 18/05/2009
#lM utilise lreverse (tcl 8.5)
return [lreverse $Liste]
if {[llength $Liste] < 2} { return $Liste }
set X [lindex $Liste 0]
set ResteRetourne [RetourneLaListe [lrange $Liste 1 end]]
return [lappend ResteRetourne $X]
}
proc ButineEtAjoute Texte {
set NouveauTexte [ContenuDuFichier [ButineArborescence All]]
if { $NouveauTexte != "" } {
$Texte insert end $NouveauTexte
}
}
proc ButineEtRemplace Texte {
set NouveauTexte [ContenuDuFichier [ButineArborescence All]]
if { $NouveauTexte != "" } {
$Texte delete 0.0 end
$Texte insert end $NouveauTexte
}
}
proc ButineArborescence {{Type ""} {RepertoireEtFichier ""}} {
global RepertoireInitialDeButine
global FichierInitialDeButine
if {$Type==""} { set Type "All" }
global OuiOuNonToujoursParDefaut
if {[info exists OuiOuNonToujoursParDefaut] && $OuiOuNonToujoursParDefaut} {
if {[file exists $RepertoireEtFichier]} { return $RepertoireEtFichier }
}
if {[regexp {/$} $RepertoireEtFichier]} {
regsub {/$} $RepertoireEtFichier "" Rep
set Fic ""
} else {
set Rep [file dirname $RepertoireEtFichier]
set Fic [file tail $RepertoireEtFichier]
}
if {$Rep!=""} {
set RepertoireInitialDeButine $Rep
}
if {$Fic!=""} {
set FichierInitialDeButine $Fic
}
if { ! [info exists RepertoireInitialDeButine]} { set RepertoireInitialDeButine [pwd] }
if { ! [info exists FichierInitialDeButine]} { set FichierInitialDeButine "" }
set Types(All) {
{{All files} * }
}
set Types(MSF) {
{{Alignment output} {.msf}}
{{All files} * }
}
set Types(Blastp) {
{{Blast output} {.blastp}}
{{All files} * }
}
set Types(FOF) {
{{File Of Filenames} {.fof}}
{{All files} * }
}
set Types(ps) {
{{Postcript file} {.ps}}
{{All files} * }
}
set Types(Sequence) {
{{All files} * }
{{Raw} {.seq}}
{{Fasta} {.tfa}}
{{GCG} {.ged}}
}
set NomDeFichier [tk_getOpenFile -title "Fichier a ouvrir" \
-initialdir $RepertoireInitialDeButine \
-initialfile $FichierInitialDeButine \
-defaultextension "" \
-filetypes $Types($Type)]
if { $NomDeFichier == "" } { return ""}
set RepertoireInitialDeButine [file dirname $NomDeFichier]
return $NomDeFichier
}
proc JunkDir {{JunkDir ""}} {
return [RepertoireDeTravail $JunkDir]
}
proc RepertoireDeTravail {{JunkDir ""}} {
global RepertoireDeTravail
global env
if {[info exists RepertoireDeTravail]} { return $RepertoireDeTravail }
if {$JunkDir == ""} {
if {[PourWscope]} {
set JunkDir "[HomeRipp]/junkdir"
} else {
if {[info exists env(HOME)]} {
set JunkDir "$env(HOME)/junkdir"
} else {
#rR set JunkDir "/tmp/tmp[pid]"
set JunkDir "[HomeRipp]/junkdir"
}
}
}
if {[file isdirectory $JunkDir]} {
set RepertoireDeTravail $JunkDir
return $RepertoireDeTravail
}
#rR on ne pose plus la question !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2021/03/12
if { 1 || [OuiOuNon "Can I create a Working directory\n$JunkDir\n ?"]} {
File mkdir $JunkDir
set RepertoireDeTravail $JunkDir
return $RepertoireDeTravail
}
if {[OuiOuNon "Do You want to choose an other Working directory ?"]} {
set AutreJunkDir [Entre [pwd]]
} else {
set AutreJunkDir ""
}
set RepertoireDeTravail [RepertoireDeTravail $AutreJunkDir]
return $RepertoireDeTravail
}
proc CanvaEnImpression {K CeQuOnVeut} {
set NomDuFichierPS [CanvaEnPostscript $K $CeQuOnVeut "[RepertoireDeTravail]/tmp[NomDe ""].ps"]
if {$NomDuFichierPS==""} { return }
return [ImprimeLeFichier $NomDuFichierPS]
}
proc CanvaEnPostscript {K {CeQuOnVeut "Visible"} {QuoiRetourner "RetourOrdres"} {Anchor "center"}} {
Gs "File"
if { $QuoiRetourner == "AskForFile" || $QuoiRetourner=="" } {
set NomDuFichierPS [FichierPourSaveAs]
if {$NomDuFichierPS==""} { return "" }
} else {
set NomDuFichierPS $QuoiRetourner
}
set Largeur [lindex [$K configure -width] 4]
set Hauteur [lindex [$K configure -height] 4]
set PortraitOuLandscape [expr $Largeur > $Hauteur]
if {[regexp "rond" $K]} {
set OptionWH "-width 768 -x 0"
} else {
if {$CeQuOnVeut=="Visible"} {
set OptionWH ""
} else {
# scan [lindex [$K configure -scrollregion] 4] "%f %f %f %f" minX minY maxX maxY
scan [$K bbox all] "%d %d %d %d" minX minY maxX maxY
set OptionWH "-width $maxX -height $maxY"
}
}
if {$QuoiRetourner=="RetourOrdres"} {
set Retour [eval $K postscript $OptionWH -rotate $PortraitOuLandscape]
} else {
eval $K postscript -file $NomDuFichierPS $OptionWH -rotate $PortraitOuLandscape
set Retour $NomDuFichierPS
}
return $Retour
}
proc CanvaEnPostscriptPourGif {K {CeQuOnVeut "Visible"}} {
return [CanvaEnPostscript $K $CeQuOnVeut "RetourOrdres"]
}
proc OldCanvaEnPostscriptPourGif {K {CeQuOnVeut "Visible"}} {
set Largeur [lindex [$K configure -width] 4]
set Hauteur [lindex [$K configure -height] 4]
set PortraitOuLandscape [expr $Largeur > $Hauteur]
set lePostscript ""
if {[regexp "rond" $K]} {
set lePostscript [$K postscript -width 768 -x 0 -rotate $PortraitOuLandscape]
} else {
if {$CeQuOnVeut=="Visible"} {
set lePostscript [$K postscript -rotate $PortraitOuLandscape]
} else {
Espionne [$K configure -scrollregion]
scan [lindex [$K configure -scrollregion] 4] "%f %f %f %f" minX minY maxX maxY
Espionne "$minX $minY $maxX $maxY"
set lePostscript [$K postscript -width $maxX -height $maxY -rotate $PortraitOuLandscape]
}
}
return $lePostscript
}
proc OldCanvaEnGIF {K {CeQuOnVeut ""} {NomDuFichierGIF ""}} {
if {$NomDuFichierGIF==""} {
set NomDuFichierGIF [FichierPourSaveAs]
}
if {$NomDuFichierGIF==""} { return "" }
Wup "On cree un fichier avec les ordres du canva K"
return [CreeLesOrdresPourGIF $K $CeQuOnVeut $NomDuFichierGIF]
}
proc CanvaEnGIF {K {CeQuOnVeut ""} {NomDuFichierGIF ""}} {
Gs "File"
if {$NomDuFichierGIF=="" || $NomDuFichierGIF=="AskForFile"} {
set NomDuFichierGIF [FichierPourSaveAs]
}
if {$NomDuFichierGIF==""} { return "" }
Wup "On cree un fichier avec les ordres du canva K"
set lePostscript [CanvaEnPostscript $K $CeQuOnVeut "RetourOrdres" "w"]
Sauve $lePostscript dans lePostscript.ps
image create photo laPhoto -data $lePostscript -format [list postscript "-zoom 5 5"]
laPhoto write $NomDuFichierGIF -format gif
return $NomDuFichierGIF
}
proc CanvaEnJpg {K {NomDuFichierJpg ""}} {
Gs "File"
package require Img
if {$NomDuFichierJpg=="" || $NomDuFichierJpg=="AskForFile"} {
set NomDuFichierJpg [FichierPourSaveAs]
}
if {$NomDuFichierJpg==""} { return "" }
set IdImage [image create photo -format window -data $K]
$IdImage write $NomDuFichierJpg -format jpeg
return $NomDuFichierJpg
}
proc CanvaEnPNG {K {CeQuOnVeut ""} {NomDuFichierPNG ""}} {
Gs "File"
#rR on prend le PrintCanvas de Luc
if {$CeQuOnVeut=="OnVeutTout"} {
package require Img
return [PrintCanvasFromLuc $K "" $NomDuFichierPNG]
}
Wup "Ca merde un peu ... refaire ce qu'il y a dans CanvaEnJpg. Ici il cree toujours une page A4 ..."
if {$NomDuFichierPNG=="" || $NomDuFichierPNG=="AskForFile"} {
set NomDuFichierPNG [FichierPourSaveAs]
}
if {$NomDuFichierPNG==""} { return "" }
Wup "On cree un fichier avec les ordres du canva K"
# set lePostscript [CanvaEnPostscript $K $CeQuOnVeut "RetourOrdres" "w"]
set lePostscript [$K postscript]
Sauve $lePostscript dans $NomDuFichierPNG.ps
if {1} {
exec gs -sDEVICE=png256 -sOutputFile=$NomDuFichierPNG -q -dNOPAUSE -dBATCH $NomDuFichierPNG.ps
# set PR [image create photo -file $NomDuFichierPNG]
# $K create image 400 400 -image $PR
return
}
laPhoto write $NomDuFichierPNG -format gif
return $NomDuFichierGIF
}
proc PrintCanvasFromLuc {canvas {format ""} {imageFile ""}} {
if {$format eq ""} { set format "png" }
if {$imageFile eq ""} {
set imageFile [DemandeEtSauveFichier $format]
if {$imageFile eq ""} {return}
}
update idletasks
after 500
## Ensure that the window is on top of everything
## else, so as not to get white ranges
## in the image, due to overlapped portions
## of the window with
## other windows...
raise [winfo toplevel $canvas]
update
set border [expr {[$canvas cget -borderwidth]+[$canvas cget -highlightthickness]}]
set view_height [expr {[winfo height $canvas]-2*$border}]
set view_width [expr {[winfo width $canvas]-2*$border}]
lassign [$canvas bbox all] x1 y1 x2 y2
set x1 [expr {int($x1-10)}]
set y1 [expr {int($y1-10)}]
set x2 [expr {int($x2+10)}]
set y2 [expr {int($y2+10)}]
set width [expr {$x2-$x1}]
set height [expr {$y2-$y1}]
set image [image create photo \
-height $height -width $width]
## Arrange the scrollregion of the canvas
## to get the whole window visible,
## so as to grab it into an image...
set scrollregion [$canvas cget -scrollregion]
set xscrollcommand [$canvas cget -xscrollcommand]
set yscrollcommand [$canvas cget -yscrollcommand]
$canvas configure -xscrollcommand {}
$canvas configure -yscrollcommand {}
set grabbed_x $x1
set grabbed_y $y1
set image_x 0
set image_y 0
while {$grabbed_y < $y2} {
while {$grabbed_x < $x2} {
$canvas configure -scrollregion [list $grabbed_x $grabbed_y \
[expr {$grabbed_x+$view_width}] [expr {$grabbed_y+$view_height}]]
update
## Take a screenshot of the visible canvas part...
# image create photo ${image}_tmp -format window -data $canvas
image create photo ${image}_tmp -data $canvas
## Copy the screenshot to the target image...
$image copy ${image}_tmp \
-to $image_x $image_y -from $border $border
incr grabbed_x $view_width
incr image_x $view_width
image delete ${image}_tmp
}
set grabbed_x $x1
set image_x 0
incr grabbed_y $view_height
incr image_y $view_height
}
$canvas configure -scrollregion $scrollregion
$canvas configure -xscrollcommand $xscrollcommand
$canvas configure -yscrollcommand $yscrollcommand
$image write $imageFile -format $format
return $image
}
proc Photo {} {
set K [GscopeBoard coucou]
set lePostscript [CanvaEnPostscript $K "Visible" "RetourOrdres"]
Espionne $lePostscript
image create photo laPhoto -data $lePostscript -format postscript
laPhoto write toto.gif -format gif
exit
}
proc OuiOuNonMemo {Message {ReponseParDefaut ""} {Value 1}} {
global OuiOuNonMemo
if {$Message=="UnsetAllPlease"} {
if {[info exists OuiOuNonMemo]} { unset OuiOuNonMemo }
return 1
}
if {$ReponseParDefaut=="SetItPleaseTo"} {
if {[info exists OuiOuNonMemo($Message)]} {
set OldRep [set OuiOuNonMemo($Message)]
} else {
set OldRep -1
}
set OuiOuNonMemo($Message) $Value
return $OldRep
}
if {$ReponseParDefaut=="UnsetItPlease"} {
if { ! [info exists OuiOuNonMemo($Message)]} { return -1 }
set OldRep [set OuiOuNonMemo($Message)]
unset OuiOuNonMemo($Message)
return $OldRep
}
if {[info exists OuiOuNonMemo($Message)]} { return [set OuiOuNonMemo($Message)] }
set Reponse [OuiOuNon $Message $ReponseParDefaut]
set OuiOuNonMemo($Message) $Reponse
return $Reponse
}
proc OuiOuNonTempo {Message {ReponseParDefaut ""} {Tempo ""}} {
global OuiOuNonToujoursParDefaut
Gs "Rien"
if {$ReponseParDefaut==""} { set ReponseParDefaut 1 }
if {$ReponseParDefaut} {
set IndexReponse 0
} else {
set IndexReponse 1
}
if {[info exists OuiOuNonToujoursParDefaut] && $OuiOuNonToujoursParDefaut} { return $ReponseParDefaut }
set Demandeur ""
catch {set Demandeur [PreFixe]}
if {$Demandeur!=""} { set Demandeur "(for $Demandeur)" }
set R [AfficheVariable "$Demandeur ... please answer within 10 seconds.\n$Message" AvecRetour OuiOuNonTempo]
if {$R==2} {
set L [info level]
set CalledBy ""
for {set L [info level]} {$L>0} {incr L -1} {
lappend LeTexte "$CalledBy [info level $L]"
set CalledBy "called by "
}
FaireLire [join $LeTexte "\n"]
set Reponse [OuiOuNon $Message $ReponseParDefaut]
} else {
set Reponse [expr 1-$R]
}
destroy .ouiounon
return $Reponse
}
proc TestOuiOuNon {} {
set R [OuiOuNon "Je pose une question"]
foreach I [NombresEntre 0 1000000] {
Espionne $I
}
exit
}
proc OuiOuNon {Message {ReponseParDefaut ""} {Force ""}} {
global OuiOuNonToujoursParDefaut
Gs "Rien"
set Force [regexp -nocase "1|Force" $Force]
if {$ReponseParDefaut==""} { set ReponseParDefaut 1 }
if {$ReponseParDefaut} {
set IndexReponse 0
} else {
set IndexReponse 1
}
if { ! $Force && [info exists OuiOuNonToujoursParDefaut] && $OuiOuNonToujoursParDefaut} { return $ReponseParDefaut }
set Demandeur ""
catch {set Demandeur [PreFixe]}
if {$Demandeur!=""} { set Demandeur "(for $Demandeur)" }
package require Tk
after idle {.ouiounon.msg configure -wraplength 10i -foreground white -background red}
set R [tk_dialog .ouiounon "$Demandeur Please press Yes or No" "$Message" {} $IndexReponse "Yes" "No" "?"]
if {$R==2} {
set L [info level]
set CalledBy ""
for {set L [info level]} {$L>=0} {incr L -1} {
lappend LeTexte "$CalledBy [info level $L]"
set CalledBy "called by "
}
FaireLire [join $LeTexte "\n"]
set Reponse [OuiOuNon $Message $ReponseParDefaut $Force]
} else {
set Reponse [expr 1-$R]
}
destroy .ouiounon
update idletasks
return $Reponse
}
proc TestWarne {} {
global WarneEnPuts
set WarneEnPuts 0
set WarneEnPuts 0
Warne salut
Warne "Comment ca va ?"
}
proc Warne Texte {
global WarneWindow
global WarneEnPuts
global WarneNon
if {[info exists WarneNon] && $WarneNon} { return "" }
if { ! [info exists WarneEnPuts]} { set WarneEnPuts 1 }
if { [info exists WarneEnPuts] && $WarneEnPuts } {
puts $Texte
return $Texte
}
# return ""
Wup "La suite est a revoir si Warne dans fenetre"
if { ! [info exists WarneWindow] || ! [winfo exists $WarneWindow]} {
set WarneWindow [AfficheVariable "Warnings..." "" "Warnings"]
wm iconify $WarneWindow
}
$WarneWindow.frame.list insert end $Texte
$WarneWindow.frame.list yview end
update
return $WarneWindow
}
proc Patience Commande {
set w [NomDe fenetre]
toplevel $w
wm title $w "Patience ..."
wm iconname $w "Patience ..."
label $w.msg -text "$Commande \n Ca bosse ... Il faut attendre. "
pack $w.msg
update
return $w
}
proc JeMeSignale {{Etat ""}} {
global FenetreDePatience NiveauFenetreDePatience
global JeMeSignaleInactif
set Commande "\[[info level -1]\]"
if { $Etat == "Get" } { return $Commande }
set CommandeComplete "$Commande $Etat"
if { $Etat == "GetAll" } { return $CommandeComplete }
if { [info exists JeMeSignaleInactif] && $JeMeSignaleInactif } { return }
if { ! [info exists NiveauFenetreDePatience] } {
set NiveauFenetreDePatience 0
}
Warne $CommandeComplete
set Commande [lindex [split $CommandeComplete " "] 0]
if { $Etat == "Patience" } {
incr NiveauFenetreDePatience
set FenetreDePatience($NiveauFenetreDePatience) [Patience $Commande]
return [set FenetreDePatience($NiveauFenetreDePatience)]
}
if { $Etat == "FinPatience" } {
Warne [set FenetreDePatience($NiveauFenetreDePatience)]
destroy [set FenetreDePatience($NiveauFenetreDePatience)]
incr NiveauFenetreDePatience -1
update
return ""
}
return ""
}
proc TriDeFichiers {A B} {
set DA [file dirname $A]
set DB [file dirname $B]
if {$DA<$DB} { return -1 }
if {$DA>$DB} { return 1 }
return [string compare [file tail $A] [file tail $B]]
}
proc ReSource {{Fichier ""}} {
global ReSource
if {$Fichier=="Precedent"} {
if {[info exists ReSource]} {
set Fichier $ReSource
} else {
set Fichier ""
}
}
if {$Fichier==""} {
set LesSourcesTcl {}
foreach F [lsort -command TriDeFichiers [LesSourcesDuProgramme "Absolute"]] {
if { ! [regexp ".tcl$" $F]} { continue }
lappend LesSourcesTcl $F
}
set Fichier [ChoixParmi $LesSourcesTcl]
if {$Fichier==""} { set ReSource "" ; return "" }
}
if {[FileAbsent $Fichier] && [FileExists [set Possible "[ProgSourceDir]/$Fichier"]]} { set Fichier $Possible }
if {[FileAbsent $Fichier] && [FileExists [set Possible "[ProgSourceDir]/$Fichier.tcl"]]} { set Fichier $Possible }
if {[FileAbsent $Fichier] && [FileExists [set Possible "[ProgSourceDir]/gscope_$Fichier.tcl"]]} { set Fichier $Possible }
if {[FileAbsent $Fichier]} {
FaireLire "$Fichier doesn't exist"
set ReSource ""
return ""
}
set ReSource $Fichier
source $Fichier
return $Fichier
}
proc DemandeEtExecute {{Commande ""}} {
global RepertoireDuGenome
global GscopeDir
FaireLire "Please write your instructions on the interactiv terminal window. To finish type 'return'."
set Commande ""
while {1} {
puts -nonewline stdout "Gscope_: "
flush stdout
set Ligne [gets stdin]
if {$Commande==""} {
set Commande $Ligne
} else {
append Commande "\n$Ligne"
}
if {[info complete $Commande]} {
if {[regexp {^ *(return|stop) *$} $Commande]} {
puts "Thanks for discussion. I close interaction. Bye bye !"
return
}
if {[catch {eval $Commande} Message]} {
puts $Message
}
set Commande ""
}
}
}
proc CompleteEtExecute Commande {
regsub { +\{ *$} $Commande "" Commande
Espionne ">$Commande<"
if {[regexp -nocase {[a-z0-9_]+ +\{\}} $Commande]} {
scan $Commande "%s" Complete
} else {
set Complete [Entre $Commande]
}
if {$Complete==""} { return "" }
return [Execute $Complete]
}
proc Execute Commande {
return [eval $Commande]
}
proc Entre {{Defo ""}} {
global RetourEntre
global EntreToujoursDefaut
if {[info exists EntreToujoursDefaut] && $EntreToujoursDefaut} { return $Defo }
set w [NomDe fenetre]
toplevel $w
wm title $w "To validate or "
wm iconname $w ""
wm geometry $w +300+300
entry $w.e -width 80 -borderwidth 10 -background red -foreground white -font {Courier 14}
if { $Defo != "" } { $w.e insert 0 $Defo }
pack $w.e -expand 1 -fill x
focus $w.e
bind $w.e "set RetourEntre($w) \[$w.e get\]"
bind $w.e "set RetourEntre($w) \[$w.e get\]"
tkwait variable RetourEntre($w)
destroy $w
set Retour [set RetourEntre($w)]
unset RetourEntre($w)
return $Retour
}
proc EditeEtCreeFichier {{Fichier ""} {Defo ""} {Ask ""}} {
set Texte [EntreTexte $Defo]
if {$Texte==""} { return "" }
if {$Texte=="\n"} {
if {[OuiOuNon "Do I cancel EditeEtCreeFichier ?"]} { return "" }
if {[OuiOuNon "Do I save as an empty string (without \\n) ?"]} { set Texte "" }
}
if {$Fichier=="" || $Ask!=""} { set Fichier [FichierPourSaveAs $Fichier] }
if {$Fichier==""} { return "" }
return [Sauve $Texte dans $Fichier]
}
proc LocaText {t {Action ""}} {
global LocaText
if {$Action==""} { set Action "Next" }
if {$Action=="Top"} {
if { ! [info exists LocaText($t,Start)]} { unset LocaText($t,Start) }
set Action "Next"
}
if {$Action=="New"} {
if {[info exists LocaText($t,Text)]} { unset LocaText($t,Text) }
if { ! [info exists LocaText($t,Start)]} { unset LocaText($t,Start) }
}
if { ! [info exists LocaText($t,Text)]} {
set Texte [Entre]
set LocaText($t,Text) $Texte
}
if { ! [info exists LocaText($t,Start)]} { set LocaText($t,Start) 1.0 }
set Index [$t search $LocaText($t,Text) $LocaText($t,Start)]
if {$Index == ""} { return "" }
set Fin [expr $Index + 0.[string length $LocaText($t,Text)]]
$t tag configure Spot -background red
$t tag remove Spot 1.0 end
$t tag add Spot $Index $Fin
set LocaText($t,Start) [expr $Index + 0.1]
return $Index
}
proc EntreTexte {{Defo ""} {BoutonsEnPlus ""} {FichierOriginePourInforme ""}} {
global RetourEntreTexte
global FenetreInfoOuverte
global PolicePourEntreTexte
if {[PourWscope]} {
set Maniere $BoutonsEnPlus
return [AfficheVariable $Defo $Maniere $FichierOriginePourInforme]
}
set w [NomDe fenetre]
toplevel $w
wm title $w "You can edit this text ... "
wm iconname $w "Edit"
set LesLignesDuTexte [split $Defo "\n"]
set PremiereLigne [lindex $LesLignesDuTexte 0]
if {[regexp {^Nom\: } $PremiereLigne]} {
scan $PremiereLigne "%s %s" Bidon Nom
set FenetreInfoOuverte($Nom) $w
}
set Hauteur [Maxi 10 [Mini 30 [llength $LesLignesDuTexte]]]
set Largeur 80
foreach Ligne $LesLignesDuTexte {
set Largeur [Maxi $Largeur [string length $Ligne]]
}
set Largeur [Mini $Largeur 180]
set Police 12
if {[info exists PolicePourEntretexte]} { set Police $PolicePourEntreTexte }
text $w.text -wrap none -relief sunken -bd 2 \
-font [list Courier $Police] \
-xscrollcommand "$w.xscroll set" \
-yscrollcommand "$w.yscroll set" \
-background "lightgreen" \
-width $Largeur -height $Hauteur
$w.text insert 0.0 $Defo
focus $w.text
frame $w.buttons
pack $w.buttons -side bottom -fill x -pady 2m
button $w.buttons.dismiss -background red -text "Dismiss"
bind $w.buttons.dismiss <1> "set RetourEntreTexte($w) \"\""
pack $w.buttons.dismiss -side left -expand 1
button $w.buttons.saveas -text "Save All/ Sel."
bind $w.buttons.saveas <1> "SaveAs \[$w.text get 1.0 end\]"
bind $w.buttons.saveas <2> "SaveAs \[$w.text get sel.first sel.last\]"
pack $w.buttons.saveas -side left -expand 1
button $w.buttons.search -text "Next/Top/New" -background yellow -foreground black
bind $w.buttons.search <1> "LocaText $w.text Next"
bind $w.buttons.search <2> "LocaText $w.text Top"
bind $w.buttons.search <3> "LocaText $w.text New"
pack $w.buttons.search -side left -expand 1
button $w.buttons.aspect -text "Font"
bind $w.buttons.aspect <1> "PolicePourEntreTexte Ask $w"
pack $w.buttons.aspect -side left -expand 1
button $w.buttons.browse -text "Replace/Append/Choose\n(with other file)"
bind $w.buttons.browse <1> "ButineEtRemplace $w.text"
bind $w.buttons.browse <2> "ButineEtAjoute $w.text"
bind $w.buttons.browse <3> "ChoisiEtAjouteChampsInfo $w.text"
pack $w.buttons.browse -side left -expand 1
button $w.buttons.accept -text "Accept All / Selection" -background green -foreground black
bind $w.buttons.accept <1> "set RetourEntreTexte($w) \[$w.text get 1.0 end\]"
bind $w.buttons.accept <2> "set RetourEntreTexte($w) \[$w.text get sel.first sel.last\]"
pack $w.buttons.accept -side left -expand 1
if {$BoutonsEnPlus!=""} {
set I 0
foreach {T C} $BoutonsEnPlus {
incr I
button $w.buttons.plus$I -text $T -background orange -foreground black
bind $w.buttons.plus$I <1> $C
pack $w.buttons.plus$I -side left -expand 1
}
}
scrollbar $w.xscroll -command "$w.text xview" -orient "horizontal"
pack $w.xscroll -side bottom -fill x
scrollbar $w.yscroll -command "$w.text yview"
pack $w.yscroll -side right -fill y
pack $w.text -expand yes -fill both
tkwait variable RetourEntreTexte($w)
if {[info exists RetourEntreTexte($w)]} {
set Retour [set RetourEntreTexte($w)]
unset RetourEntreTexte($w)
} else {
set Retour ""
}
destroy $w
regsub {\n$} $Retour "" Retour
return $Retour
}
proc FaireLire {Message {Force ""} {Affiche "no"}} {
global FaireLireNon
global FaireLireSurEspionne
#lm for debugging purposes
if {$Affiche ne "no" || ([info exists FaireLireSurEspionne] && $FaireLireSurEspionne)} {
Espionne "\n-------- FaireLire ----------"
Espionne "| $Message"
Espionne "\n"
flush stdout
}
if {[info commands "PourWscope"]!={} && [info commands "OnTraite"]!={} && \
[PourWscope] && [OnTraite "RetGene"]} { return [AfficheVariable $Message] }
set Force [regexp -nocase "1|Force" $Force]
if { ! $Force && [info exists FaireLireNon] && $FaireLireNon} { return }
if {[string length $Message] > 1500} {
set Message "[string range $Message 0 499]\n ... \n ... [string range $Message end-499 end]"
}
package require Tk
#rR 2014/08/13 rajout de NomDe
set FL [NomDe faireLire]
#lm pour pouvoir changer la fonte
if {"FaireLireFonte" ni [font names]} {
font create FaireLireFonte -family Helvetica -size 12
}
after idle [list $FL.msg configure -wraplength 10i -foreground white -background red -font FaireLireFonte]
tk_dialog $FL "Please press OK" "$Message" {} 0 Acknowledge
catch {destroy $FL}
update
}
proc BoutonneLaFenetre {Fenetre Texte {Commande ""}} {
set NdB [NomDe bouton]
if {$Commande==""} {
button $Fenetre.buttons$NdB -text $Texte
} else {
button $Fenetre.buttons$NdB -text $Texte -command $Commande
}
pack $Fenetre.buttons$NdB -side right -expand 1
return "$Fenetre.buttons$NdB"
}
proc NomDe Machin {
global NumeroDe
if { ! [info exists NumeroDe] } {set NumeroDe 0000}
incr NumeroDe
return ".$Machin$NumeroDe"
}
proc TestTmpFile {} {
set F1 "[TmpFile RRR ~ "" WithDateAndUniqueRoot]_F1"
Sauve xxx dans $F1
set F2 "[TmpFile RRR ~ "" WithDateAndUniqueRoot]_F2"
Sauve xxx dans $F2
exit
}
proc TmpFile {{Racine ""} {Rep ""} {Sep ""} {WithDate ""}} {
#biotcl tmpFile {}
global TmpFileNumber
if {[regexp -nocase "Date" $Sep]} { set WithDate $Sep ; set Sep "" }
set TestUniqueRoot [regexp -nocase "UniqueRoot" $WithDate]
set WithDate [regexp -nocase "WithDate" $WithDate]
if {$Rep=="envTEMP"} {
global env
if {[info exists env(TEMP)]} {
set Rep [set env(TEMP)]
} else {
set Rep ""
}
}
set MemoSep $Sep
if {$Sep==""} { set Sep "." }
if {[regexp "NoSep" $Sep]} { set Sep "" }
if {$Rep==""} { set Rep [RepertoireDeTravail] }
regsub -all {/*$} $Rep "" Rep
if { ! [info exists TmpFileNumber]} { set TmpFileNumber 0 }
if {$Racine==""} { set Racine "tmp" }
if {$WithDate} {
set Date [Date "Seconds"]
set TmpFileName "$Rep/$Racine$Sep$Date"
if {$TestUniqueRoot && [glob -nocomplain "$TmpFileName*"]!={}} {
after 1000
return [TmpFile $Racine $Rep $MemoSep "WithDateAndUniqueRoot"]
}
return $TmpFileName
}
set Pid [pid]
incr TmpFileNumber
set TmpFileName "$Rep/$Racine$Sep$Pid$Sep$TmpFileNumber"
return $TmpFileName
}
proc Focalise {Fenetre {Action ""}} {
global MotFocalise
global PositionFocalise
if {$Action=="ask"} { if {[info exists MotFocalise]} { unset MotFocalise } }
if {$Action=="top"} { set PositionFocalise -1 }
if { ! [info exists MotFocalise] } {
set MotFocalise [Entre ""]
if {$MotFocalise==""} { return }
set PositionFocalise -1
}
incr PositionFocalise
set FenetreListBox $Fenetre.frame.list
foreach Ligne [$FenetreListBox get $PositionFocalise end] {
if { [regexp -nocase $MotFocalise $Ligne] } {
$FenetreListBox yview $PositionFocalise
$FenetreListBox selection set $PositionFocalise
return
}
incr PositionFocalise
}
set PositionFocalise -1
}
proc EraseLeCanva {K {ListeDeTags ""} {Demander ""}} {
if {$Demander==""} { set Demander 0 }
if {$ListeDeTags==""} {
set ListeDeTags [list "all"]
if {[OuiOuNon "Do I erase ALL widgets ?"]} {
set Demander 0
} elseif {[OuiOuNon "Do I ask for each widget ?"]} {
set Demander 1
}
}
set IdCadre [$K find withtag "Cadre"]
foreach Tag $ListeDeTags {
set LesIds [$K find withtag $Tag]
foreach Id $LesIds {
if {$Id==$IdCadre} { continue }
set Type [$K type $Id]
if {$Demander && ! [OuiOuNon "Erase $Type ?"]} {
continue
}
$K delete $Id
}
}
return $K
}
proc RestaureLeCanva {K {ListeOuFichier {}}} {
if {[llength $ListeOuFichier] > 1} {
set LesCommandesDeCreation $ListeOuFichier
} else {
if {[llength $ListeOuFichier] == 1} {
set Fichier $ListeOuFichier
} else {
set Fichier [ButineArborescence]
if {$Fichier == ""} { return "" }
}
set LesCommandesDeCreation [LesLignesDuFichier $Fichier]
}
foreach CommandeDeCreation $LesCommandesDeCreation {
eval $K $CommandeDeCreation
}
return $K
}
proc SauveLeCanva {K ListeDeTags {Fichier ""}} {
Wup "Retourne le nom du fichier de sauvegarde. String vide si rien n'est sauve."
set LesCommandesDeCreation {}
foreach Tag $ListeDeTags {
set LesIds [$K find withtag $Tag]
foreach Id $LesIds {
if {[info exists DejaVu($Id)]} { continue }
set DejaVu($Id) 1
set CommandeDeCreation "create [$K type $Id] [join [$K coords $Id] " "] "
Espionne "[$K itemconfigure $Id]"
foreach Option [$K itemconfigure $Id] {
set NomDOption [lindex $Option 0]
set Valeur [lindex $Option end]
if {$Valeur == ""} { set Valeur "\{\}" }
if {[regexp " " $Valeur]} { set Valeur "\{$Valeur\}" }
append CommandeDeCreation " $NomDOption $Valeur"
}
lappend LesCommandesDeCreation $CommandeDeCreation
}
}
if {$Fichier != ""} {
set Fichier $ListeOuFichier
} else {
set Fichier [FichierPourSaveAs]
if {$Fichier == ""} { return "" }
}
return [SauveLesLignes $LesCommandesDeCreation dans $Fichier]
}
proc Mini {a b} {
#biotcl mini {}
if {$a<$b} { return $a } else { return $b }
}
proc Maxi {a b} {
#biotcl maxi {}
if {$a<$b} { return $b } else { return $a }
}
proc Wup Texte {
}
proc Gs TypeDeRetour {
# Differents types de retour :
# Rien
# Text
# Frame
}
proc File {Commande args} {
Wup "Copyright 1999 Raymond Ripp"
Wup "Tcl8.2 accepts much more 'file' commands then earlier versions"
Wup " I wrote 'File' to try to run with these old versions"
if {[info tclversion] >= 8.2} {
return [eval file $Commande $args]
} else {
set Args $args
if {[regexp -nocase "win" $tcl_platform(os)]} {
if {[lindex $Args 0]=="-force"} {
set Args [lreplace $args 0 0 "/Y"]
}
switch $Commande {
"delete" { set Commande "erase" }
}
} else {
if {[lindex $Args 0]=="-force"} {
set Args [lreplace $args 0 0 "-f"]
}
switch $Commande {
"delete" { set Commande "rm" }
"rename" { set Commande "mv" }
"copy" { set Commande "cp" }
}
}
return [eval exec $Commande $Args]
}
}
proc ComplementString S {
#biotcl complementSequence {}
regsub -all -- "A" $S "Z" S
regsub -all -- "T" $S "A" S
regsub -all -- "Z" $S "T" S
regsub -all -- "G" $S "Z" S
regsub -all -- "C" $S "G" S
regsub -all -- "Z" $S "C" S
regsub -all -- "a" $S "z" S
regsub -all -- "t" $S "a" S
regsub -all -- "z" $S "t" S
regsub -all -- "g" $S "z" S
regsub -all -- "c" $S "g" S
regsub -all -- "z" $S "c" S
return $S
}
proc ReverseString S {
set Reverse ""
for {set i [expr [string length $S]-1]} {$i>=0} {incr i -1} {
append Reverse [string range $S $i $i]
}
return $Reverse
}
proc PremiereLigneDuFichier Fichier {
#biotcl firstLineFromFile {file}
if { $Fichier == "" } {return ""}
set f [open $Fichier r]
if {[gets $f Ligne]<0} { set Ligne "" }
close $f
return $Ligne
}
proc DerniereLigneDuFichier Fichier {
#biotcl lastLineFromFile {file}
return [lindex [LesLignesDuFichier $Fichier] end]
}
proc LesPremieresLignesDuFichier {Fichier n} {
#biotcl fitsLinesFromFile {file n}
if { $Fichier == "" } {return {}}
if {$n<1} { return {}}
set f [open $Fichier r]
set LesLignes {}
while {[gets $f Ligne]>=0} {
lappend LesLignes $Ligne
if { ! [incr n -1]} { break }
}
close $f
return $LesLignes
}
proc IemeLigneDuFichier {Fichier i} {
#biotcl lineIFromFile {file i}
return [lindex [LesLignesDuFichier $Fichier] [incr i -1]]
}
proc LesLignesIaJDuFichier {Fichier i j} {
#biotcl linesItoJFromFile {file i j}
return [lrange [LesLignesDuFichier $Fichier] $i $j]
# return [lrange [LesPremieresLignesDuFichier $Fichier $j] [incr i -1] end]
}
proc CompareLesFloatsEnDebut {TexteA TexteB} {
#biotcl compareFloatsAtBegin {}
scan $TexteA "%f" a
scan $TexteB "%f" b
if {[expr double($a) < double($b)]} { return -1}
if {[expr double($a) == double($b)]} { return 0}
if {[expr double($a) > double($b)]} { return 1}
}
proc DenicheEtCompareLesIntegersEnDebut {TexteA TexteB} {
#biotcl findAndCompareFloatsAtBegin {}
regsub -all {[^0-9]} $TexteA " " TexteA
regsub -all {[^0-9]} $TexteB " " TexteB
return [CompareLesIntegersEnDebut $TexteA $TexteB]
}
proc CompareLesIntegersEnDebut {TexteA TexteB} {
#biotcl compareIntegersAtBegin {}
scan $TexteA "%d" a
scan $TexteB "%d" b
if {[expr $a < $b]} { return -1}
if {[expr $a == $b]} { return 0}
if {[expr $a > $b]} { return 1}
}
proc CompareLesFloats {TexteA TexteB} {
#biotcl compareFloats {}
if { [llength [split [string trim $TexteA] " "]] > 1 } {
scan $TexteA "%s %f" A a
} else {
scan $TexteA "%f" a
}
if { [llength [split [string trim $TexteB] " "]] > 1 } {
scan $TexteB "%s %f" B b
} else {
scan $TexteB "%f" b
}
if {[expr double($a) < double($b)]} { return -1}
if {[expr double($a) == double($b)]} { return 0}
if {[expr double($a) > double($b)]} { return 1}
}
proc CompareLesIntegers {TexteA TexteB} {
#biotcl compareIntegers {}
if { [llength [split [string trim $TexteA] " "]] > 1 } {
scan $TexteA "%s %f" A a
} else {
scan $TexteA "%f" a
}
if { [llength [split [string trim $TexteB] " "]] > 1 } {
scan $TexteB "%s %f" B b
} else {
scan $TexteB "%f" b
}
if {[expr $a < $b]} { return -1}
if {[expr $a == $b]} { return 0}
if {[expr $a > $b]} { return 1}
}
proc CompareSansPremierChamp {TexteA TexteB} {
#biotcl compareWithoutFirstField {}
set iB [string first " " $TexteA]
if {$iB < 0} {
set a ""
} else {
set a [string trimleft [string range $TexteA $iB end]]
}
set iB [string first " " $TexteB]
if {$iB < 0} {
set b ""
} else {
set b [string trimleft [string range $TexteB $iB end]]
}
return [string compare $a $b]
}
proc CompareLeDeuxiemeChamp {LigneA LigneB} {
#biotcl compareSecondField {}
scan $LigneA "%s %f" A a
scan $LigneB "%s %f" B b
if {[expr $a < $b]} { return -1}
if {[expr $a == $b]} { return 0}
if {[expr $a > $b]} { return 1}
}
proc CompareLeTroisiemeChamp {LigneA LigneB} {
#biotcl compareThirdField {}
scan $LigneA "%s %s %f" A AA a
scan $LigneB "%s %s %f" B BB b
if {[expr $a < $b]} { return -1}
if {[expr $a == $b]} { return 0}
if {[expr $a > $b]} { return 1}
}
proc CompareLesMilieux {LigneA LigneB} {
#biotcl compareMiddleFields {}
scan $LigneA "%s %d %d" A DA FA
scan $LigneB "%s %d %d" B DB FB
set a [expr ($DA+$FA)/2]
set b [expr ($DB+$FB)/2]
if {[expr $a < $b]} { return -1}
if {[expr $a == $b]} { return 0}
if {[expr $a > $b]} { return 1}
}
proc EditAndShow {Texte {FichierPourSave ""} {Maniere ""}} {
return [AfficheVariable [EntreTexte $Texte] "AvecFormate$Maniere" $FichierPourSave]
}
proc IntegerEnFin {de Texte} {
#biotcl integerAtEnd {of text}
return [ValeurEnFin de $Texte "%d"]
}
proc FloatEnFin {de Texte} {
#biotcl floatAtEnd {of text}
return [ValeurEnFin de $Texte "%f"]
}
proc ValeurEnFin {de Texte Format} {
#biotcl valueAtEnd {of text format}
set BonTexte [string trim $Texte]
set iZone [expr [string last " " $BonTexte]+1]
scan [string range $BonTexte $iZone end] "$Format" Valeur
return $Valeur
}
proc ValeurApres {Champ dans Texte Format} {
#biotcl valueAfter {field in text format}
set iZone [string first $Champ $Texte]
if {$iZone<0} { return "" }
incr iZone [string length $Champ]
if { $Format == "ExposantEventuellementMalFoutu" } {
set sPN [string trim [string range $Texte $iZone end] " '"]
regsub {^[eE]} $sPN "1.0e" sPN
scan $sPN "%f" PN
if {[catch { expr $PN > 0.001 } ]} {
Warne "Oh le vilain $sPN trop petit, je prends 1.0E-200"
set PN 1.0E-200
}
set Valeur $PN
} else {
if {$iZone<0} {return ""}
set Valeur ""
scan [string range $Texte $iZone end] "$Format" Valeur
}
return $Valeur
}
proc StringSuivant {Champ dans Texte} {
#biotcl stringFollowing {field in text}
set i [string first $Champ $Texte]
if {$i==-1} { return "" }
incr i [string length $Champ]
return [string range $Texte $i end]
}
proc StringApres {Champ dans Texte} {
#biotcl stringAfter {field in text}
return [ValeurApres $Champ dans $Texte "%s"]
}
proc IntegerApres {Champ dans Texte} {
#biotcl integerAfter {field in text}
return [ValeurApres $Champ dans $Texte "%d"]
}
proc FloatApres {Champ dans Texte} {
#biotcl floatAfter {field in text}
return [ValeurApres $Champ dans $Texte "%f"]
}
proc LIndexes {Liste args} {
set L {}
foreach I $args {
lappend L [lindex $Liste $I]
}
return $L
}
proc LConcatTest {} {
set L {a b c}
return [LConcat L {d e f}]
}
proc LConcat {aListe ListeB} {
upvar $aListe Liste
if { ! [info exists Liste]} { set Liste {} }
set Liste [concat $Liste $ListeB]
return $Liste
}
proc LogWscopeL Liste {
return [LogWscope [join $Liste "\n"]]
}
proc LogWscope Texte {
return [Log $Texte "gscopehtmlserver.log" "DoNotMemo"]
}
proc LogL {{Liste ""} {FichierLog ""}} {
return [Log [join $Liste "\n"] $FichierLog]
}
proc Log {{Texte ""} {FichierLog ""} {DoNotMemo ""}} {
global FichierLogMemo
if {$FichierLog==""} {
if {[info exists FichierLogMemo]} {
set FichierLog $FichierLogMemo
} else {
set FichierLog "gscope.log"
}
}
if { ! [regexp {^/} $FichierLog]} {
if {[info proc LogDir]==""} {
#rR pour pouvoir être indépendatn de gscope_topographe.tcl
set FichierLog "~/$FichierLog"
} else {
set FichierLog "[LogDir]/$FichierLog"
}
}
if { ! [string equal -nocase $DoNotMemo "DoNotMemo"]} { set FichierLogMemo $FichierLog }
return [AppendAuFichier $FichierLog $Texte]
}
proc EspionneL {{Liste ""}} {
Espionne [join $Liste "\n"]
}
proc EspionneOldVoirPlusBasAvecArgs {{Texte ""}} {
global EspionneNon
if {$Texte=="SetEspionneNON"} { set EspionneNon 1 }
if {$Texte=="SetEspionneOUI"} { set EspionneNon 0 }
if {[info exists EspionneNon] && $EspionneNon} { return }
puts $Texte
return $Texte
}
proc Espionne {args} {
global EspionneNon
if {$args=="SetEspionneNON"} { set EspionneNon 1 }
if {$args=="SetEspionneOUI"} { set EspionneNon 0 }
if {[info exists EspionneNon] && $EspionneNon} { return }
if {$args==""} { puts "" }
puts [join $args " "]
return $args
}
proc ContenuDuFichier {{Fichier ""}} {
#biotcl textFromFile
if { $Fichier == "" } {return ""}
if {[regexp -nocase {https?\://|ftp\://} $Fichier]} { return [HttpCopy $Fichier] } ;#rR 2014/07/02
if {[regexp {\.gz$} $Fichier]} { return [exec zcat $Fichier] }
if {[regexp -nocase {(\.jpg|\.gif|\.png)$} $Fichier]} {
set f [open $Fichier r]
fconfigure $f -translation binary
set Texte [read $f]
} else {
set f [open $Fichier r]
set Texte [read -nonewline $f]
}
close $f
return $Texte
}
proc LesLignesDuFichier {{Fichier ""}} {
#biotcl linesFromFile {file}
if { $Fichier == "" } {return {}}
if {[regexp -nocase {https?\://|ftp\://} $Fichier]} { return [split [HttpCopy $Fichier] "\n"] } ;#rR 2014/07/02
if {[regexp {\.gz$} $Fichier]} { return [split [exec zcat $Fichier] "\n"] }
set LesLignes {}
set f [open $Fichier r]
while {[gets $f Ligne]>=0} {
lappend LesLignes $Ligne
}
close $f
return $LesLignes
}
proc SauveLesLignes {LesLignes dans Fichier} {
#biotcl linesToFile {lines to file}
set f [open $Fichier w]
foreach Ligne $LesLignes {
puts $f $Ligne
}
close $f
file attribute $Fichier -permissions 0664
return $Fichier
}
proc Sauve {Texte dans Fichier} {
#biotcl textToFile {text to file}
set f [open $Fichier w]
if { $Texte != "" } { puts $f $Texte }
close $f
if {[file owned $Fichier]} { file attribute $Fichier -permissions 0664 }
return $Fichier
}
proc FichierPourSaveAs {{RepertoireEtFichier ""}} {
global RepertoireInitial
if {[info exists OuiOuNonToujoursParDefaut] && $OuiOuNonToujoursParDefaut} {
if { $RepertoireEtFichier!="" && ! [file isdirectory $RepertoireEtFichier]} { return $RepertoireEtFichier }
}
if {$RepertoireEtFichier==""} { set RepertoireEtFichier "unnamed" }
if {[regexp {/$} $RepertoireEtFichier]} {
regsub {/$} $RepertoireEtFichier "" Rep
set Fic ""
} else {
set Rep [file dirname $RepertoireEtFichier]
set Fic [file tail $RepertoireEtFichier]
}
if {$Rep!=""} {
set RepertoireInitial $Rep
}
if {$Fic!=""} {
set FichierInitial "$Fic"
}
if { ! [info exists RepertoireInitial]} { set RepertoireInitial [pwd] }
if { ! [info exists FichierInitial]} { set FichierInitial "unnamed"}
set Fichier [tk_getSaveFile -title "File to create" \
-initialfile $FichierInitial \
-initialdir $RepertoireInitial]
if { $Fichier == "" } { return ""}
set RepertoireInitial [file dirname $Fichier]
return $Fichier
}
proc SaveAs {Page {RepertoireEtFichier "unnamed"}} {
set Fichier [FichierPourSaveAs $RepertoireEtFichier]
if {$Fichier==""} { return "" }
return [Sauve $Page dans $Fichier]
}
proc IntegerToRGB Couleur {
#biotcl integerToRGB {}
binary scan [binary format "i*" $Couleur] "c1c1c1c1" b g r v
set r [expr ( $r + 0x100 ) % 0x100]
set g [expr ( $g + 0x100 ) % 0x100]
set b [expr ( $b + 0x100 ) % 0x100]
return "$r $g $b"
}
proc RGBToInteger {r g b} {
#biotcl rgbToInteger {}
binary scan [binary format "c1c1c1c1" $b $g $r 0] "i" Couleur
return $Couleur
}
proc CouleurDuNuancier {Ieme NombreDeCouleurs {UnPeu ""} {Passion ""} {Format ""} {Saturation ""} {Brightness ""}} {
#biotcl colorsFromChart {}
if {$NombreDeCouleurs<1} { set NombreDeCouleurs 1 }
incr Ieme -1
if {$NombreDeCouleurs<2} {
set Amour 0
} else {
set Amour [expr 1.0*$Ieme/($NombreDeCouleurs-1)]
}
set Couleur [Nuance $Amour $UnPeu $Passion $Format $Saturation $Brightness]
return $Couleur
}
proc CouleurFormat {rgb Format {InputFormat ""}} {
#biotcl colorFormat {}
#rR rajoute 2016/01/21 .. ça ne fait pas de mal ;)
if {[regexp -nocase {[a-z]} $rgb]} {
lassign [FromTkCol $rgb rgb] r g b
set r [expr $r*256]
set g [expr $g*256]
set b [expr $b*256]
set rgb [list $r $g $b]
}
if {$InputFormat=="3x8"} {
lassign $rgb r g b
set r [expr $r*256]
set g [expr $g*256]
set b [expr $b*256]
set rgb [list $r $g $b]
}
if {[llength $rgb]==1 && [string length $rgb]>=12} {
regsub "#" $rgb "" rgb
scan $rgb "%04x%04x%04x" r g b
set rgb [list $r $g $b]
} elseif {[llength $rgb]==1 && [string length $rgb]>=6} {
regsub "#" $rgb "" rgb
scan $rgb "%02x%02x%02x" r g b
set r [expr $r*256]
set g [expr $g*256]
set b [expr $b*256]
set rgb [list $r $g $b]
}
lassign $rgb r g b
if {$Format=="3x16"} { return "$r $g $b" }
if {$Format=="3x8" } { return [format "%d %d %d" [expr $r/256] [expr $g/256] [expr $b/256]] }
if {$Format=="hexa"} { return [format "#%04x%04x%04x" $r $g $b] }
if {$Format=="hexa2"} { return [format "#%02x%02x%02x" [expr $r/256] [expr $g/256] [expr $b/256]] }
if {[regexp -nocase "n" $Format] } {
set Proche [PlusProcheCouleur [list [expr $r/256] [expr $g/256] [expr $b/256]] "3x8"]
if {[regexp -nocase "all" $Format]} { return [FromTkCol $Proche "Nom"] }
set Nom [lindex [FromTkCol $Proche "Nom"] 0]
return $Nom
}
return $rgb
}
proc Nuance3x8 {Amour {UnPeu ""} {Passion ""} {Saturation ""} {Brightness ""}} {
#biotcl color3x8 {}
return [Nuance $Amour $UnPeu $Passion "3x8" $Saturation $Brightness]
}
proc Nuance {Amour {UnPeu ""} {Passion ""} {Format ""} {Saturation ""} {Brightness ""}} {
#biotcl shade {}
#rR réécrit 2014/11/17
#rR Amour va de 0 à 1 et de ca fait correspondra à Hue de UnPeu à Passion
if {$Saturation==""} { set Saturation 1. }
if {$Brightness==""} { set Brightness 1. }
if {$UnPeu ==""} { set UnPeu 0.1 }
if {$Passion ==""} { set Passion 0.6 }
if {$Format ==""} { set Format "hexa" }
if {$UnPeu<=$Passion} {
set Hue [expr {$UnPeu + ($Passion-$UnPeu)*$Amour}]
} else {
set Hue [expr {$UnPeu - ($UnPeu-$Passion)*$Amour}]
}
set rgb [hsbToRgb $Hue $Saturation $Brightness]
return [CouleurFormat $rgb $Format]
}
proc Sature {Amour {UnPeu ""} {Passion ""} {Format ""} {Hue ""} {Brightness ""}} {
#biotcl sature {}
#rR réécrit 2014/11/17
#rR Amour va de 0 à 1 et de ce fait correspondra à Saturation de UnPeu à Passion
if {$Hue ==""} { set Hue 0.5 }
if {$Brightness==""} { set Brightness 1. }
if {$UnPeu ==""} { set UnPeu 0.1 }
if {$Passion ==""} { set Passion 0.6 }
if {$Format ==""} { set Format "hexa" }
set Saturation [expr $UnPeu + ($Passion-$UnPeu)*$Amour]
set rgb [hsbToRgb $Hue $Saturation $Brighness]
return [CouleurFormat $rgb $Format]
}
proc ColorFromHSB {H S B} {
#biotcl colorFromHSB {}
set rgb [hsbToRgb $H $S $B]
lassign $rgb r g b
set color [format "#%04x%04x%04x" $r $g $b]
return $color
}
proc oldhsbToRgb {hue sat value} {
# The procedure converts an HSB value to RGB. It takes hue, saturation,
# and value components (floating-point, 0-1.0) as arguments, and returns a
# list containing RGB components (integers, 0-65535) as result. The code
# here is a copy of the code on page 616 of "Fundamentals of Interactive
# Computer Graphics" by Foley and Van Dam.
set v [format %.0f [expr 65535.0*$value]]
if {$sat == 0} {
return "$v $v $v"
} else {
set hue [expr $hue*6.0]
if {$hue >= 6.0} {
set hue 0.0
}
scan $hue. %d i
set f [expr $hue-$i]
set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]]
set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]]
set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]]
case $i \
0 {return "$v $t $p"} \
1 {return "$q $v $p"} \
2 {return "$p $v $t"} \
3 {return "$p $q $v"} \
4 {return "$t $p $v"} \
5 {return "$v $p $q"}
error "i value $i is out of range"
}
}
proc PlusProcheCouleur {Couleur {Format ""}} {
#biotcl nearestColor {}
set MaxDist2 99999999999
foreach Rgb [FromTkCol ListOf rgb] {
set Dist2 0
foreach c $Couleur r $Rgb {
set Dist2 [expr $Dist2 + ($c-$r)**2]
}
if {$Dist2>=$MaxDist2} { continue }
set MaxDist2 $Dist2
set PlusProcheCouleur $Rgb
}
return [CouleurFormat $PlusProcheCouleur $Format "3x8"]
}
proc FromTkCol {{Qui ""} {Quoi ""}} {
#rR TkCol connait toutes les couleurs TkCol(aquamarine) = 127 255 212
#rR FromTkCol fournit l'un en fonction de l'autre et aussi les listes
#rR nom est le nom de la couleur n le meme sans blanc
#rR FromTkCol répond même avec une mauvaise casse ;-)
global TkCol FromTkCol
set Quoi [string tolower $Quoi]
if {[info exists FromTkCol($Qui,$Quoi)]} { return $FromTkCol($Qui,$Quoi) }
if {[info exists FromTkCol("EstCharge")]} {
set QUI [string toupper $Qui]
regsub -all " " $QUI "" QUI
if {[info exists FromTkCol($QUI,$Quoi)]} { return $FromTkCol($QUI,$Quoi) }
return ""
}
set FromTkCol("EstCharge") 1
if { ! [info exists TkCol]} { InitTkCol }
foreach {Nom Rgb} [array get TkCol] {
regsub -all " " $Nom "" n
set NOM [string toupper $Nom]
set N [string toupper $n]
set FromTkCol($Nom,rgb) $Rgb
set FromTkCol($n,rgb) $Rgb
set FromTkCol($NOM,rgb) $Rgb
set FromTkCol($N,rgb) $Rgb
set FromTkCol($Nom,nom) $Nom
set FromTkCol($n,nom) $Nom
set FromTkCol($NOM,nom) $Nom
set FromTkCol($N,nom) $Nom
set FromTkCol($Nom,n) $n
set FromTkCol($n,n) $n
set FromTkCol($NOM,n) $n
set FromTkCol($N,n) $n
lappend FromTkCol($Rgb,nom) $Nom
lappend FromTkCol($Rgb,n) $n
lappend FromTkCol(LISTOF,nom) $Nom
lappend FromTkCol(LISTOF,n) $n
lappend FromTkCol(LISTOF,rgb) $Rgb
}
set FromTkCol(LISTOF,nom) [concat $FromTkCol(LISTOF,nom) $FromTkCol(LISTOF,n)]
set FromTkCol(LISTOF,nom) [lsort -unique $FromTkCol(LISTOF,nom)]
set FromTkCol(LISTOF,n) [lsort -unique $FromTkCol(LISTOF,n)]
return [FromTkCol $Qui $Quoi]
}
proc PaletteDeCouleurs {{CouleurParDefaut ""} {FichierRgbTxt ""} {titre ""}} {
global red green blue colorSpace color updating autoUpdate
global LaCouleurDePaletteDeCouleurs
global PEnGlobalPourPaletteDeCouleurs
global CouleurNommeePourPaletteDeCouleurs
if {$CouleurParDefaut == ""} { set CouleurParDefaut "black" }
if {$FichierRgbTxt==""} { set FichierRgbTxt "[GscopeEtc]/rgb.txt" }
set P [NomDe palette]
toplevel $P
if {$titre ne ""} {
wm title $P $titre
} else {
wm title $P "This widget is taken from the TK8.2's demos. Adapted for GScope by Raymond Ripp."
}
set PEnGlobalPourPaletteDeCouleurs $P
# Global variables that control the program:
#
# colorSpace - Color space currently being used for
# editing. Must be "rgb", "cmy", or "hsb".
# label1, label2, label3 - Labels for the scales.
# red, green, blue - Current color intensities in decimal
# on a scale of 0-65535.
# color - A string giving the current color value
# in the proper form for x:
# #RRRRGGGGBBBB
# updating - Non-zero means that we're in the middle of
# updating the scales to load a new color,so
# information shouldn't be propagating back
# from the scales to other elements of the
# program: this would make an infinite loop.
# command - Holds the command that has been typed
# into the "Command" entry.
# autoUpdate - 1 means execute the update command
# automatically whenever the color changes.
# name - Name for new color, typed into entry.
set colorSpace hsb
set red 65535
set green 0
set blue 0
set list [winfo rgb $P $CouleurParDefaut]
set red [lindex $list 0]
set green [lindex $list 1]
set blue [lindex $list 2]
set CouleurParDefaut [format "#%04x%04x%04x" $red $green $blue]
set color $CouleurParDefaut
set updating 0
set autoUpdate 0
set CouleurNommeePourPaletteDeCouleurs ""
# Create the menu bar at the top of the window.
frame $P.menu -relief raised -borderwidth 2
pack $P.menu -side top -fill x
menubutton $P.menu.file -text "ColorSpace : RGB, CMY or HSB" -menu $P.menu.file.m -underline 0
menu $P.menu.file.m
$P.menu.file.m add radio -label "RGB color space" -variable colorSpace \
-value rgb -underline 0 -command "changeColorSpace rgb $P"
$P.menu.file.m add radio -label "CMY color space" -variable colorSpace \
-value cmy -underline 0 -command "changeColorSpace cmy $P"
$P.menu.file.m add radio -label "HSB color space" -variable colorSpace \
-value hsb -underline 0 -command "changeColorSpace hsb $P"
# $P.menu.file.m add separator
# $P.menu.file.m add radio -label "Automatic updates" -variable autoUpdate \
# -value 1 -underline 0
# $P.menu.file.m add radio -label "Manual updates" -variable autoUpdate \
# -value 0 -underline 0
# $P.menu.file.m add separator
# $P.menu.file.m add command -label "Exit program" -underline 0 \
# -command { set LaCouleurDePaletteDeCouleurs "" }
pack $P.menu.file -side left
# Create the command entry window at the bottom of the window, along
# with the update button.
frame $P.bot -relief raised -borderwidth 2
pack $P.bot -side bottom -fill x
label $P.commandLabel -text "Command:"
entry $P.command -relief sunken -borderwidth 2 -textvariable command \
-font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
button $P.update -text "Accept" -background "green" -command {set LaCouleurDePaletteDeCouleurs $color}
button $P.dismiss -text "Dismiss" -background "red" -command {set LaCouleurDePaletteDeCouleurs ""}
# pack $P.commandLabel -in $P.bot -side left
pack $P.dismiss -in $P.bot -side left -pady .1c -padx .25c
pack $P.update -in $P.bot -side right -pady .1c -padx .25c
# pack $P.command -in $P.bot -expand yes -fill x -ipadx 0.25c
# Create the listbox that holds all of the color names in rgb.txt,
# if an rgb.txt file can be found.
frame $P.middle -relief raised -borderwidth 2
pack $P.middle -side top -fill both
#lm enleve la boucle sur les fichiers X11 Linux pour
#lm la remplacer par la liste des coulerus reconnues
#lm par Tk sur toutes les plates-formes
# foreach i [list $FichierRgbTxt /usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt \
# /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt \
# /usr/openwin/lib/X11/rgb.txt] {
# if ![file readable $i] { continue }
# set f [open $i]
global TkCol
if {! [info exists TkCol]} {InitTkCol}
frame $P.middle.left
pack $P.middle.left -side left -padx .25c -pady .25c
listbox $P.names -width 20 -height 12 \
-yscrollcommand "$P.scroll set" \
-relief sunken -borderwidth 2 \
-exportselection false
bind $P.names "tc_loadNamedColor \[$P.names get \[$P.names curselection\]\] $P"
scrollbar $P.scroll -orient vertical \
-command "$P.names yview" \
-relief sunken -borderwidth 2
pack $P.names -in $P.middle.left -side left
pack $P.scroll -in $P.middle.left -side right -fill y
foreach e [lsort [array names TkCol]] {
regsub -all "_" $e " " e
$P.names insert end $e
}
#lm je commentarise ...
##while {[gets $f line] >= 0} {
# if {[llength $line] == 4} {
#$P.names insert end [lindex $line 3]
# }
#}
# close $f
# break
# }
# Create the three scales for editing the color, and the entry for
# typing in a color value.
frame $P.middle.middle
pack $P.middle.middle -side left -expand yes -fill y
frame $P.middle.middle.1
frame $P.middle.middle.2
frame $P.middle.middle.3
frame $P.middle.middle.4
pack $P.middle.middle.1 $P.middle.middle.2 $P.middle.middle.3 -side top -expand yes
pack $P.middle.middle.4 -side top -expand yes -fill x
foreach i {1 2 3} {
label $P.label$i -textvariable label$i
scale $P.scale$i -from 0 -to 1000 -length 6c -orient horizontal \
-command "tc_scaleChanged $P"
pack $P.scale$i $P.label$i -in $P.middle.middle.$i -side top -anchor w
}
label $P.nameLabel -text "Name:"
entry $P.name -relief sunken -borderwidth 2 -textvariable CouleurNommeePourPaletteDeCouleurs -width 10 \
-font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
pack $P.nameLabel -in $P.middle.middle.4 -side left
pack $P.name -in $P.middle.middle.4 -side right -expand 1 -fill x
bind $P.name {tc_loadNamedColor $CouleurNommeePourPaletteDeCouleurs $PEnGlobalPourPaletteDeCouleurs}
# Create the color display swatch on the right side of the window.
frame $P.middle.right
pack $P.middle.right -side left -pady .25c -padx .25c -anchor s
frame $P.swatch -width 2c -height 5c -background $color
label $P.value -textvariable color -width 13 \
-font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
pack $P.swatch -in $P.middle.right -side top -expand yes -fill both
pack $P.value -in $P.middle.right -side bottom -pady .25c
#lm rajoute grab
update idletasks
set OldGrab [grab current]
grab set $P
wm attributes $P -topmost 1
wm transient $P .
changeColorSpace hsb $P
tkwait variable LaCouleurDePaletteDeCouleurs
destroy $P
#lm remet le grab si necessaire
if {$OldGrab ne ""} {grab [lindex $OldGrab 0]}
return $LaCouleurDePaletteDeCouleurs
}
# The procedure below is invoked when one of the scales is adjusted.
# It propagates color information from the current scale readings
# to everywhere else that it is used.
proc tc_scaleChanged {P args} {
global red green blue colorSpace color updating autoUpdate
global LaCouleurDePaletteDeCouleurs
if $updating {
return
}
if {$colorSpace == "rgb"} {
set red [format %.0f [expr [$P.scale1 get]*65.535]]
set green [format %.0f [expr [$P.scale2 get]*65.535]]
set blue [format %.0f [expr [$P.scale3 get]*65.535]]
} else {
if {$colorSpace == "cmy"} {
set red [format %.0f [expr {65535 - [$P.scale1 get]*65.535}]]
set green [format %.0f [expr {65535 - [$P.scale2 get]*65.535}]]
set blue [format %.0f [expr {65535 - [$P.scale3 get]*65.535}]]
} else {
set list [hsbToRgb [expr {[$P.scale1 get]/1000.0}] \
[expr {[$P.scale2 get]/1000.0}] \
[expr {[$P.scale3 get]/1000.0}]]
set red [lindex $list 0]
set green [lindex $list 1]
set blue [lindex $list 2]
}
}
set color [format "#%04x%04x%04x" $red $green $blue]
$P.swatch config -bg $color
if { $autoUpdate } {
set LaCouleurDePaletteDeCouleurs $color
}
update idletasks
}
# The procedure below is invoked to update the scales from the
# current red, green, and blue intensities. It's invoked after
# a change in the color space and after a named color value has
# been loaded.
proc tc_setScales P {
global red green blue colorSpace updating
set updating 1
if {$colorSpace == "rgb"} {
$P.scale1 set [format %.0f [expr $red/65.535]]
$P.scale2 set [format %.0f [expr $green/65.535]]
$P.scale3 set [format %.0f [expr $blue/65.535]]
} else {
if {$colorSpace == "cmy"} {
$P.scale1 set [format %.0f [expr (65535-$red)/65.535]]
$P.scale2 set [format %.0f [expr (65535-$green)/65.535]]
$P.scale3 set [format %.0f [expr (65535-$blue)/65.535]]
} else {
set list [rgbToHsv $red $green $blue]
$P.scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]]
$P.scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]]
$P.scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]]
}
}
set updating 0
}
# The procedure below is invoked when a named color has been
# selected from the listbox or typed into the entry. It loads
# the color into the editor.
proc tc_loadNamedColor {name P} {
global red green blue color autoUpdate
global LaCouleurDePaletteDeCouleurs
if {[string index $name 0] != "#"} {
if {[catch {set list [winfo rgb $P.swatch $name]} Message]} {
FaireLire "Error in color name with message\n$Message"
return ""
}
set red [lindex $list 0]
set green [lindex $list 1]
set blue [lindex $list 2]
} else {
case [string length $name] {
4 {set format "#%1x%1x%1x"; set shift 12}
7 {set format "#%2x%2x%2x"; set shift 8}
10 {set format "#%3x%3x%3x"; set shift 4}
13 {set format "#%4x%4x%4x"; set shift 0}
default {error "syntax error in color name \"$name\""}
}
if {[scan $name $format red green blue] != 3} {
error "syntax error in color name \"$name\""
}
set red [expr $red<<$shift]
set green [expr $green<<$shift]
set blue [expr $blue<<$shift]
}
tc_setScales $P
set color [format "#%04x%04x%04x" $red $green $blue]
$P.swatch config -bg $color
if { $autoUpdate } {
set LaCouleurDePaletteDeCouleurs $color
}
}
# The procedure below is invoked when a new color space is selected.
# It changes the labels on the scales and re-loads the scales with
# the appropriate values for the current color in the new color space
proc changeColorSpace {space P} {
global label1 label2 label3
if {$space == "rgb"} {
set label1 Red
set label2 Green
set label3 Blue
tc_setScales $P
return
}
if {$space == "cmy"} {
set label1 Cyan
set label2 Magenta
set label3 Yellow
tc_setScales $P
return
}
if {$space == "hsb"} {
set label1 Hue
set label2 Saturation
set label3 Brightness
tc_setScales $P
return
}
}
# The procedure below converts an RGB value to HSB. It takes red, green,
# and blue components (0-65535) as arguments, and returns a list containing
# HSB components (floating-point, 0-1) as result. The code here is a copy
# of the code on page 615 of "Fundamentals of Interactive Computer Graphics"
# by Foley and Van Dam.
proc rgbToHsv {red green blue} {
#biotcl rgbToHsv {}
if {$red > $green} {
set max $red.0
set min $green.0
} else {
set max $green.0
set min $red.0
}
if {$blue > $max} {
set max $blue.0
} else {
if {$blue < $min} {
set min $blue.0
}
}
set range [expr $max-$min]
if {$max == 0} {
set sat 0
} else {
set sat [expr {($max-$min)/$max}]
}
if {$sat == 0} {
set hue 0
} else {
set rc [expr {($max - $red)/$range}]
set gc [expr {($max - $green)/$range}]
set bc [expr {($max - $blue)/$range}]
if {$red == $max} {
set hue [expr {.166667*($bc - $gc)}]
} else {
if {$green == $max} {
set hue [expr {.166667*(2 + $rc - $bc)}]
} else {
set hue [expr {.166667*(4 + $gc - $rc)}]
}
}
if {$hue < 0.0} {
set hue [expr $hue + 1.0]
}
}
return [list $hue $sat [expr {$max/65535}]]
}
# The procedure below converts an HSB value to RGB. It takes hue, saturation,
# and value components (floating-point, 0-1.0) as arguments, and returns a
# list containing RGB components (integers, 0-65535) as result. The code
# here is a copy of the code on page 616 of "Fundamentals of Interactive
# Computer Graphics" by Foley and Van Dam.
proc hsbToRgb {hue sat value} {
#biotcl hsbToRgb {}
set v [format %.0f [expr {65535.0*$value}]]
if {$sat == 0} {
return "$v $v $v"
} else {
set hue [expr {$hue*6.0}]
if {$hue >= 6.0} {
set hue 0.0
}
scan $hue. %d i
set f [expr {$hue-$i}]
set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]]
set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]]
set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]]
case $i \
0 {return "$v $t $p"} \
1 {return "$q $v $p"} \
2 {return "$p $v $t"} \
3 {return "$p $q $v"} \
4 {return "$t $p $v"} \
5 {return "$v $p $q"}
error "i value $i is out of range"
}
}
proc TuMontrerasCeQueFaitLeBouton Bouton {
global QuelBouton
return [set QuelBouton [after 1000 MontreCeQueFaitLeBouton $Bouton]]
}
proc MontreCeQueFaitLeBouton Bouton {
global LeBoutonQuiEstMontre
catch {destroy $LeBoutonQuiEstMontre}
set LesActions [QueFaitLeBouton $Bouton]
if {$LesActions == {} } { return "" }
global RapetisseLesBoutonsDe
if {[info exists RapetisseLesBoutonsDe($Bouton)]} {
set TexteActions "[set RapetisseLesBoutonsDe($Bouton)]\n\n[join $LesActions "\n"]"
} else {
set TexteActions [join $LesActions "\n"]
}
regsub -nocase {\.[a-z_0-9]*$} $Bouton "" FdB
if {$FdB==""} { return "" }
regsub -nocase {\.[a-z_0-9]*$} $FdB "" FdFdB
if {$FdFdB==""} { return "" }
set x [winfo x $FdB]
set y [winfo y $FdB]
incr x [winfo x $Bouton]
incr y [winfo y $Bouton]
incr y -10
set M ${FdFdB}[NomDe message]
message $M -borderwidth 3 -relief raise -width 800 -text $TexteActions -background "lightyellow" -foreground "black"
if {[expr $x > 400]} {
set Anchor se
} else {
set Anchor sw
}
place $M -x $x -y $y -anchor $Anchor -in $FdFdB
set LeBoutonQuiEstMontre $M
return $LeBoutonQuiEstMontre
}
proc LacheLeBouton w {
global QuelBouton
global LeBoutonQuiEstMontre
catch {after cancel $QuelBouton}
catch {destroy $LeBoutonQuiEstMontre}
}
proc QueFaitLeBouton Bouton {
set LesActions {}
foreach Sequence {<1> <2> <3> } {
set Action {}
catch {set Action [bind $Bouton $Sequence]}
if {$Action == {} } { continue }
lappend LesActions "$Sequence $Action"
}
return $LesActions
}
proc QueFontLesBoutonsDe w {
set LesActions [list " "]
foreach Bouton [LesBoutonsDeLaFrame $w.buttons] {
foreach SeqAct [QueFaitLeBouton $Bouton] {
lappend LesActions "$Bouton $SeqAct"
}
}
Espionne [join $LesActions "\n"]
# ShowText [join $LesActions "\n"] "AvecCallProc"
}
proc ExecuteUnBoutonDe w {
set Tabulation [string repeat " " [string length "Button"]]
set Sel ""
catch {set Sel [selection get]}
foreach Bouton [LesBoutonsDeLaFrame $w.buttons] {
set Texte [lindex [$Bouton configure -text] 4]
regsub -all "\n" $Texte " ++ " Texte
lappend LesActions "Button $Bouton $Texte"
foreach SeqAct [QueFaitLeBouton $Bouton] {
regsub -nocase {<[a-z0-9\-]*> } $SeqAct "" Act
regsub {\[selection get\]} $Act "\{$Sel\}" Act
lappend LesActions "$Tabulation $Act"
}
}
set Action [ChoixParmi $LesActions]
if {$Action=="" || [regexp "^Button" $Action]} { return "" }
return [eval $Action]
}
proc OldRapetisseLesBoutonsDe {w {FonteVoulue ""}} {
if {$FonteVoulue!=""} { set Fonte $FonteVoulue }
foreach Bouton [LesBoutonsDeLaFrame $w.buttons] {
if { ! [info exists Fonte]} {
set OldFonte [lindex [$Bouton configure -font] 4]
ScanLaListe $OldFonte Police Size Style
set NewSize [expr $Size + 1]
if {$NewSize==-5} { set NewSize -14 }
set Fonte [list "tiny" $NewSize "normal"]
Espionne $Fonte
}
$Bouton configure -font $Fonte
}
return $Fonte
}
proc RapetisseLesBoutonsDe {w {Reset ""}} {
global RapetisseLesBoutonsDe
if {$Reset=="Reset" && ! [info exists RapetisseLesBoutonsDe($w)]} { return "" }
set RapetisseLesBoutonsDe($w) 1
foreach Bouton [LesBoutonsDeLaFrame $w.buttons] {
set NewWidth [lindex [$Bouton configure -width] 4]
incr NewWidth -3
if {$NewWidth < 3} { set NewWidth 20 }
$Bouton configure -width $NewWidth
continue
if { ! [info exists RapetisseLesBoutonsDe($w,$Bouton)]} {
set Texte [lindex [$Bouton configure -text] 4]
set RapetisseLesBoutonsDe($w,$Bouton) $Texte
set RapetisseLesBoutonsDe($Bouton) $Texte
regsub -all {[a-z]} $Texte "" NewTexte
} else {
set NewTexte [set RapetisseLesBoutonsDe($w,$Bouton)]
unset RapetisseLesBoutonsDe($w,$Bouton)
if {[info exists RapetisseLesBoutonsDe($w)]} { unset RapetisseLesBoutonsDe($w) }
}
$Bouton configure -text $NewTexte
}
return $w
}
proc DetruitUnBoutonDe w {
set LesBoutons {}
set Bouton [ChoixParmi [LesBoutonsDeLaFrame $w.buttons]]
if {$Bouton==""} { return "" }
if { ! [OuiOuNon "Do You want to remove the button $Bouton ?"]} { return "" }
destroy $Bouton
return $Bouton
}
proc ShowText {Page Maniere {NomDuFichierOrigine ""}} {
Wup "Shows the text Page in a listbox, with a lot of buttons."
Wup "Copyright 1999 Raymond Ripp"
global PagePropre
set w [NomDe fenetre]
regsub -all {\t} $Page " " PagePropre($w)
if { $NomDuFichierOrigine == "" } {
set NomDuFichierOrigine "Tsointsoin"
}
toplevel $w
set Titre "$NomDuFichierOrigine"
wm title $w "$Titre"
wm iconname $w "$Titre"
label $w.msg -wraplength 4i -justify left -text "$Titre"
pack $w.msg -side top
frame $w.buttons
pack $w.buttons -side bottom -fill x -pady 2m
button $w.buttons.dismiss -text "Dismiss//?" -background "red" -command "destroy $w"
bind $w.buttons.dismiss <3> "QueFontLesBoutonsDe $w"
pack $w.buttons.dismiss -side left -expand 1
button $w.buttons.save -text "Save\nAll/Sel/Edit"
bind $w.buttons.save <1> "SaveAs \[set PagePropre($w)\]"
bind $w.buttons.save <2> "SaveAs \[selection get\]"
bind $w.buttons.save <3> "EditAndShow \[set PagePropre($w)\]"
bind $w.buttons.save "destroy $w.buttons.save"
pack $w.buttons.save -side left -expand 1
button $w.buttons.focalise -text "Nex/Top/New"
bind $w.buttons.focalise <1> "Focalise $w"
bind $w.buttons.focalise <2> "Focalise $w top"
bind $w.buttons.focalise <3> "Focalise $w ask"
pack $w.buttons.focalise -side left -expand 1
if { [regexp "AvecShow" $Maniere] } {
button $w.buttons.show -text "Show" -background green -foreground black
bind $w.buttons.show <1> {AfficheLesFichiers "[selection get]" "GrandeLargeur"}
pack $w.buttons.show -side right -expand 1
}
if {[regexp "AvecAffiProc" $Maniere]} {
button $w.buttons.affiproc -text "Show" -background "green"
bind $w.buttons.affiproc <1> "AfficheLaProc \[selection get\]"
pack $w.buttons.affiproc -side left -expand 1
}
if {[regexp "AvecCallProc" $Maniere]} {
button $w.buttons.quijappel -text "Called Procs sel./all" -background "green"
bind $w.buttons.quijappel <1> "QuiJAppel $NomDuFichierOrigine \[selection get\] "
bind $w.buttons.quijappel <2> "AfficheLesProcs NameIsIn \[QuiJAppel $NomDuFichierOrigine LaListeMerci\]"
pack $w.buttons.quijappel -side left -expand 1
button $w.buttons.quimappel -text "Calling Procs" -background "yellow"
bind $w.buttons.quimappel <1> "QuiMAppel $NomDuFichierOrigine"
pack $w.buttons.quimappel -side left -expand 1
button $w.buttons.execute -text "Execute\nEdit\nNew proc" -background "orange"
bind $w.buttons.execute <1> "CompleteEtExecute \[selection get\]"
bind $w.buttons.execute "CreeUneNouvelleProcedure \[set PagePropre($w)\]"
bind $w.buttons.execute "CreeUneNouvelleProcedure"
pack $w.buttons.execute -side left -expand 1
}
frame $w.frame -borderwidth 5
pack $w.frame -side top -expand yes -fill both
scrollbar $w.frame.yscroll -command "$w.frame.list yview"
scrollbar $w.frame.xscroll -command "$w.frame.list xview" \
-orient horizontal
set Largeur 80
set Hauteur 30
if { [regexp "GrandeLargeur" $Maniere] } { set Largeur 128 }
listbox $w.frame.list -width $Largeur -height $Hauteur -setgrid 1 \
-yscroll "$w.frame.yscroll set" \
-xscroll "$w.frame.xscroll set" \
-selectmode extended \
-background "deepskyblue4" \
-foreground "white" \
-font {Courier 10}
grid $w.frame.list -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky nsew
grid $w.frame.yscroll -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky nsew
grid $w.frame.xscroll -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky nsew
grid rowconfig $w.frame 0 -weight 1 -minsize 0
grid columnconfig $w.frame 0 -weight 1 -minsize 0
foreach Ligne [split [set PagePropre($w)] "\n"] {
$w.frame.list insert end $Ligne
}
return $w
}
proc AfficheLaRechercheDansLesBody {{Texte ""}} {
set LesTrouvees [RechercheDansLesBody $Texte]
if {$LesTrouvees=={}} { return "" }
return [ShowText [join $LesTrouvees "\n"] \
"SansFetchAvecRienAvecAffiProc" "Procs containing your text."]
}
proc RechercheDansLesBody {{Texte ""}} {
Wup "Asks which text is to search in all proc bodies"
if {$Texte==""} {
set Texte [Entre ""]
if {$Texte==""} { return ""}
}
set LesTrouvees {}
foreach Proc [LesProceduresExistantes] {
set Body [info body $Proc]
if {[regexp -nocase $Texte $Body]} {
lappend LesTrouvees $Proc
}
}
return $LesTrouvees
}
proc LesProceduresExistantes {} {
Wup "Returns the list of existing procs ... begining with Uppercase"
global LesProceduresExistantes
if { ! [info exists LesProceduresExistantes]} {
set LesProceduresExistantes [lsort [info procs {[A-Z]*}]]
}
return $LesProceduresExistantes
}
proc AfficheLaProc Procedure {
Wup "Shows the proc Procedure or lappend to the called procs"
scan [string trim $Procedure] "%s" Procedure
if {[info procs $Procedure]=={}} { return "" }
set Args [info args $Procedure]
set Body [info body $Procedure]
set TexteProc "$Procedure {$Args} {\n$Body\n}"
if {[PourWscope]} { return [Html_DuTexteTelQuel $TexteProc] }
return [ShowText $TexteProc "SansFetchAvecRienAvecCallProcGrandeLargeur" $Procedure]
}
proc AppendLaProc {SousProcedure Procedure} {
global LesSousProcedures
if {[info procs $SousProcedure]=={}} { return }
lappend LesSousProcedures($Procedure) $SousProcedure
}
proc AfficheLesProcs {{LesQuelles ""} {Liste {}}} {
Wup "Shows the names and args of all Procs"
Gs "Frame"
if { ! [PourWscope] && ! [AutorisationPourPsy] } { return "" }
set WithRef [PourWscope]
set LesBonnes {}
foreach Procedure [LesProceduresExistantes] {
set Args [info args $Procedure]
#AAAAAAAAAAAAAAAAAAAAAAAAAAFFFFFFFFFFFFFFFFFIIIIIIIIIIIIIIIIIINNNNNNNNNNNNNNNNNNNIIIIIIIIIIIIIRRR set MotProc $Procedure
# if {$WithRef} { set MotProc "