/binaries/theo/data
#! | 11949 lines | 11578 code | 371 blank | 0 comment | 0 complexity | a46072b61571bbf554c0a511964b7832 MD5 | raw file
Possible License(s): 0BSD
- ####################
- # SCRIPTREE
- # Copyright Š 2000-2008 Chevenet F. chevenet@ird.fr
- # IRD SPIRALES
- #
- # This program is under the terms of the GNU General Public License
- ####################
- ####################
- # INTERFACE
- ####################
- namespace eval Interface {
-
-
- proc TreeDynInitialisation {} {
- global tcl_platform S T db IMGshn IMGil1 B asedCon find
- #des preferences
- set S(ltoolboxusername) {}
- set S(toolboxType) all
- set S(Preference_display_eu) 1
- set S(Preference_fgc) black
- set S(Preference_mainXY) +297+129
- set S(Preference_display_eu) 1
- set S(Preference_fgc) black
- set S(version) "TreeDyn (196.3)"
- set S(treedynpack) Marianne
- set S(patchnumber) 196
- set S(manual) 1.0
- set S(TreeDynUpdate) {Marianne 196 1.0}
- set S(loc) 1
- set S(history) ""
- set S(AutoReset) 0
- set S(illustration-tabulation) 0
- set S(TabulationAnnot) 5
- set S(-family) Arial
- set S(-weight) normal
- set S(-size) 10
- set S(-slant) roman
- set S(-underline) 0
- set S(-overstrike) 0
- set S(gfo) [list -family $S(-family) \
- -weight $S(-weight) \
- -size $S(-size) \
- -slant $S(-slant) \
- -underline $S(-underline) \
- -overstrike $S(-overstrike)]
- set S(fontbase) [list -family Arial -weight normal -size 10 -slant roman -underline 0 -overstrike 0]
- # Database
- set S(lastid) 0
- set S(nbobj) 0
- set S(database) ""
- set S(ldatabase) {}
- set asedCon [interp create treedyn]
- $asedCon alias db "Database::db"
- set S(topmessage) $S(version)
- set S(ghi) grey ;# couleur de hightlight
- set S(ilt) 0 ;# liste des identificateurs tree
- set S(ilw) 0 ;# liste des identificateurs windows
- set S(col) red
- set S(display_eu) normal
- set S(nodefilter) 0
- set S(tool) move
- set S(cp) "" ; # variable contenant les arguemnts pour les copy/paste
- set S(und) "?" ; # variable undo
- set S(Xfactor) 1.0
- set S(Yfactor) 1.0
- set S(collection) "" ;# liste des ID de collection (processus de copy / paste)
- set S(browserCP_width) 150
- set S(browserCP_height) 150
- ### variable package supertree
- set S(supertreeConsDisplayNewWindow) 1
- set S(supertreeConsDisplaySameWindow) 1
- set S(supertreeConsFile) 0
- ##### variable de reset graphique
- set S(OpResetLFgC) 0
- set S(OpResetLBgC) 0
- set S(OpResetLF) 0
- set S(OpResetNFgC) 0
- set S(OpResetNBgC) 0
- set S(OpResetNLW) 0
- set S(OpResetNLD) 0
- set S(OpResetNUS) 0
- set S(OpResetNUC) 0
- set S(OpResetAL) 0
- set S(OpResetAN) 0
- set S(OpResetAC) 0
- set S(AutoReset) 0 ;# variable de reset automatic du panel "Interface::Find"
- ##### variable/ valeur par defaut pour exportation HTML
- set S(url-prefix) "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=Nucleotide&cmd=search&val="
- set S(stipple) z.xbm
- # variable clavier virtuel (illustration)
- set S(ill-family) Wingdings
- set S(ill-size) 6
- set S(ill-weight) normal
- set S(ill-overstrike) 0
- set S(ill-underline) 0
- set S(ill-slant) roman
- # operation l'identification
- set S(operation) leaffgcolor
- set S(operationName) "Leaf Foreground Color"
- set S(operationlabelisation) menu
- set S(operationdatabase) localisation
- set S(AnnotateNote) <text>
- set S(illustration-tabulation) 0
- set S(TabulationAnnot) 5
- set S(loc) 1
- set S(history) {}
- set find(case) 1
- set S(newW) 350 ;# Width et Height par defaut
- set S(newH) 350 ;# Width et Height par defaut
- set S(defaultshape) 1 ;# la forme par defaut des backgrounds
- set S(DisplayVOV) 1 ;# variable pour qLannC et qLannC360 pour differencie affichage variableValeur
- # variable MULTI IMPORT
- set S(MultiImportTDY) 0
- set S(MultiImportSFN) "0 File(s)"
- set S(MultiImportAFN) "0 File(s)"
- set S(MultiImportTRE) "0 Tree(s)"
- set S(MultiImportDII) {} ;# conservation des directories deja visitees
- set S(MultiImportTAR) new
- set S(MultiImportNBC) 3
- # fonte d'illustration par defaut
- set S(ill-fon) +
- set S(ill-car) +
- #variable SIMPLE IMPORT
- set S(SimpleImportTDY) 0
- set S(SimpleImportAFN) "0 File(s)"
- set S(SimpleImportTRE) "0 Tree(s)"
- set S(SimpleImportDII) {} ;# conservation des directories deja visitees
- # parametre par defaut Legend (identification query variable)
- set S(LegendLabels) 0
- set S(LegendVariable) 0
- set S(LegendOperator) 0
- set S(LegendOperation) 0
- set S(LegendBox) 1
- set S(LegendCadre) 0
- # variable BigImport
- set S(BIseuil) 5
- set S(ImportAUTOTAR) 1 ;# autotarget
- set S(alterTool) move
- set S(toolswitch) ""
- }
-
-
-
- }
- ####################
- ####################
- # REFLECTION
- ####################
- namespace eval Reflection {
-
- ### Transition I / Transition Empirique Simple
- proc Transition-I {w} {
- global S T
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set ti [string range $key 0 [expr [string first , $key] - 1]]
- if {$ti != 0} {
- set wi $S($ti,w)
- #liste des codes
- set SouCodLea [Tools::NodeNoToLe $t $n]
- #liste de noms
- set SouRefLea [Tools::NodeLeCoToRe $t $SouCodLea]
- Operation::Operation $wi $ti $SouRefLea
- }
- }
- }
- }
- }
-
- #
- proc ConnectionAction {w t n key} {
- global S T
- #liste des codes
- set SouCodLea [Tools::NodeNoToLe $t $n]
- #liste de noms
- set SouRefLea [Tools::NodeLeCoToRe $t $SouCodLea]
- if {$key != "nodenetwork"} {
- foreach ti $S($w,t) {
- switch $key {
- nodefgcolor {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeColorFgTree $ti $ni $S(col)
- }
- }
- leaffgcolor {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeColorFgLeaf $ti $ni $S(col)
- }
- }
- shrink {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Abstraction::Shrink $w $ti $ni
- }
- }
- unshrink {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Abstraction::ShrinkUn $w $ti $ni
- }
- }
- nodebgcolor {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeColorBgSubTree $ti $ni
- }
- }
- leafbgcolor {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeColorBgLeaf $ti $ni
- }
- }
- leaffontglob {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::FontSetGlobal $ti $ni $S(gfo)
- }
- }
- widthline+ {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeLineWidth $ti $ni +
- }
- }
- widthline- {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeLineWidth $ti $ni -
- }
- }
- nodedashOn {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeLineDash $ti $ni 1
- }
- }
- nodedashOff {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- Figuration::NodeLineDash $ti $ni 0
- }
- }
- leafhide {
- }
- leafdisplay {
- }
- collapse {
- }
- uncollapse {
- }
- anotationmatrix {
- Annotation::LabelMatrix $w $ti $SouRefLea User
- }
- }
- }
- } else {
- set lkv {}
- lappend lkv $t $n
- foreach ti $S($w,t) {
- set peres [FindFatherNode $ti $SouRefLea]
- foreach ni $peres {
- lappend lkv $ti $ni
- }
- }
- Reflection::NodeNetworkBuild $w $lkv ""
- }
- }
-
- # des feuilles vers des feuilles
- proc Transition-IIIAction {w t n database variable} {
- global S T
- # liste feuilles sources
- set SouRefLea [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $n]]
- # liste records dont la valeur de la variable contient au moins une feuille de liste source
- set MatchingRecords {}
- foreach f $SouRefLea {
- # ceci ok si la variable a pour valeurs des feuilles
- set recordsOK [Database::dbQueryRecordsFromVarPatVal $database $variable $f]
- foreach r $recordsOK {
- if {[lsearch -exact $MatchingRecords $r] == -1} {lappend MatchingRecords $r}
- }
- }
- # traduction records vers leafs
- set leaves [Database::dbQueryEusFromRecords $database $MatchingRecords]
- # localisation multi-arbres
- # allumage
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set ti [string range $key 0 [expr [string first , $key] - 1]]
- if {$ti != 0} {
- set wi $S($ti,w)
- # allumer les resultats
- Operation::Operation $w $ti $leaves
- # allumer la source et ses copies
- Operation::Operation $w $ti $SouRefLea
- }
- }
- }
- }
-
- ###
- proc Transition-IIAction {w t n database variable} {
- global S T
- # liste feuilles sources
- set SouRefLea [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $n]]
-
- # liste records correspondant aux feuilles sources
- set MatchingRecords {}
- foreach f $SouRefLea {
- set recordsOK [Database::dbQueryRecordsFromVarPatVal $database EU $f]
- foreach r $recordsOK {
- lappend MatchingRecords $r
- }
- }
- # liste valeurs pour $variable sur les matching records
- upvar #0 $database X
- set MatchingValues {}
- foreach r $MatchingRecords {
- set t $X($r)
- if {!([set pos [lsearch $t $variable]]%2)} {
- set val [lindex $t [incr pos]]
- if {[lsearch -exact $MatchingValues $val] == -1} {lappend MatchingValues $val}
- }
- }
- # Records matchant les MatchingValues sur la $database
- set MatchingRecordsFinal {}
- foreach v $MatchingValues {
- set recordsOK [Database::dbQueryRecordsFromVarPatVal $database $variable $v]
- foreach r $recordsOK {
- if {[lsearch -exact $MatchingRecordsFinal $r] == -1} {lappend MatchingRecordsFinal $r}
- }
- }
- # traduction records vers leafs
- set leaves [Database::dbQueryEusFromRecords $database $MatchingRecordsFinal]
- # localisation multi-arbres
-
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set ti [string range $key 0 [expr [string first , $key] - 1]]
- if {$ti != 0} {
- set wi $S($ti,w)
- Operation::Operation $w $ti $leaves
- }
- }
- }
- }
- ### OPTIMISATION : si un node est ok : ne pas tester ses nodes fils
- proc FindFatherNode {t SouRefLea} {
- global S T
- set L {}
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $T($t,all_cod)] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test inclusion des references leaf de TARGET avec SOURCE
- if {$S(nodefilter) == 0} {
- set r [Tools::ListInclu $TarRefLea $SouRefLea]
- if {$r == 1} {lappend L $TarCodNod}
- } else {
- set r [Tools::ListIncluSauf $TarRefLea $SouRefLea $S(nodefilter)]
- if {$r == 1} {lappend L $TarCodNod}
- }
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {
- if {[lsearch -exact $T($t,ue_lab) $SouRefLea] != -1} {return $T($t,ltc,$SouRefLea)} else {return {}}
- }
- }
- ### allume fg leafs et nodes a partir d'un node select par user
- ### et compare les topologies, transmission aux tree de la meme fenetre
- ### selon resultats comparaison
- proc Congruence {w} {
- global S T
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- foreach ti $S($w,t) {
- congruenceTNs $t $n $ti
- }
- }
- }
- # cette proc applique la procedure congruenceTN a tous les nodes
- # issus de nsource issue de tsource
- proc congruenceTNs {tsource nsource ttarget} {
- global T S
- #
- set lresult {}
- # Figuration::NodeColorFgTree $tsource $nsource $S(col)
- set nodesfromsource [Tools::NodeNoCoFaToNoCoCh $tsource $nsource]
- # on ne prend pas en compte les codes des feuilles
- set latest [Tools::SousL $nodesfromsource $T($tsource,ue_cod)]
- foreach node $latest {
- lappend lresult [congruenceTN $tsource $node $ttarget]
- }
- #puts LRESULT$lresult
- if {[lsearch $lresult 0] == -1} {
- Figuration::NodeColorFgTree $ttarget [lindex $lresult 0] $S(col)
- }
- }
- # si il existe un et un seul node pere de ttarget commun
- # aux leafs names de tsource pour nsource, cette fonction
- # retourne ce node, sinon retourne 0
- proc congruenceTN {tsource nsource ttarget} {
- # liste des noms leafs de tsource pour nsource
- set SouCodLea [Tools::NodeNoToLe $tsource $nsource]
- set SouRefLea [Tools::NodeLeCoToRe $tsource $SouCodLea]
- # recherche d'un node pere a ces leafs sur ttarget
- set result [Tools::FatherSearch2 $ttarget $SouRefLea]
- #puts ===================
- #puts $SouRefLea
- #puts $result
- if {$result != "" && [llength $result] == 1} {
- return $result
- } else {
- return 0
- }
- }
-
- # compl?Šter un reseau, cad ajouter des nodes
- # sachant l'id d'un node network, on reactive la descrition du reseau
- # avec en argument le dernier element de B($id,CONnod)
- proc ReStartNodeNetwork {w id} {
- global S B
- set lasttree [lindex $B(CONtre,$id) end]
- set S(tool) connect
- bindtags $w [list $S(tool) $w Canvas . all]
- bind connect <Button-1> "Reflection::Connection %W $id"
- bind connect <Double-Button-1> "Reflection::UpdateLinkStop %W $lasttree $id"
- bind connect <Motion> "Reflection::UpdateLink %W $lasttree $id %x %y"
- }
- # delete
- proc ConnectorDelete {w id} {
- global B S
- # nettoyage canvas
- $w delete [format "%s%s%s" Connect ? $id]
- $w delete [format "%s%s%s" ConIconTag ? $id]
- # nettoyage array B
- unset B(CONtre,$id)
- unset B(CONnod,$id)
- unset B(CONnot,$id)
- # retrait
- set index [lsearch -exact $S($w,con) $id]
- set S($w,con) [concat [lrange $S($w,con) 0 [expr $index - 1]] \
- [lrange $S($w,con) [expr $index + 1] end]]
- }
- ### voir modifications pour network en etoile
- proc UpdateLink {w t id xmouse ymouse} {
- global B S
- set lcoords {}
- foreach n $B(CONnod,$id) {
- set co [$w coords $n]
- lappend lcoords [lindex $co 0] [lindex $co 1]
- }
- lappend lcoords [expr $xmouse - 5] [expr $ymouse - 5]
- # prise en compte figuration preexistante
- set j [format "%s%s%s" Connect ? $id ]
- if {[$w find withtag $j] != ""} {
- set width_line [lindex [$w itemconfigure $j -width] end]
- set dash_line [lindex [$w itemconfigure $j -dash] end]
- set color_line [lindex [$w itemconfigure $j -fill] end]
- } else {
- set width_line 1
- set dash_line {2 2}
- set color_line $S(col)
- }
- $w delete $j
- if {$lcoords != {} } {
- $w create line $lcoords -width $width_line -fill $color_line -dash $dash_line \
- -tags "Connect [format "%s%s%s" Connect ? $id ] "
- }
- $w lower Connect
- }
- #
- proc UpdateLinkStop {w t id} {
- global B
- set lcoords {}
- foreach n $B(CONnod,$id) {
- set co [$w coords $n]
- lappend lcoords [lindex $co 0] [lindex $co 1]
- }
- set j [format "%s%s%s" Connect ? $id ]
- set width_line [lindex [$w itemconfigure $j -width] end]
- set dash_line [lindex [$w itemconfigure $j -dash] end]
- set color_line [lindex [$w itemconfigure $j -fill] end]
- $w delete $j
- if {[llength $lcoords] != 2 } {
- $w create line $lcoords -fill $color_line -dash $dash_line -width $width_line \
- -tags "Connect $j"
- }
- bind connect <Button-1> "Reflection::Connection %W"
- # mise a nil pour le reste
- bind connect <Motion> ""
- bind connect <Double-Button-1> ""
- }
- #
- proc UpdateAll {w} {
- global B S
- foreach id $S($w,con) {
- set lcoords {}
- foreach n $B(CONnod,$id) {
- set co [$w coords $n]
- lappend lcoords [lindex $co 0] [lindex $co 1]
- }
- set j [format "%s%s%s" Connect ? $id ]
- set width_line [lindex [$w itemconfigure $j -width] end]
- set dash_line [lindex [$w itemconfigure $j -dash] end]
- set color_line [lindex [$w itemconfigure $j -fill] end]
- set state [lindex [$w itemconfigure $j -state] end]
- $w delete $j
- if {[llength $lcoords] != 2 } {
- $w create line $lcoords -fill $color_line -dash $dash_line -width $width_line \
- -tags "Connect $j" -state $state
- }
- }
- $w lower Connect
- }
- proc ConnectNoteOk {w id} {
- global B
- set B(CONnot,$id) [.connectnote.st get 1.0 end]
- destroy .connectnote
- Reflection::ConnectorIconifyUpdate $w $id
- }
- # network ON/OFF
- proc ConnectorIconifyONOFF {w id} {
- set connector [format "%s%s%s" Connect ? $id ]
- set etat [$w itemcget $connector -state]
- if {$etat == "normal"} {
- $w itemconfigure $connector -state hidden
- } else {
- $w itemconfigure $connector -state normal
- }
- }
- #
- proc ConnectorIconify {w id x y } {
- global B S
- set connector [format "%s%s%s" Connect ? $id ]
- set ConIconTag [format "%s%s%s" ConIconTag ? $id]
- # destruction de l'ancien si existe, mais on conserve x y
- set idtext [$w find withtag [list $ConIconTag && text]]
- set idline [$w find withtag [list $ConIconTag && line]]
- if {$idline != ""} {
- set coords [$w coords $idline]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- $w delete $idtext
- $w delete $idline
- }
- # $w delete $idtext
- # on masque le reseau
- $w itemconfigure $connector -state hidden
- # on cree l'icon
- #set color [lindex [$w itemconfigure $connector -fill] end]
- set width_line [lindex [$w itemconfigure $connector -width] end]
- set dash_line [lindex [$w itemconfigure $connector -dash] end]
- set color_line [lindex [$w itemconfigure $connector -fill] end]
- $w create line $x $y [expr $x + 20] $y -width $width_line -dash $dash_line -fill $color_line \
- -tag "ConnectIcon $id $ConIconTag line"
- if {$B(CONnot,$id) != "" } {
- $w create text $x [expr $y + 3] -text "$B(CONnot,$id)" -anchor nw \
- -tag "ConnectIcon $id $ConIconTag text" -fill $color_line -font $S(gfo)
- } else {
- $w create text $x [expr $y + 3] -text "" -anchor nw \
- -tag "ConnectIcon $id $ConIconTag text" -fill $color_line -font $S(gfo)
- }
- }
- # mise a jour icone node network apres annotation network (display ON)
- proc ConnectorIconifyUpdate {w id} {
- global B
- set ConIconTag [format "%s%s%s" ConIconTag ? $id]
- set idtext [$w find withtag [list $ConIconTag && text]]
- $w itemconfigure $idtext -text $B(CONnot,$id) -anchor nw
- }
- #
- proc ConnectorIconRemove {w id} {
- set ConIconTag [format "%s%s%s" ConIconTag ? $id]
- $w delete $ConIconTag
- ConnectorIconifyONOFF $w $id
- }
- proc ConnectorMerge {w idsource lid} {
- global B
- # fusion de node network
- # lid est soit un id de node network soit une liste d'id node network (selection de all)
- # mise a jour array
- foreach id $lid {
- #tre
- foreach tid $B(CONtre,$id) {
- if {[lsearch $B(CONtre,$idsource) $tid] == -1} {
- lappend B(CONtre,$idsource) $tid
- }
- }
- #nod
- foreach nid $B(CONnod,$id) {
- if {[lsearch $B(CONnod,$idsource) $nid] == -1} {
- lappend B(CONnod,$idsource) $nid
- }
- }
- # mise en ordre
- set B(CONnod,$idsource) [lsort -dictionary $B(CONnod,$idsource)]
- # not
- foreach notid $B(CONnot,$id) {
- # on ne garde les note que si elle sont differente de id et pas deja referencees
- if {$notid != $id} {
- if {[lsearch $B(CONnot,$idsource) $notid] == -1} {
- lappend B(CONnot,$idsource) $notid
- }
- }
- }
- #deletion graphique
- Reflection::ConnectorDelete $w $id
- }
- # mise a jour graphic de idsource
- UpdateAll $w
- }
- proc NodeNetworkBuild {w lkv note} {
- global B S
- set id [Tools::GenId]
- if {$note == ""} {set note $id}
- # liste tree
- set B(CONtre,$id) {}
- # liste node
- set B(CONnod,$id) {}
- # note
- set B(CONnot,$id) [list $note]
- # liste id network / window
- lappend S($w,con) $id
- foreach {tree node} $lkv {
- lappend B(CONtre,$id) $tree
- lappend B(CONnod,$id) $node
- }
- # graphic
- set lcoords {}
- foreach n $B(CONnod,$id) {
- set co [$w coords $n]
- lappend lcoords [lindex $co 0] [lindex $co 1]
- }
- set j [format "%s%s%s" Connect ? $id ]
- set width_line 1
- set dash_line {2 2}
- set color_line $S(col)
- $w delete $j
- if {[llength $lcoords] != 2 } {
- $w create line $lcoords -fill $color_line -dash $dash_line -width $width_line \
- -tags "Connect $j"
- }
- }
-
- }
- ####################
- ####################
- # FIGURATION
- ####################
- namespace eval Figuration {
- ###
- proc FontSet {t w n variable value} {
- global T
- set f [lindex [$w itemconfigure [format "%s%s" $n EUL] -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == $variable} {lappend fnew $var $value} {lappend fnew $var $val}
- }
- set T($t,gfo,$n) $fnew
- $w itemconfigure [format "%s%s" $n EUL] -font $fnew
- }
- ###
- proc LineSize {mode} {
- global T S
- RecLineSize $S(ict) $mode
- if {$S(com) != {}} {
- foreach t $S(com) {
- set current [string range $t 2 [expr [string first .c $t] -1]]
- if {$current != $S(ict)} {
- RecLineSize $current $mode
- }
- }
- }
- }
-
- ###
- proc RecLineSize {t mode} {
- global T S
- set w [format "%s%s%s" .t $t .c]
- if {$mode == "+" || $mode == "-"} {
- if {$T($t,sel) == "*"} {
- foreach c $T($t,all_cod) {
- set code [format "%s%s" $c L]
- set width_line [lindex [$w itemconfigure $code -width] end]
- set new_wl [expr abs($width_line $mode 1)]
- $w itemconfigure $code -width $new_wl
- $w itemconfigure [format "%s%s" $code C] -width $new_wl
- set T($t,gls,$code) $new_wl
- }
- }
- if {$T($t,sel) != "*"} {
- foreach c $T($t,sel) {
- set code [format "%s%s" $c L]
- set width_line [lindex [$w itemconfigure $code -width] end]
- set new_wl [expr abs($width_line $mode 1)]
- $w itemconfigure $code -width $new_wl
- set T($t,gls,$code) $new_wl
- }
- }
- } else {
-
- if {$T($t,sel) == "*"} {
- foreach c $T($t,all_cod) {
- set code [format "%s%s" $c L]
- set new_wl 1
- $w itemconfigure $code -width $new_wl
- $w itemconfigure [format "%s%s" $code C] -width $new_wl
- set T($t,gls,$code) $new_wl
- }
- }
- if {$T($t,sel) != "*"} {
- foreach c $T($t,sel) {
- set code [format "%s%s" $c L]
- set new_wl 1
- $w itemconfigure $code -width $new_wl
- set T($t,gls,$code) $new_wl
- }
- }
- }
- if {$S(desel) == 1} {TBA::UnSelect $w}
- }
- ###
- proc PreLineStipple {mode} {
- global T S
- set t $S(ict)
- set w [format "%s%s%s" .t $t .c ]
- LineStipple $t $w $mode
- if {$S(com) != {}} {
- foreach w $S(com) {
- set t [string range $w 2 [expr [string first .c $w] -1]]
- if {$t != $S(ict)} {
- LineStipple $t $w $mode
- }
- }
- }
- }
- ###
- proc LineStipple {t w mode} {
- global T S
- foreach c $T($t,sel) {
- set code [format "%s%s" $c L]
- set dash_line [lindex [$w itemconfigure $code -dash] end]
- if {$mode == "+" || $mode == "-"} {
- switch -exact $dash_line {
- 1 { if {$mode == "+"} {
- set new_dl 2
- } else {
- set new_dl {}
- }
- }
- 15 { if {$mode == "+"} {
- set new_dl {}
- } else {
- set new_dl 14
- }
- }
- {} { if {$mode == "+"} {
- set new_dl 1
-
- } else {
- set new_dl 15
- }
- }
- default {
- set new_dl [expr abs($dash_line $mode 1)]
- }
- }
- } else {set new_dl {}}
- set T($t,gld,$c) $new_dl
- $w itemconfigure $code -dash $new_dl
- }
- if {$S(desel) == 1} {TBA::UnSelect $w}
- }
- #
- proc RedrawT {w t} {
- $w delete T$t
- TDcom::PhyNJ $t $w
- }
- # restauration sur un arbre entier
- proc RestaureT {w t} {
- #restauration des variables graphiques
- # gfg lbg lfg bbg gfo gls gld
- NodeGraVarRest $t
- # 2 variables graphiques particulieres (items suplementaires)
- # les bg tree et leaf
- Figuration::RestaureBGSall $w $t
- Figuration::RestaureBGLall $w $t
- ### restauration des variables de dessin
- # DANS L'ORDRE decomposition, bll , querynode, shrink
- #RestaureOVAall $w $t
- RestaureBLLall $w $t
- RestaureQYNall $w $t
- RestaureShrinkAll $w $t
- }
- #
- proc RestaureShrinkAll {w t} {
- global T S B IMGshn
- # il faut reconstruire la structure hierarchique des shrink
- # les plus anciens shrink d'abord, ajout incr?Šmental du tag
- # si le tag est deja present on tag pas
- foreach id [lsort -increasing $B($t,shi)] {
- set TAG [format "%s%s%s" SHI ? $id]
- # dessin
- set c0 [$w coords $B(SHInod,$id)]
- set x0 [lindex $c0 2]
- set y0 [lindex $c0 3]
- # passer au bitmap set $S(col)
- $w create text [expr $x0 +5] $y0 -text + \
- -tags "SHRINK [format "%s%s%s" SHN ? $id] T$t" -font $B(SHIfon,$id) -fill $B(SHIcol,$id)
- # bll associees a n et ses derives
- set pattern [format "%s%s" $B(SHInod,$id) *]
- foreach idbll $B($t,bll) {
- if {[string match $pattern $B(BLLnod,$idbll)] == 1 } {
- if {[$w itemcget $B(BLLidt,$idbll) -state] != "hidden"} {
- $w addtag $TAG withtag $B(BLLidt,$idbll)
- $w addtag $TAG withtag $B(BLLidl,$idbll)
- $w itemconfigure $B(BLLidt,$idbll) -state hidden
- $w itemconfigure $B(BLLidl,$idbll) -state hidden
- }
- }
- }
- # leaves
- set leafs [Tools::NodeNoToLe $t $B(SHInod,$id)]
- foreach i $leafs {
- set tagi [list [format "%s%s" EUL $T($t,ctl,$i)] && T$t]
- if {[$w itemcget $tagi -state] != "hidden"} {
- $w addtag $TAG withtag $tagi
- $w itemconfigure $tagi -state hidden
- }
- }
- # background leaves
- set pattern [format "%s%s" $B(SHInod,$id) *]
- foreach idi $B($t,bgl) {
- if {[string match $pattern $B(BGLnod,$idi)] == 1} {
- if {[$w itemcget [format "%s%s%s" BGL ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGL ? $idi]
- $w itemconfigure [format "%s%s%s" BGL ? $idi] -state hidden
- }
- }
- }
- # arretes terminales
- set Le [Tools::NodeNoToLe $t $B(SHInod,$id)]
- foreach e $Le {
- if {[$w itemcget $e -state] != "hidden"} {
- $w addtag $TAG withtag $e
- $w itemconfigure $e -state hidden
- }
- }
- # tree
- set lchild [Tools::NodeNoCoFaToNoCoCh $t $B(SHInod,$id)]
- foreach i $lchild {
- if {[$w itemcget $i -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s" $i C]
- $w itemconfigure [format "%s%s" $i C] -state hidden
- }
- }
- # background tree
- set pattern [format "%s%s" $B(SHInod,$id) *]
- foreach idi $B($t,bgs) {
- if {[string match $pattern $B(BGSnod,$idi)] == 1} {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGS ? $idi]
- $w itemconfigure [format "%s%s%s" BGS ? $idi] -state hidden
- }
- }
- }
- # sous shrink
- set pattern [format "%s%s" $B(SHInod,$id) *]
- foreach idi $B($t,shi) {
- if {[string match $pattern $B(SHInod,$idi)] == 1 && $id != $idi} {
- if {[$w itemcget [format "%s%s%s" SHN ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" SHN ? $idi]
- $w itemconfigure [format "%s%s%s" SHN ? $idi] -state hidden
- set B(SHIsta,$idi) hidden
- }
- }
- }
- }
- }
- #
- proc RestaureBLLall {w t} {
- global B
- set l {}
- foreach id $B($t,bll) {
- $w create text $B(BLLxxx,$id) $B(BLLyyy,$id) \
- -text $B(BLLtxt,$id) -font $B(BLLgfo,$id) -fill $B(BLLcol,$id) -anchor nw \
- -tags "bullab T$B(BLLtre,$id) $B(BLLidt,$id)"
- set co_sou [$w coords $B(BLLnod,$id)]
- set x1 [lindex $co_sou 0]
- set y1 [lindex $co_sou 1]
- $w create line $x1 $y1 $B(BLLxxx,$id) $B(BLLyyy,$id) \
- -width 1 -fill $B(BLLcol,$id) -tags "Link T$B(BLLtre,$id) $B(BLLidl,$id)"
- }
- }
- #
- proc RestaureQYNall {w t} {
- global B
- foreach id $B($t,qyn) {
- set idtext [format "%s%s%s" QYN ? $id]
- $w create text $B(QYNxxx,$id) $B(QYNyyy,$id) \
- -text [lrange $B(QYNqry,$id) [expr [lsearch $B(QYNqry,$id) where] + 1] end] \
- -font $B(QYNgfo,$id) -fill $B(QYNcol,$id) -anchor nw \
- -tags "querynode T$t $B(QYNidt,$id)"
- $w raise Q$t
- }
- }
- #
- proc RestaureOVAall {w t} {
- global B
- set lnodlid {}
- foreach id $B($t,ova) {
- lappend lnodlid $B(OVAnod2,$id)
- set decomp($B(OVAnod2,$id)) $id
- }
- foreach n [lsort -increasing $lnodlid] {
- set id $decomp($n)
- set TAG [format "%s%s%s" TD ? $id]
- Decomposition::SubTreeDescendant $w $t $n $id $TAG
-
- $w move $TAG $B(OVAtrx,$id) $B(OVAtry,$id)
- }
- Decomposition::UpdateLink $w $t
- if [array exists decomp] {unset decomp}
- }
- #
- proc RestaureBGSall {w t} {
- global T S B
- set lnodes {}
- foreach idi $B($t,bgs) {
- $w delete [format "%s%s%s" BGS ? $idi]
- lappend lnodes $B(BGSnod,$idi)
- set transit($B(BGSnod,$idi)) $idi
- }
- foreach ni [lsort -increasing $lnodes] {
- # compatibilit?Š sauvegarde precedent la creation variable du type des contours et stipple
- if {[catch {set v $B(BGStyp,$transit($ni))} err]} then {set B(BGStyp,$transit($ni)) 1}
- if {[catch {set v $B(BGSsti,$transit($ni))} err]} then {set B(BGSsti,$transit($ni)) z.xbm}
- set lxy [Figuration::NodeColorBgSubTreeContourSwitch $w $t $ni $B(BGStyp,$transit($ni))]
- set idi $transit($ni)
- set tag [format "%s%s%s" BGS ? $idi]
- if {$B(BGSsti,$idi) == "z.xbm"} {
- $w create polygon $lxy -outline $B(BGScol,$idi) -fill $B(BGScol,$idi) -tags "bgtree T$t $tag"
- } else {
- #$w create polygon $lxy -outline $B(BGScol,$idi) -fill $B(BGScol,$idi) -tags "bgtree T$t $tag" \
- # -stipple @[file join [file dirname [info script]] +/stipple/ $B(BGSsti,$idi)]
- #
- # ATTENTION a rester sur un path relatif
- #$w create polygon $lxy -outline $B(BGScol,$idi) -fill $B(BGScol,$idi) -tags "bgtree T$t $tag" \
- # -stipple @[file join $S(stidir) $B(BGSsti,$idi)]
- # @[file join + stipple $S(stipple)]
-
- $w create polygon $lxy -outline $B(BGScol,$idi) -fill $B(BGScol,$idi) -tags "bgtree T$t $tag" \
- -stipple @[file join $S(TheoPATH) + stipple $B(BGSsti,$idi)]
- }
- }
- $w lower bgtree
- if {[array exists transit] == 1} {unset transit}
- }
- #
- proc RestaureBGLall {w t} {
- global T S B
- set lnodes {}
- foreach idi $B($t,bgl) {
- $w delete [format "%s%s%s" BGL ? $idi]
- lappend lnodes $B(BGLnod,$idi)
- set transit($B(BGLnod,$idi)) $idi
- }
- foreach ni $lnodes {
- set lab $T($t,ctl,$ni)
- set coords [$w bbox [list [format "%s%s" EUL $lab ] && T$t]]
- if {$coords != ""} {
- set x1 [lindex $coords 0]
- set y1 [expr [lindex $coords 1] -1]
- set x2 [lindex $coords 2]
- set y2 [lindex $coords 3]
- set idi $transit($ni)
- set tag [format "%s%s%s" BGL ? $idi]
- # dessin
- $w create rectangle $x1 $y1 $x2 $y2 \
- -fill $B(BGLcol,$idi) -outline $B(BGLcol,$idi) \
- -tags "bgleaf T$t $tag"
- }
- }
- $w lower bgleaf
- if {[array exists transit] == 1} {unset transit}
- }
- #
- proc RedrawBGLall {w t} {
- global T B
- foreach idi $B($t,bgl) {
- set lab $T($t,ctl,$B(BGLnod,$idi))
- set coords [$w bbox [list [format "%s%s" EUL $lab ] && T$t]]
- if {$coords != ""} {
- $w coords [format "%s%s%s" BGL ? $idi] $coords
- }
- }
- }
- ### Procedure de restauration des variables graphiques sur tout l'arbre
- proc NodeGraVarRest {t} {
- global S T
- set w $S($t,w)
- ###
- # T($t,gfg,$n) restauration des foreground color tree
- # on classe les codes pour fg les subtree de la racine vers les feuilles
- set li [lsort -dictionary [array names T $t,gfg,*]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- Figuration::NodeColorFgItem $w $j $T($key)
- }
- }
- }
- ###
- # T($t,lfg,$n) restauration des foreground color leaf
- foreach key [array names T $t,lfg,*] {
- set n [string range $key [expr [string last , $key] + 1] end]
- set lab $T($t,ctl,$n)
- $w itemconfigure [list [format "%s%s" EUL $lab ] && T$t] -fill $T($key)
- }
- ###
- # T($t,gld,$n) restauration des line dash
- set li [lsort -dictionary [array names T $t,gld,*]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- $w itemconfigure $j -dash $T($key)
- }
- }
- }
- ###
- # set T($t,gls,$i) restauration des line width
- set li [lsort -dictionary [array names T $t,gls,*]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- $w itemconfigure $j -width $T($key)
- }
- }
- }
- ###
- # set T($t,gfo,$i) restauration des font
- foreach key [array names T $t,gfo,*] {
- set n [string range $key [expr [string last , $key] + 1] end]
- set lab $T($t,ctl,$n)
- set i [$w find withtag [list [format "%s%s" EUL $lab ] && T$t]]
- $w itemconfigure $i -font $T($key)
- }
- }
- #Procedure de restauration des variables graphiques a partir de N
- #independance de l'existence de variable
- proc NodeGraVarRestLOCAL {t n} {
- global S T
- set w $S($t,w)
- set p [format "%s%s" $n *]
- ###
- # T($t,gfg,$n) restauration des foreground color tree
- # on classe les codes pour fg les subtree de la racine vers les feuilles
- set li [lsort -dictionary [array names T $t,gfg,$p]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- Figuration::NodeColorFgItem $w $j $T($key)
- }
- }
- }
- ###
- # T($t,lfg,$n) restauration des foreground color leaf
- foreach key [array names T $t,lfg,$p] {
- set n [string range $key [expr [string last , $key] + 1] end]
- set lab $T($t,ctl,$n)
- $w itemconfigure [list [format "%s%s" EUL $lab ] && T$t] -fill $T($key)
- }
- ###
- # T($t,gld,$n) restauration des line dash
- set li [lsort -dictionary [array names T $t,gld,$p]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- $w itemconfigure $j -dash $T($key)
- }
- }
- }
- ###
- # set T($t,gls,$i) restauration des line width
- set li [lsort -dictionary [array names T $t,gls,$p]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- $w itemconfigure $j -width $T($key)
- }
- }
- }
- ###
- # set T($t,gfo,$i) restauration des font
- foreach key [array names T $t,gfo,$p] {
- set n [string range $key [expr [string last , $key] + 1] end]
- set lab $T($t,ctl,$n)
- set i [$w find withtag [list [format "%s%s" EUL $lab ] && T$t]]
- $w itemconfigure $i -font $T($key)
- }
- }
-
-
- # T($t,gfg,$n) init des foreground color tree
- # a l'appel n* = les desceandants aussi
- # par defaut l'arbre entier
- proc GraVarInitFgTree {w t {n *}} {
- global T S
- # liste key soit une si n soit peut etre liste si n*, fonction de l'appel
- set li [lsort -dictionary [array names T $t,gfg,$n]]
- foreach key $li {
- # destruction variable
- unset T($key)
- # coloration back to default
- # set node [string range $key [expr [string last , $key] + 1] end]
- set p [format "%s%s" $n *]
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- Figuration::NodeColorFgItem $w $j $S(Preference_fgc)
- }
- }
- }
- }
- # si que n restauration locale sur d'eventuelle variable
- # si n* on a tout detruit donc pas besoin de restauration
- if {[string range $n end end] != "*"} {
- #restauration locale et specifique variable
- set p [format "%s%s" $n *]
- set li [lsort -dictionary [array names T $t,gfg,$p]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set Le [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach e $Le {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- Figuration::NodeColorFgItem $w $j $T($key)
- }
- }
- }
- }
- }
- # init des background color tree
- proc GraVarInitBgSubTree {w t {n *}} {
- if {[string range $n end end] == "*"} {
- NodeColorBgSubTreeRemoveAll $t $n
- } else {
- NodeColorBgSubTreeRemove $t $n
- }
- }
- # init des background color tree
- #proc GraVarInitBgSubTree {w t} {
- # foreach j [$w find withtag [list bgtree && T$t]] {
- # Figuration::NodeColorBgSubTreeDelete $w $j
- # }
- #}
- # T($t,lfg,$n) init des foreground color leaf
- proc GraVarInitFgLeaf {w t {n *}} {
- global T S
- if {$n != "*"} {set pattern [format "%s%s" $n *]} {set pattern *}
- foreach key [array names T $t,lfg,$pattern] {
- set n [string range $key [expr [string last , $key] + 1] end]
- set lab $T($t,ctl,$n)
- $w itemconfigure [list [format "%s%s" EUL $lab ] && T$t] -fill $S(Preference_fgc)
- unset T($key)
- }
- }
- # init des background color leaf
- proc GraVarInitBgLeaf {w t {n *}} {
- global T S B
- set listid {}
-
- if {$n != "*"} {set p [format "%s%s" $n *]} {set p *}
- foreach {k v} [array get B BGLnod,*] {
- if {[string match $p $v] == 1} {
- lappend listid [string trimleft $k "BGLnod," ]
- }
- }
- foreach id $listid {
- $w delete [format "%s%s%s" BGL ? $id]
- set w $S($t,w)
- set t $B(BGLtre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- set index [lsearch -exact $B($t,bgl) $id]
- set B($t,bgl) [concat [lrange $B($t,bgl) 0 [expr $index - 1]] \
- [lrange $B($t,bgl) [expr $index + 1] end]]
- }
- }
-
- # set T($t,gfo,$i) init des font
- proc GraVarInitFont {w t {n *}} {
- global T S
- foreach key [array names T $t,gfo,$n] {
- set n [string range $key [expr [string last , $key] + 1] end]
- set lab $T($t,ctl,$n)
- $w itemconfigure [list [format "%s%s" EUL $lab] && T$t] -font $S(fontbase)
- unset T($key)
- }
- }
- # T($t,gls,$c) la taille du trait
- proc GraVarInitLineWidth {w t {n *}} {
- global T
- set li [lsort -dictionary [array names T $t,gls,$n]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set p [format "%s%s" $n *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- lappend listeitems $j
- }
- }
- }
- foreach i $listeitems {
- $w itemconfigure $i -width 1
- }
- unset T($key)
- }
- }
- # T($t,gld,$c) le pointille du trait
- proc GraVarInitLineDash {w t {n *}} {
- global T
- set li [lsort -dictionary [array names T $t,gld,$n]]
- foreach key $li {
- set n [string range $key [expr [string last , $key] + 1] end]
- set p [format "%s%s" $n *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- lappend listeitems $j
- }
- }
- }
- foreach i $listeitems {
- $w itemconfigure $i -dash {}
- }
- unset T($key)
- }
- }
- # reset general de tous les arbres de toutes les fenetres
- proc ResetGlob {} {
- global S
- set l {}
- foreach key [array names S *,w] {
- foreach t $S($S($key),t) {
- if {[lsearch -exact $l $t] == -1} {lappend l $t}
- }
- }
- foreach t $l {
- Figuration::NodeGraVarInit $t
- }
- }
-
- # procedure de suppression de toutes les variables graphiques
- proc NodeGraVarInit {t} {
- global S T
- set w $S($t,w)
- # init des foreground color tree
- GraVarInitFgTree $w $t
- # init des background color tree
- GraVarInitBgSubTree $w $t
- # init des background color leaf
- GraVarInitBgLeaf $w $t
- # T($t,lfg,$n) init des foreground color leaf
- GraVarInitFgLeaf $w $t
- # set T($t,gfo,$i) init des font
- GraVarInitFont $w $t
- # T($t,gls,$c) la taille du trait
- GraVarInitLineWidth $w $t
- # T($t,gld,$c) le pointille du trait
- GraVarInitLineDash $w $t
- }
- proc GraVarInitAllN {w t n} {
- GraVarInitFgTree $w $t $n
- GraVarInitBgSubTree $w $t $n
- GraVarInitBgLeaf $w $t $n
- GraVarInitFgLeaf $w $t $n
- GraVarInitFont $w $t $n
- GraVarInitLineWidth $w $t $n
- GraVarInitLineDash $w $t $n
- }
- # fonction de copy des variables graphiques d'un arbre vers un autre
- ## c un peu magique mais ca marche, il y a corespondance
- ## exacte entre les codes tsource/ttarget, cela vient de la procedure NodeNoCoFaToNoCoCh
- proc TransitionVG {w tsource npere ttarget} {
- global T S B
- set lnodesFrom [Tools::NodeNoCoFaToNoCoCh $tsource $npere]
- set lnodesTo [Tools::NodeNoCoFaToNoCoCh $ttarget $ttarget]
- foreach nf $lnodesFrom nt $lnodesTo {
- set transition($nf) $nt
- }
- set lnodesFrom2 [lsort -dictionary [Tools::NodeFathers $tsource $npere]]
- foreach nf $lnodesFrom2 {
- set transition2($nf) $ttarget
- }
- # GROUPE 1, on prend en compte les nodes ascendants
- # variables T
- set lvar {gfg lfg gld gls gfo}
- foreach nf $lnodesFrom2 {
- foreach var $lvar {
- if {[catch {set v $T($tsource,$var,$nf)} err]} then {
- #rien
- } else {
- set T($ttarget,$var,$transition2($nf)) $v
- }
- }
- }
- # BGL bg leaves
- foreach idbgl $B($tsource,bgl) {
- if {[lsearch -exact $lnodesFrom2 $B(BGLnod,$idbgl)] != -1} {
- Figuration::NodeColorBgLeaf2 $ttarget $transition2($B(BGLnod,$idbgl)) $B(BGLcol,$idbgl)
- }
- }
- # BGS bg subtree
- foreach idbgs $B($tsource,bgs) {
- if {[lsearch -exact $lnodesFrom2 $B(BGSnod,$idbgs)] != -1} {
- Figuration::NodeColorBgSubTree2 $ttarget $transition2($B(BGSnod,$idbgs)) $B(BGScol,$idbgs) $B(BGSsti,$idbgs)
- }
- }
- # GROUPE 2 on ne prend pas en compte les ascendants
- # variables graphiques
- set lvar {gfg lfg gld gls gfo}
- foreach nf $lnodesFrom {
- foreach var $lvar {
- if {[catch {set v $T($tsource,$var,$nf)} err]} then {
- #rien
- } else {
- set T($ttarget,$var,$transition($nf)) $v
- }
- }
- }
- # BGL bg leaves
- foreach idbgl $B($tsource,bgl) {
- if {[lsearch -exact $lnodesFrom $B(BGLnod,$idbgl)] != -1} {
- Figuration::NodeColorBgLeaf2 $ttarget $transition($B(BGLnod,$idbgl)) $B(BGLcol,$idbgl)
- }
- }
- # BGS bg subtree
- foreach idbgs $B($tsource,bgs) {
- if {[lsearch -exact $lnodesFrom $B(BGSnod,$idbgs)] != -1} {
- Figuration::NodeColorBgSubTree2 $ttarget $transition($B(BGSnod,$idbgs)) $B(BGScol,$idbgs) $B(BGSsti,$idbgs)
- }
- }
- # variables B : shi bll ova
- # construction des items (mais array seuleument, pas graphique)
- # BLL
- # on prend les nodes des bll on regarde si ils sont dans la liste des nodes copies
- foreach bi $B($tsource,bll) {
- if {[lsearch -exact $lnodesFrom $B(BLLnod,$bi)] != -1} {
- set co [$w coords $transition($B(BLLnod,$bi))]
- set x [lindex $co 0]
- set y [lindex $co 1]
- set titx [string first "\n" $B(BLLtxt,$bi)]
- set titre [string range $B(BLLtxt,$bi) 0 [expr $titx - 1]]
- set text [string range $B(BLLtxt,$bi) [expr $titx + 1] end]
- # BLLmake2 ne construit que les array
- Annotation::BLLmake2 $w $ttarget $x $y $titre $text $transition($B(BLLnod,$bi)) $B(BLLcol,$bi) $B(BLLgfo,$bi)
- }
- }
- ### OVA
- # on prend les nodes sous decomposition et on regarde si ils sont dans la liste des nodes copies
- foreach idc $B($tsource,ova) {
- if {[lsearch -exact $lnodesFrom $B(OVAnod2,$idc)] != -1} {
- Decomposition::SubTree2 $ttarget $B(OVAtrx,$idc) $B(OVAtry,$idc) $transition($B(OVAnod2,$idc))
- }
- }
- # SHI en dernier
- # il suffit de reconstruire les shrink en partant des plus bas
- # afin d'appliquer le state/tag de visiblite au fur et a mesure
- set lni {}
- # on prend les nodes qui sont shrink et on regarde si ils sont dans la liste des nodes copies
- foreach si $B($tsource,shi) {
- if {[lsearch -exact $lnodesFrom $B(SHInod,$si)] != -1} {lappend lni $B(SHInod,$si)}
- }
- # on ordonne ensuite les codes nodes, les plus profons d'abord, la fct shrink
- # reconstruit la strucutre imbriqu?Še des shrink
- foreach ni [lsort -decreasing $lni] {
- Abstraction::Shrink2 $w $ttarget $transition($ni) $S(col)
- }
- unset transition
- }
-
-
- ###set S(contour2mode) c ; set S(contour2mode) d ;
- proc NodeColorBgSubTreeToolbox {w command} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- switch -exact $command {
- add1 {NodeColorBgSubTree $t $n}
- remove {NodeColorBgSubTreeRemove $t $n}
- removeall {NodeColorBgSubTreeRemoveAll $t $n}
- menushape {SetDefaultShape $w}
- }
- Figuration::RestaureBGSall $w $t
- }
- }
-
- ### Background color of Subtree
- # on calcule le pourtour du sous-arbre
- # pour etre independant des orientations des arbres et des items
- # on compare les normes des vecteurs entre chaque extremites et
- #une des coordonn?Šes du node pere
- proc NodeColorBgSubTree {t n} {
- global T S B
-
- set w $S($t,w)
- set id [format "%s%s" $t [Tools::GenId]]
- # MEM
- set B(BGStre,$id) $t
- set B(BGSnod,$id) $n
- set B(BGScol,$id) $S(col)
- set B(BGSsti,$id) $S(stipple)
- set B(BGStyp,$id) $S(defaultshape)
- # Liste des BGS par tree
- lappend B($t,bgs) $id
- # RestaureBGSall est place ailleurs car trop long en identification
- #Figuration::RestaureBGSall $w $t
- }
- proc NodeColorBgSubTreeSwitch {w i type} {
- global S B
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BGS*]] ?] end]
- set B(BGStyp,$id) $type
- Figuration::RestaureBGSall $w $B(BGStre,$id)
- }
- proc NodeColorBgSubTreeUpdateStipple {w i} {
- global S B
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BGS*]] ?] end]
- set B(BGSsti,$id) $S(stipple)
- Figuration::RestaureBGSall $w $B(BGStre,$id)
- }
- #
- proc NodeColorBgSubTreeRemove {t n } {
- global T S B
- set w $S($t,w)
- set listid {}
- foreach {k v} [array get B BGSnod,*] {
- if {$n == $v} {
- lappend listid [string trimleft $k "BGSnod," ]
- }
- }
- foreach id $listid {
- $w delete [format "%s%s%s" BGS ? $id]
- set w $S($t,w)
- set t $B(BGStre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bgs) $id]
- set B($t,bgs) [concat [lrange $B($t,bgs) 0 [expr $index - 1]] \
- [lrange $B($t,bgs) [expr $index + 1] end]]
- }
- }
- #
- proc NodeColorBgSubTreeRemoveAll {t n } {
- global T S B
- set w $S($t,w)
- set p [format "%s%s" $n *]
- set listid {}
- foreach {k v} [array get B BGSnod,*] {
- if {[string match $p $v] == 1} {
- lappend listid [string trimleft $k "BGSnod," ]
- }
- }
- foreach id $listid {
- $w delete [format "%s%s%s" BGS ? $id]
- set w $S($t,w)
- set t $B(BGStre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bgs) $id]
- set B($t,bgs) [concat [lrange $B($t,bgs) 0 [expr $index - 1]] \
- [lrange $B($t,bgs) [expr $index + 1] end]]
- }
- }
- #
- proc NodeColorBgSubTree2 {t n c s} {
- global T S B
- set id [format "%s%s" $t [Tools::GenId]]
- # MEM
- set B(BGStre,$id) $t
- set B(BGSnod,$id) $n
- set B(BGScol,$id) $c
- set B(BGSsti,$id) $s
- # Liste des BGS par tree
- lappend B($t,bgs) $id
- }
- #
- proc NodeColorBgSubTreeDelete {w i} {
- global B S
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BGS*]] ?] end]
- $w delete [format "%s%s%s" BGS ? $id]
- set t $B(BGStre,$id)
- set w $S($t,w)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bgs) $id]
- set B($t,bgs) [concat [lrange $B($t,bgs) 0 [expr $index - 1]] \
- [lrange $B($t,bgs) [expr $index + 1] end]]
- }
- #
- proc NodeColorBgSubTreeUpateColor {w i c} {
- global B S
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BGS*]] ?] end]
- $w itemconfigure [format "%s%s%s" BGS ? $id] -fill $c -outline $c
- set B(BGScol,$id) $c
- }
- proc NodeColorBgSubTreeContourSwitch {w t n mode} {
- switch $mode {
- 1 {set lxy [NodeColorBgSubTreeContour $w $t $n]}
- 2 {set lxy [NodeColorBgSubTreeContour2 $w $t $n 2]}
- 3 {set lxy [NodeColorBgSubTreeContour2 $w $t $n 3]}
- 4 {set lxy [NodeColorBgSubTreeContour2 $w $t $n 4]}
- 5 {set lxy [NodeColorBgSubTreeContour2 $w $t $n 5]}
- }
- return $lxy
- }
- ###
- proc NodeColorBgSubTreeContour {w t n} {
- #on trace le polygon du contour du sous-arbre
- # depart
- set lxy {}
- set leafs [Tools::NodeNoToLe $t $n]
- set nodes [Tools::SousL [Tools::NodeNoCoFaToNoCoCh $t $n] $n]
- set sbase [string length $n]
- if {[llength $leafs] != 1 } {
- # descandants gauche y compris feuilles
- set ldesgauche {}
- foreach ni [lsort -increasing $nodes] {
- set suffixe [string range $ni $sbase end]
- if {[string match *d* $suffixe] == 0} {
- lappend ldesgauche $ni
- }
- }
- # ascendants droits y compris feuilles
- set lascdroit {}
- foreach ni [lsort -decreasing $nodes] {
-
- set suffixe [string range $ni $sbase end]
-
- if {[string match *g* $suffixe] == 0} {
- lappend lascdroit $ni
- }
- }
- # feuilles intermediaires (sans les descandants feuilles g et d)
- set leafsinter [Tools::SousL $leafs [concat $ldesgauche $lascdroit]]
- # coordonnees
- set lxy {}
- # la base
- set npap [Tools::NodeParentNode $t $n]
- if {$npap == $t || $npap == ""} {
- set npap [format "%s%s" $t C]
- }
- set conp [$w coords $npap]
- set xp [lindex $conp 0]
- set yp [lindex $conp 1]
-
- if {$n == $t || $n == ""} {
- set n2 [format "%s%s" $t C]
- } else {
- set n2 $n
- }
- # NB pb avec les copy paste
- set coni [$w coords $n2]
- set x1 [lindex $coni 0]
- set y1 [lindex $coni 1]
- set x2 [lindex $coni 2]
- set y2 [lindex $coni 3]
- set norm1 [expr sqrt((($xp - $x1) * ($xp - $x1)) + (($yp - $y1) * ($yp - $y1)))]
- set norm2 [expr sqrt((($xp - $x2) * ($xp - $x2)) + (($yp - $y2) * ($yp - $y2)))]
- if {$norm1 <= $norm2} {
- lappend lxy [list $x2 $y2]
- } else {
- lappend lxy [list $x1 $y1]
- }
- # descandants gauche
- foreach i $ldesgauche {
- set npap [Tools::NodeParentNode $t $i]
- if {$npap == $t} {
- set npap [format "%s%s" $t C]
- }
- set conp [$w coords $npap]
-
- set xp [lindex $conp 0]
- set yp [lindex $conp 1]
- set coni [$w coords $i]
- set x1 [lindex $coni 0]
- set y1 [lindex $coni 1]
- set x2 [lindex $coni 2]
- set y2 [lindex $coni 3]
- set norm1 [expr sqrt((($xp - $x1) * ($xp - $x1)) + (($yp - $y1) * ($yp - $y1)))]
- set norm2 [expr sqrt((($xp - $x2) * ($xp - $x2)) + (($yp - $y2) * ($yp - $y2)))]
- if {$norm1 <= $norm2} {
- lappend lxy [list $x1 $y1 $x2 $y2]
- } else {
- lappend lxy [list $x2 $y2 $x1 $y1]
- }
- }
- # feuilles
- foreach i $leafsinter {
- set npap [Tools::NodeParentNode $t $i]
- if {$npap == $t} {
- set npap [format "%s%s" $t C]
- }
- set conp [$w coords $npap]
- set xp [lindex $conp 0]
- set yp [lindex $conp 1]
- set coni [$w coords $i]
- set x1 [lindex $coni 0]
- set y1 [lindex $coni 1]
- set x2 [lindex $coni 2]
- set y2 [lindex $coni 3]
- set norm1 [expr sqrt((($xp - $x1) * ($xp - $x1)) + (($yp - $y1) * ($yp - $y1)))]
- set norm2 [expr sqrt((($xp - $x2) * ($xp - $x2)) + (($yp - $y2) * ($yp - $y2)))]
- if {$norm1 <= $norm2} {
- lappend lxy [list $x2 $y2]
- } else {
- lappend lxy [list $x1 $y1]
- }
- }
- # ascendants droits
- foreach i $lascdroit {
- set npap [Tools::NodeParentNode $t $i]
- if {$npap == $t} {
- set npap [format "%s%s" $t C]
- }
- set conp [$w coords $npap]
- set xp [lindex $conp 0]
- set yp [lindex $conp 1]
- set coni [$w coords $i]
- set x1 [lindex $coni 0]
- set y1 [lindex $coni 1]
- set x2 [lindex $coni 2]
- set y2 [lindex $coni 3]
- set norm1 [expr sqrt((($xp - $x1) * ($xp - $x1)) + (($yp - $y1) * ($yp - $y1)))]
- set norm2 [expr sqrt((($xp - $x2) * ($xp - $x2)) + (($yp - $y2) * ($yp - $y2)))]
- if {$norm1 <= $norm2} {
- lappend lxy [list $x2 $y2 $x1 $y1]
- } else {
- lappend lxy [list $x1 $y1 $x2 $y2]
- }
- }
- regsub -all "\{" $lxy "" lxy
- regsub -all "\}" $lxy "" lxy
- } else {
- set lxy [$w coords $n]
- }
- return $lxy
- }
- #
- ### NodeColorBgSubTreeContour2 un background tree en rectangle
- proc NodeColorBgSubTreeContour2 {w t n mode} {
- global S T
- # x1 (partie commune)
- if {$n == $t || $n == ""} {
- set n [format "%s%s" $t C]
- }
- set cop [$w coords $n]
- set xp1 [lindex $cop 0]
- set xp2 [lindex $cop 2]
- if {$xp1 < $xp2} {
- set x1 $xp1
- } else {
- set x1 $xp2
- }
- # x2 (xmax) y1 (ymin) y2 (ymax)
- set leafs [Tools::NodeNoToLe $t $n]
- set x2 0 ; set y1 100000 ; set y2 0
- # NB pas de switch sur 1 qui correpond au contour 1
- switch -exact $mode {
- 2 {
- foreach i $leafs {
- # le texte des feuilles n'est pas pris en compte
- set coi [$w coords $i]
- set xi1 [lindex $coi 0]
- set yi1 [lindex $coi 1]
- set xi2 [lindex $coi 2]
- set yi2 [lindex $coi 3]
- # x2
- if {$xi1 > $xi2} {
- if {$xi1 > $x2} {set x2 $xi1}
- } else {
- if {$xi2 > $x2} {set x2 $xi2}
- }
- # y1 et y2
- if {$yi1 > $yi2} {
- # y1: on regarde yi2
- if {$yi2 < $y1} {set y1 $yi2}
- # y2: on regarde yi1
- if {$yi1 > $y2} {set y2 $yi1}
- } else {
- # y1: on regarde yi1
- if {$yi1 < $y1} {set y1 $yi1}
- # y2: on regarde yi2
- if {$yi2 > $y2} {set y2 $yi2}
- }
- }
- }
- 3 {
- # prise en compte des texte feuilles
- foreach i $leafs {
- set ii [$w find withtag [list [format "%s%s" EUL $T($t,ctl,$i)] && T$t]]
- set coi [$w bbox $ii]
- # le texte des feuilles n'est pas pris en compte
- #set coi [$w coords $i]
- set xi1 [lindex $coi 0]
- set yi1 [lindex $coi 1]
- set xi2 [lindex $coi 2]
- set yi2 [lindex $coi 3]
- # x2
- if {$xi1 > $xi2} {
- if {$xi1 > $x2} {set x2 $xi1}
- } else {
- if {$xi2 > $x2} {set x2 $xi2}
- }
- # y1 et y2
- if {$yi1 > $yi2} {
- # y1: on regarde yi2
- if {$yi2 < $y1} {set y1 $yi2}
- # y2: on regarde yi1
- if {$yi1 > $y2} {set y2 $yi1}
- } else {
- # y1: on regarde yi1
- if {$yi1 < $y1} {set y1 $yi1}
- # y2: on regarde yi2
- if {$yi2 > $y2} {set y2 $yi2}
- }
- }
- }
- 4 {
- # cas d'un xmax commun a tous les backgrounds, non prise en compte des annotations
- set coi [$w bbox [list T$t && L]]
- set x2 [lindex $coi 2]
- foreach i $leafs {
- set tagi [format "%s%s" EUL $T($t,ctl,$i)]
- #set coi [$w coords $tagi]
- set coi [$w bbox [list $tagi && T$t]]
- set xi1 [lindex $coi 0]
- set yi1 [lindex $coi 1]
- set xi2 [lindex $coi 2]
- set yi2 [lindex $coi 3]
- # y1 et y2
- if {$yi1 > $yi2} {
- # y1: on regarde yi2
- if {$yi2 < $y1} {set y1 $yi2}
- # y2: on regarde yi1
- if {$yi1 > $y2} {set y2 $yi1}
- } else {
- # y1: on regarde yi1
- if {$yi1 < $y1} {set y1 $yi1}
- # y2: on regarde yi2
- if {$yi2 > $y2} {set y2 $yi2}
- }
- }
- }
- 5 {
- # cas d'un xmax commun a tous les backgrounds, prise en compte des annotations
- set coi [$w bbox T$t]
- set x2 [lindex $coi 2]
- foreach i $leafs {
- set tagi [format "%s%s" EUL $T($t,ctl,$i)]
- #set coi [$w coords $tagi]
- set coi [$w bbox [list $tagi && T$t]]
- set xi1 [lindex $coi 0]
- set yi1 [lindex $coi 1]
- set xi2 [lindex $coi 2]
- set yi2 [lindex $coi 3]
- # y1 et y2
- if {$yi1 > $yi2} {
- # y1: on regarde yi2
- if {$yi2 < $y1} {set y1 $yi2}
- # y2: on regarde yi1
- if {$yi1 > $y2} {set y2 $yi1}
- } else {
- # y1: on regarde yi1
- if {$yi1 < $y1} {set y1 $yi1}
- # y2: on regarde yi2
- if {$yi2 > $y2} {set y2 $yi2}
- }
- }
- }
- }
- # redim x2 (du au bounding box du bbox)
- # original return [list $x1 $y1 [expr $x2 -2] $y1 [expr $x2 -2] $y2 $x1 $y2]
- return [list $x1 [expr $y1 + 3] [expr $x2 -2] [expr $y1 + 3] [expr $x2 -2] [expr $y2 - 3] $x1 [expr $y2 - 3]]
- }
- ###
- proc NodeColorBgLeafToolbox {w command} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- switch -exact $command {
- add {NodeColorBgLeaf $t $n}
- remove {NodeColorBgLeafRemove $t $n}
- }
-
- }
- }
- ### foreground color leaf via node pere
- proc NodeColorFgLeaf {t n c} {
- global T S
- set w $S($t,w)
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- $w itemconfigure [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t] -fill $c
- set T($t,lfg,$code) $c
- }
- }
- ###
- proc NodeColorFgLeafToolbox {w} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- NodeColorFgLeaf $t $n $S(col)
- }
- }
- ###
- proc NodeColorFgLeafToolboxRemove {w} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- GraVarInitFgLeaf $w $t $n
- }
- }
- ###
- proc NodeLineDashToolbox {w o} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- NodeLineDash $t $n $o
- }
- }
- # NodeLineDash
- # variable binaire
- # donc on ne creer une variable graphique que pour l'etat dash
- # et une variable globale pour le noeud a l'origine du sous-arbre
- proc NodeLineDash {t n o} {
- global T S
- set w $S($t,w)
- set p [format "%s%s" $n *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- lappend listeitems $e
- }
- }
- # creation d'une variable pour chaque node
- if {$o == "1"} {
- foreach i $listeitems {
- $w itemconfigure $i -dash {2 2}
- $w itemconfigure [format "%s%s" $i C] -dash {2 2}
- set T($t,gld,$i) {2 2}
- }
- } else {
- # il faut supprimer les variables des nodes issues de $code
- # set pattern [format "%s%s" $n *]
- # foreach key [array names T $t,gld,$pattern] {
- # unset T($key)
- # }
- foreach i $listeitems {
- $w itemconfigure $i -dash {}
- $w itemconfigure [format "%s%s" $i C] -dash {}
- set T($t,gld,$i) {}
- }
- }
- }
-
- ###
- proc NodeLineWidthToolbox {w o} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- if {[string length $o] == "1"} {
- NodeLineWidth $t $n $o
- } {NodeLineWidthSet $t $n $o}
-
- }
- }
- # NodeLineWidth augmente (si o = +) ou diminue ( o = -)
- # la valeur des epaisseurs de traits issus de node
- # donc creation d'une variable graphique propre a chaque element
- # (possiblilite d'avoir des epaisseur differentes pour les arretes de n)
- proc NodeLineWidth {t n o} {
- global T S
- set w $S($t,w)
- set p [format "%s%s" $n *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- foreach j [$w find withtag [format "%s%s" $e C]] {
- set width_line [lindex [$w itemconfigure $j -width] end]
- set new_wl [expr abs($width_line $o 1)]
- $w itemconfigure $j -width $new_wl
- set T($t,gls,$e) $new_wl
- }
- }
- }
- }
- # NodeLineWidth augmente (si o = +) ou diminue ( o = -)
- # la valeur des epaisseurs de traits issus de node
- # donc creation d'une variable graphique propre a chaque element
- # (possiblilite d'avoir des epaisseur differentes pour les arretes de n)
- proc NodeLineWidth2 {t n o} {
- global T S
- set w $S($t,w)
- set item [$w find withtag $n]
- set width_line [lindex [$w itemconfigure $item -width] end]
- set new_wl [expr abs($width_line $o 1)]
- $w itemconfigure $item -width $new_wl
-
-
- }
- # NodeLineDash2
- # variable binaire
- # donc on ne creer une variable graphique que pour l'etat dash
- # et une variable globale pour le noeud a l'origine du sous-arbre
- proc NodeLineDash2 {t n o} {
- global T S
- set w $S($t,w)
- set item [$w find withtag $n]
- $w itemconfigure $item -dash {2 2}
-
- }
- # cette fonction met l'epaisseur de trait des arretes issues de n
- # a la valeur de l'epaisseur de trait de n augmente/diminue de 1 (toutes
- # les arretes auront la meme epaisseur)
- proc NodeLineWidthSet {t n o} {
- global T S
- if {$o == "++"} {set o +} else {set o -}
- set w $S($t,w)
- set p [format "%s%s" $n *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- lappend listeitems $e
- }
- }
- set width_line [lindex [$w itemconfigure $n -width] end]
- set new_wl [expr abs($width_line $o 1)]
- foreach i $listeitems {
- $w itemconfigure $i -width $new_wl
- $w itemconfigure [format "%s%s" $i C] -width $new_wl
- #set T($t,gls,$i) $new_wl
- }
- # on detruit les variables sous-jacentes
- set pattern [format "%s%s" $n *]
- foreach key [array names T $t,gls,$pattern] {
- unset T($key)
- }
- # on stocke la variable pour le noeud pere
- set T($t,gls,$n) $new_wl
- }
- # le probleme de la presence de multiple arbres ds la meme w et
- # ayant des eu names en commun est resolu via le bbox &&
- proc NodeColorBgLeaf {t n } {
- global T S B
- set w $S($t,w)
- set p [format "%s%s" $n *]
- set listneu {}
- foreach e $T($t,ue_cod) {
- if {[string match $p $e] == 1} {
- lappend listneu $e
- }
- }
- foreach i $listneu {
- set id [format "%s%s" $t [Tools::GenId]]
- # MEM
- set B(BGLtre,$id) $t
- set B(BGLnod,$id) $i
- set B(BGLcol,$id) $S(col)
- # Liste des BGL par tree
- lappend B($t,bgl) $id
- }
- Figuration::RestaureBGLall $w $t
- }
- #
- proc NodeColorBgLeafRemove {t n } {
- global T S B
- set w $S($t,w)
- set p [format "%s%s" $n *]
- set listid {}
- foreach {k v} [array get B BGLnod,*] {
- if {[string match $p $v] == 1} {
- #lappend listid [string range $k [expr [string first , $k] - 1]] end ]
- lappend listid [string trimleft $k "BGLnod," ]
- }
- }
- foreach id $listid {
- $w delete [format "%s%s%s" BGL ? $id]
- set w $S($t,w)
- set t $B(BGLtre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bgl) $id]
- set B($t,bgl) [concat [lrange $B($t,bgl) 0 [expr $index - 1]] \
- [lrange $B($t,bgl) [expr $index + 1] end]]
- }
- Figuration::RestaureBGLall $w $t
- }
- #
- proc NodeColorBgLeafDelete {w i} {
- global B S
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BGL*]] ?] end]
- $w delete [format "%s%s%s" BGL ? $id]
- set t $B(BGLtre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bgl) $id]
- set B($t,bgl) [concat [lrange $B($t,bgl) 0 [expr $index - 1]] \
- [lrange $B($t,bgl) [expr $index + 1] end]]
- }
- #
- proc NodeColorBgLeaf2 {t n c} {
- global T S B
- set p [format "%s%s" $n *]
- foreach e $T($t,ue_cod) {
- if {[string match $p $e] == 1} {
- set id [format "%s%s" $t [Tools::GenId]]
- # MEM
- set B(BGLtre,$id) $t
- set B(BGLnod,$id) $e
- set B(BGLcol,$id) $c
- # Liste des BGL par tree
- lappend B($t,bgl) $id
- }
- }
- }
- ### idem NodeColorBgLeaf mais l'argument est une liste de leafs et non un code node pere
- proc EUColorBgLeaf {t eus c} {
- global T S B
- set w $S($t,w)
- foreach i $eus {
- set id [format "%s%s" $t [Tools::GenId]]
- # MEM
- set B(BGLtre,$id) $t
- set B(BGLnod,$id) $T($t,ltc,$i)
- #set B(BGLcol,$id) $S(col)
- set B(BGLcol,$id) $c
- # Liste des BGL par tree
- lappend B($t,bgl) $id
- }
- Figuration::RestaureBGLall $w $t
- }
- ### couleur d'ecriture des text leaf, arg = liste eu
- proc EUColorFgLeaf {t eus c} {
- global T S
- set w $S($t,w)
- foreach i $eus {
- set tag [list [format "%s%s" EUL $i ] && T$t]
- # creation des variables graphiques
- #set T($t,lfg,$T($t,ltc,$i)) $S(col)
- set T($t,lfg,$T($t,ltc,$i)) $c
- # dessin
- $w itemconfigure $tag -fill $c
- }
- }
- ###
- proc NodeColorFgTag {w tag color} {
- set listeitems [$w find withtag $tag]
- foreach i $listeitems {
- switch [$w type $i] {
- line - text {
- $w itemconfigure $i -fill $color
- }
- rectangle - polygon - oval - arc {
- $w itemconfigure $i -outline $color
- }
- }
- }
- }
- ###
- proc NodeColorFgItem {w item color} {
- switch [$w type $item] {
- line {
- $w itemconfigure $item -fill $color
- }
- rectangle - polygon - oval - arc {
- $w itemconfigure $item -outline $color
- }
- }
- }
- ###
- proc NodeColorFgTreeToolbox {w} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- NodeColorFgTree $t $n $S(col)
- }
- }
- ###
- proc NodeColorFgTreeToolboxRemove {w} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- GraVarInitFgTree $w $t $n
- }
- }
- ### cette fonction modifie la valeur $T($ti,gfg,$node) (affecte $color)
- ### elle est utilisee par la localisation et NodeColorFgTreeToolbox
- proc NodeColorFgTree {t code color} {
- global T S
- set w $S($t,w)
- set p [format "%s%s" $code *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- foreach j [$w find withtag [format "%s%s" $e C]] {
- NodeColorFgItem $w $j $color
- }
- }
- }
- # il faut supprimer les variables des nodes issues de $code
- set pattern [format "%s%s" $code *]
- foreach key [array names T $t,gfg,$pattern] {
- unset T($key)
- }
- # on cree la variable graphique pour le node pere seuleument
- set T($t,gfg,$code) $color
- }
- ### cette fonction modifie la valeur $T($ti,gfg,$node) (affecte $color)
- ### elle est utilisee par la localisation et NodeColorFgTreeToolbox
- proc NodeColorFgTree2 {t code color} {
- global T S
- set w $S($t,w)
- #set p [format "%s%s" $code *]
- set item [$w find withtag $code]
- # set item [$w find withtag [format "%s%s" $code C]]
- NodeColorFgItem $w $item $color
- }
- ### cette fonction modifie la valeur $T($ti,gfg,$node) (affecte $color)
- ### elle est utilisee par la localisation et NodeColorFgTreeToolbox
- proc NodeColorFgTreeNoMem {t code color} {
- global T S
- set w $S($t,w)
- set p [format "%s%s" $code *]
- set listeitems {}
- foreach e $T($t,all_cod) {
- if {[string match $p $e] == 1} {
- foreach j [$w find withtag [list [format "%s%s" $e C] && T$t]] {
- lappend listeitems $j
- }
- }
- }
- foreach i $listeitems {
- NodeColorFgItem $w $i $color
- }
- }
- ###
- proc CatchColor {w} {
- global S
- set i [$w find withtag current]
- set color ""
- switch [$w type $i] {
- rectangle - polygon - oval - line - text {
- set color [lindex [$w itemconfigure $i -fill] end]
- }
- arc {
- set color [lindex [$w itemconfigure $i -outline] end]
- }
- }
- if {$color != ""} {
- set S(col) $color
- if {[winfo exists .colorpanel.sample] == 1} {.colorpanel.sample configure -background $S(col)}
- set winwin [format "%s%s%s" .colorpanel.dic. $S(col) .b]
- if {[winfo exists $winwin] == 1} {$winwin select}
- }
- }
- ###
- proc CatchFont {w} {
- global S
- set i [$w find withtag current]
- set font ""
- switch [$w type $i] {
- text {
- set font [lindex [$w itemconfigure $i -font] end]
- }
- }
- if {$font != ""} {
- set S(gfo) $font
- foreach {var val} $font {
- set S($var) $val
- }
- if {[winfo exists .fontpanel.msg] == 1} {.fontpanel.msg configure -font $S(gfo)}
- }
- }
-
- ###
- proc FontWeight {w} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- set i [$w find withtag [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t]]
- set f [lindex [$w itemconfigure $i -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == "-weight"} {
- if {$val == "bold"} {set val normal} {set val bold}
- }
- lappend fnew $var $val
- }
- set T($t,gfo,$code) $fnew
- $w itemconfigure $i -font $fnew
- }
- }
- }
- ###
- proc FontSlant {w} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- set i [$w find withtag [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t]]
- set f [lindex [$w itemconfigure $i -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == "-slant"} {
- if {$val == "roman"} {set val italic} {set val roman}
- }
- lappend fnew $var $val
- }
- set T($t,gfo,$code) $fnew
- $w itemconfigure $i -font $fnew
- }
-
- }
- }
- ###
- proc FontOverstrike {w} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- set i [$w find withtag [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t]]
- set f [lindex [$w itemconfigure $i -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == "-overstrike"} {
- if {$val == "true"} {set val false} {set val true}
- }
- lappend fnew $var $val
- }
- set T($t,gfo,$code) $fnew
- $w itemconfigure $i -font $fnew
- }
- }
- }
- ###
- proc FontUnderline {w} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- set i [$w find withtag [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t]]
- set f [lindex [$w itemconfigure $i -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == "-underline"} {
- if {$val == "true"} {set val false} {set val true}
- }
- lappend fnew $var $val
- }
- set T($t,gfo,$code) $fnew
- $w itemconfigure $i -font $fnew
- }
- }
- }
- ### OK
- proc FontSize {w mode} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- set i [$w find withtag [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t]]
- set f [lindex [$w itemconfigure $i -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == "-size"} {
- if {$mode == "+"} {set val [incr val]} {set val [incr val -1]}
- }
- lappend fnew $var $val
- }
- set T($t,gfo,$code) $fnew
- $w itemconfigure $i -font $fnew
- }
- }
- }
- ### OK
- proc FontSetGlobalToolbox {w} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- FontSetGlobal $t $n $S(gfo)
-
- }
- }
- ### Font du panel Font, via un node pere
- proc FontSetGlobal {t n font} {
- global T S
- set w $S($t,w)
- set leafs [Tools::NodeNoToLe $t $n]
- foreach code $leafs {
- $w itemconfigure [list [format "%s%s" EUL $T($t,ctl,$code)] && T$t] -font $font
- set T($t,gfo,$code) $font
- }
- }
- ### Font du panel Font, via une liste d'eu
- proc FontSetGlobalEU {t eus font} {
- global T S
- set w $S($t,w)
- foreach eu $eus {
- $w itemconfigure [list [format "%s%s" EUL $eu] && T$t] -font $font
- set T($t,gfo,$T($t,ltc,$eu)) $font
- }
- }
- ###
- proc FontSet {t w n variable value} {
- global T
- set f [lindex [$w itemconfigure [format "%s%s" $n EUL] -font] end]
- set fnew {}
- foreach {var val} $f {
- if {$var == $variable} {lappend fnew $var $value} {lappend fnew $var $val}
- }
- set T($t,gfo,$n) $fnew
- $w itemconfigure [format "%s%s" $n EUL] -font $fnew
- }
- ###
- proc RecFoSw {t variable value} {
- global T S
- set w [format "%s%s%s" .t $t .c]
- foreach code $T($t,sel) {
- if {[lsearch -exact $T($t,ue_cod) $code] != -1} {
- FontSet $t $w $code $variable $value
- }
- }
-
- }
-
- }
- ####################
- ####################
- # INTEGRATION
- ####################
- namespace eval Integration {
-
-
- ### renvoie une chaine newick a partir d'un fichier nexus
- proc NexusToNewick {} {
- global S
- set fSource $S(NexusFileIN)
- set fTarget $S(NexusFileOUT)
- if {$fSource != "" && $fTarget != ""} {
- if [catch {open $fSource r} fidS] {
- puts stderr "Error Opening File"
- } else {
- set s [read $fidS]
- regsub -all "\n" $s "" s
- regsub -all {\[} $s "" s
- # suppression des signes - sur les longueurs de branches
- #regsub -all {:-} $s ":" s
- regsub -all {\]} $s "" s
-
-
- #OK puts $s
- set fidT [open $fTarget w]
- # un petit regexp pour recuperer dans blaa la liste des feuilles 1 BLSK, 2 SHSFH, 3 SGGSS
- regexp {Translate(.+?);} $s bla blaa
- #OK puts $blaa
- # un petit foreach pour ranger dans une liste $l les nom des feuilles {BLSK SHSFH SGGSS}
- foreach e $blaa {
- if {[regexp {^[0-9]+$} $e ] ==0} {
- regexp {[^,]+} $e e1
- lappend l $e1
- }
- }
- # un petit regexp de nouveau pour recuperer dans blaa1 l'arbre en format ((1:346.34,2:56.6):876.9,3:1.9)
- # original regexp {;[^(]+([^;]+);(E|e)nd;} $s bla1 blaa1
- regexp {;[^(]+([^;]+);(E|e)nd;} $s bla1 blaa1
- # initialisation de la variable qui va contenir le resultat final
- set Nick {}
- set i 0
- # un petit regsub pour spliter $blaa1 de la forme ((1,2),3) pour la forme ( ( 1 , 2 ) , 3 )
- # pour traiter blaa1 comme une liste avec un foreach
- # Tout d'abord l'arbre a t'il des longueur de feuilles ou faut-il en mettre?
- if [regexp : $blaa1] {
- regsub -all {(\(|,|\)|:)} $blaa1 { & } blaa1
- # un petit foreach pour remplacer dans l'expression $blaa1 les chiffres par le nom
- # des feuilles stocke dans $l
- foreach e $blaa1 {
- if {[regexp {^[0-9]+$} $e] & [lindex $blaa1 [expr $i+1]] == ":"} {
- set Nick $Nick[lindex $l [expr $e -1]]
- } elseif [string equal $e ")"] {
- set Nick $Nick)
- } {
- set Nick $Nick$e
- }
- incr i
- }
- } {
- regsub -all {(\(|,|\))} $blaa1 { & } blaa1
- # un petit foreach pour remplacer dans l'expression $blaa1 les chiffres par le nom
- # des feuilles stocke dans $l
- foreach e $blaa1 {
- if [regexp {^[0-9]+$} $e] {
- set Nick $Nick[lindex $l [expr $e -1]]:1.0
- } elseif [string equal $e ")"] {
- set Nick $Nick):1.0
- } {
- set Nick $Nick$e
- }
- }
-
- }
- # et c'est fini
- #return $Nick
- puts $fidT "$Nick ;"
- close $fidT
- close $fidS
- }
- }
- }
- # traductoin fichier matrice leaves*variables vers fichier records label file fo treedyn
- proc MakeLabelFile {} {
- global S
- set fSource $S(MakeLabelFileIN)
- set fTarget $S(MakeLabelFileOUT)
- if {$fSource != "" && $fTarget != ""} {
- set fidS [open $fSource r]
- set fidT [open $fTarget w]
- # premiere ligne = liste de variable
- set nbrows 1
- set lrowsBad ""
- gets $fidS variables
- while {[eof $fidS] != 1} {
- incr nbrows
- gets $fidS row
- # verification a faire sur le nombre de valeurs correspondant nombre de variables
- set data ""
- if {[llength $variables] == [llength $row]} {
- # le premier couple var val doit etre EU / $eu on ecrit que $eu sans {}
- set data [lindex $row 0 0]
- #ok
- foreach var [lrange $variables 1 end] val [lrange $row 1 end] {
- set data [concat $data $var [format "%s%s%s" "{" $val "}"]]
- }
- puts $fidT $data
- } else {
- # attention si retour charriot sur la derniere ligne du fichier
- if {$row != ""} {
- set lrowsBad [concat $lrowsBad "Row: $nbrows ([lindex $row 0]) \n"]
- }
- }
- }
- if {$lrowsBad != ""} {
- tk_messageBox -type ok -default ok -icon warning \
- -message "Missing non-paired item/value list ($fSource):\n $lrowsBad"
- }
- close $fidS
- close $fidT
- }
- }
- #
- proc MIbackfile {} {
- set files [.fsp.lfb.l get 0 end]
- destroy .fsp
- .int.n.canvas.notebook.cs.page1.cs.ld.l delete 0 end
- foreach f $files {
- .int.n.canvas.notebook.cs.page1.cs.ld.l insert 0 $f
- }
- }
- #
- proc MIupdateAvailableFile {} {
- global S
- .fsp.lfa.l delete 0 end
- set filter [.fsp.fi get]
- if {$filter == "ALL"} { set pattern *
- } else {
- set pattern [format "%s%s" * $filter]
- }
- #[format "%s%s" $S(userDIR) /?.nwk]
- set AFN [lsort [glob -nocomplain -type f -dir $S(userDIR) $pattern]]
- set S(MultiImportAFN) "[llength $AFN] File(s)"
- foreach f $AFN {
- .fsp.lfa.l insert end [file tail $f]
- }
- MIConfigBg
- }
- #
- proc MIConfigBg {} {
- global S
- # config bg si deja en selection
- set lfselectavecDir {}
- set lfselectsansDir {}
- foreach e [.fsp.lfb.l get 0 end] {
- lappend lfselectsansDir [file tail $e]
- lappend lfselectavecDir $e
- }
- set index 0
- foreach f [.fsp.lfa.l get 0 end] {
- if {[lsearch $lfselectavecDir [format "%s%s%s" $S(userDIR) / $f]] != -1} {
- .fsp.lfa.l itemconfigure $index -background NavajoWhite2
- } elseif {[lsearch $lfselectsansDir $f] != -1} {
- .fsp.lfa.l itemconfigure $index -background NavajoWhite3
- } else {
- .fsp.lfa.l itemconfigure $index -background LightGoldenrodYellow
- }
- incr index
- }
- }
- #
- proc MIupdateDirectories {} {
- global S
- .fsp.ld.l delete 0 end
- foreach d [lsort [glob -nocomplain -type d -dir $S(userDIR) *]] {
- .fsp.ld.l insert end [file tail $d]
- }
- .fsp.ld.l insert 0 ..
- }
- #
- proc MIupdateFol {f} {
- global S
- set S(userDIR) $f
- MIupdateDirectories
- MIupdateAvailableFile
- MIupdateFilter
- }
- #
- proc MIaddFile {} {
- global S
- set li [.fsp.lfa.l curselection] ;# des index
- set lsel {}
- foreach i $li {
- lappend lsel [.fsp.lfa.l get $i]
- .fsp.lfa.l itemconfigure $i -background NavajoWhite2
- }
- set lall2 [.fsp.lfb.l get 0 end]
- .fsp.lfb.l delete 0 end
- foreach e $lsel {
- lappend lall2 [format "%s%s%s" $S(userDIR) / $e]
- }
- foreach e $lall2 {
- .fsp.lfb.l insert 0 $e
- }
- # deselection des fichiers liste available
- .fsp.lfa.l selection clear 0 end
- # conservation dir deja visitees
- if {[lsearch $S(MultiImportDII) $S(userDIR)] == -1} {
- MIupdateFolRebuild
- }
- }
- #
- proc MIaddFileMouse {listbox x y} {
- global S
- set newfile [format "%s%s%s" $S(userDIR) / [.fsp.lfa.l get @$x,$y]]
- .fsp.lfa.l selection clear @$x,$y
- .fsp.lfb.l insert 0 $newfile
- # conservation dir deja visitees
- if {[lsearch $S(MultiImportDII) $S(userDIR)] == -1} {
- MIupdateFolRebuild
- }
- }
- #
- proc MIupdateFolRebuild {} {
- global S
- .fsp.dir.m delete 0 end
- lappend S(MultiImportDII) $S(userDIR)
- foreach e [file volume] {
- .fsp.dir.m add command -label $e -command "Integration::MIupdateFol $e"
- }
- .fsp.dir.m add separator
- foreach e $S(MultiImportDII) {
- .fsp.dir.m add command -label $e -command "Integration::MIupdateFol $e"
- }
- }
- #
- proc MIremFile {} {
- # attention retrait a partir de l'index le plus bat
- # le delete remet a jour les index
- set li [lsort -decreasing [.fsp.lfb.l curselection]] ;# des index
- foreach i $li {
- .fsp.lfb.l delete $i
- }
- # deselection des fichiers liste available
- .fsp.lfa.l selection clear 0 end
- }
- # retrait d'un elt par double-1 sans toucher la selection
- proc MIremFileMouse {listbox x y} {
- $listbox delete @$x,$y
- }
- #
- proc MIupdateDirectoriesMouse {listbox x y} {
- global S
- set repertoire [$listbox get @$x,$y]
- if {$repertoire != ".."} {
- if {[string length $S(ImportDIR)] == 3} {
- set S(ImportDIR) [format "%s%s" $S(userDIR) $repertoire]
- } else {
- set S(ImportDIR) [format "%s%s%s" $S(userDIR) / $repertoire]
- }
- } else {
- set S(ImportDIR) [file dirname $S(userDIR)]
- }
- MIupdateDirectories
- MIupdateAvailableFile
- }
- #
- proc MIupdateFilter {} {
- global S
- .fsp.fi select ALL
- }
- #
- proc RobinsonFoulds {} {
- }
- #
- proc TranslationSelectFile {txt var} {
- global S
- set typelist {
- {"All Files" {*}}
- }
- set file [tk_getOpenFile -initialdir $S(userDIR) \
- -filetypes $typelist -defaultextension "*" \
- -title $txt]
- if {$file != ""} {set S(userDIR) [file dirname $file] ; set S($var) $file}
-
- }
- # procedure de changement des noms des feuilles si les noms des feuilles
- # attention ne pas melanger entre des longueurs de branche et des nombres pour des noms de feuilles
- # feuilles : (f: soit ,f: attention bien cadrer a gauche et a droite, ne pas prendre que $f:)
- # impossible de melanger avec longueurs de branche
- # qui sont soit ":v," soit ":v)"
- proc NewickTranslation {} {
- global S
- set filename $S(FSPtransTrF)
- if [catch {open $filename r} fid] {
- puts stderr "Error Opening File"
- } else {
- set filename2 $S(FSPtransFF)
- if [catch {open $filename2 r} fid2] {
- puts stderr "Error Opening File"
- } else {
- set translation [read $fid]
- set source [read $fid2]
- regsub -all {\n} $source "" source
- set fidTARGET [open $S(FSPtransTF) a]
- foreach {val var trans} $translation {
- set feuilleFrom [format "%s%s%s" "\\(" $val ":" ]
- set feuilleVers [format "%s%s%s" "\(" $trans ":" ]
- #set feuilleVers [format "%s%s%s" "\(" [string toupper $trans] ":" ]
- set trouve [regsub $feuilleFrom $source $feuilleVers source]
- if {$trouve == 0} {
- set feuilleFrom [format "%s%s%s" , $val : ]
- set feuilleVers [format "%s%s%s" , $trans : ]
- #set feuilleVers [format "%s%s%s" , [string toupper $trans] : ]
- regsub $feuilleFrom $source $feuilleVers source
- }
- }
- puts $fidTARGET $source
- close $fid
- close $fid2
- close $fidTARGET
- }
- }
- }
- proc FileConcatenation {} {
- global S
- set fSource [.int.p.cs.page0.cs.ld.l get 0 end]
- set fTarget $S(FSPtargetfile)
- if {$fSource != "" && $fTarget != ""} {
- set fidT [open $fTarget a]
- foreach f $fSource {
- set fid [open $f r]
- set data [read $fid]
- puts $fidT $data
- close $fid
- }
- close $fidT
- }
- }
- }
- ####################
- ####################
- # ILLUSTRATION
- ####################
- namespace eval Illustration {
-
- proc BracketDrawLeafs {w t leafs text colortext fo tab dx color stipple} {
- global S
- set ltag {}
- foreach l $leafs {
- set tag [format "%s%s" EUL $l]
- lappend ltag $tag
- }
- set co [eval $w bbox $ltag]
- if {$tab == 0} {
- set x [lindex $co 2]
- } else {
- # on tabul relativement a l'arbre
- set tag [format "%s%s" T$t &&!DRAW]
- set cotree [eval $w bbox $tag]
- set xt [lindex $cotree 2]
- set x [expr $xt + $tab]
- }
-
- set y1 [expr [lindex $co 1] + 3]
- set y2 [expr [lindex $co 3] - 3]
-
-
- set id [format "%s%s" NBKT [Tools::GenId]]
- $w create rectangle $x $y1 [expr $x + $dx] $y2 \
- -fill $color -outline $color -width 1 -tags "nbracket nbracketrec $id DRAW T$t" \
- -stipple @[file join $S(TheoPATH) + stipple $stipple]
- set ym [expr ($y1 + $y2) / 2.0]
- $w create text [expr $x + $dx + 5] $ym -text $text \
- -anchor w -font $fo -fill $colortext -tags "nbracket nbracketext $id DRAW T$t"
- }
-
- proc BracketDrawCreateNode {w shape x y} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- set leafs [Tools::NodeNoToLe $t $n]
- set l1 [lindex $leafs 0]
- set l2 [lindex $leafs end]
- set co1 [$w coords $l1]; set co2 [$w coords $l2]
- set x1 [lindex $co1 0] ; set y1 [lindex $co1 1]
- set x2 [lindex $co2 0] ; set y2 [lindex $co2 1]
- set id [format "%s%s" NBKT [Tools::GenId]]
- switch -exact $shape {
- bracket {
- $w create rectangle $x1 $y1 [expr $x1 +5] $y2 \
- -fill $S(col) -width 1 -tags "nbracket nbracketrec $id DRAW T$t" \
- -stipple @[file join $S(TheoPATH) + stipple $S(stipple)]
- set ym [expr ($y1 + $y2) / 2.0]
- $w create text [expr $x1 + 10] $ym -text $S(AnnotateNote) \
- -anchor w -font $S(gfo) -fill $S(col) -tags "nbracket nbracketext $id DRAW T$t"
-
- }
- }
- # passage mode move
- set S(tool) move
- bindtags $w [list $S(tool) $w Canvas . all]
- }
- }
- ### Draw bracket, forcer la ligne verticalite
- # possibilit?Š de grande taille, dessin vectoriel
- # shape sera soit bracket soit accolade
- #
- proc BracketDrawCreate {w shape x y} {
- global S
- set id [$w find closest $x $y]
- set tags [$w gettags $id]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$t != ""} {
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set id [format "%s%s" BKT [Tools::GenId]]
- set S(bracketdrawOri) $x
- set S(bracketdrawId) $id
- set S(bracketdrawIdT) T$t
- switch -exact $shape {
- bracket {
- $w create line [expr $x -5] $y $x $y \
- -fill black -width 1 -tags "bracket $id DRAW T$t"
- $w create line $x $y $x $y \
- -fill black -width 1 -tags "bracket $id rubbershape DRAW T$t"
- }
- accolade {
- #A FAIRE
- }
- }
- }
- }
- #
- proc BracketDrawDrag {w x y} {
- global S
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set coords [$w coords "rubbershape"]
- set coords [lreplace $coords 2 3 $S(bracketdrawOri) $y]
- eval $w coords "rubbershape" $coords
- }
- #
- proc BracketDrawEnd {w x y} {
- global S
- BracketDrawDrag $w $S(bracketdrawOri) $y
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- $w create line [expr $S(bracketdrawOri) - 5] $y [expr $S(bracketdrawOri) + 1] $y \
- -fill black -width 1 -tags "bracket $S(bracketdrawId) DRAW $S(bracketdrawIdT)"
- $w dtag "rubbershape"
- }
- proc BracketNproperties {w i what} {
- global S
- switch -- $what {
- text {
- set id [$w find withtag [list $i && nbracketext]]
- set co [$w coords $id]
- set xi [lindex $co 0] ; set yi [lindex $co 1]
-
- set col [lindex [$w itemconfigure $id -fill] end]
- set fo [lindex [$w itemconfigure $id -font] end]
-
- set tags [$w gettags $id]
- $w delete $id
- $w create text $xi $yi -text $S(AnnotateNote) \
- -anchor w -font $fo -fill $col -tags $tags
- }
- color {
- set id [$w find withtag [list $i && nbracketrec]]
- $w itemconfigure $id -fill $S(col)
- set id [$w find withtag [list $i && nbracketext]]
- $w itemconfigure $id -fill $S(col)
- }
- stipple {
- set id [$w find withtag [list $i && nbracketrec]]
- $w itemconfigure $id -stipple @[file join $S(TheoPATH) + stipple $S(stipple)]
- }
- font {
- set id [$w find withtag [list $i && nbracketext]]
- $w itemconfigure $id -font $S(gfo)}
- }
- }
-
- #
- proc BracketAddLabel {w i} {
- global S
- set tags [$w gettags $i]
- set id [lindex $tags [lsearch -glob $tags BKT*]]
- $w delete LAB$id
- set cod [$w bbox $id]
- set x [lindex $cod 2]
- set y1 [lindex $cod 1]
- set y2 [lindex $cod 3]
- set y [expr ($y1 + $y2) / 2.0]
- $w create text $x $y -text $S(AnnotateNote) \
- -anchor w \
- -font $S(gfo) -tags "bracket LAB$id $id DRAW"
- }
- #
- proc BracketAlign {w i} {
- global S
- set tags [$w gettags $i]
- set id [lindex $tags [lsearch -glob $tags BKT*]]
- set cod [$w bbox $id]
- set x [lindex $cod 2]
- set bkt [$w find withtag bracket]
- foreach i $bkt {
- set coi [$w bbox $i]
- set newc [list $x [lrange $cod 1 end]]
- $w coords $i $newc
- }
-
- }
- ###
- proc NodeBgContour {w x y} {
- global S B
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set lxy [Figuration::NodeColorBgSubTreeContour $w $t $n]
- set c0 [$w bbox $n]
- set x0 [lindex $c0 0]
- set y0 [lindex $c0 1]
- set id [format "%s%s" $t [Tools::GenId]]
- set tag [format "%s%s%s" BGS ? $id]
- $w create polygon "$x0 $y0 $lxy $x0 $y0" -smooth 1 -splinesteps 100 \
- -fill $S(col) -outline $S(col) -tags "bgtree T$t $tag"
- $w lower bgtree
- # MEM
- set B(BGStre,$id) $t
- set B(BGSnod,$id) $n
- set B(BGScol,$id) $S(col)
- # Liste des BGS par tree
- lappend B($t,bgs) $id
-
- }
- #
- #
- proc NodeIllustration {w x y} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- set co [$w coords $n]
- set x [lindex $co 0]
- set y [lindex $co 1]
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $w $x $y [list T$t AnnotMatrix AM$t $tagC AMatrixCo]
- update
- }
- }
- #
- proc NodeIllustration2 {w x y} {
- global S
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- set co [$w coords $n]
- set y [lindex $co 1]
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $w $x $y [list T$t AnnotMatrix AM$t $tagC AMatrixCo]
- update
- }
- }
- #
- proc SymbolInsert {w x y} {
- global S
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $w [$w canvasx $x] [$w canvasy $y] [list DRAW symbol]
- }
- proc LillLtoolbox {w x y} {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set p [format "%s%s" $n *]
- set leu {}
- foreach e $T($t,ue_cod) {
- if {[string match $p $e] == 1} {
- lappend leu $T($t,ctl,$e)
- }
- }
- LillL $w $t $leu
- }
- }
- # Leaves Illustration mode Leave
- proc LillL {w t leu} {
- global T S
- # tag serie
- switch -exact $S($t,type) {
- PhyNJ - ClaSla - ClaRec {
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- #set l $T($t,ctl,$code)
- set i [$w find withtag [list ILLL?$l && T$t]]
- if {$i == ""} {
- set i [$w find withtag [list [format "%s%s" EUL $l] && T$t]]
- set co [$w coords $i]
- set y [lindex $co 1]
- set x [lindex [$w bbox $i] 2]
- } else {
- # cas si plusieurs ajout on recup le i de plus gran x
- set co [$w coords [lindex $i 0]]
- set y [lindex $co 1]
- set x 0
- foreach ii $i {
- set xii [lindex [$w bbox $ii] 2]
- if {$xii >= $x} {
- set x $xii
- }
- }
- }
- if {$x != "" && $y != ""} {
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $w $x $y [list ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo]
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- LillL360bis $w $t $leu
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- LillL360 $w $t $leu
- }
- }
- }
- #
- proc LillL360 {} {
- }
- #
- proc LillL360bis {} {
- }
- #
- proc LillCtoolbox {w x y } {
- global T S
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set p [format "%s%s" $n *]
- set leu {}
- foreach e $T($t,ue_cod) {
- if {[string match $p $e] == 1} {
- lappend leu $T($t,ctl,$e)
- }
- }
- LillC $w $t $leu
- }
- }
- # Leaves Illustration mode Columns
- # tab la variable de tabulation entre differentes colonnes
- proc LillC {w t leu } {
-
- global S ann T
- if {$S(illustration-tabulation) == 1} {
- set S($t,LabelMatrixBase) [expr $S($t,LabelMatrixBase) + $S(TabulationAnnot)]
- }
- #set S($t,LabelMatrixBase) [expr $S($t,LabelMatrixBase) + $S(TabulationAnnot)]
- #
- switch -exact $S($t,type) {
- PhyNJ - ClaSla - ClaRec {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- # recherche y (code arrete terminale)
- set item [$w find withtag [list [format "%s%s" EU $l ] && T$t]]
- if {$item != ""} {
- set co [$w coords $item]
- set y [lindex $co 1]
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- drawsymbol $w $x $y [list ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo]
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # ENCORE DU TRAVAIL A FAIRE
- # PB du rectangle / oval, des zones de dessin arbre en dehors de l'oval
- # LillC360bis $w $t $leu
- LillC360bis2 $w $t $leu
-
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- LillC360 $w $t $leu
- }
- }
- #Navigation::FitToContents $w
- }
- proc drawsymbol {w x y tags} {
- global S
-
- switch $S(symboltype) {
- 01 {
- # carre rectangle ok
- $w create rectangle [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 02 {
- # cercle/ocal ok
- $w create oval [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 03 {
- # losange ok
- $w create polygon [expr $x-$S(symboldx)] $y $x [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] $y $x [expr $y+$S(symboldy)] \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 04 {
- # triangle right ok
- $w create polygon [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] $y [expr $x-$S(symboldx)] [expr $y+$S(symboldy)] \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 05 {
- # triangle left ok
- $w create polygon [expr $x+$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] [expr $x-$S(symboldx)] $y \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 06 {
- # triangle bottom ok
- $w create polygon [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y-$S(symboldy)] $x [expr $y+$S(symboldy)] \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 07 {
- # triangle top
- $w create polygon [expr $x-$S(symboldx)] [expr $y+$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] $x [expr $y-$S(symboldy)] \
- -fill $S(symbolcolorfill) -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 08 {
- #case a cocher 0 OK
- $w create rectangle [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] \
- -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(symbolstipple)]
- }
- 09 {
- #case a cocher 1 OK
- $w create rectangle [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] \
- -outline $S(symbolcoloroutline) \
- -tags $tags -stipple @[file join $S(TheoPATH) + stipple $S(stipple)]
- $w create line [expr $x-$S(symboldx)] [expr $y-$S(symboldy)] [expr $x+$S(symboldx)] [expr $y+$S(symboldy)] \
- -fill $S(symbolcolorfill) \
- -tags $tags
- $w create line [expr $x-$S(symboldx)] [expr $y+$S(symboldy)] [expr $x+$S(symboldx)] [expr $y-$S(symboldy)] \
- -fill $S(symbolcolorfill) \
- -tags $tags
- }
- }
- }
- proc LillCpolygon {w t leu } {
- global S ann T
- #
- if [catch {expr $S($t,LabelMatrixBase) + $S(TabulationAnnot)} result] {
- set S($t,LabelMatrixBase) $S(TabulationAnnot)
- } else {
- # tabulation entre colonnes
- # possiblit?Š de rester sur la meme colonne
- if {$S(illustration-tabulation) == 1} {
- set S($t,LabelMatrixBase) $result
- }
- }
- #
- switch -exact $S($t,type) {
- PhyNJ - ClaSla - ClaRec {
- # recherche x
- if {$S(illustration-tabulation) == 1} {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$t && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- } else {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- }
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- # recherche y (code arrete terminale)
- set item [$w find withtag [list [format "%s%s" EU $l ] && T$t]]
- if {$item != ""} {
- set co [$w coords $item]
- set y [lindex $co 1]
- # avoir 2 caracteres pour bon centrage
- #set illtxt [concat " " [lindex $S(ill-car-fon) 0 ]]
- #set illfon [lrange $S(ill-car-fon) 1 end]
- set illtxt [concat " " $S(ill-car) ]
- set illfon $S(ill-fon)
-
- # On va chercher pour la variable en selection la liste des coords du polygon a trace
- # f est un facteur d'amplification ? appliquer sur les coord du polygon
- # x et y sont utiliser pour appliquer une translation en x et y respectivement
- set item [$w create text $x $y \
- -text $illtxt \
- -anchor center -justify center \
- -fill $S(col) \
- -font $illfon \
- -tags "ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"]
- $w raise $item
- update
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- }
- }
- }
- ###
- proc LillC360 {w t leu} {
- global S ann T
- set d $S($t,LabelMatrixBase)
- set co [$w bbox [list Z && T$t]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
-
- set C(dx) [expr abs(($x2 - $x1)) /2.0]
- set C(dy) [expr abs(($y2 - $y1)) /2.0]
- set a_ref [expr 360.0/ [llength $T($t,ue_cod)]] ;# unit?Š d'angle
- set n 0
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- if { $S($t,type) == "ClaCir2"} {
- # inversion de la liste des eus
- set LLE {}
- foreach e $T($t,ue_cod) {
- set LLE [concat $e $LLE]
- }
- set n 1
- } else {
- set LLE $T($t,ue_cod)
- }
- foreach e $LLE {
- set C(angle,$e) [expr $n*$a_ref]
- if { [lsearch $leu $T($t,ctl,$e)] != -1} {
- # degres -> radians
- set angrad [expr (2 * acos(-1) * $C(angle,$e)) / 360.0]
- # d est l'augmentation du rayon du cercle
- set x [expr ($C(dx) + $d ) * cos($angrad)]
- set y [expr ($C(dy) + $d ) * sin($angrad)]
- set l $T($t,ctl,$e)
- #set illtxt [concat " " [lindex $S(ill-car-fon) 0 ]]
- #set illfon [lrange $S(ill-car-fon) 1 end]
- set illtxt [concat " " $S(ill-car) ]
- set illfon $S(ill-fon)
- set item [$w create text [expr $x + $x1 + $C(dx)] [expr $y + $y1 + $C(dy)] \
- -text $illtxt \
- -anchor center -justify center \
- -fill $S(col) \
- -font $illfon \
- -tags "ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"]
- $w raise $item
- update
- }
- incr n
- }
- unset C
- }
- ###
- # s est soit tab- soit tab+
- # cette fonction permet d'inc?Šmenter (+) // d?Šcr?Šmenter (-)
- # la variable de tabulation pour les arbres en target
- # manuellement (afin de tab entre 2 series de requetes)
- proc IllCTabulation {s} {
- global S T
- # A-list window/tree des arbres en target d'une session treedyn
- foreach {w t} [Selection::TreeTar] {
- switch -exact $s {
- tab+ {
- if [catch {expr $S($t,LabelMatrixBase) + $S(TabulationAnnot)} result] {
- set S($t,LabelMatrixBase) $S(TabulationAnnot)
- } else {
- set S($t,LabelMatrixBase) $result
- }
- }
- tab- {
- if [catch {expr $S($t,LabelMatrixBase) - $S(TabulationAnnot)} result] {
- # rien
- } else {
- set S($t,LabelMatrixBase) $result
- }
- }
- }
- }
- }
- proc IllCTabulationSet {s v} {
- global S T
- # A-list window/tree des arbres en target d'une session treedyn
- foreach {w t} [Selection::TreeTar] {
- switch -exact $s {
- tab+ {
- if [catch {expr $S($t,LabelMatrixBase) + $v} result] {
- set S($t,LabelMatrixBase) $v
- } else {
- set S($t,LabelMatrixBase) $result
- }
- }
- tab- {
- if [catch {expr $S($t,LabelMatrixBase) - $v} result] {
- # rien
- } else {
- set S($t,LabelMatrixBase) $result
- }
- }
- tab= {
- set S($t,LabelMatrixBase) $v
-
- }
- }
- }
- }
-
- proc LillC360bis2 {w t leu} {
- global S ann T
- # cercle d'illustration fixer R le rayon du cercle d'illustration
- # on peut fixer une valeur pour par ex. 200 + tabulation
- # mais mieux de chercher une valeur adapt?Še ? chaque
- # arbre
- # set R [expr 200 + $S($t,LabelMatrixBase)]
- #set co [$w bbox [list L && T$t]]
- set co [$w bbox [list Z && T$t]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set Rx [expr double(($x2 - $x1) /2.0)]
- set Ry [expr double(($y2 - $y1) /2.0)]
- if {$Rx > $Ry} {
- set R [expr $Rx + $S($t,LabelMatrixBase)]
- } else {
- set R [expr $Ry + $S($t,LabelMatrixBase)]
- }
- set a_ref [expr double(6.28318530717958 / [llength $T($t,ue_cod)])]
- set n 0
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach e $T($t,ue_cod) {
- set a [expr double($n*$a_ref)]
- if {[lsearch $leu $T($t,ctl,$e)] != -1} {
- set x [expr double($R * cos($a))]
- set y [expr double($R * sin($a))]
- set l $T($t,ctl,$e)
- #set illtxt [concat " " [lindex $S(ill-car-fon) 0 ]]
- #set illfon [lrange $S(ill-car-fon) 1 end]
- set illtxt [concat " " $S(ill-car) ]
- set illfon $S(ill-fon)
- set item [$w create text $x $y \
- -text $illtxt \
- -anchor center -justify center \
- -fill $S(col) \
- -font $illfon \
- -tags "ILLCo?$l AnnotMatrix AM$t MA?$l T$t $tagC AMatrixCo"]
- }
- incr n
- }
- # centrage sur arbre tags root "[format "%s%s" $t C] T$t Z"
- set co [$w coords [format "%s%s" $t C]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set xcenter [expr ($x1 + $x2) /2.0]
- set ycenter [expr ($y1 + $y2) /2.0]
- $w move $tagC $xcenter $ycenter
- }
- ###
- proc LillC360bis {w t leu} {
- global S ann T
-
- #set f [expr double($R / $T($t,xmax))]
- set d $S($t,LabelMatrixBase)
- set co [$w bbox [list Z && T$t]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set C(dx) [expr abs(($x2 - $x1)) /2.0]
- set C(dy) [expr abs(($y2 - $y1)) /2.0]
- # pb il y a 4 zones de dessin en dehors de l'oval : forme phycir, phyrad etc.
- # on va donc toujours dessiner un cercle, on prend ds ce cas
- # le plus grand cote, soit dx soit dy, et on corrige x et y
- set delta [expr (abs($C(dx) - $C(dy))) / 2.0]
- if {[expr abs($x2 - $x1)] < [expr abs($y2 - $y1)]} {
- # update des x
- set x1 [expr $x1 - $delta]
- set x2 [expr $x2 + $delta]
- # update dx
- set C(dx) $C(dy)
- } {
- # update des y
- set y1 [expr $y1 - $delta]
- set y2 [expr $y2 + $delta]
- # update dy
- set C(dy) $C(dx)
- }
- $w create oval [expr $x1 -$d] [expr $y1 -$d] [expr $x2 +$d] [expr $y2 +$d] \
- -tags "T$t" -outline grey80
-
- $w create rectangle [expr $x1 -$d] [expr $y1 -$d] [expr $x2 +$d] [expr $y2 +$d] \
- -tags "T$t" -outline grey80
-
- set a_ref [expr 360.0/ [llength $T($t,ue_cod)]] ;# unit?Š d'angle
- set n 0
- foreach e $T($t,ue_cod) {
- set C(angle,$e) [expr $n*$a_ref]
- if { [lsearch $leu $T($t,ctl,$e)] != -1} {
- # passer ? l'egalit?Š nom de feuilles
- # degres -> radians
- set angrad [expr (2 * acos(-1) * $C(angle,$e)) / 360.0]
-
- set x [expr ($C(dx) + $d ) * cos($angrad)]
- set y [expr ($C(dy) + $d ) * sin($angrad)]
- $w create oval [expr $x + $x1 + $C(dx) -2] [expr $y + $y1 + $C(dy) -2] \
- [expr $x + $x1 + $C(dx) +2] [expr $y + $y1 + $C(dy) +2] \
- -fill $S(col) -outline $S(col) \
- -tags "T$t" \
- }
- incr n
- }
- unset C
- }
- ###
- proc CreateShape {w shape x y} {
- global S
- set x [$w canvasx $x]
- set y [$w canvasy $y]
- set id [$w find closest $x $y]
- set tags [$w gettags $id]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$t != ""} {
- switch -exact $shape {
- line {
- $w create $shape $x $y $x $y \
- -fill $S(col) -width 1 -tags "rubbershape DRAW T$t"
- }
- rectangle - oval {
- $w create $shape $x $y $x $y \
- -fill $S(col) -width 1 -tags "rubbershape DRAW T$t"
- }
- }
- }
- }
- #
- proc CreateShapeFill {w shape x y} {
- global S
- set x [$w canvasx $x]
- set y [$w canvasy $y]
- set id [$w find closest $x $y]
- set tags [$w gettags $id]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$t != ""} {
- switch -exact $shape {
- line {
- $w create $shape $x $y $x $y \
- -outline $S(col) -width 1 -tags "rubbershape DRAW T$t"
- }
- rectangle - oval {
- $w create $shape $x $y $x $y \
- -outline $S(col) -width 1 -tags "rubbershape DRAW T$t"
- }
- }
- }
- }
- ###
- proc DragShape {w x y} {
- set x [$w canvasx $x]
- set y [$w canvasy $y]
- set coords [$w coords "rubbershape"]
- set coords [lreplace $coords 2 3 $x $y]
- eval $w coords "rubbershape" $coords
- }
- ###
- proc EndShape {w x y} {
- DragShape $w $x $y
- $w dtag "rubbershape"
- }
- }
- ####################
- ####################
- # IMPORT EXPORT
- ####################
- namespace eval ImportExport {
-
- proc NewickParser_Root {t s} {
- global T S
- set code $t
- set n 0
- set sx 0
- #
- set T($t,xmax) 0
- set T($t,tot) 0
- set T($t,all_cod) $code
- set T($t,dbv,$code) 0
- set T($t,dbl,$code) 0
- set T($t,nwk,$code) $s
- set tp [string last ")" $s]
- set dt [string range $s 0 $tp]
- set dx [string range $s [expr $tp + 1] end]
- set id [BgBdx $dt]
- set bg [string range $dt [expr $id + 1] [expr [string length $dt] - 2]]
- set bd [string range $dt 1 [expr $id - 1]]
- lappend T($t,cbg,$n) $n
- NewickParser2 $t $bg [format "%s%s" $code g] [expr $n + 1] $sx
- NewickParser2 $t $bd [format "%s%s" $code d] [expr $n + 1] $sx
- }
- ###
- proc BgBdx {s} {
- set i -1
- set id -1
- foreach c [split $s {}] {
- incr id
- switch -exact -- $c {
- ( {incr i}
- ) {incr i -1}
- , {if {$i == 0} {return $id}}
- }
- }
- return ""
- }
- ###
- proc NewickParser2 {t s code n sx} {
- global T S
- lappend T($t,all_cod) $code
- set T($t,nwk,$code) $s
- if {[string match *,* $s]} {
- ######
- if {[TDcom::Dicho $s] == 1} {
- set s [format "%s%s%s" ( $s ):0]
- }
- ######
- set tp [string last ")" $s]
- set dt [string range $s 0 $tp]
- set dx [string range $s [expr $tp + 1] end]
- set T($t,dbl,$code) [string range $dx [expr [string last ":" $dx] + 1] end]
- set T($t,dbv,$code) [string range $dx 0 [expr [string last ":" $dx] - 1]]
- ######
- if {[string compare [string range $dt 0 0] ( ] != 0 || \
- [string compare [string range $dt end end] ) ] != 0} {
- set dt [format "%s%s%s" ( $dt )]
- }
- set id [BgBdx $dt]
- set bg [string range $dt [expr $id + 1] [expr [string length $dt] - 2]]
- set bd [string range $dt 1 [expr $id - 1]]
- lappend T($t,cbg,$n) [format "%s%s" $code $n]
- NewickParser2 $t $bg [format "%s%s%s" $code $n g] [expr $n +1] [expr $sx + $T($t,dbl,$code)]
- NewickParser2 $t $bd [format "%s%s%s" $code $n d] [expr $n +1] [expr $sx + $T($t,dbl,$code)]
- } { set tp [string last ":" $s]
- set dt [string range $s 0 [expr $tp - 1]]
- set dx [string range $s [expr $tp + 1] end]
- set T($t,dbl,$code) [string range $dx [expr [string last ":" $dx] + 1] end]
- set T($t,ctl,$code) $dt
- set T($t,ltc,$dt) $code
- lappend T($t,ue_cod) $code
- lappend T($t,ue_lab) $dt
- set sx [expr $sx + $dx]
- set T($t,sox,$code) $sx
- if {$sx >= $T($t,xmax)} {set T($t,xmax) $sx}
- if {$n >= $T($t,tot)} {set T($t,tot) $n}
- return
- }
- }
- ###
- proc UpdateArrayCanvas {w t} {
- global T S B
- ### canvas
- $w delete T$t
- ### array T
- foreach {key value} [array get T $t,*] {
- unset T($key)
- }
- ### array S
- foreach {key value} [array get S $t,*] {
- unset S($key)
- }
- # array B/BLL
- foreach bll $B($t,bll) {
- foreach key [array names B *,$bll] {
- unset B($key)
- }
- }
- unset B($t,bll)
- # array B/SHI
- foreach shi $B($t,shi) {
-
- foreach key [array names B *,$shi] {
- unset B($key)
- }
- }
- unset B($t,shi)
- #array B/ OVA
- foreach ova $B($t,ova) {
- foreach key [array names B *,$ova] {
- unset B($key)
- }
- }
- #array B/ QYN
- unset B($t,ova)
- foreach qyn $B($t,qyn) {
- foreach key [array names B *,$qyn] {
- unset B($key)
- }
- }
- unset B($t,qyn)
- #mise a jour la liste des tree S(ilt)
- set index [lsearch -exact $S(ilt) $t]
- set S(ilt) [concat [lrange $S(ilt) 0 [expr $index - 1]] \
- [lrange $S(ilt) [expr $index + 1] end]]
- #mise a jour la liste des tree S(w,t)
- set index [lsearch -exact $S($w,t) $t]
- set S($w,t) [concat [lrange $S($w,t) 0 [expr $index - 1]] \
- [lrange $S($w,t) [expr $index + 1] end]]
-
- }
-
- }
- ####################
- ####################
- # NAVIGATION
- ####################
- namespace eval Navigation {
-
- ### FitToContents
- proc FitToContents {w} {
- global S
- $w configure -scrollregion [$w bbox all]
- }
- ### FitToWindow
- proc FitToWindow {w t} {
- global S T
- foreach {x0 y0 x1 y1} [$w bbox all] {}
- set widw [winfo width $w]
- set heiw [winfo height $w]
- set fx [expr abs($widw. /[expr $x1 - $x0])]
- set fy [expr abs($heiw. /[expr $y1 - $y0])]
- $w scale T$t 0 0 $fx $fy
- $w configure -scrollregion [$w bbox all]
- }
-
- proc deleteDocumentAnnotationL {w} {
- global S
- foreach t $S($w,t) {$w delete AM$t}
- }
- proc deleteDocumentAnnotationN {w} {
- global S
- foreach t $S($w,t) {Interface::D3ActionTree $w $t removeallannotation}
- }
-
- proc resetDocumentVar {w v} {
- global S
- foreach ti $S($w,t) {
- switch $v {
- tbg {Figuration::GraVarInitBgSubTree $w $ti}
- tfg {Figuration::GraVarInitFgTree $w $ti}
- tlw {Figuration::GraVarInitLineWidth $w $ti}
- tld {Figuration::GraVarInitLineDash $w $ti}
- t {
- Figuration::GraVarInitBgSubTree $w $ti
- Figuration::GraVarInitFgTree $w $ti
- Figuration::GraVarInitLineWidth $w $ti
- Figuration::GraVarInitLineDash $w $ti
- }
- lbg {Figuration::GraVarInitBgLeaf $w $ti}
- lfg {Figuration::GraVarInitFgLeaf $w $ti}
- lfo {Figuration::GraVarInitFont $w $ti}
- l {
- Figuration::GraVarInitBgLeaf $w $ti
- Figuration::GraVarInitFgLeaf $w $ti
- Figuration::GraVarInitFont $w $ti
- }
- tl {
- Figuration::GraVarInitBgSubTree $w $ti
- Figuration::GraVarInitFgTree $w $ti
- Figuration::GraVarInitLineWidth $w $ti
- Figuration::GraVarInitLineDash $w $ti
- Figuration::GraVarInitBgLeaf $w $ti
- Figuration::GraVarInitFgLeaf $w $ti
- Figuration::GraVarInitFont $w $ti
- }
- }
- }
- }
- proc resetTreeVar {w ti v} {
- global S
- switch $v {
- tbg {Figuration::GraVarInitBgSubTree $w $ti}
- tfg {Figuration::GraVarInitFgTree $w $ti}
- tlw {Figuration::GraVarInitLineWidth $w $ti}
- tld {Figuration::GraVarInitLineDash $w $ti}
- t {
- Figuration::GraVarInitBgSubTree $w $ti
- Figuration::GraVarInitFgTree $w $ti
- Figuration::GraVarInitLineWidth $w $ti
- Figuration::GraVarInitLineDash $w $ti
- }
- lbg {Figuration::GraVarInitBgLeaf $w $ti}
- lfg {Figuration::GraVarInitFgLeaf $w $ti}
- lfo {Figuration::GraVarInitFont $w $ti}
- l {
- Figuration::GraVarInitBgLeaf $w $ti
- Figuration::GraVarInitFgLeaf $w $ti
- Figuration::GraVarInitFont $w $ti
- }
- tl {
- Figuration::GraVarInitBgSubTree $w $ti
- Figuration::GraVarInitFgTree $w $ti
- Figuration::GraVarInitLineWidth $w $ti
- Figuration::GraVarInitLineDash $w $ti
- Figuration::GraVarInitBgLeaf $w $ti
- Figuration::GraVarInitFgLeaf $w $ti
- Figuration::GraVarInitFont $w $ti
- }
- }
- }
- proc resetNodeVar {w ti n v} {
- global S
- switch $v {
- tbg {Figuration::GraVarInitBgSubTree $w $ti $n}
- tfg {Figuration::GraVarInitFgTree $w $ti $n}
- tlw {Figuration::GraVarInitLineWidth $w $ti $n}
- tld {Figuration::GraVarInitLineDash $w $ti $n}
- t {
- Figuration::GraVarInitBgSubTree $w $ti $n
- Figuration::GraVarInitFgTree $w $ti $n
- Figuration::GraVarInitLineWidth $w $ti $n
- Figuration::GraVarInitLineDash $w $ti $n
- }
- lbg {Figuration::GraVarInitBgLeaf $w $ti $n}
- lfg {Figuration::GraVarInitFgLeaf $w $ti $n}
- lfo {Figuration::GraVarInitFont $w $ti $n}
- l {
- Figuration::GraVarInitBgLeaf $w $ti $n
- Figuration::GraVarInitFgLeaf $w $ti $n
- Figuration::GraVarInitFont $w $ti $n
- }
- tl {
- Figuration::GraVarInitBgSubTree $w $ti $n
- Figuration::GraVarInitFgTree $w $ti $n
- Figuration::GraVarInitLineWidth $w $ti $n
- Figuration::GraVarInitLineDash $w $ti $n
- Figuration::GraVarInitBgLeaf $w $ti $n
- Figuration::GraVarInitFgLeaf $w $ti $n
- Figuration::GraVarInitFont $w $ti $n
- }
- }
- }
-
- #
- proc CoPaCollectionCreateInsert {w t n} {
- global S T
- # si aucune collection
- # le [Tools::GenId] est l'ID de la collection
- set IDcollection [Tools::GenId]
- # S(collection) est la liste des ID collections
- lappend S(collection) $IDcollection
- # creation de la fenetre de collection
- set collection [ImportExport::NewCanvas]
- #chaque ID collection reference la path window correspondant
- set S(collection,$IDcollection) $collection
- # ...final, copy paste
- Navigation::CoPaCollectionInsert $w $t $n $IDcollection
- }
- #
- proc CoPaCollectionInsert {wsource tsource nodesource IDcollection} {
- global S T
- set wtarget $S(collection,$IDcollection)
- set t [expr [lrange [lsort -integer -increasing $S(ilt)] end end] + 1]
- lappend S(ilt) $t
- lappend S($wtarget,t) $t
- set code $t
- set data $T($tsource,nwk,$nodesource)
- set T($t,nwk) $data
- ImportExport::TreeInit $t
- if {[catch [ImportExport::NewickParser_Root $t $data] result] != 0} {
- ImportExport::CleanArrayTree $t
- } else {
- set T($t,xmax) $T($tsource,xmax)
- set S($t,w) $wtarget
- set S($t,tit) -
- set S($t,type) $S($tsource,type)
- Conformation::ArrToCanType2 $t $wtarget
- ImportExport::NodeBind $wtarget $t
- Figuration::TransitionVG $wtarget $tsource $nodesource $t
- Figuration::RestaureT $wtarget $t
- Operation::TreeViewerPanelUpdate
- }
- }
-
- # organisation des arbres d'un canvas en rows columns
- proc Reorganize {w {c ?} {r ?}} {
- global S
- set heMAX 0
- set wiMAX 0
- if {$S($w,BIcol) == "?"} {set S($w,BIcol) 3}
- if {$S($w,BIrow) == "?"} {set S($w,BIrow) [expr round(0.5 + ([llength $S($w,t)]/3))] }
- if {$c == "?"} { set c $S($w,BIcol)}
- if {$r == "?"} { set r $S($w,BIrow)}
- #
- foreach ti $S($w,t) {
- # NON [$w bbox [list Z && T$ti]] (prise en compte taille des feuilles)
- set coords [$w bbox T$ti]
- set wi [expr abs([lindex $coords 0] - [lindex $coords 2])]
- if {$wi >= $wiMAX} {set wiMAX $wi}
- set he [expr abs([lindex $coords 1] - [lindex $coords 3])]
- if {$he >= $heMAX} {set heMAX $he}
- }
- set n [llength $S($w,t)]
- set index -1
- for {set i 0} {$i < $r} {incr i} {
- for {set j 0} {$j < $c} {incr j} {
- incr index
- if {$index < $n} {
- set ti [lindex $S($w,t) $index]
- # attention le move ajoute, donc remettre a zero avant
- set coords [$w bbox T$ti]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- $w move T$ti [expr 0 - $x] [expr 0 - $y]
- set px [expr $j * $wiMAX]
- set py [expr $i * $heMAX]
- $w move T$ti $px $py
- }
- }
- }
- Navigation::FitToContents $w
- }
-
-
- # proc associ?Še a un return sur les entry hauteur/largeur , main panel, onglet navigation
- proc ResizeAuto {} {
- # retourne la A-liste $windows $tree pour tous les tree en target d'une session treedyn
- set Alist [Selection::TreeTar]
- foreach {wi ti} $Alist {
- Navigation::ResizeOneGo $wi $ti
- Figuration::RestaureT $wi $ti
- }
- }
- #
-
- proc ResizeOneGo {w t} {
- global S
- set co [$w bbox T$t]
- set x [lindex $co 0]
- set y [lindex $co 1]
- Conformation::ArrToCanType3 $t $w $x $y $S(newW) $S(newH)
- Figuration::RestaureT $w $t
- }
- }
- ####################
- ####################
- # ANNOTATION
- ####################
- namespace eval Annotation {
-
- #
- proc HTTPPanel {} {
- global S
- set S(httpref) ?
-
- toplevel .annothttp
- wm title .annothttp {W3}
- # frame control
- set f [frame .annothttp.control ]
- #
- # boxlist url
- iwidgets::combobox $f.combourl -width 12 -labeltext "URL:"
- foreach e [list "http://pbil.univ-lyon1.fr/cgi-bin/acnuc-search-ac?query="] {
- $f.combourl insert list end $e
- }
- $f.combourl selection set "http://pbil.univ-lyon1.fr/cgi-bin/acnuc-search-ac?query="
- # Entry reference gene/pr etc
- iwidgets::entryfield $f.ref -textvariable S(httpref) -labeltext "Ref:" -command Annotation::AnnotHttp2
- # boxlist database
- iwidgets::combobox $f.combo -labeltext "Database:" -selectioncommand Annotation::AnnotHttp2
- foreach e [list GenBank EMBL EMGLib NRSub SwissProt NBRF "Hobacgen nucl." \
- "Hobacgen prot." "Hovergen nucl." "Hovergen prot." "RTKdb nucl." "RTKdb prot." \
- "HoGenome nucl." "HoGenome prot." "Hovergen Clean nucl." "Hovergen Clean prot." \
- "HAMAP nucl." "HAMAP prot." "MitALib prot." "MitALib nucl." "Hoppsigen Nurebase nucl." \
- "Nurebase prot." "TestForm prot." "TestForm nucl."] {
- $f.combo insert list end $e
- }
- $f.combo selection set GenBank
- # browser
- set htm [optcl::new -window .annothttp.htm Shell.Explorer.2] ;# MSIE ActiveX Control
- set S(navigator) $htm
- .annothttp.htm config -width 500 -height 400
- #
- grid $f.combourl -row 0 -column 0 -columnspan 2 -sticky news
- grid $f.combo -row 1 -column 0 -sticky news
- grid $f.ref -row 1 -column 1 -sticky news
- grid $f -row 0 -column 0 -sticky news
- grid .annothttp.htm -row 1 -column 0 -sticky news
- grid rowconfigure .annothttp 1 -weight 1
- grid columnconfigure .annothttp 0 -weight 1
- }
- #
- proc AnnotHttp {w x y} {
- global S T
- set unit [$w itemcget current -text]
- if {$unit != ""} {
- if {[winfo exists .annothttp] == 0 } {HTTPPanel}
- set S(httpref) $unit
- set url [.annothttp.control.combourl getcurselection]
- append url $unit
- append url "&db="
- append url [.annothttp.control.combo getcurselection]
- $S(navigator) navigate $url
- }
- }
- #
- proc AnnotHttp2 {} {
- global S T
- set unit $S(httpref)
- if {$unit != "" && $unit != "?"} {
- if {[winfo exists .annothttp] == 0 } {HTTPPanel}
- set url [.annothttp.control.combourl getcurselection]
- append url $unit
- append url "&db="
- append url [.annothttp.control.combo getcurselection]
- $S(navigator) navigate $url
- }
- }
- #
- # .ann.l.lfa.l
- proc MatrixAnnotateGo {} {
- global S ann T
- set lv {}
- set lindex [.ann.l.lfa.l curselection]
- foreach i $lindex {
- lappend lv [.ann.l.lfa.l get $i]
- }
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- MatrixAnnotateGoGo $lv $ltreetarget
- }
- proc MatrixColorsAnnotateGo {} {
- global S ann T
- set lv {}
- set lindex [.ann.l.lfa.l curselection]
- foreach i $lindex {
- lappend lv [.ann.l.lfa.l get $i]
- }
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- MatrixColorsAnnotateGoGo $lv $ltreetarget
-
- }
- #
- proc MatrixAnnotateGoGo {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- set w $S($ti,w)
- set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$ti && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- if [catch {expr $S($ti,LabelMatrixBase) + 7} result] {
- set S($ti,LabelMatrixBase) 7
- } else {
- set S($ti,LabelMatrixBase) $result
- }
- #set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- #set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- #if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
- set x [expr $XMAX + $S($ti,LabelMatrixBase)]
- set colnumber 0
- foreach var $lv {
- incr colnumber 1
- incr x $ann(binmatPadding)
- set dx [expr $ann(binmatWidth) / 2]
- set dy [expr $ann(binmatHeight) / 2]
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- if {$ann(binmatColumnsNumber) == 1} {
- set spliNB 0
- foreach lettre [split $colnumber {}] {
- set ycolumns [lindex [$w bbox [list T$ti && Z]] 1]
- $w create text $x [expr $ycolumns - 10 - $spliNB] -text $lettre \
- -fill black -tags "T$ti AnnotMatrix"
- incr spliNB 8
- }
- }
- foreach l $T($ti,ue_lab) {
- # recherche y
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- if {$item == ""} {
- set items [$w find withtag [list ADD?$l && T$ti]]
- set y 0
- foreach ii $items {
- set yii [lindex [$w coords $ii] 1]
- if {$yii >= $y} {
- set y $yii
- }
- }
- } else {
- set co [$w coords $item]
- set y [lindex $co 1]
- }
- # construction de itemtext sur query
- # attention si des feuilles ds l'arbre mais absentes du fichier de labels !
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- if {$val == "1"} {
- set color $ann(binmatColor1)
- } else {
- set color $ann(binmatColor0)
- }
- }
- }
- }
- # coordonnees
- if {$ann(binmatOutline) == 0} {
- $w create rectangle [expr $x-$dx] [expr $y-$dy] [expr $x+$dx] [expr $y+$dy] \
- -fill $color -outline $color \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo NBC$colnumber"
- } else {
- $w create rectangle [expr $x-$dx] [expr $y-$dy] [expr $x+$dx] [expr $y+$dy] \
- -fill $color -outline black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo NBC$colnumber"
- }
- }
- }
- }
- Navigation::FitToContents $w
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
- #
- proc MatrixColorsAnnotateGoGo {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- set w $S($ti,w)
- set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$ti && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- if [catch {expr $S($ti,LabelMatrixBase) + 7} result] {
- set S($ti,LabelMatrixBase) 7
- } else {
- set S($ti,LabelMatrixBase) $result
- }
- #set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- #set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- #if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
- set x [expr $XMAX + $S($ti,LabelMatrixBase)]
- set colnumber 0
- foreach var $lv {
- incr colnumber 1
- incr x $ann(binmatPadding)
- set dx [expr $ann(binmatWidth) / 2]
- set dy [expr $ann(binmatHeight) / 2]
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- if {$ann(binmatColumnsNumber) == 1} {
- set spliNB 0
- foreach lettre [split $colnumber {}] {
- set ycolumns [lindex [$w bbox [list T$ti && Z]] 1]
- $w create text $x [expr $ycolumns - 10 - $spliNB] -text $lettre \
- -fill black -tags "T$ti AnnotMatrix"
- incr spliNB 8
- }
- }
- foreach l $T($ti,ue_lab) {
- # recherche y
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- if {$item == ""} {
- set items [$w find withtag [list ADD?$l && T$ti]]
- set y 0
- foreach ii $items {
- set yii [lindex [$w coords $ii] 1]
- if {$yii >= $y} {
- set y $yii
- }
- }
- } else {
- set co [$w coords $item]
- set y [lindex $co 1]
- }
- # construction de itemtext sur query
- # attention si des feuilles ds l'arbre mais absentes du fichier de labels !
- set records [Database::dbQueryRecordsFromVarVal $database EU $l]
- if {$records == {}} {
- $w create text [expr $x-$dx+1] [expr $y-$dy+1] -text - \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo NBC$colnumber"
- } elseif {[llength $records] >= 2} {
- $w create text [expr $x-$dx+1] [expr $y-$dy+1] -text * \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo NBC$colnumber"
- } else {
- set record [lindex $records 0]
- foreach {vari val} $X($record) {
-
- if {[string equal $var $vari] == 1} {
-
- set rgb [split $val ,]
- set r [lindex $rgb 0]
- set g [lindex $rgb 1]
- set b [lindex $rgb 2]
- puts RGB****$rgb
- puts R***$r
- puts G***$g
- puts B***$b
- set color [format "#%.2x%.2x%.2x" $r $g $b ]
- puts color***$color
- $w create rectangle [expr $x-$dx] [expr $y-$dy] [expr $x+$dx] [expr $y+$dy] \
- -fill $color -outline $color \
- -tags "T$ti AnnotMatrix AM$ti BIN?$$val MA?$l $tagC AMatrixCo NBC$colnumber"
- }
- }
-
- }
- }
- }
- Navigation::FitToContents $w
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
-
- proc DrawAnnotateGo {} {
- }
-
-
- # ls : listbox source ; lt listbox target
- proc AnnotateAddItem {ls lt} {
- global S
- if {$S(database) != ""} {
- set lindexvariables [$ls curselection] ;# des index
- foreach index $lindexvariables {
- set variable [$ls get $index]
- $ls itemconfigure $index -background NavajoWhite2
- set lvalues [Database::dbQueryValFromVar $S(database) $variable]
- foreach value [lsort -dictionary $lvalues] {
- $lt insert end [format "%s%s%s%s%s" $value < $variable < $S(database)]
- }
- }
- }
- }
- proc AnnotateQuit {} {
- set choix [tk_messageBox -type okcancel -default ok \
- -message "Exit Annotation Browser ?" -icon question]
- if {$choix == "ok"} {
- eval destroy .annotation
- }
- }
- #
- proc AnnotateLabelsFileSwitch {m} {
- global S
- set select [$m get]
- switch -exact $select {
- "?" {puts Default}
- default {set S(database) $select}
- }
- # mise a jour listbox des variables
- set lvar [Database::dbQueryVarAll $S(database)]
- # remplissage listbox
- .annotation.p.pane0.childsite.n.canvas.notebook.cs.page1.cs.lfa.l delete 0 end
- eval {.annotation.p.pane0.childsite.n.canvas.notebook.cs.page1.cs.lfa.l insert end} $lvar
- }
-
- #
- proc SwitchCol0 {w} {
- global S ann
- $w configure -background $S(col)
- set ann(binmatColor0) $S(col)
- }
- #
- proc SwitchCol1 {w} {
- global S ann
- $w configure -background $S(col)
- set ann(binmatColor1) $S(col)
- }
- #
- proc ANmoveMatrix {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set S(mox) $x
- set S(moy) $y
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- # motion sur AM$t
- set i [lindex $tags [lsearch -glob $tags T*]]
- set t [string range $i 1 end]
- bind movematrix <B1-Motion> "Annotation::ANmoveMotion %W %x %y AM$t"
- }
- }
- }
- #
- proc ANmoveCOL {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set S(mox) $x
- set S(moy) $y
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- bind movecol <B1-Motion> "Annotation::ANmoveMotion %W %x %y $tag"
- }
- }
- }
- #
- proc ANmoveMotion {w x y tag} {
- global S T
- $w move $tag [expr $x - $S(mox)] 0
- #$w move $tag [expr $x - $S(mox)] [expr $y - $S(moy)]
- set S(mox) $x
- set S(moy) $y
- }
- proc ANannfgcol {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- $w itemconfigure $tag -fill $S(col)
- }
- }
- }
- proc ANannfgrow {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags MA?*]]
- catch {$w itemconfigure $tag -fill $S(col)}
- }
- }
- }
- proc ANannfocol {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- if {[$w type $id] == "text"} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- set li [$w find withtag $tag]
- foreach i $li {
- if {[$w type $i] == "text"} {
- $w itemconfigure $i -font $S(gfo)}
- }
-
- }
- }
- }
- }
- proc ANannRowCol {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- set lid [$w find withtag $tag]
- foreach i $lid {
- set co [$w coords $i]
- #set x [$w canvasx [lindex $co 0]] ; set y [$w canvasy [lindex $co 1]]
- set x [lindex $co 0] ; set y [lindex $co 1]
- set text [lindex [$w itemconfigure $i -text] end]
- if {$text != "" && $text != " -"} {
- set id [format "%s%s" 1 [Tools::GenId]]
- set idtext [format "%s%s%s" anntext ? $id]
- set idlink [format "%s%s%s" annlink ? $id]
- set font [lindex [$w itemconfigure $i -font] end]
- set color [lindex [$w itemconfigure $i -fill] end]
- $w delete $i
- regsub -all " " $text "\n" newtext
- set newtext [string trimleft $newtext "\n"]
- # -stipple @[file join + stipple $S(stipple)]
- $w create oval [expr $x -3] [expr $y - 3] [expr $x + 3] [expr $y + 3] \
- -fill black -outline black -tags $tags
- $w create text [expr $x + 30 ] $y \
- -text $newtext -anchor nw \
- -tags "bullann $idtext $tags" -font $font -fill $color
- #
- $w create line $x $y [expr $x + 30 ] $y \
- -width 1 -fill $color -tags "Link $idlink $tags"
- } else {
- $w delete i
- }
- }
- }
- }
- $w bind bullann <Button-1> {Annotation::ANmovebullann %W %x %y}
- }
- proc ANmovebullann {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set S(mox) $x
- set S(moy) $y
- set tags [$w gettags $id]
- if {[lsearch -exact $tags bullann] != -1} {
- set tag [lindex $tags [lsearch -glob $tags anntext?*]]
- $w bind bullann <B1-Motion> "Annotation::ANmotionbullann %W %x %y $tag"
- }
- }
- }
- #
- proc ANmotionbullann {w x y tag} {
- global S T
- # move du text
- $w move $tag [expr $x - $S(mox)] [expr $y - $S(moy)]
- # delete et reconstruction du lien
- set taglink [format "%s%s%s" annlink ? [string trimleft $tag anntext? ]]
- set co [$w coords $taglink]
- set xl [lindex $co 0] ; set yl [lindex $co 1]
- set tags [$w gettags $taglink]
- set color [lindex [$w itemconfigure $taglink -fill] end]
- $w delete $taglink
- set idc [$w create line $xl $yl [$w canvasx $x] [$w canvasy $y] \
- -width 1 -fill $color -tags "Link $taglink $tags"]
- $w lower $idc
- # ok
- set S(mox) $x
- set S(moy) $y
- }
- proc ANannillcol {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- $w itemconfigure $tag -font $S(ill-fon)
- }
- }
- }
- proc ANannillcar {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- $w itemconfigure $tag -text $S(ill-car) -font $S(ill-fon)
- }
- }
- }
-
- proc ANannforow {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags MA?*]]
- $w itemconfigure $tag -font $S(gfo)
- }
- }
- }
- proc ANannanchw {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- $w itemconfigure $tag -anchor w
- }
- }
- }
- proc ANannanche {w x y} {
- global S
- set id [$w find withtag current]
- if {$id == ""} {set id [$w find closest $x $y]}
- if {$id != ""} {
- set tags [$w gettags $id]
- if {[lsearch -exact $tags AnnotMatrix] != -1} {
- set tag [lindex $tags [lsearch -glob $tags COL?*]]
- $w itemconfigure $tag -anchor e
- }
- }
- }
- #
- proc AnnotationPanelUpdate {} {
- global S
- set m .ann.l.m
- if {[winfo exists .ann] == "1"} {
- $m delete 0 end
- foreach lf $S(ldatabase) {$m insert end $lf}
- $m select end
- ANVariablesUpdate
- }
- }
- #
- proc ANLabelsFileSwitch {m} {
- global S
- set select [$m get]
- switch -exact $select {
- "?" {puts Default}
- default {set S(database) $select}
- }
- ANVariablesUpdate
- #pour l'instant
- #.ann.l.lfb.l delete 0 end
- }
- # mise a jour liste des variables pour le fichier de label courant
- proc ANVariablesUpdate {} {
- global S
- # liste des variables
- set lvar [Database::dbQueryVarAll $S(database)]
- # remplissage listbox
- .ann.l.lfa.l delete 0 end
- eval {.ann.l.lfa.l insert end} $lvar
- # reconfiguration background des feuilles de la listbox
- # pour celles deja en selection
- # if {[.ann.l.lfb.l get 0 end] != {}} {ANConfigBg}
- }
- # config bg si deja en selection
- proc ANConfigBg {} {
- global S
- set li {}
- set lni {}
- set lavailable [.ann.l.lfa.l get 0 end] ;# var available
- set selectL [.ann.l.lfb.l get 0 end] ;# feuilles en selection
- foreach e $lavailable {
- set r [lsearch $selectL $e]
- set index [lsearch $lavailable $e]
- if {$r != -1} {
- .ann.l.lfa.l itemconfigure $index -background NavajoWhite2
- } else {
- .ann.l.lfa.l itemconfigure $index -background LightGoldenrodYellow
- }
- }
- }
- #
- proc ANaddVarMouse {listbox x y} {
- global S abs
- set leaf [$listbox get @$x,$y]
- set selectL [.ann.l.lfb.l get 0 end]
- if {[lsearch $selectL $leaf] == -1} {
- .ann.l.lfb.l insert end $leaf
- }
- .ann.l.lfa.l selection clear @$x,$y
- ANConfigBg
- }
- # boutton ajout de la selection leave available dans la liste selection
- proc ANAddL {} {
- global S abs
- # mise a jour listbox fichiers selection
- # on conserve l'ordre des groupes de selection
- set li [.ann.l.lfa.l curselection] ;# des index
- set lsel {}
- foreach i $li {
- lappend lsel [.ann.l.lfa.l get $i]
- .ann.l.lfa.l itemconfigure $i -background NavajoWhite2
- }
- set lall2 [.ann.l.lfb.l get 0 end]
- .ann.l.lfb.l delete 0 end
- # c moche je sais
- foreach e $lsel {
- lappend lall2 $e
- }
- #
- foreach e [Tools::DelRep $lall2] {
- .ann.l.lfb.l insert 0 $e
- }
- # deselection des fichiers liste available
- .ann.l.lfa.l selection clear 0 end
- # update nb de tree total
- }
- #
- proc ANRemL {} {
- global abs
- # attention retrait a partir de l'index le plus bat
- # le delete remet a jour les index
- set li [lsort -decreasing [.ann.l.lfb.l curselection]] ;# des index
- foreach i $li {
- .ann.l.lfb.l delete $i
- }
- # deselection des fichiers liste available
- .ann.l.lfa.l selection clear 0 end
- ANConfigBg
- }
- #
- proc ANremVarMouse {listbox x y} {
- global S abs
- $listbox delete @$x,$y
- ANConfigBg
- }
-
- # Query Leaves Annotation Mode Leave
- proc qLannL {w t leu} {
- global S ann T
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- set i [$w find withtag [list ADD?$l && T$t]]
- if {$i == ""} {
- set i [$w find withtag [list [format "%s%s" EU $l] && T$t]]
- set co [$w coords $i]
- set y [lindex $co 1]
- set i2 [$w find withtag [list [format "%s%s" EUL $l] && T$t]]
-
- if {[$w itemcget $i2 -state] == "hidden"} {
- set x [lindex [$w bbox $i] 2]
- } else {
- set x [lindex [$w bbox $i2] 2]
- }
-
- } else {
- set co [$w coords [lindex $i 0]]
- set y [expr [lindex $co 1] + 6]
- set x 0
- foreach ii $i {
- set xii [lindex [$w bbox $ii] 2]
- if {$xii >= $x} {
- set x $xii
- }
- }
- }
- #
- if {$x != "" && $y != ""} {
- if {$S(DisplayVOV) == 0} {set sss [lrange $S(query) 2 end]}
- set lc [split $sss {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $sss
- } else {
- set s " $sss"
- }
-
- $w create text $x $y -text $s \
- -font $S(gfo) \
- -fill $S(col) \
- -anchor center -justify center \
- -tags "ADD?$l T$t AnnotMatrix $tagC AM$t MA?$l" -anchor w
- }
-
- }
- }
- #
- proc qLannC {w t leu} {
- global S ann T
- switch -exact $S($t,type) {
- PhyNJ - ClaSla - ClaRec {
- # recherche x
- if {$S(illustration-tabulation) == 1} {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$t && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- } else {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- }
-
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- # recherche y (code arrete terminale)
- set item [$w find withtag [list [format "%s%s" EU $l ] && T$t]]
- if {$item != ""} {
- set co [$w coords $item]
- set y [lindex $co 1]
- # avoir un nombre pair de caractere pour bien centrer
- # sinon on ajoute devant un espace
- #if {$S(DisplayVOV) == 0} {set sss [lrange $S(query) 2 end]}
- if {$S(DisplayVOV) == 0} {set sss $S(query)}
- set lc [split $sss {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $sss
- } else {
- set s " $sss"
- }
- $w create text $x $y \
- -text $s \
- -fill $S(col) \
- -font $S(gfo) \
- -anchor w -justify center \
- -tags "T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- qLannC360 $w $t $leu
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- qLannC360 $w $t $leu
- }
- }
- }
- ###
- proc qLannC360old {w t leu} {
- global S ann T
- #puts coucou
- set d $S($t,LabelMatrixBase)
- #set co [$w bbox [list Z && T$t]]
- set co [$w bbox [list L && T$t]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set C(dx) [expr abs(($x2 - $x1)) /2.0]
- set C(dy) [expr abs(($y2 - $y1)) /2.0]
-
- # test pour eviter l'oval
- #if {$C(dx) >= $C(dy)} {set C(dy) $C(dx)} {set C(dx) $C(dy)}
- set R [expr 200 + $S($t,LabelMatrixBase)]
-
-
- set a_ref [expr 360.0/ [llength $T($t,ue_cod)]] ;# unit?Š d'angle
- set n 0
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- # inversion de la liste des eus
- if { $S($t,type) == "ClaCir2"} {
- set LLE {}
- foreach e $T($t,ue_cod) {
- set LLE [concat $e $LLE]
- }
- set n 1
- } else {
- set LLE $T($t,ue_cod)
- }
- # l?Šger d?Šcalage du a anchor/justify si l'annotation a un seul caractere
- # on ajoute a l'avant un espace
- foreach e $LLE {
- set C(angle,$e) [expr $n*$a_ref]
- if {[lsearch $leu $T($t,ctl,$e)] != -1} {
- # degres -> radians
- set angrad [expr (2 * acos(-1) * $C(angle,$e)) / 360.0]
- # d est l'augmentation du rayon du cercle
- set x [expr ($C(dx) + $d ) * cos($angrad)]
- set y [expr ($C(dy) + $d ) * sin($angrad)]
-
- set l $T($t,ctl,$e)
- # query
- if {$S(DisplayVOV) == 0} {set sss [lrange $S(query) 2 end]}
- # avoir un nombre pair de caractere pour bien centrer
- # sinon on ajoute devant un espace
- set lc [split $sss {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $sss
- } else {
- set s " $sss"
- }
- $w create text [expr $x + $x1 + $C(dx)] [expr $y + $y1 + $C(dy)] \
- -text $s \
- -anchor center -justify center \
- -fill $S(col) \
- -font $S(gfo) \
- -tags "ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"
- }
- incr n
- }
- unset C
- }
- # NB pb si les feuilles de sont pas affich?Šes
- # en plus attention en circulaire sans longueur de branche
- # il
- proc qLannC360 {w t leu} {
- global S ann T
- # cercle d'illustration fixer R le rayon du cercle d'illustration
- # on peut fixer une valeur pour par ex. 200 + tabulation
- # mais mieux de chercher une valeur adapt?Še ? chaque
- # arbre
- # set R [expr 200 + $S($t,LabelMatrixBase)]
- set co [$w bbox [list L && T$t]]
- # si les feuilles ne sont pas affich?Šes on prend les arretes terminales
- set co [$w bbox [list Z && T$t]]
- # et si on utillisait toujours sur Z ?
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set Rx [expr ($x2 - $x1) /2.0]
- set Ry [expr ($y2 - $y1) /2.0]
- if {$Rx > $Ry} {
- set R [expr $Rx + $S($t,LabelMatrixBase)]
- } else {
- set R [expr $Ry + $S($t,LabelMatrixBase)]
- }
- set a_ref [expr 6.28318530717958 / [llength $T($t,ue_cod)]]
- set n 0
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- # inversion ordre liste feuilles selon conformation
- if { $S($t,type) == "ClaCir2"} {
- set LLE {}
- foreach e $T($t,ue_cod) {
- set LLE [concat $e $LLE]
- }
- set n 1
- } else {
- set LLE $T($t,ue_cod)
- }
- # l?Šger d?Šcalage du a anchor/justify si l'annotation a un seul caractere
- # ou nombre impair, on ajoute a l'avant un espace
- foreach e $LLE {
- set a [expr double($n*$a_ref)]
- if {[lsearch $leu $T($t,ctl,$e)] != -1} {
- set x [expr $R * cos($a)]
- set y [expr $R * sin($a)]
- # TAG
- set l $T($t,ctl,$e)
- # query
- if {$S(DisplayVOV) == 0} {set sss [lrange $S(query) 2 end]}
- # avoir un nombre pair de caractere pour bien centrer
- # sinon on ajoute devant un espace
- set lc [split $sss {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $sss
- } else {
- set s " $sss"
- }
- $w create text $x $y \
- -text $s \
- -anchor center -justify center \
- -fill $S(col) \
- -font $S(gfo) \
- -tags "ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"
- }
- incr n
- }
- # centrage sur arbre tags root "[format "%s%s" $t C] T$t Z"
- set co [$w coords [format "%s%s" $t C]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set xcenter [expr ($x1 + $x2) /2.0]
- set ycenter [expr ($y1 + $y2) /2.0]
- $w move $tagC $xcenter $ycenter
- }
- # Leaves Annotation Mode Leave
- proc LannLtoolbox {w x y} {
- global T
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set p [format "%s%s" $n *]
- set leu {}
- foreach e $T($t,ue_cod) {
- if {[string match $p $e] == 1} {
- lappend leu $T($t,ctl,$e)
- }
- }
- LannL $w $t $leu
- }
- }
- #
- proc LannL {w t leu} {
- global S ann T
- switch -exact $S($t,type) {
- PhyNJ - ClaSla - ClaRec {
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- set i [$w find withtag [list ADD?$l && T$t]]
- if {$i == ""} {
- set i [$w find withtag [list [format "%s%s" EU $l] && T$t]]
- set co [$w coords $i]
- set y [lindex $co 1]
- set i2 [$w find withtag [list [format "%s%s" EUL $l] && T$t]]
-
- if {[$w itemcget $i2 -state] == "hidden"} {
- set x [lindex [$w bbox $i] 2]
- } else {
- set x [lindex [$w bbox $i2] 2]
- }
-
- } else {
- set co [$w coords [lindex $i 0]]
- set y [lindex $co 1]
- set x 0
- foreach ii $i {
- set xii [lindex [$w bbox $ii] 2]
- if {$xii >= $x} {
- set x $xii
- }
- }
- }
- if {$x != "" && $y != ""} {
- # avoir un nombre pair de caractere pour bien centrer
- # sinon on ajoute devant un espace
- set lc [split $S(AnnotateNote) {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $S(AnnotateNote)
- } else {
- set s " $S(AnnotateNote)"
- }
- $w create text $x $y -text $s \
- -font $S(gfo) \
- -fill $S(col) \
- -anchor center -justify center \
- -tags "ADD?$l T$t $tagC AnnotMatrix AM$t MA?$l" -anchor w
- }
- }
-
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # rien pour l'instant
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # pour l'instant on reste sur LannC360 mais il faudra
- # passer par une proc LannL360
- LannC360 $w $t $leu
- }
- }
- }
- # AnnotMatrix AM$t MA?$l
- proc LannCtoolbox {w x y} {
- global T
- set tags [$w gettags [$w find withtag current]]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set p [format "%s%s" $n *]
- set leu {}
- foreach e $T($t,ue_cod) {
- if {[string match $p $e] == 1} {
- lappend leu $T($t,ctl,$e)
- }
- }
- LannC $w $t $leu
- }
- }
- #
- proc LannC {w t leu} {
- global S ann T
- switch -exact $S($t,type) {
- PhyNJ - ClaSla - ClaRec {
- # recherche x
- if {$S(illustration-tabulation) == 1} {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$t && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- } else {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- }
-
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $leu {
- # recherche y (code arrete terminale)
- set item [$w find withtag [list [format "%s%s" EU $l ] && T$t]]
- if {$item != ""} {
- set co [$w coords $item]
- set y [lindex $co 1]
- # avoir un nombre pair de caractere pour bien centrer
- # sinon on ajoute devant un espace
- set lc [split $S(AnnotateNote) {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $S(AnnotateNote)
- } else {
- set s " $S(AnnotateNote)"
- }
- $w create text $x $y \
- -text $s \
- -fill $S(col) \
- -font $S(gfo) \
- -anchor center -justify center \
- -tags "T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- LannC360 $w $t $leu
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- LannC360 $w $t $leu
- }
- }
- }
- ###
- proc LannC360 {w t leu} {
- global S ann T
- # cercle d'illustration fixer R le rayon du cercle d'illustration
- # on peut fixer une valeur pour par ex. 200 + tabulation
- # mais mieux de chercher une valeur adapt?Še ? chaque
- # arbre
- # set R [expr 200 + $S($t,LabelMatrixBase)]
- set co [$w bbox [list L && T$t]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set Rx [expr ($x2 - $x1) /2.0]
- set Ry [expr ($y2 - $y1) /2.0]
- if {$Rx > $Ry} {
- set R [expr $Rx + $S($t,LabelMatrixBase)]
- } else {
- set R [expr $Ry + $S($t,LabelMatrixBase)]
- }
- set a_ref [expr 6.28318530717958 / [llength $T($t,ue_cod)]]
- set n 0
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- # inversion ordre liste feuilles selon conformation
- if { $S($t,type) == "ClaCir2"} {
- set LLE {}
- foreach e $T($t,ue_cod) {
- set LLE [concat $e $LLE]
- }
- set n 1
- } else {
- set LLE $T($t,ue_cod)
- }
- # l?Šger d?Šcalage du a anchor/justify si l'annotation a un seul caractere
- # on ajoute a l'avant un espace
- foreach e $LLE {
- set a [expr double($n*$a_ref)]
- if {[lsearch $leu $T($t,ctl,$e)] != -1} {
- set x [expr $R * cos($a)]
- set y [expr $R * sin($a)]
- # TAG
- set l $T($t,ctl,$e)
- # avoir un nombre pair de caractere pour bien centrer
- # sinon on ajoute devant un espace
- set lc [split $S(AnnotateNote) {}]
- set nbc [llength $lc]
- if {[expr $nbc / 2 * 2] == $nbc} {
- set s $S(AnnotateNote)
- } else {
- set s " $S(AnnotateNote)"
- }
- #-text $S(AnnotateNote)
- $w create text $x $y \
- -text $s \
- -anchor center -justify center \
- -fill $S(col) \
- -font $S(gfo) \
- -tags "ILLCo?$l T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"
- }
- incr n
- }
- # centrage sur arbre tags root "[format "%s%s" $t C] T$t Z"
- set co [$w coords [format "%s%s" $t C]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set xcenter [expr ($x1 + $x2) /2.0]
- set ycenter [expr ($y1 + $y2) /2.0]
- $w move $tagC $xcenter $ycenter
- }
- proc DrawANGo {} {
- global S ann T
- set lv {}
- set lindex [.ann.l.lfa.l curselection]
- foreach i $lindex {
- lappend lv [.ann.l.lfa.l get $i]
- }
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- DrawANGoGo $lv $ltreetarget
- }
-
- proc DrawANGoGo {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
-
- foreach var $lv {
- set w $S($ti,w)
- set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$ti && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- if [catch {expr $S($ti,LabelMatrixBase) + $S(TabulationAnnot)} result] {
- set S($ti,LabelMatrixBase) $S(TabulationAnnot)
- } else {
- set S($ti,LabelMatrixBase) $result
- }
- set x [expr $XMAX + $S($ti,LabelMatrixBase)]
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $T($ti,ue_lab) {
- #
- # x et y appliquent une translation en et y respectivement
- # f est un facteur d'amplication de taille
- set lcoordsCONTOUR {} ; set f 100.0
- # recherche y
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- if {$item == ""} {
- set items [$w find withtag [list ADD?$l && T$ti]]
- set y 0
- foreach ii $items {
- set yii [lindex [$w coords $ii] 1]
- if {$yii >= $y} {
- set y $yii
- }
- }
- } else {
- set co [$w coords $item]
- set y [lindex $co 1]
- }
- switch $ann(ann-fgfiguration) {
- asleaf {set itemfgcolor [$w itemcget $item -fill]}
- asuser {set itemfgcolor $S(col)}
- }
- switch $ann(ann-fofiguration) {
- asleaf {set itemfont [$w itemcget $item -font]}
- asuser {set itemfont $S(gfo)}
- }
- # construction de itemtext sur query
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- append itemtext " $val"
- }
- }
- }
- }
- set ID [Tools::GenId]
- # transformation coordonnees
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $ann(DrawFactor))]
- set yy [expr $y + ($yi * $ann(DrawFactor))]
- append lcoordsCONTOUR $xx
- append lcoordsCONTOUR " "
- append lcoordsCONTOUR $yy
- append lcoordsCONTOUR " "
- if {$ann(DrawNode) == 1} {
- $w create rectangle [expr $xx -1] [expr $yy-1] [expr $xx+1] [expr $yy+1] -fill white -outline black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo Morpho MOR$ID"
- }
-
- }
- set iitteemm [$w create polygon $lcoordsCONTOUR -fill white -outline black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo Morpho MOR$ID" ]
- $w lower $iitteemm
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
- proc DrawPlotANGo {} {
- global S ann T
- set lv {}
- set lindex [.ann.l.lfa.l curselection]
- foreach i $lindex {
- lappend lv [.ann.l.lfa.l get $i]
- }
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- DrawPlotANGoGo $lv $ltreetarget
- }
- proc DrawPlotANGoGo {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
-
- foreach var $lv {
- set w $S($ti,w)
- set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$ti && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- if [catch {expr $S($ti,LabelMatrixBase) + $S(TabulationAnnot)} result] {
- set S($ti,LabelMatrixBase) $S(TabulationAnnot)
- } else {
- set S($ti,LabelMatrixBase) $result
- }
- set x [expr $XMAX + $S($ti,LabelMatrixBase)]
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $T($ti,ue_lab) {
- #
- # x et y appliquent une translation en et y respectivement
- # f est un facteur d'amplication de taille
- set lcoordsCONTOUR {} ; set f 100.0
-
-
- # recherche y
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- if {$item == ""} {
- set items [$w find withtag [list ADD?$l && T$ti]]
- set y 0
- foreach ii $items {
- set yii [lindex [$w coords $ii] 1]
- if {$yii >= $y} {
- set y $yii
- }
- }
- } else {
- set co [$w coords $item]
- set y [lindex $co 1]
- }
- switch $ann(ann-fgfiguration) {
- asleaf {set itemfgcolor [$w itemcget $item -fill]}
- asuser {set itemfgcolor $S(col)}
- }
- switch $ann(ann-fofiguration) {
- asleaf {set itemfont [$w itemcget $item -font]}
- asuser {set itemfont $S(gfo)}
- }
- # construction de itemtext sur query
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- append itemtext " $val"
- }
- }
- }
- }
- # transformation coordonnees
- set ximax 0 ; set yimax 0
- # recherche xmax ymax
- foreach {xi yi} $itemtext {
- if {$xi >= $ximax} {set ximax $xi}
- if {$yi >= $yimax} {set yimax $yi}
- }
- set fx [expr $ann(DrawXsize) / $ximax]
- set fy [expr $ann(DrawYsize) / $yimax]
- switch $ann(XYmode) {
- scatter {
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $fx)]
- set yy [expr $y + ($yi * $fy)]
- $w create line $xx $yy [expr $xx +1] [expr $yy +1] -fill black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo"
- }
- }
- batons {
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $fx)]
- set yy [expr $y + ($yi * $fy)]
- $w create line $xx [expr $y + $ann(DrawYsize) + 3] $xx [expr $yy +1] -fill black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo"
- }
- }
- curve {
- set ldot ""
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $fx)]
- set yy [expr $y + ($yi * $fy)]
- $w create line $xx $yy [expr $xx +1] [expr $yy +1] -fill black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo"
- append ldot " $xx $yy"
- }
- $w create line $ldot -fill black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo"
- }
- }
-
- # voir si bbox
- set iit [$w create rectangle \
- [expr $x - $ann(DrawXsize) - 3 ] [expr $y - $ann(DrawYsize) - 3] \
- [expr $x + $ann(DrawXsize) + 3] [expr $y + $ann(DrawYsize) + 3] -fill white -outline black \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo" ]
- $w lower $iit
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
-
- #
- proc PlotNodeMGo {w t n database variable} {
- set ln [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach ni $ln {
- if {$ni == $t} {
- set co [$w coords [format "%s%s" $n C]]
- set x [lindex $co 0]
- set y [expr ([lindex $co 3] - [lindex $co 1]) / 2.0]
- } else {
- set co [$w coords $ni]
- set x [lindex $co 0]
- set y [lindex $co 1]
- }
- PlotNodeGo $w $t $ni $database $variable $x $y
- }
- }
- #
- proc PlotNodeGo {w t n database variable x y} {
- global S T ann B
- # liste feuilles sources
- set SouRefLea [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $n]]
-
- # liste records correspondant aux feuilles sources
- set MatchingRecords {}
- foreach f $SouRefLea {
- set recordsOK [Database::dbQueryRecordsFromVarPatVal $database EU $f]
- foreach r $recordsOK {
- lappend MatchingRecords $r
- }
- }
- # liste valeurs pour $variable sur les matching records
- upvar #0 $database X
- set MatchingValues {}
- foreach r $MatchingRecords {
- set toc $X($r)
- if {!([set pos [lsearch $toc $variable]]%2)} {
- set val [lindex $toc [incr pos]]
- if {[lsearch -exact $MatchingValues $val] == -1} {lappend MatchingValues $val}
- }
- }
- # $MatchingValues est une liste de liste de coordonn?Šes non ordonn?Še
- set nb [llength $MatchingValues] ;# on va calculer la moyenne
- foreach lc $MatchingValues {
- set cindex 0
- foreach c $lc {
- incr cindex
- if [catch {expr $Somme($cindex) + $c} result] {
- set Somme($cindex) $c
- } else {
- set Somme($cindex) $result
- }
- }
- }
- # passage array vers liste
- # probleme recuperer dans l'ordre
- set itemtext {}
- for {set i 1} {$i <= $cindex} {incr i 1} {
- append itemtext " [expr $Somme($i) / $nb]"
- }
- # transformation coordonnees
- set ID [Tools::GenId]
-
-
- # transformation coordonnees
- set ximax 0 ; set yimax 0
- # recherche xmax ymax
- foreach {xi yi} $itemtext {
- if {$xi >= $ximax} {set ximax $xi}
- if {$yi >= $yimax} {set yimax $yi}
- }
- set fx [expr $ann(DrawXsize) / $ximax]
- set fy [expr $ann(DrawYsize) / $yimax]
- switch $ann(XYmode) {
- scatter {
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $fx)]
- set yy [expr $y + ($yi * $fy)]
- $w create line $xx $yy [expr $xx +1] [expr $yy +1] -fill black \
- -tags "T$t bullab BLL?$ID AnnotMatrix AM$t AMatrixCo Plot Plot$ID"
- }
- }
- batons {
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $fx)]
- set yy [expr $y + ($yi * $fy)]
- $w create line $xx [expr $y + $ann(DrawYsize) + 3] $xx [expr $yy +1] -fill black \
- -tags "T$t bullab BLL?$ID AnnotMatrix AM$t AMatrixCo Plot Plot$ID"
- }
- }
- curve {
- set ldot ""
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $fx)]
- set yy [expr $y + ($yi * $fy)]
- $w create line $xx $yy [expr $xx +1] [expr $yy +1] -fill black \
- -tags "T$t bullab BLL?$ID AnnotMatrix AM$t AMatrixCo Plot Plot$ID"
- append ldot " $xx $yy"
- }
- $w create line $ldot -fill black \
- -tags "T$t AnnotMatrix AM$t MA?$l $tagC AMatrixCo"
- }
- }
-
- set iit [$w create rectangle \
- [expr $x - $ann(DrawXsize) - 3] [expr $y - $ann(DrawYsize) - 3] \
- [expr $x + $ann(DrawXsize) + 3] [expr $y + $ann(DrawYsize) + 3] -fill white -outline black \
- -tags "T$t bullab BLL?$ID AnnotMatrix AM$t AMatrixCo Plot Plot$ID" ]
- $w lower $iit
- BLLmake4 $w $t $x $y $ID $n
- }
-
- proc SubtreeShapeMGo {w t n database variable} {
- set ln [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach ni $ln {
- if {$ni == $t} {
- set co [$w coords [format "%s%s" $n C]]
- set x [lindex $co 0]
- set y [expr ([lindex $co 3] - [lindex $co 1]) / 2.0]
- } else {
- set co [$w coords $ni]
- set x [lindex $co 0]
- set y [lindex $co 1]
- }
- SubtreeShapeGo $w $t $ni $database $variable $x $y
- }
- }
- #
- proc SubtreeShapeGo {w t n database variable x y} {
- global S T ann B
- # liste feuilles sources
- set SouRefLea [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $n]]
-
- # liste records correspondant aux feuilles sources
- set MatchingRecords {}
- foreach f $SouRefLea {
- set recordsOK [Database::dbQueryRecordsFromVarPatVal $database EU $f]
- foreach r $recordsOK {
- lappend MatchingRecords $r
- }
- }
- # liste valeurs pour $variable sur les matching records
- upvar #0 $database X
- set MatchingValues {}
- foreach r $MatchingRecords {
- set toc $X($r)
- if {!([set pos [lsearch $toc $variable]]%2)} {
- set val [lindex $toc [incr pos]]
- if {[lsearch -exact $MatchingValues $val] == -1} {lappend MatchingValues $val}
- }
- }
- # $MatchingValues est une liste de liste de coordonn?Šes non ordonn?Še
- set nb [llength $MatchingValues] ;# on va calculer la moyenne
- foreach lc $MatchingValues {
- set cindex 0
- foreach c $lc {
- incr cindex
- if [catch {expr $Somme($cindex) + $c} result] {
- set Somme($cindex) $c
- } else {
- set Somme($cindex) $result
- }
- }
- }
- # passage array vers liste
- # probleme recuperer dans l'ordre
- set itemtext {}
- for {set i 1} {$i <= $cindex} {incr i 1} {
- append itemtext " [expr $Somme($i) / $nb]"
- }
- # transformation coordonnees
- set ID [Tools::GenId]
- foreach {xi yi} $itemtext {
- set xx [expr $x + ($xi * $ann(DrawFactor))]
- set yy [expr $y + ($yi * $ann(DrawFactor))]
- append lcoordsCONTOUR $xx
- append lcoordsCONTOUR " "
- append lcoordsCONTOUR $yy
- append lcoordsCONTOUR " "
- if {$ann(DrawNode) == 1} {
- $w create rectangle [expr $xx -1] [expr $yy-1] [expr $xx+1] [expr $yy+1] -fill white -outline black \
- -tags "T$t bullab BLL?$ID AnnotMatrix AM$t AMatrixCo Morpho MOR$ID"
- }
- }
- if {$S(stipple) == "z.xbm"} {
- if {$ann(DrawFill) == 1} {
- set iitt [$w create polygon $lcoordsCONTOUR -outline black -fill $S(col) \
- -tags "bullab BLL?$ID T$t AnnotMatrix AM$t AMatrixCo Morpho MOR$ID"]
- } else {
- set iitt [$w create polygon $lcoordsCONTOUR -outline black -fill white \
- -tags "bullab BLL?$ID T$t AnnotMatrix AM$t AMatrixCo Morpho MOR$ID"]
- }
- } else {
- set iitt [$w create polygon $lcoordsCONTOUR -fill $S(col) -outline black \
- -stipple @[file join $S(TheoPATH) + stipple $S(stipple)] \
- -tags "bullab BLL?$ID T$t AnnotMatrix AM$t AMatrixCo Morpho MOR$ID"]
- }
- $w lower $iitt
- BLLmake4 $w $t $x $y $ID $n
- }
- # nb anchor a remplacer par justify
- proc ANGoNew {} {
- global S ann T
- set lv {}
- set lib .annotation.p.pane0.childsite.n.canvas.notebook.cs.page1.cs.lfa.l
- set lindex [$lib curselection]
- foreach i $lindex {
- lappend lv [$lib get $i]
- }
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- ANGoGo $lv $ltreetarget
- }
- proc ANGo {} {
- global S ann T
- set lv {}
- set lindex [.ann.l.lfa.l curselection]
- foreach i $lindex {
- lappend lv [.ann.l.lfa.l get $i]
- }
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- ANGoGo $lv $ltreetarget
- }
- #
- proc ANGoLeaves {lv ltreetarget} {
- global S ann T
- switch $ann(ann-leavemod) {
- add {
- ANGoLeavesAdd $lv $ltreetarget
- }
- replace {
- ANGoLeavesReplace $lv $ltreetarget
- }
- }
- }
- # lv liste de variables
- proc ANGoGoNew {lv ltreetarget} {
- global S ann T
- switch $ann(ann-textmod) {
- add {
- ANGoLeavesAdd $lv $ltreetarget
- #
-
- set li .annotation.p.pane2.childsite.n.canvas.notebook.cs.page1.cs.s1.l
- #$li insert end "color $ann(ann-fgfiguration) asleaf
- #set ann(ann-fofiguration)
- foreach v $lv {
- $li insert end "AN LeavesAdd {$S(database) {$v}} {prefix \"$ann(ann-prefix)\" suffix \"$ann(ann-suffix)\" exposant \"$ann(ann-exposant)\"}"
- }
- }
- replace {
- ANGoLeavesReplace $lv $ltreetarget
- set li .annotation.p.pane2.childsite.n.canvas.notebook.cs.page1.cs.s1.l
- foreach v $lv {
- $li insert end "AN LeavesReplace {$S(database) {$v}} {prefix \"$ann(ann-prefix)\" suffix \"$ann(ann-suffix)\" exposant \"$ann(ann-exposant)\"}"
- }
- }
- addcolumns {
- ANGoColumns $lv $ltreetarget
- set li .annotation.p.pane2.childsite.n.canvas.notebook.cs.page1.cs.s1.l
- foreach v $lv {
- $li insert end "AN LeavesAddColumns {$S(database) {$v}} {prefix \"$ann(ann-prefix)\" suffix \"$ann(ann-suffix)\" exposant \"$ann(ann-exposant)\"}"
- }
- }
- }
- }
- proc ANGoGo {lv ltreetarget} {
- global S ann T
- switch $ann(ann-position) {
- add {
- ANGoLeaves $lv $ltreetarget
- }
- justify {
- ANGoColumns $lv $ltreetarget
- }
- }
- }
- # set S($t,type) ClaCir5 (circulaire interne)
- proc ANGoColumns {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
- foreach var $lv {
- set w $S($ti,w)
-
- set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$ti && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- if [catch {expr $S($ti,LabelMatrixBase) + 7} result] {
- set S($ti,LabelMatrixBase) 7
- } else {
- set S($ti,LabelMatrixBase) $result
- }
- set x [expr $XMAX + $S($ti,LabelMatrixBase)]
-
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $T($ti,ue_lab) {
- # recherche y
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- if {$item == ""} {
- set items [$w find withtag [list ADD?$l && T$ti]]
- set y 0
- foreach ii $items {
- set yii [lindex [$w coords $ii] 1]
- if {$yii >= $y} {
- set y $yii
- }
- }
- } else {
- set co [$w coords $item]
- set y [lindex $co 1]
- }
- switch $ann(ann-fgfiguration) {
- asleaf {set itemfgcolor [$w itemcget $item -fill]}
- asuser {set itemfgcolor $S(col)}
- }
- switch $ann(ann-fofiguration) {
- asleaf {set itemfont [$w itemcget $item -font]}
- asuser {set itemfont $S(gfo)}
- }
- # construction de itemtext sur query
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- append itemtext " $val"
- }
- }
- }
- }
- # coordonnees
- set texto [format "%s%s%s" $ann(ann-prefix) $itemtext $ann(ann-suffix)]
- $w create text $x [expr $y + $ann(ann-exposant)] \
- -text $texto \
- -fill $itemfgcolor \
- -font $itemfont \
- -tags "T$ti AnnotMatrix AM$ti MA?$l $tagC AMatrixCo" -anchor w
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
-
- # ATTENTION PB si leaf hidden
- proc ANGoLeavesAdd {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
- foreach var $lv {
- set w $S($ti,w)
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- foreach l $T($ti,ue_lab) {
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- set itemfgcolor [$w itemcget $item -fill]
- set itemfont [$w itemcget $item -font]
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- append itemtext $val
- }
- }
- }
- }
- foreach vi $itemtext {
- set i [$w find withtag [list ADD?$l && T$ti]]
- if {$i == ""} {
- set i [$w find withtag [list [format "%s%s" EU $l] && T$ti]]
- set co [$w coords $i]
- set y [lindex $co 1]
- set i2 [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
-
- if {[$w itemcget $i2 -state] == "hidden"} {
- set x [lindex [$w bbox $i] 2]
- } else {
- set x [lindex [$w bbox $i2] 2]
- }
- } else {
- set co [$w coords [lindex $i 0]]
- set y [lindex $co 1]
- set x 0
- foreach ii $i {
- set xii [lindex [$w bbox $ii] 2]
- if {$xii >= $x} {
- set x $xii
- }
- }
- }
- switch $ann(ann-fgfiguration) {
- asleaf {
- set item [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set itemfgcolor [$w itemcget $item -fill]
- }
- asuser {set itemfgcolor $S(col)}
- }
- switch $ann(ann-fofiguration) {
- asleaf {
- set item [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set itemfont [$w itemcget $item -font]
- }
- asuser {set itemfont $S(gfo)}
- }
- if {$x != "" && $y != ""} {
- set vi [string trimleft $vi " "]
- set texto [format "%s%s%s" $ann(ann-prefix) $vi $ann(ann-suffix)]
- $w create text $x [expr $y + $ann(ann-exposant)] -text "$texto" \
- -font $itemfont \
- -fill $itemfgcolor \
- -tags "ADD?$l T$ti MA$l $tagC AnnotMatrix AM$ti" -anchor w
- }
- }
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
- #
- proc ANGoLeavesReplaceORI {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
-
- foreach var $lv {
- set w $S($ti,w)
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
-
- foreach l $T($ti,ue_lab) {
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- set itemfgcolor [$w itemcget $item -fill]
- set itemfont [$w itemcget $item -font]
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- append itemtext $val
- }
- }
- }
- }
- foreach vi $itemtext {
- set i [$w find withtag [list ADD?$l && T$ti]]
- if {$i == ""} {
- set i [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set co [$w coords $i]
- set y [lindex $co 1]
- set x [lindex [$w bbox $i] 0]
- } else {
- # cas si plusieurs ajout on recup le i de plus gran x
- set co [$w coords [lindex $i 0]]
- set y [lindex $co 1]
- set x 0
- foreach ii $i {
- set xii [lindex [$w bbox $ii] 2]
- if {$xii >= $x} {
- set x $xii
- }
- }
- }
-
- switch $ann(ann-fgfiguration) {
- asleaf {
- set item [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set itemfgcolor [$w itemcget $item -fill]
- }
- asuser {set itemfgcolor $S(col)}
- }
- switch $ann(ann-fofiguration) {
- asleaf {
- set item [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set itemfont [$w itemcget $item -font]
- }
- asuser {set itemfont $S(gfo)}
- }
- set vi [string trimleft $vi " "]
- $w itemconfigure $item -state hidden
- set texto [format "%s%s%s" $ann(ann-prefix) $vi $ann(ann-suffix)]
- $w create text $x [expr $y + $ann(ann-exposant)] -text "$texto" \
- -font $itemfont \
- -fill $itemfgcolor \
- -tags "ADD?$l T$ti MA$l $tagC AnnotMatrix AM$ti" -anchor w
- }
- }
- }
- }
-
-
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
- #
- proc ANGoLeavesReplace {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
-
- foreach var $lv {
- set w $S($ti,w)
- # tag de colonne
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
-
- foreach l $T($ti,ue_lab) {
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$ti]]
- set itemfgcolor [$w itemcget $item -fill]
- set itemfont [$w itemcget $item -font]
- set record [Database::dbQueryRecordsFromVarVal $database EU $l]
- set itemtext ""
- if {$record == {}} {
- set itemtext "-"
- } else {
- foreach ri $record {
- foreach {vari val} $X($ri) {
- if {[string equal $var $vari] == 1} {
- append itemtext $val
- }
- }
- }
- }
-
- set i [$w find withtag [list ADD?$l && T$ti]]
- if {$i == ""} {
- set i [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set co [$w coords $i]
- set y [lindex $co 1]
- set x [lindex [$w bbox $i] 0]
- } else {
- # cas si plusieurs ajout on recup le i de plus gran x
- set co [$w coords [lindex $i 0]]
- set y [lindex $co 1]
- set x 0
- foreach ii $i {
- set xii [lindex [$w bbox $ii] 2]
- if {$xii >= $x} {
- set x $xii
- }
- }
- }
-
- switch $ann(ann-fgfiguration) {
- asleaf {
- set item [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set itemfgcolor [$w itemcget $item -fill]
- }
- asuser {set itemfgcolor $S(col)}
- }
- switch $ann(ann-fofiguration) {
- asleaf {
- set item [$w find withtag [list [format "%s%s" EUL $l] && T$ti]]
- set itemfont [$w itemcget $item -font]
- }
- asuser {set itemfont $S(gfo)}
- }
- set vi [string trimleft $itemtext " "]
- $w itemconfigure $item -state hidden
- set texto [format "%s%s%s" $ann(ann-prefix) $vi $ann(ann-suffix)]
- $w create text $x [expr $y + $ann(ann-exposant)] -text "$texto" \
- -font $itemfont \
- -fill $itemfgcolor \
- -tags "ADD?$l T$ti MA$l $tagC AnnotMatrix AM$ti" -anchor w
-
- }
- }
- }
-
-
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
- # A FAIRE
- }
- ClaCir1 - ClaCir2 - ClaCir3 {
- # A FAIRE
- }
- }
- }
- }
- ###
- proc CanvasTextSelect {w x y} {
- global S
- set x [$w canvasx $x]
- set y [$w canvasy $y]
- CanvasTextDone $w
- if {[$w type current] == "text"} {
- $w addtag "EdiText" withtag current
- } else {
- set ltags {EdiText TXT}
- foreach ti $S($w,t) {
- lappend ltags "T$ti"
- }
- $w create text $x $y -font $S(gfo) -fill $S(col) -justify left -tags $ltags
- }
- focus $w
- $w focus "EdiText"
- $w icursor "EdiText" @$x,$y
- }
- ###
- proc CanvasTextEditAdd {w s} {
- $w insert "EdiText" insert $s
- }
- ###
- proc CanvasTextEnd {w } {
- $w delete "EdiText"
- }
- ###
- proc CanvasTextEditBacksp {w} {
- set pos [expr [$w index "EdiText" insert] -1]
- if {$pos >= 0} {
- $w dchars "EdiText" $pos
- }
- }
- ###
- proc CanvasTextDone {w} {
- set msg [$w itemcget "EdiText" -text]
- if {[string length [string trim $msg]] == 0} {
- $w delete "EdiText"
- }
- $w dtag "EdiText"
- $w focus ""
- }
- ### A REVOIR
- proc Insert {what} {
- global S T
- set w [format "%s%s%s" .t $S(ict) .c]
- switch -exact $what {
- Scale {$w delete SCA
- set kv [array get T $S(ict),dbl,*]
- set max 0
- foreach {key value} $kv {
- if {$value >= $max} {set max $value ; set keymax $key}
- }
- set code [string range $keymax [expr [string last "," $keymax] +1] end]
- set cood [$w coords $code]
- set leng [expr [lrange $cood 0 0] - [lrange $cood 2 2]]
- set wgoal [expr [winfo width $w] / 10.0]
- set r [expr $wgoal / $leng]
- set dxfinal [expr $r * $max]
- set deci [string last . $dxfinal]
- set dxfinal [string range $dxfinal 0 [expr $deci +2] ]
- set lefinal [expr $r * $leng]
- set ori_x 20.0
- set ori_y 20.0
- $w create line $ori_x $ori_y \
- $ori_x [expr $ori_y + 7.0] \
- $ori_x [expr $ori_y + 3.0] \
- [expr $ori_x + $lefinal] [expr $ori_y + 3.0] \
- [expr $ori_x + $lefinal] [expr $ori_y + 7.0] \
- [expr $ori_x + $lefinal] $ori_y \
- -width 1 -fill blue -tags SCA
- $w create text [expr $ori_x + $lefinal / 2] [expr $ori_y + 10.0] \
- -text $dxfinal -font $T($S(ict),gfo) -fill blue -tags SCA -anchor center
- set S(und) "$w delete SCA"
- }
- Date {set s [clock format [clock seconds] -format "%A %B %d %H:%M:%S %Z %Y"]
- $w create text 30 30 -text $s -font $S(gfo) -fill $T($S(ict),gfg) -tags "TXT"
- }
- File {set s $T($S(ict),fil)
- $w create text 40 40 -text $s -font $S(gfo) -fill $T($S(ict),gfg) -tags "TXT"
- }
- Text {set s $T($S(ict),fil)
- Interface::toolbar_select .treedyn.n.tab.notebook.page1.w.pt textinsert
- TBA::CanvasTextSelect $w 10 10
- }
- }
- }
- #
- proc AnnotateBuiltIn {w t x y what {color black} } {
- global S T
- switch -exact $what {
- Scale {
- #$w delete SCA
- set kv [array get T $t,dbl,*]
- # recherche d'une longueur de branche moyenne
- set dblB 0.0
- foreach {key value} $kv {
- if {$value >= $dblB} {set dblB $value ; set keymax $key}
- }
- set dblA $dblB
- foreach {key value} $kv {
- if {$value <= $dblA} {set dblA $value ; set keymin $key}
- }
-
- set dblmoy [expr ($dblB - $dblA) / 2.0]
- # longueur C du trait correspondant a la dblmoy
- set code [string range $keymax [expr [string last "," $keymax] +1] end]
-
- if { $S($t,type) == "PhyRad"} {
- set code [format "%s%s" $code C]
- }
- set cood [$w coords $code]
-
- set B [expr [lrange $cood 0 0] - [lrange $cood 2 2]]
-
- set C [expr ($dblmoy * $B) / $dblB]
- #arrondir dblmoy
- set scientif [format "%e" $dblmoy]
- set exposant [string range $scientif [string first e $scientif] end]
- set prefixe [expr round([string range $scientif 0 [expr [string first e $scientif] -1]])]
- set dblmoyarrondi [format "%f" [format "%s%s" $prefixe $exposant]]
- #ajuster la longueur du trait moyen a l'arrondi
- set D [expr ($dblmoyarrondi * $C) / $dblmoy]
- # dessin
- set ori_x $x
- set ori_y $y
- set tagi [format "%s%s" TSCA [Tools::GenId]]
- $w create line $ori_x $ori_y [expr $ori_x + $D] $ori_y \
- -width 1 -fill $color -tags "SCA T$t $tagi"
- $w create text [expr $ori_x + $D / 2] [expr $ori_y + 10.0] \
- -text [string trimright $dblmoyarrondi 0 ] -font $S(gfo) -fill $color -tags "SCA T$t $tagi" -anchor center
- set S(und) "$w delete [list SCA && T$t]"
- }
- Scale100 {
- set co [$w bbox [list T$t && Z]]
- set x1 [lindex $co 0]
- set x2 [lindex $co 2]
- set dx [expr $x2 - $x1]
- set unit [expr $dx / 10.0]
- set tagi [format "%s%s" TSCA [Tools::GenId]]
- for {set i 0} {$i <= 10} {incr i 1} {
- $w create line [expr $x + ($i * $unit)] [expr $y -3] \
- [expr $x + ($i * $unit)] [expr $y +4] -width 1 -fill black -tags "SCA T$t $tagi"
- set texto [format "%s%s" [expr 10 * $i] "%"]
- $w create text [expr $x + ($i * $unit)] [expr $y -5] -text $texto \
- -fill black -tags "SCA T$t $tagi" -anchor s -justify center
- }
- $w create line $x $y [expr $x + $dx] $y -width 1 -fill black -tags "SCA T$t $tagi"
- }
- Date {
- $w create text $x $y -text [clock format [clock seconds] -format "%A %B %d %Y"] \
- -font $S(gfo) -fill $S(col) -tags "TXT T$t"
- }
- File {
- #
- #[wm title [winfo parent $w]]
- $w create text $x $y -text $S($t,tit) -font $S(gfo) -fill $S(col) -tags "TXT T$t" -anchor w
- }
- }
- }
- ###
- proc DisplayDBL {w t} {
- global T S
- set li [$w find withtag [list T$t && DBL]]
- if {$li != ""} {
- $w delete [list T$t && DBL]
- } else {
- $w delete [list T$t && DBL]
- set l [lrange $T($t,all_cod) 1 end]
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
-
- set co [$w coords $i]
- if {$co != ""} {
- set x [lrange $co 2 2]
- set y [lrange $co 1 1]
- eval {$w create text} \
- {$x $y} \
- {-text $T($t,dbl,$i) -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"}
- }
- }
- }
- }
- }
- ###
- proc DisplayDBLpercent {w t} {
- global T S
- # recherche plus grande longueur de branche
- set ls [lrange $T($t,all_cod) 1 end]
- set blmax 0
- foreach l $ls {
- if {$T($t,dbl,$l) > $blmax} {set blmax $T($t,dbl,$l)}
- }
- # facteur / 100
- set N [expr $blmax / 100.0]
- set li [$w find withtag [list T$t && DBL]]
- if {$li != ""} {
- $w delete [list T$t && DBL]
- } else {
- $w delete [list T$t && DBL]
- set l [lrange $T($t,all_cod) 1 end]
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- set x [lrange $co 2 2]
- set y [lrange $co 1 1]
- set bl [format "%s%s" [expr round($T($t,dbl,$i) / $N)] %]
- eval {$w create text} \
- {$x $y} \
- {-text $bl -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"}
- }
- }
- }
- }
- }
- #
- proc NodeDBLp {w x y} {
- global S T
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- # recherche plus grande longueur de branche
- set ls [lrange $T($t,all_cod) 1 end]
- set blmax 0
- foreach l $ls {
- if {$T($t,dbl,$l) > $blmax} {set blmax $T($t,dbl,$l)}
- }
- # facteur / 100
- set N [expr $blmax / 100.0]
- set bl [format "%s%s" [expr round($T($t,dbl,$n) / $N)] %]
- $w create text $x $y -text $bl -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"
- }
- }
- #
- proc NodeDBL {w x y} {
- global S T
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- $w create text $x $y -text $T($t,dbl,$n) -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"
- }
- }
- #
- proc NodeDBV {w x y} {
- global S T
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- if [catch {set test $T($t,dbv,$n)} res] {
- #nothing
- } else {
- $w create text $x $y -text $T($t,dbv,$n) -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"
- }
- }
- }
- #
- proc NodeDBVp {w x y} {
- global S T
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- if [catch {set test $T($t,dbv,$n)} res] {
- #nothing
- } else {
- set lall [lrange $T($t,all_cod) 1 end]
- # on retire les codes des ue
- set l [Tools::SousL $lall $T($t,ue_cod)]
- # recherche plus grande valeur bootstrap
- set bvmax 0
- foreach i $l {
- if {$T($t,dbv,$i) > $bvmax} {set bvmax $T($t,dbv,$i)}
- }
- # facteur / 100
- set N [expr $bvmax / 100.0]
- if {$T($t,dbv,$n) != ""} {
- set txt [format "%s%s" [expr round($T($t,dbv,$n) / $N)] %]
- $w create text $x $y -text $txt -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"
- }
- }
- }
- }
- ###
- proc DisplayDBV {w t} {
- global T S
- set x [$w canvasx $x] ; set y [$w canvasy $y]
- set li [$w find withtag [list T$t && DBV]]
- if {$li != ""} {
- $w delete [list T$t && DBV]
- } else {
- set lall [lrange $T($t,all_cod) 1 end]
- # on retire les codes des ue
- set l [Tools::SousL $lall $T($t,ue_cod)]
- $w delete [list T$t && DBV]
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- set x [lrange $co 0 0]
- set y [lrange $co 1 1]
- if {$T($t,dbv,$i) != ""} {
- set txt $T($t,dbv,$i)
- eval {$w create text} \
- {$x $y} \
- {-text $txt -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBV"}
- }
- }
- }
- }
- }
- }
-
- proc DisplayDBVseuilGO {w t} {
- global T S
- $w delete [list T$t && DBV]
- set lall [lrange $T($t,all_cod) 1 end]
- set l [Tools::SousL $lall $T($t,ue_cod)]
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- set x [lrange $co 0 0]
- set y [lrange $co 1 1]
- if {$T($t,dbv,$i) != "" && $T($t,dbv,$i) >= $S(dbvseuil) } {
- set txt $T($t,dbv,$i)
- eval {$w create text} \
- {$x $y} \
- {-text $txt -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBV"}
- }
- }
- }
- }
- }
-
- proc DisplayDBLseuilGO {w t} {
- global T S
- $w delete [list T$t && DBL]
- set l [lrange $T($t,all_cod) 1 end]
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- set x [lrange $co 2 2]
- set y [lrange $co 1 1]
- if {$T($t,dbl,$i) != "" && $T($t,dbl,$i) >= $S(dblseuil) } {
- eval {$w create text} \
- {$x $y} \
- {-text $T($t,dbl,$i) -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBL"}
- }
- }
- }
- }
-
- }
- ###
- proc DisplayDBVpercent {w t} {
- global T S
- $w delete [list T$t && DBV]
- set lall [lrange $T($t,all_cod) 1 end]
- # on retire les codes des ue
- set l [Tools::SousL $lall $T($t,ue_cod)]
- # recherche plus grande valeur bootstrap
- set bvmax 0
- foreach i $l {
- if {$T($t,dbv,$i) > $bvmax} {set bvmax $T($t,dbv,$i)}
- }
- # facteur / 100
- set N [expr $bvmax / 100.0]
- $w delete [list T$t && DBV]
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- set x [lrange $co 0 0]
- set y [lrange $co 1 1]
- if {$T($t,dbv,$i) != ""} {
- set txt [format "%s%s" [expr round($T($t,dbv,$i) / $N)] %]
- eval {$w create text} \
- {$x $y} \
- {-text $txt -fill $S(col) \
- -font $S(gfo) -anchor nw -tags "T$t DBV"}
- }
-
- }
- }
- }
-
- }
- #
- proc LabelMatrix {w t EUS tagquery} {
- global S
- set tagquery [format "%s%s%s" MA ? $tagquery]
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if [catch {expr $S($t,LabelMatrixBase) + $S(TabulationAnnot)} result] {
- set S($t,LabelMatrixBase) $S(TabulationAnnot)
- } else {
- set S($t,LabelMatrixBase) $result
- }
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- foreach eu $EUS {
- set i [$w find withtag [list T$t && EUL$eu]]
- if {$i != ""} {
- set co [$w coords $i]
- set y [lindex $co 1]
- $w create text $x $y -text + -fill $S(col) -tags "T$t $tagquery AnnotMatrix ML?$eu"
- }
- }
- $w bind AnnotMatrix <Any-Enter> "after 500 Annotation::AnyEnterAM %W %x %y"
- $w bind AnnotMatrix <Any-Leave> "after 500 Annotation::AnyLeaveAM %W"
- }
- #
- proc AnyEnterAM {w x y} {
- set tags [$w gettags current]
- set color [$w itemcget current -fill]
- set maq [lindex $tags [lsearch -glob $tags MA*]]
- set maf [lindex $tags [lsearch -glob $tags ML*]]
- set q [lindex [split $maq ?] end]
- set ql [lindex [split $maf ?] end]
- $w create text [expr $x + 15] $y -text [format "%s%s%s" $ql : $q] \
- -anchor w -tag AMi -fill $color
- }
- proc AnyLeaveAM {w} {
- $w delete AMi
- }
- #
- proc BLLmake {w t x y titre text n} {
- global B S
- # attention 1n:nBLL
- set id [format "%s%s" $t [Tools::GenId]]
- set idtext [format "%s%s%s" BLL ? $id]
- set idlink [format "%s%s%s" LIN ? $id]
- #BLL
- set txt $text
- set txtfinal $txt
- $w create text [$w canvasx [expr $x + 30 ] ] [$w canvasy [expr $y + 30 ]] \
- -text $txtfinal -font $S(gfo) -fill $S(col) -anchor nw \
- -tags "bullab T$t $idtext"
- # LIN [expr $x + 30 ] [expr $y + 30 ]
- $w create line [$w canvasx $x] [$w canvasy $y] [$w canvasx [expr $x + 30 ] ] [$w canvasy [expr $y + 30 ]] \
- -width 1 -fill $S(col) -tags "Link T$t $idlink"
- # MEM
- set B(BLLtre,$id) $t
- set B(BLLnod,$id) $n
- set B(BLLtxt,$id) $txtfinal
- set B(BLLidt,$id) $idtext
- set B(BLLidl,$id) $idlink
- set B(BLLcol,$id) $S(col)
- set B(BLLgfo,$id) $S(gfo)
- set B(BLLxxx,$id) [expr $x + 30 ]
- set B(BLLyyy,$id) [expr $y + 30 ]
- # Liste des BLL par tree
- lappend B($t,bll) $id
- }
- # idem que BLLmake mais ne cree pas les items graphiques
- # utilise dans les copy/paste et restauration
- # 2 arguments suple la couleur et la fonte
- proc BLLmake2 {w t x y titre text n col gfo} {
- global B S
- # attention 1n:nBLL
- set id [format "%s%s" $t [Tools::GenId]]
- set idtext [format "%s%s%s" BLL ? $id]
- set idlink [format "%s%s%s" LIN ? $id]
- #BLL
- set txt $text
- #set txtfinal [format "%s%s%s" $titre \n $txt]
- set txtfinal $txt
- # MEM
- set B(BLLtre,$id) $t
- set B(BLLnod,$id) $n
- set B(BLLtxt,$id) $txtfinal
- set B(BLLidt,$id) $idtext
- set B(BLLidl,$id) $idlink
- set B(BLLcol,$id) $col
- set B(BLLgfo,$id) $gfo
- set B(BLLxxx,$id) [expr $x + 30 ]
- set B(BLLyyy,$id) [expr $y + 30 ]
- # Liste des BLL par tree
- lappend B($t,bll) $id
- }
- # comme BLLmake mais ici on utilise les fontes pour illustration
- proc BLLmake3 {w t x y text n} {
- global B S
- # attention 1n:nBLL
- set id [format "%s%s" $t [Tools::GenId]]
- set idtext [format "%s%s%s" BLL ? $id]
- set idlink [format "%s%s%s" LIN ? $id]
- #BLL
- set txt $text
- set txtfinal $txt
- $w create text [$w canvasx [expr $x + 30 ] ] [$w canvasy [expr $y + 30 ]] \
- -text $txtfinal -font $S(ill-fon) -fill $S(col) -anchor nw \
- -tags "bullab T$t $idtext"
- # LIN [expr $x + 30 ] [expr $y + 30 ]
- $w create line [$w canvasx $x] [$w canvasy $y] [$w canvasx [expr $x + 30 ] ] [$w canvasy [expr $y + 30 ]] \
- -width 1 -fill $S(col) -tags "Link T$t $idlink"
- # MEM
- set B(BLLtre,$id) $t
- set B(BLLnod,$id) $n
- set B(BLLtxt,$id) $txtfinal
- set B(BLLidt,$id) $idtext
- set B(BLLidl,$id) $idlink
- set B(BLLcol,$id) $S(col)
- set B(BLLgfo,$id) $S(ill-fon)
- set B(BLLxxx,$id) [expr $x + 30 ]
- set B(BLLyyy,$id) [expr $y + 30 ]
- # Liste des BLL par tree
- lappend B($t,bll) $id
- }
- ###
- # comme BLLmake mais ici une forme complexe type polygon
- # id est un tag unique partage par tous les items composant la structure
- proc BLLmake4 {w t x y id n} {
- global B S
- # attention 1n:nBLL
- # set id [format "%s%s" $t [Tools::GenId]]
- # set idtext [format "%s%s%s" BLL ? $id]
- set idlink [format "%s%s%s" LIN ? $id]
- $w create line [$w canvasx $x] [$w canvasy $y] [$w canvasx [expr $x + 30 ] ] [$w canvasy [expr $y + 30 ]] \
- -width 1 -fill $S(col) -tags "Link T$t $idlink"
- # MEM
- set B(BLLtre,$id) $t
- set B(BLLnod,$id) $n
- set B(BLLtxt,$id) -
- set B(BLLidt,$id) MOR$id
- set B(BLLidl,$id) $idlink
- set B(BLLcol,$id) $S(col)
- set B(BLLgfo,$id) $S(ill-fon)
- set B(BLLxxx,$id) [expr $x + 30 ]
- set B(BLLyyy,$id) [expr $y + 30 ]
- # Liste des BLL par tree
- lappend B($t,bll) $id
- }
- ###
- proc BLLDelete {w i} {
- global B
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BLL*]] ?] end]
- $w delete [format "%s%s%s" BLL ? $id]
- $w delete [format "%s%s%s" LIN ? $id]
- set t $B(BLLtre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bll) $id]
- set B($t,bll) [concat [lrange $B($t,bll) 0 [expr $index - 1]] \
- [lrange $B($t,bll) [expr $index + 1] end]]
- }
- ###
- proc BLLDelete2 {w id} {
- global B
- $w delete [format "%s%s%s" BLL ? $id]
- $w delete [format "%s%s%s" LIN ? $id]
- set t $B(BLLtre,$id)
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,bll) $id]
- set B($t,bll) [concat [lrange $B($t,bll) 0 [expr $index - 1]] \
- [lrange $B($t,bll) [expr $index + 1] end]]
- }
- ###
- proc BLLUpdateColor {w i} {
- global B S
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BLL*]] ?] end]
- $w itemconfigure [format "%s%s%s" BLL ? $id] -fill $S(col)
- $w itemconfigure [format "%s%s%s" LIN ? $id] -fill $S(col)
- set B(BLLcol,$id) $S(col)
- }
- ###
- proc BLLUpdateFont {w i} {
- global B S
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BLL*]] ?] end]
- $w itemconfigure [format "%s%s%s" BLL ? $id] -font $S(gfo)
- set B(BLLgfo,$id) $S(gfo)
- }
- ###
- proc BLLmove {w x y i} {
- global B S
- $w move $S(mov) [expr $x - $S(mox)] [expr $y - $S(moy)]
- set S(mox) $x
- set S(moy) $y
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags BLL*]] ?] end]
- if {$B(BLLnod,$id) == $B(BLLtre,$id)} {
- set co_sou [$w coords [format "%s%s" $B(BLLnod,$id) C]]
- set x1 [lindex $co_sou 0]
- set y1 [expr ([lindex $co_sou 3] - [lindex $co_sou 1]) / 2.0]
- } else {
- set co_sou [$w coords $B(BLLnod,$id)]
- set x1 [lindex $co_sou 0]
- set y1 [lindex $co_sou 1]
- }
- set co_tar [$w coords $i]
- set x2 [lindex $co_tar 0]
- set y2 [lindex $co_tar 1]
- # il peu y avoir des tags suplementaires a la liste "Link T$B(BLLtre,$id) $idlink"
- # en particulier le tag lie aux decompositions
- set tagslink [$w gettags $B(BLLidl,$id)]
- $w delete $B(BLLidl,$id)
- $w create line $x1 $y1 $x2 $y2 \
- -width 1 -fill $B(BLLcol,$id) -tags $tagslink
- set B(BLLxxx,$id) $x
- set B(BLLyyy,$id) $y
- }
- # QUERYNODE
- proc QueryNode {w t eu} {
- global S T B
- set id [format "%s%s" $t [Tools::GenId]]
- set idtext [format "%s%s%s" QYN ? $id]
- set co [$w bbox [list Z && T$t]]
- $w create text [lindex $co 0] [lindex $co 1] -text $S(query) \
- -fill $S(col) -font $S(gfo) -tags "querynode T$t $idtext" -anchor nw
- $w raise Q$t
- # restriction de result aux EU appartenant au tree target
- set leu {}
- foreach e $eu {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- set B(QYNres,$id) $leu
- set B(QYNqry,$id) $S(query)
- set B(QYNtre,$id) $t
- set B(QYNidt,$id) $idtext
- set B(QYNcol,$id) $S(col)
- set B(QYNgfo,$id) $S(gfo)
- set B(QYNxxx,$id) 0
- set B(QYNyyy,$id) 0
- lappend B($t,qyn) $id
- }
- ### NB : pas de QueryNodeLink sur les nodes, trop de recouvrements
- proc QueryNodeLinkLeaf {id leu} {
- global B S T
- # set tags [$w gettags $i]
- # set id [lindex [split [lindex $tags [lsearch -glob $tags QYN*]] ?] end]
- set w $S($B(QYNtre,$id),w)
- set co_sou [$w coords [format "%s%s%s" QYN ? $id]]
- set x1 [lindex $co_sou 0]
- set y1 [lindex $co_sou 1]
- foreach eu $leu {
- set i2 [$w find withtag [list [format "%s%s" EU $eu] && T$B(QYNtre,$id)]]
- set co_tar [$w coords $i2]
- set x2 [lindex $co_tar 0]
- set y2 [lindex $co_tar 1]
- set idlink [format "%s%s%s" LIN ? $id]
- QueryNodeLink $w $x1 $y1 $x2 $y2 $B(QYNcol,$id) "Link $idlink T$B(QYNtre,$id)"
- }
- }
- proc QueryNodeUnLinkLeaf {id leu} {
- global B S
- set w $S($B(QYNtre,$id),w)
- set idlink [format "%s%s%s" LIN ? $id]
- $w delete $idlink
- }
- ###
- proc QueryNodeLink {w x1 y1 x2 y2 c tags} {
- $w create line $x1 $y1 $x2 $y2 -width 1 -fill $c -tags $tags
- }
- ###
- proc QueryNodeUpdateColor {w id} {
- global B S
- $w itemconfigure [format "%s%s%s" QYN ? $id] -fill $S(col)
- $w itemconfigure [format "%s%s%s" LIN ? $id] -fill $S(col)
- set B(QYNcol,$id) $S(col)
- }
- ###
- proc QueryNodeUpdateFont {w id} {
- global B S
- $w itemconfigure [format "%s%s%s" QYN ? $id] -font $S(gfo)
- set B(QYNgfo,$id) $S(gfo)
- }
-
- ### OK
- proc QueryNodeLocalisation {id} {
- global B S T
- set t $B(QYNtre,$id)
- set w $S($t,w)
- # restriction aux eus du tree target,
- # voir aussi si prise en compte des eus sous shrink
- set EUS {}
- foreach e $B(QYNres,$id) {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend EUS $e}
- }
- Operation::Operation $w $t $EUS
- }
- ###
- proc QueryNodeMove {w x y i} {
- global S T B
- $w move $S(mov) [expr $x - $S(mox)] [expr $y - $S(moy)]
- set S(mox) $x
- set S(moy) $y
- set tags [$w gettags $i]
- set id [lindex [split [lindex $tags [lsearch -glob $tags QYN*]] ?] end]
- # delete et redraw des link
- if {[$w find withtag [format "%s%s%s" LIN ? $id]] != {} } {
- $w delete [format "%s%s%s" LIN ? $id]
- set co_sou [$w coords $i]
- set x1 [lindex $co_sou 0]
- set y1 [lindex $co_sou 1]
- foreach eu $B(QYNres,$id) {
- set i2 [$w find withtag [list [format "%s%s" EU $eu] && T$B(QYNtre,$id)]]
- set co_tar [$w coords $i2]
- set x2 [lindex $co_tar 0]
- set y2 [lindex $co_tar 1]
- set idlink [format "%s%s%s" LIN ? $id]
- QueryNodeLink $w $x1 $y1 $x2 $y2 $B(QYNcol,$id) "Link $idlink T$B(QYNtre,$id)"
- }
- }
- set B(QYNxxx,$id) $x
- set B(QYNyyy,$id) $y
- }
- ###
- proc QueryNodeDelete {w id} {
- global B
- $w delete [format "%s%s%s" QYN ? $id]
- $w delete [format "%s%s%s" LIN ? $id]
- set t $B(QYNtre,$id)
-
- foreach key [array names B *,$id] {
- unset B($key)
- }
- #retirer
- set index [lsearch -exact $B($t,qyn) $id]
- set B($t,bll) [concat [lrange $B($t,qyn) 0 [expr $index - 1]] \
- [lrange $B($t,qyn) [expr $index + 1] end]]
- }
- ###
- proc InsertTextNode {w x y} {
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- InsertTextNodeMake $w $t $x $y $n
- }
- }
- ###
- proc InsertTextNodeMake {w t x y n} {
- global S
- # set x [$w canvasx $x]
- # set y [$w canvasy $y]
- set text $S(AnnotateNote)
- Annotation::BLLmake $w $t $x $y "Note :" $text $n
- $w configure -scrollregion [$w bbox all]
- }
- #
- proc InsertSymbolNode {w x y} {
- set tags [$w gettags [$w find withtag current]]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- set t [string range \
- [lindex $tags [lsearch -glob $tags T*]] 1 end]
- if {$n != ""} {
- InsertSymbolNodeMake $w $t $x $y $n
- }
- }
- ###
- proc InsertSymbolNodeMake {w t x y n} {
- global S
- # set x [$w canvasx $x]
- # set y [$w canvasy $y]
- set text $S(ill-car)
- Annotation::BLLmake3 $w $t $x $y $text $n
- $w configure -scrollregion [$w bbox all]
- }
- ###
- # s est soit tab- soit tab+
- # cette fonction permet d'inc?Šmenter (+) // d?Šcr?Šmenter (-)
- # la variable de tabulation pour les arbres en target
- # manuellement (afin de tab entre 2 series de requetes)
- proc AnnCTabulation {s} {
- global S T
- # A-list window/tree des arbres en target d'une session treedyn
- foreach {w t} [Selection::TreeTar] {
- switch -exact $s {
- tab+ {
- if [catch {expr $S($t,LabelMatrixBase) + $S(TabulationAnnot)} result] {
- set S($t,LabelMatrixBase) $S(TabulationAnnot)
- } else {
- set S($t,LabelMatrixBase) $result
- }
- }
- tab- {
- if [catch {expr $S($t,LabelMatrixBase) - $S(TabulationAnnot)} result] {
- # rien
- } else {
- set S($t,LabelMatrixBase) $result
- }
- }
- }
- }
- }
-
-
-
- }
- ####################
- ####################
- # ABSTRACTION
- ####################
- namespace eval Abstraction {
-
- # Collapse cumulatif de la selection user
- proc CollapseToolbox {w} {
- global B T
- set item [$w find withtag current]
- set tags [$w gettags $item]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set TarCodLea [Tools::NodeNoToLe $t $n]
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # ON AJOUTE
- foreach i $TarRefLea {lappend T($t,eu_collapse) $i}
- set finalleaves [Tools::SousL $T($t,ue_lab) $T($t,eu_collapse)]
- # on envoie les feuilles qu'on garde
- NewickAbstract $w $t $finalleaves
- }
- }
- # UnCollapse cumulatif de la selection user
- proc CollapseUnToolbox {w} {
- global B T
- set item [$w find withtag current]
- set tags [$w gettags $item]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright \
- [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- set TarCodLea [Tools::NodeNoToLe $t $n]
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # ON SOUSTRAIT
- set T($t,eu_collapse) [Tools::SousL $T($t,eu_collapse) $TarRefLea]
- set finalleaves [Tools::SousL $T($t,ue_lab) $T($t,eu_collapse)]
- # on envoie les feuilles qu'on garde
- NewickAbstract $w $t $finalleaves
- }
- }
- # Collapse cumulatif de la selection user
- proc Collapse {w t TarRefLea} {
- global B T
- # ON AJOUTE
- foreach i $TarRefLea {lappend T($t,eu_collapse) $i}
- set finalleaves [Tools::SousL $T($t,ue_lab) $T($t,eu_collapse)]
- # on envoie les feuilles qu'on garde
- NewickAbstract $w $t $finalleaves
- }
- # UnCollapse cumulatif de la selection user
- proc CollapseUn {w t TarRefLea} {
- global B T
- # ON SOUSTRAIT
- set T($t,eu_collapse) [Tools::SousL $T($t,eu_collapse) $TarRefLea]
- set finalleaves [Tools::SousL $T($t,ue_lab) $T($t,eu_collapse)]
- # on envoie les feuilles qu'on garde
- NewickAbstract $w $t $finalleaves
-
- }
- proc Shrink3 {w t n} {
- global S T B IMGshn
- set id [format "%s%s" $t [Tools::GenId]]
- set TAG [format "%s%s%s" SHI ? $id]
- set c0 [$w bbox $n]
- set x0 [lindex $c0 0]
- set y0 [lindex $c0 1]
- set leafs [Tools::NodeNoToLe $t $n]
- set lxy [Figuration::NodeColorBgSubTreeContour $w $t $n]
- $w create polygon "$x0 $y0 $lxy $x0 $y0" -smooth 1 -splinesteps 100 \
- -fill $S(col) -outline $S(col) -tags "SHRINK [format "%s%s%s" SHN ? $id] T$t"
- $w lower [format "%s%s%s" SHN ? $id] all
- # BLL
- set pattern [format "%s%s" $n *]
- foreach idbll $B($t,bll) {
- if {[string match $pattern $B(BLLnod,$idbll)] == 1 } {
- if {[$w itemcget $B(BLLidt,$idbll) -state] != "hidden"} {
- $w addtag $TAG withtag $B(BLLidt,$idbll)
- $w addtag $TAG withtag $B(BLLidl,$idbll)
- $w itemconfigure $B(BLLidt,$idbll) -state hidden
- $w itemconfigure $B(BLLidl,$idbll) -state hidden
- }
- }
- }
- # leaves
- set leafs [Tools::NodeNoToLe $t $n]
- foreach i $leafs {
- set tagi [list [format "%s%s" EUL $T($t,ctl,$i)] && T$t]
- if {[$w itemcget $tagi -state] != "hidden"} {
- $w addtag $TAG withtag $tagi
- $w itemconfigure $tagi -state hidden
- }
- }
- # background leaves
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgl) {
- if {[string match $pattern $B(BGLnod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGL ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGL ? $idi]
- $w itemconfigure [format "%s%s%s" BGL ? $idi] -state hidden
- }
- }
- }
- # arretes terminales
- set Le [Tools::NodeNoToLe $t $n]
- foreach e $Le {
- if {[$w itemcget $e -state] != "hidden"} {
- $w addtag $TAG withtag $e
- $w itemconfigure $e -state hidden
- }
- }
- # tree
- set lchild [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach i $lchild {
- if {[$w itemcget $i -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s" $i C]
- $w itemconfigure [format "%s%s" $i C] -state hidden
- }
- }
- # ova (en fait que le link)
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,ova) {
- if {[string match $pattern $B(OVAnod1,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" link ? $idi ]
- $w itemconfigure [format "%s%s%s" link ? $idi ] -state hidden
-
- }
- }
- }
- # background tree
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgs) {
- if {[string match $pattern $B(BGSnod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGS ? $idi]
- $w itemconfigure [format "%s%s%s" BGS ? $idi] -state hidden
-
- }
- }
- }
- ### mem & text a afficher en D3
- lappend B($t,shi) $id
- set B(SHInod,$id) $n
- set B(SHItxt,$id) -
- set B(SHItre,$id) $t
- set B(SHIcol,$id) $S(col)
- set B(SHIsta,$id) normal
- # UNDO
- set S(und) "Abstraction::ShrinkUn $w $t $id"
- return $id
- }
- proc Shrink4 {w t n} {
- global S T B IMGshn
- set id [format "%s%s" $t [Tools::GenId]]
- set TAG [format "%s%s%s" SHI ? $id]
- set c0 [$w bbox $n]
- set x0 [lindex $c0 0]
- set y0 [lindex $c0 1]
- set leafs [Tools::NodeNoToLe $t $n]
- set lxy [Figuration::NodeColorBgSubTreeContour $w $t $n]
- $w create polygon "$x0 $y0 $lxy $x0 $y0" -smooth 1 -splinesteps 100 \
- -fill $S(col) -outline $S(col) -tags "SHRINK [format "%s%s%s" SHN ? $id] T$t"
- $w lower [format "%s%s%s" SHN ? $id] all
- # BLL
- set pattern [format "%s%s" $n *]
- foreach idbll $B($t,bll) {
- if {[string match $pattern $B(BLLnod,$idbll)] == 1 } {
- if {[$w itemcget $B(BLLidt,$idbll) -state] != "hidden"} {
- $w addtag $TAG withtag $B(BLLidt,$idbll)
- $w addtag $TAG withtag $B(BLLidl,$idbll)
- $w itemconfigure $B(BLLidt,$idbll) -state hidden
- $w itemconfigure $B(BLLidl,$idbll) -state hidden
- }
- }
- }
- # leaves
- set leafs [Tools::NodeNoToLe $t $n]
- foreach i $leafs {
- set tagi [list [format "%s%s" EUL $T($t,ctl,$i)] && T$t]
- if {[$w itemcget $tagi -state] != "hidden"} {
- $w addtag $TAG withtag $tagi
- $w itemconfigure $tagi -state hidden
- }
- }
- # background leaves
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgl) {
- if {[string match $pattern $B(BGLnod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGL ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGL ? $idi]
- $w itemconfigure [format "%s%s%s" BGL ? $idi] -state hidden
- }
- }
- }
- # arretes terminales
- set Le [Tools::NodeNoToLe $t $n]
- foreach e $Le {
- if {[$w itemcget $e -state] != "hidden"} {
- $w addtag $TAG withtag $e
- $w itemconfigure $e -state hidden
- }
- }
- # tree
- set lchild [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach i $lchild {
- if {[$w itemcget $i -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s" $i C]
- $w itemconfigure [format "%s%s" $i C] -state hidden
- }
- }
- # ova (en fait que le link)
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,ova) {
- if {[string match $pattern $B(OVAnod1,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" link ? $idi ]
- $w itemconfigure [format "%s%s%s" link ? $idi ] -state hidden
-
- }
- }
- }
- # background tree
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgs) {
- if {[string match $pattern $B(BGSnod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGS ? $idi]
- $w itemconfigure [format "%s%s%s" BGS ? $idi] -state hidden
-
- }
- }
- }
- ### mem & text a afficher en D3
- lappend B($t,shi) $id
- set B(SHInod,$id) $n
- set B(SHItxt,$id) -
- set B(SHItre,$id) $t
- set B(SHIcol,$id) $S(col)
- set B(SHIsta,$id) normal
- # UNDO
- set S(und) "Abstraction::ShrinkUn $w $t $id"
- return $id
- }
- ###
- proc Shrink {w t n {txt user}} {
- global T S B IMGshn
- set id [format "%s%s" $t [Tools::GenId]]
- # le tag commun a tous les items qui vont passer en mode hidden
- set TAG [format "%s%s%s" SHI ? $id]
- if {[lsearch -exact $B($t,shi) $id] == -1} {
- # dessin
- set c0 [$w coords $n]
- set x0 [lindex $c0 2]
- set y0 [lindex $c0 3]
- $w create text [expr $x0 +5] $y0 -text + \
- -tags "SHRINK [format "%s%s%s" SHN ? $id] T$t" -font $S(gfo) -fill $S(col)
- # BLL
- set pattern [format "%s%s" $n *]
- foreach idbll $B($t,bll) {
- if {[string match $pattern $B(BLLnod,$idbll)] == 1 } {
- if {[$w itemcget $B(BLLidt,$idbll) -state] != "hidden"} {
- $w addtag $TAG withtag $B(BLLidt,$idbll)
- $w addtag $TAG withtag $B(BLLidl,$idbll)
- $w itemconfigure $B(BLLidt,$idbll) -state hidden
- $w itemconfigure $B(BLLidl,$idbll) -state hidden
- }
- }
- }
- # leaves
- set leafs [Tools::NodeNoToLe $t $n]
- foreach i $leafs {
- set tagi [list [format "%s%s" EUL $T($t,ctl,$i)] && T$t]
- if {[$w itemcget $tagi -state] != "hidden"} {
- $w addtag $TAG withtag $tagi
- $w itemconfigure $tagi -state hidden
- }
- }
- # background leaves
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgl) {
- if {[string match $pattern $B(BGLnod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGL ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGL ? $idi]
- $w itemconfigure [format "%s%s%s" BGL ? $idi] -state hidden
- }
- }
- }
- # arretes terminales
- set Le [Tools::NodeNoToLe $t $n]
- foreach e $Le {
- if {[$w itemcget $e -state] != "hidden"} {
- $w addtag $TAG withtag $e
- $w itemconfigure $e -state hidden
- }
- }
- # tree
- set lchild [Tools::NodeNoCoFaToNoCoCh $t $n]
- foreach i $lchild {
- if {[$w itemcget $i -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s" $i C]
- $w itemconfigure [format "%s%s" $i C] -state hidden
- }
- }
- # ova (en fait que le link)
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,ova) {
- if {[string match $pattern $B(OVAnod1,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" link ? $idi ]
- $w itemconfigure [format "%s%s%s" link ? $idi ] -state hidden
-
- }
- }
- }
- # background tree
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgs) {
- if {[string match $pattern $B(BGSnod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" BGS ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" BGS ? $idi]
- $w itemconfigure [format "%s%s%s" BGS ? $idi] -state hidden
-
- }
- }
- }
- # sous shrink
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,shi) {
- if {[string match $pattern $B(SHInod,$idi)] == 1 } {
- if {[$w itemcget [format "%s%s%s" SHN ? $idi] -state] != "hidden"} {
- $w addtag $TAG withtag [format "%s%s%s" SHN ? $idi]
- $w itemconfigure [format "%s%s%s" SHN ? $idi] -state hidden
- set B(SHIsta,$idi) hidden
- }
- }
- }
- ### mem & text a afficher en D3
- lappend B($t,shi) $id
- set B(SHInod,$id) $n
- set B(SHItxt,$id) $txt
- set B(SHItre,$id) $t
- set B(SHIcol,$id) $S(col)
- set B(SHIfon,$id) $S(gfo)
- set B(SHIsta,$id) normal
- # UNDO
- set S(und) "Abstraction::ShrinkUn $w $t $id"
- return $id
- }
- }
- ### comme shrink mais array seuleument col argument en plus
- proc Shrink2 {w t n col {txt user} } {
- global T S B IMGshn
- set id [format "%s%s" $t [Tools::GenId]]
- lappend B($t,shi) $id
- set B(SHInod,$id) $n
- set B(SHItxt,$id) $txt
- set B(SHItre,$id) $t
- set B(SHIcol,$id) $col
- set B(SHIsta,$id) normal
- }
- ###
- proc ShrinkUn {w t id} {
- global B S
- if {[lsearch -exact $B($t,shi) $id] != -1} {
- set p [format "%s%s%s" SHI ? $id]
- set litems [$w find withtag $p]
- foreach j $litems {
- $w itemconfigure $j -state normal
- $w dtag $j $p
- }
- $w delete [format "%s%s%s" SHN ? $id]
-
- # UNDO
- set S(und) "Abstraction::Shrink $w $t $B(SHInod,$id)"
- #mise a jour array B
- set index [lsearch -exact $B($t,shi) $id]
- set B($t,shi) [concat [lrange $B($t,shi) 0 [expr $index - 1]] \
- [lrange $B($t,shi) [expr $index + 1] end]]
- unset B(SHIsta,$id) ; unset B(SHItre,$id) ; unset B(SHItxt,$id) ; unset B(SHIcol,$id) ; unset B(SHInod,$id)
-
- }
- }
- proc ShrinkUnAll {w t} {
- global B
- foreach id $B($t,shi) {
- ShrinkUn $w $t $id
- }
- }
- # unshrink sachant une liste de node
- proc ShrinkUnLN {w t ln} {
- global B
- set lnshi {}
- foreach id $B($t,shi) {
- lappend lnshi $B(SHInod,$id)
- set transit($B(SHInod,$id)) $id
- }
- foreach n $ln {
- if {[lsearch $lnshi $n] != -1} {
- ShrinkUn $w $t $transit($n)
- }
-
- }
- if [array exists transit] {unset transit}
- }
- ###
- proc ShrinkNodeUpdateColor {w i} {
- global B S
- set tags [$w gettags $i]
- $w itemconfigure $i -fill $S(col)
- set type [$w type $i]
- if {$type == "polygon"} {
- $w itemconfigure $i -outline $S(col)
- }
- set id [lindex [split [lindex $tags [lsearch -glob $tags SHN*]] ?] end]
- set B(SHIcol,$id) $S(col)
- }
- #
- proc LeafShrink {w t leu} {
- global T S B
- # leaves
- foreach i $leu {
- set tagi [list [format "%s%s" EUL $i] && T$t]
- $w itemconfigure $tagi -state hidden
- }
- # background leaves
- set ln [Operation::FindFatherNode $t $leu]
- foreach n $ln {
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgl) {
- if {[string match $pattern $B(BGLnod,$idi)] == 1 } {
- $w itemconfigure [format "%s%s%s" BGL ? $idi] -state hidden
- }
- }
- }
- }
- #
- proc LeafUnShrink {w t leu} {
- global T S B
- # leaves
- foreach i $leu {
- set tagi [list [format "%s%s" EUL $i] && T$t]
- $w itemconfigure $tagi -state normal
- }
- # background leaves
- set ln [Operation::FindFatherNode $t $leu]
- foreach n $ln {
- set pattern [format "%s%s" $n *]
- foreach idi $B($t,bgl) {
- if {[string match $pattern $B(BGLnod,$idi)] == 1 } {
- $w itemconfigure [format "%s%s%s" BGL ? $idi] -state normal
- }
- }
- }
- }
- ### SHRINK OPEN/CLOSE NEXT LEVEL
- proc NodeOpen {{w ?}} {
- global S T
- if {$w == "?"} {set w [format "%s%s%s" .t $S(ict) .c]}
- set t [string range $w 2 [expr [string first .c $w] -1]]
- if {$T($t,currentlevel) == "?"} {
- set level $T($t,tot)
- } elseif {$T($t,currentlevel) == $T($t,tot) } {
- set level $T($t,tot)
- } else {set level $T($t,currentlevel)}
- if {$level != $T($t,tot)} {
- set T($t,currentlevel) [expr $level + 1]
- foreach i $T($t,cbg,$level) {
- set bg [format "%s%s" $i g]
- set bd [format "%s%s" $i d]
- foreach n [list $bg $bd] {
- if {$S(DebugMod) == 1} {
- puts "LEVEL: $level // NODES $T($t,cbg,$level)"
- puts "NODE: $n"
- }
- set Le [TRE::NoToLe $t $n]
- set T($t,lsk) [TRE::SousL $T($t,lsk) $Le]
- set T($t,nsk) [TRE::SousL $T($t,nsk) $n]
- $w delete Z
- }
- }
- }
- TRE::ArrayToCanvasRedisplay $t
- }
- #
- proc NodeClose {{w ?}} {
- global T S
- if {$w == "?"} {set w [format "%s%s%s" .t $S(ict) .c]}
- set t [string range $w 2 [expr [string first .c $w] -1]]
- if {$T($t,currentlevel) == "?"} {
- set level [expr $T($t,tot) - 1]
- } elseif {$T($t,currentlevel) == 0 } {
- set level 0
- } else {set level [expr $T($t,currentlevel) - 1]}
- if {$T($t,currentlevel) != 0} {
- set T($t,currentlevel) $level
- foreach i $T($t,cbg,$level) {
- set bg [format "%s%s" $i g]
- set bd [format "%s%s" $i d]
- foreach n [list $bg $bd] {
- set tagshrink [format "%s%s" $i S]
- set tags [$w gettags [$w find withtag $n]]
- set c0 [$w coords $n]
- if {$S(DebugMod) == 1} {
- puts "LEVEL: $level // NODES $T($t,cbg,$level)"
- puts "NODE: $n // TAGS: $tags"
- }
- set x0 [lindex $c0 2]
- set y0 [lindex $c0 1]
- set Le [TRE::NoToLe $t $n]
- set T($t,lsk) [concat $T($t,lsk) $Le]
- set T($t,nsk) [concat $T($t,nsk) $n]
- foreach e $Le {$w delete $e}
- set lchild [TRE::NoCoFaToNoCoCh $t $n]
- foreach i $lchild {
- $w delete [format "%s%s" $i C]
- $w delete [format "%s%s" $i R] ;# Box
- }
- $w create oval [expr $x0 +2] $y0 [expr $x0 +5] [expr $y0 +3] \
- -outline $T($t,gfg) -fill $T($t,gbg) \
- -tags "$tags L LH Z $tagshrink $Le SHRINK"
- }
- }
- }
- }
- ### Simplification sur la base d'une valeur seuil de bootstrap
- proc NodeOpenClose {{w ?} mode} {
- global T S
- if {$w == "?"} {set w [format "%s%s%s" .t $S(ict) .c]}
- set t [string range $w 2 [expr [string first .c $w] -1]]
- set l {}
- foreach n $T($t,all_cod) {
- if {$n != 0 && [lsearch $T($t,ue_cod) $n] == -1} {
- if {$T($t,dbv,$n) != "?" && $T($t,dbv,$n) != "" && $T($t,dbv,$n) <= $S(lim)} {
- lappend l $n
- }
- }
- }
- set lsup [TRE::FaNoId {} $l]
- # CLOSE
- if {$mode == "c"} {
- foreach i $lsup {
- set n $i
- set tagshrink [format "%s%s" $i S]
- set tags [$w gettags [$w find withtag $n]]
- set c0 [$w coords $n]
- if {$c0 != ""} {
- set x0 [lindex $c0 2]
- set y0 [lindex $c0 1]
- set Le [TRE::NoToLe $t $n]
- set T($t,lsk) [concat $T($t,lsk) $Le]
- set T($t,nsk) [concat $T($t,nsk) $n]
- foreach e $Le {$w delete $e}
- set lchild [TRE::NoCoFaToNoCoCh $t $n]
- foreach i $lchild {
- $w delete [format "%s%s" $i C]
- $w delete [format "%s%s" $i R] ;# Box
- }
- $w create oval [expr $x0 +2] $y0 [expr $x0 +5] [expr $y0 +3] \
- -outline $T($t,gfg) -fill $T($t,gbg) \
- -tags "$tags L LH Z $tagshrink $Le SHRINK"
- }
- }
- }
- # OPEN
- if {$mode == "o"} {
- foreach i $lsup {
- set Le [TRE::NoToLe $t $i]
- set T($t,lsk) [TRE::SousL $T($t,lsk) $Le]
- set T($t,nsk) [TRE::SousL $T($t,nsk) $i]
- $w delete Z
- }
- }
- TRE::ArrayToCanvasRedisplay $t
- }
-
- #
- proc AbsGo {} {
- global S abs
- if {[.abs.lfb.l get 0 end] != {}} {
- # liste de tree target
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- # feuilles en selection
- # si on est en remove, la liste des feuilles est la
- # liste des feuilles available moins la liste des feuilles en selection
- switch $abs(What) {
- display {
- set EUS [.abs.lfb.l get 0 end]
- }
- hidden {
- set EUS [Tools::SousL [.abs.lfa.l get 0 end] [.abs.lfb.l get 0 end]]
- }
- }
- #
- switch $abs(Mode) {
- shrink {
- # pour chaque tree en target identifier SHRINK
- # des noeuds pere sachant la liste leaf en selection
- foreach t $ltreetarget {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {
- Shrink $S($t,w) $t $e "Leaves Abstraction"
- }
- }
- }
- collapse {
- # pour chaque tree en target identifier COLLAPSE
- # des noeuds pere sachant la liste leaf en selection
- foreach t $ltreetarget {
- NewickAbstract $S($t,w) $t $EUS
- }
- }
- }
- }
- }
-
- # mise a jour liste des feuilles en fonction des arbres en target
- proc AbsAddAvailableLeaves {} {
- global S abs T
- # liste de tree target
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- # construction de la liste des feuilles de tous lmes arbres en selection
- # liste sans repetitions, classe par ordre alpha et respectant le filtre
- set leu {}
- if {$abs(stringsearch) != "*"} {
- foreach t $ltreetarget {
- foreach i $T($t,ue_lab) {
- if {[string match $abs(stringsearch) $i]} {lappend leu $i }
- }
- }
- } else {
- foreach t $ltreetarget {
- set leu [concat $leu $T($t,ue_lab)]
- }
- }
- if {[llength $ltreetarget] != 1} {set leu [Tools::DelRep $leu]}
- set leu [lsort -dictionary $leu]
- # remplissage listbox
- .abs.lfa.l delete 0 end
- eval {.abs.lfa.l insert end} $leu
- # reconfiguration background des feuilles de la listbox
- # pour celles deja en selection
- if {[.abs.lfb.l get 0 end] != {}} {AbsConfigBg}
- # mise ajour nb de feuille availabale
- set abs(nbLavailable) [llength [.abs.lfa.l get 0 end]]
- }
- # l'utilisateur modifie le filtre, mise a jour de la listbox des feuilles available
- # attention respect de la casse
- proc AbsUpdateActionFilter {} {
- Abstraction::AbsAddAvailableLeaves
- }
- # config bg si deja en selection
- proc AbsConfigBg {} {
- global S
- set li {}
- set lavailable [.abs.lfa.l get 0 end] ;# feuilles available
- .abs.lfa.l delete 0 end
- eval {.abs.lfa.l insert end} $lavailable
- set selectL [.abs.lfb.l get 0 end] ;# feuilles en selection
- foreach e $selectL {
- set r [lsearch $lavailable $e]
- if {$r != -1} {lappend li $r}
- }
- foreach i $li {
- .abs.lfa.l itemconfigure $i -background NavajoWhite2
- }
- }
- #
- proc AbsaddLeafMouse {listbox x y} {
- global S abs
- set leaf [$listbox get @$x,$y]
- set selectL [.abs.lfb.l get 0 end]
- if {[lsearch $selectL $leaf] == -1} {
- .abs.lfb.l insert 0 $leaf
- }
- .abs.lfa.l selection clear @$x,$y
- AbsConfigBg
- set abs(nbLselection) [llength [.abs.lfb.l get 0 end]]
- }
- # boutton ajout de la selection leave available dans la liste selection
- proc AbsAddL {} {
- global S abs
- # mise a jour listbox fichiers selection
- # on conserve l'ordre des groupes de selection
- set li [.abs.lfa.l curselection] ;# des index
- set lsel {}
- foreach i $li {
- lappend lsel [.abs.lfa.l get $i]
- .abs.lfa.l itemconfigure $i -background NavajoWhite2
- }
- set lall2 [.abs.lfb.l get 0 end]
- .abs.lfb.l delete 0 end
- # c moche je sais
- foreach e $lsel {
- lappend lall2 $e
- }
- #
- foreach e [Tools::DelRep $lall2] {
- .abs.lfb.l insert 0 $e
- }
- # deselection des fichiers liste available
- .abs.lfa.l selection clear 0 end
- # update nb de tree total
- set abs(nbLselection) [llength $lall2]
- }
- #
- proc AbsRemL {} {
- global abs
- # attention retrait a partir de l'index le plus bat
- # le delete remet a jour les index
- set li [lsort -decreasing [.abs.lfb.l curselection]] ;# des index
- foreach i $li {
- .abs.lfb.l delete $i
- }
- # deselection des fichiers liste available
- .abs.lfa.l selection clear 0 end
- set abs(nbLselection) [llength [.abs.lfb.l get 0 end]]
- AbsConfigBg
- }
- #
- proc AbsremLeafMouse {listbox x y} {
- global S abs
- $listbox delete @$x,$y
- AbsConfigBg
- set abs(nbLselection) [llength [.abs.lfb.l get 0 end]]
- }
- ### OPTIMISATION : si un node est ok : ne pas tester ses nodes fils
- proc FindFatherNode {t SouRefLea} {
- global S T
- set L {}
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $T($t,all_cod)] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test inclusion des references leaf de TARGET avec SOURCE
- if {$S(nodefilter) == 0} {
- set r [Tools::ListInclu $TarRefLea $SouRefLea]
- if {$r == 1} {lappend L $TarCodNod}
- } else {
- set r [Tools::ListIncluSauf $TarRefLea $SouRefLea $S(nodefilter)]
- if {$r == 1} {lappend L $TarCodNod}
- }
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {
- if {[lsearch -exact $T($t,ue_lab) $SouRefLea] != -1} {return $T($t,ltc,$SouRefLea)} else {return {}}
- }
- }
- }
- ####################
- ####################
- # LOCALISATION
- ####################
- namespace eval Localisation {
-
-
-
- ###
- proc LocalisationEU {w t EUS } {
- Operation::Operation $w $t $EUS
- }
- ###
- proc LocalisationDB {w t database var val } {
- global S
- set S(query) [format "%s%s%s" $var " == " $val]
- set records [Database::dbQueryRecordsFromVarVal $database $var $val]
- set EUS [Database::dbQueryEusFromRecords $database $records]
- Operation::Operation $w $t $EUS
- }
- }
- ####################
- ####################
- # IDENTIFICATION
- ####################
- namespace eval Identification {
-
-
- #
- proc SelectUpdateAscend {t SouRefLea} {
- global S
- if {$S(nodefilter) == 0} {
- SelectUpdateAscendOriginal $t $SouRefLea
- } else {
- SelectUpdateAscendSauf $t $SouRefLea
- }
- }
- ### OPTIMISATION : si un node est ok : ne pas tester ses nodes fils
- proc SelectUpdateAscendOriginal {t SouRefLea} {
- global S T
- set L {}
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $T($t,all_cod)] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test inclusion des references leaf de TARGET avec SOURCE
- if {$S(nodefilter) == 0} {
- set r [Tools::ListInclu $TarRefLea $SouRefLea]
- if {$r == 1} {lappend L $TarCodNod}
- } else {
- set r [Tools::ListIncluSauf $TarRefLea $SouRefLea $S(nodefilter)]
- if {$r == 1} {lappend L $TarCodNod}
- }
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {return $T($t,ltc,$SouRefLea) }
- }
- ### OPTIMISATION : si un node est ok : ne pas tester ses nodes fils
- proc SelectUpdateAscendSauf {t SouRefLea} {
- global S T
- set L {}
- # on ne prend pas en compte les codes des feuilles
- set latest [Tools::SousL $T($t,all_cod) $T($t,ue_cod)]
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $latest] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test inclusion des references leaf de TARGET avec SOURCE
- set r [Tools::ListIncluSauf $TarRefLea $SouRefLea $S(nodefilter)]
- if {$r == 1} {lappend L $TarCodNod}
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {return $T($t,ltc,$SouRefLea) }
- }
- ###
- proc InitGraph {} {
- global S
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set t [string range $key 0 [expr [string first , $key] - 1]]
- Figuration::NodeGraVarInit $t
- }
- }
- }
- ### Bulle Labels : UEs
- proc InsertBulUE {w x y i} {
- global S T
- set tags [$w gettags $i]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- if {[lsearch -exact $T($t,all_cod) $n] != -1} {
- set La {}
- set SouCodLea [Tools::NodeNoToLe $t $n]
- set UE [lsort -dictionary [Tools::NodeLeCoToRe $t $SouCodLea]]
- foreach i $UE {
- regsub -all {?} $i " " texti
- lappend La $texti
- #lappend La [string toupper $i]
- }
-
- Annotation::BLLmake $w $t $x $y \
- [format "%s%s" [llength $La] " Leaves : "]\
- [Tools::FormatText $La] $n
-
- }
- }
- ### Bulle Labels : DB
- proc InsertBulDBCommonTags {w x y i} {
- global S T db
- set tags [$w gettags $i]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- set euls [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $n]]
- set lrecords {}
- set database $S(database)
- if {$database != ""} {
- foreach eu $euls {
- lappend lrecords [Database::dbQueryRecordsFromVarVal $database EU $eu]
- }
- # pour chaque record on reduit la A-List a une liste de var#val (concat)
- # on a donc une liste de liste, on cherche l'intersection
- upvar #0 $database X
- set ll {}
- foreach record $lrecords {
- set l {}
- foreach {var val} $X($record) {
- lappend l [format "%s%s%s" $var = $val]
- }
- lappend ll $l
- }
- set intersection [lsort -dictionary [Tools::operatorANDll $ll]]
- # ?
- #lappend intersection
- Annotation::BLLmake $w $t $x $y \
- [format "%s%s" [llength $intersection] " Labels (Common, $database) : "]\
- [Tools::FormatText $intersection] $n
- }
- }
- ### LABEL : NODE / Intersection Variables-Modalites avec Specificite
- proc InsertBulDBSpecificTags {w x y i} {
- global S T db
- set tags [$w gettags $i]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- set euls [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $n]]
- set lrecords {}
- set database $S(database)
- if {$database != ""} {
- foreach eu $euls {
- lappend lrecords [dbQueryRecordsFromVarVal $database EU $eu]
- }
- # pour chaque record on reduit la A-List a une liste de var=val (concat)
- # on a donc une liste de liste, on cherche l'intersection
- upvar #0 $database X
- set ll {}
- foreach record $lrecords {
- set l {}
- foreach {var val} $X($record) {
- lappend l [format "%s%s%s" $var = $val]
- }
- lappend ll $l
- }
- #
- set intersection [lsort -dictionary [Tools::operatorANDll $ll]]
-
- }
- }
- #
- proc InsertBulDBCouple {w t x y n couple} {
- global S
- set database $S(database)
- Annotation::BLLmake $w $t $x $y \
- $database\
- $couple $n
- }
- #
- proc InsertVarVal {w t x y n} {
- global S
- set database $S(database)
- set q $S(query)
- Annotation::BLLmake $w $t [$w canvasx $x] [$w canvasy $y ] \
- $database [lrange $q [expr [lsearch $q where] + 1] end] $n
- }
- proc InsertVarVal2 {w t x y n} {
- global S
- set database $S(database)
- set q $S(query)
- Annotation::BLLmake $w $t [$w canvasx $x] [$w canvasy $y ] \
- $database [lindex $q end] $n
- }
-
-
-
-
- }
- ####################
- ####################
- # ORIENTATION
- ####################
- namespace eval Orientation {
- ### proc ok(sauf conformation circulaire)
- ### nb : tourne sur T$t pour l'instant
- ### le menu/submenu "orientation" du menu contextuel TREE
- ### n'apparait pas si le type de l'arbre est circulaire
- ### pour etendre Anchor aux vues circulaires : integrer la gestion des arcs
- ### donc filtrer selon le type de l'item
- proc Anchor {w t} {
- global T S
- set co [$w bbox T$t]
- set wi [expr [lindex $co 2] - [lindex $co 0]]
- set he [expr [lindex $co 3] - [lindex $co 1]]
- set items [$w find withtag T$t]
- set b [$w bbox T$t]
- set x0 [lindex $b 3]
- set x0prim [lindex $b 0]
- foreach i $items {
- set ic [$w coords $i]
- set x1 [lindex $ic 0]
- set y1 [lindex $ic 1]
- set x2 [lindex $ic 2]
- set y2 [lindex $ic 3]
- switch [$w type $i] {
- line {
- $w coords $i [expr $x0 + ($x0 - $x1)] $y1 [expr $x0 + ($x0 - $x2)] $y2
- }
- text {
- $w coords $i [expr $x0 + ($x0 - $x1)] $y1
- $w itemconfigure $i -anchor e
- }
- }
- }
- $w move T$t [expr $x0prim - $x0] 0
- Figuration::RestaureT $w $t
- }
- }
- ####################
- ####################
- # CONFORMATION
- ####################
- namespace eval Conformation {
-
-
-
- # Stage de Alex Guez
- ###
- proc Swap {w {t ?} {n ?}} {
- global S
- if {$n == "?" } {
- set tags [$w gettags [$w find withtag current]]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- }
- #
- if {$t != "" && $n != ""} {
- SwapOperation $w $t $n
- Figuration::RedrawT $w $t
- Navigation::FitToContents $w
- }
- }
- ###
- proc SwapOperation {w {t ?} {n ?}} {
- global T S B
- if {$n == $t} {
- set gen $t
- set sg [format "%s%s" $gen g]
- set sd [format "%s%s" $gen d]
- } else {
- set gen [expr [llength [split $n {g d}]] - 1]
- set sg [format "%s%s%s" $n $gen g]
- set sd [format "%s%s%s" $n $gen d]
- }
- set NoCoFaToNoCoCh [Tools::NodeNoCoFaToNoCoCh $t $n]
- set SouCodLeaALL $T($t,ue_cod)
- set SouRefLeaALL $T($t,ue_lab)
- set SouCodLeaG [Tools::NodeNoToLe $t $sg]
- set SouRefLeaG [Tools::NodeLeCoToRe $t $SouCodLeaG]
- set SouCodLeaD [Tools::NodeNoToLe $t $sd]
- set SouRefLeaD [Tools::NodeLeCoToRe $t $SouCodLeaD]
- ### T ARRAY MAJ T(t,xxx,from n)
- # ne pas utiliser l'option -all avec les regsub, car 0g* matche 10g*
- set pg [format "%s%s" $sg *]
- set pd [format "%s%s" $sd *]
- set kvg [array get T $t,*,$pg]
- set kvd [array get T $t,*,$pd]
- foreach {key value} $kvd {unset T($key)}
- foreach {key value} $kvg {unset T($key)}
- foreach {key value} $kvg {
- regsub $sg $key $sd keyswi ; set T($keyswi) $value
- }
- foreach {key value} $kvd {
- regsub $sd $key $sg keyswi ; set T($keyswi) $value
- }
- ### T ARRAY MAJ T(t,ltc,*)
- foreach codeleaf $SouCodLeaG nameleaf $SouRefLeaG {
- regsub $sg $T($t,ltc,$nameleaf) \
- $sd T($t,ltc,$nameleaf)
- }
- foreach codeleaf $SouCodLeaD nameleaf $SouRefLeaD {
- regsub $sd $T($t,ltc,$nameleaf) \
- $sg T($t,ltc,$nameleaf)
- }
- # si clic racine et si indice arbre 2 et arbre,tot =2 ca plante
- for {set i 0} {$i < $T($t,tot)} {incr i} {
- set codegene $T($t,cbg,$i)
- set T($t,cbg,$i) {}
- #puts "SWAP DEDANS iteration codegene= $codegene"
-
- foreach e $codegene {
- switch -glob $e \
- $pg {regsub $sg $e $sd e ; lappend T($t,cbg,$i) $e} \
- $pd {regsub $sd $e $sg e ; lappend T($t,cbg,$i) $e} \
- default {lappend T($t,cbg,$i) $e}
- }
- puts "SWAP T($t,cbg,$i) $T($t,cbg,$i)"
- }
-
- ### T ARRAY MAJ T(t,all_cod)
- set codall $T($t,all_cod)
- set T($t,all_cod) {}
- foreach e $codall {
- switch -glob $e \
- $pg {regsub $sg $e $sd e ; lappend T($t,all_cod) $e} \
- $pd {regsub $sd $e $sg e ; lappend T($t,all_cod) $e} \
- default {lappend T($t,all_cod) $e}
- }
- # B ARRAY MAJ B(BLLnod,$id)
- set lkv [array get B BLLnod,*]
- foreach {key value} $lkv {
- switch -glob $value \
- $pg {regsub $sg $value $sd value ; set B($key) $value} \
- $pd {regsub $sd $value $sg value ; set B($key) $value} \
- default {set B($key) $value}
- }
- # B ARRAY MAJ B(SHInod,$id)
- set lkv [array get B SHInod,*]
- foreach {key value} $lkv {
- switch -glob $value \
- $pg {regsub $sg $value $sd value ; set B($key) $value} \
- $pd {regsub $sd $value $sg value ; set B($key) $value} \
- default {set B($key) $value}
- }
- # B ARRAY MAJ B(OVAnod,$id)
- set lkv [array get B OVAnod*,*]
- foreach {key value} $lkv {
- switch -glob $value \
- $pg {regsub $sg $value $sd value ; set B($key) $value} \
- $pd {regsub $sd $value $sg value ; set B($key) $value} \
- default {set B($key) $value}
- }
- # B ARRAY MAJ B(BGSnod,$id)
- set lkv [array get B BGSnod*,*]
- foreach {key value} $lkv {
- switch -glob $value \
- $pg {regsub $sg $value $sd value ; set B($key) $value} \
- $pd {regsub $sd $value $sg value ; set B($key) $value} \
- default {set B($key) $value}
- }
- # B ARRAY MAJ B(BGSnod,$id)
- set lkv [array get B BGLnod*,*]
- foreach {key value} $lkv {
- switch -glob $value \
- $pg {regsub $sg $value $sd value ; set B($key) $value} \
- $pd {regsub $sd $value $sg value ; set B($key) $value} \
- default {set B($key) $value}
- }
- # B ARRAY MAJ B(CONnod,$id)
- # ATTENTION value est une liste de node le switch ne passe pas si le node
- # en question n'est pas en debut de liste, on passe tous les elements de value
- # en revue
- set lkv [array get B CONnod,*]
- foreach {key value} $lkv {
- foreach v $value {
- switch -glob $v \
- $pg {regsub $sg $value $sd value ; set B($key) $value} \
- $pd {regsub $sd $value $sg value ; set B($key) $value} \
- default {set B($key) $value}
- }
-
- }
- set lkv [array get B CONnod,*]
- ### T ARRAY MAJ T(t,ue_cod)
- ### T ARRAY MAJ T(t,ue_lab)
- ### ATTENTION LISTES ORDONNEES
- set esup [lrange $SouRefLeaG 0 0]
- set einf [lrange $SouRefLeaD end end]
- set isup [lsearch $SouRefLeaALL $esup]
- set iinf [lsearch $SouRefLeaALL $einf]
- set T($t,ue_lab) [join [lreplace $SouRefLeaALL $isup $iinf $SouRefLeaD $SouRefLeaG]]
- unset T($t,ue_cod)
- foreach ref $T($t,ue_lab) {
- lappend T($t,ue_cod) $T($t,ltc,$ref)
- }
- }
- ### OUTGROUP
- proc Outgroup {w mode {tsource ?} {n ?}} {
- global T S B
- if {$tsource == "?"} {
- set id [$w find withtag current]
- set tags [$w gettags $id]
- set tsource [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- }
- if {$n != "" && $n != $tsource} {
- set co [$w bbox [list Z && T$tsource]]
- set px [lindex $co 0]
- set py [lindex $co 1]
- set wi [expr [lindex $co 2] - [lindex $co 0]]
- set he [expr [lindex $co 3] - [lindex $co 1]]
- set t [expr [lrange [lsort -integer -increasing $S(ilt)] end end] + 1]
- lappend S(ilt) $t
- set T($t,nwk) [NewickReBuild $tsource $n]
- ImportExport::TreeInit $t
- if {[catch [ImportExport::NewickParser_Root $t $T($t,nwk)] result] != 0} {
- ImpotExport::UpdateArrayCanvas $w $t
- Interface::TreeDynMessage "Error"
- } else {
- set w2 [ImportExport::NewCanvas]
- set S($t,w) $w2
- set S($t,tit) $S($tsource,tit)
- set S($t,type) $S($tsource,type)
- lappend S($w2,t) $t
- Conformation::ArrToCanType2 $t $w2 0 0 $wi $he
- ImportExport::NodeBind $w2 $t
- Operation::TreeViewerPanelUpdate
- }
- }
- }
- # outgroup tree meme window delete du tree precedent
- proc Outgroup2 {w mode {tsource ?} {n ?}} {
- global T S B
- if {$tsource == "?"} {
- set id [$w find withtag current]
- set tags [$w gettags $id]
- set tsource [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- }
- if {$n != "" && $n != $tsource} {
- set co [$w bbox [list Z && T$tsource]]
- set px [lindex $co 0]
- set py [lindex $co 1]
- set wi [expr [lindex $co 2] - [lindex $co 0]]
- set he [expr [lindex $co 3] - [lindex $co 1]]
- set t [expr [lrange [lsort -integer -increasing $S(ilt)] end end] + 1]
- lappend S(ilt) $t
- set T($t,nwk) [NewickReBuild $tsource $n]
- TDcom::TreeInit $t
- if {[catch [ImportExport::NewickParser_Root $t $T($t,nwk)] result] != 0} {
- ImportExport::UpdateArrayCanvas $w $t
- #Interface::TreeDynMessage "Error"
- } else {
- #set w2 [ImportExport::NewCanvas]
- set S($t,w) $w
- set S($t,tit) $S($tsource,tit)
- set S($t,type) $S($tsource,type)
- lappend S($w,t) $t
- TDcom::PhyNJ $t $w
- #Conformation::ArrToCanType2 $t $w 0 0 $wi $he
- #ImportExport::NodeBind $w $t
- # delete tree
- ImportExport::UpdateArrayCanvas $w $tsource
- set S($t,tar) 1
- #Operation::TreeViewerPanelUpdate
- }
- }
- }
- #
- proc NewickReBuild {t n} {
- global T
- # 50%
- set bl [expr 0.5 * $T($t,dbl,$n)]
- if [catch {set test $T($t,dbv,$n)} res] {
- set bv ""
- } else {
- set np [Tools::NodeParentNode $t $n]
- set bv $T($t,dbv,$np)
- }
- # noeud pointe garde bv et bl/2 (50%)
- set id [string last ":" $T($t,nwk,$n)]
- set nwkn [format "%s%s%s" [string range $T($t,nwk,$n) 0 [expr $id - 1]] ":" $bl]
- # brother node
- set bn [Tools::NodeBrotherNode $n]
- set nwkbn $T($t,nwk,$bn)
- ###
- set T(newick) [format "%s%s%s%s%s%s%s%s%s%s" "(" $nwkn ",(" $nwkbn "," xxx ")" ":" $bl ");"]
- NewickReBuildRec $t $n
- return $T(newick)
- }
- proc NewickReBuildRec {t n} {
- global T
- set nn [string trimleft $n $t]
- switch -exact $nn {
- d1d {NewickInsertFinal $t [format "%s%s" $t g]}
- d1g {NewickInsertFinal $t [format "%s%s" $t g]}
- g1d {NewickInsertFinal $t [format "%s%s" $t d]}
- g1g {NewickInsertFinal $t [format "%s%s" $t d]}
- default {
- set pn [Tools::NodeParentNode $t $n]
- set bn [Tools::NodeBrotherNode $pn]
- NewickInsert $t $bn $pn
- NewickReBuildRec $t $pn
- }
- }
- }
- ###
- proc NewickInsert {t n no} {
- global T
- if [catch {set test $T($t,dbv,$no)} res] {
- set bv ""
- } else {
- set np [Tools::NodeParentNode $t $n]
- set bv $T($t,dbv,$no)
- }
- set ns [format "%s%s%s%s%s%s%s%s" ( xxx , $T($t,nwk,$n) ) $bv : $T($t,dbl,$no) ]
- regsub "xxx" $T(newick) $ns T(newick)
- }
- ###
- proc NewickInsertFinal {t n} {
- global T
- set bl [expr $T($t,dbl,[format "%s%s" $t g]) + $T($t,dbl,[format "%s%s" $t d])]
- set id [string last ":" $T($t,nwk,$n)]
- #set id [string last ")" $T($t,nwk,$n)]
- set nwkn [format "%s%s%s" [string range $T($t,nwk,$n) 0 [expr $id - 1]] ":" $bl]
-
- puts $T($t,nwk,$n)
- puts $nwkn
- regsub "xxx" $T(newick) $nwkn T(newick)
- }
- ###
- proc NewickReBuildInit {t n} {
- global T
- set bn [Tools::NodeBrotherNode $n]
- set bnd1 [expr 0.8 * $T($t,dbl,$bn)]
- set bnd2 [expr 0.2 * $T($t,dbl,$bn)]
- set tp2 [string last ":" $T($t,nwk,$bn)]
- set nwk [string range $T($t,nwk,$bn) 0 [expr $tp2 - 1]]
- if {[array exists T($t,dbv,$n)] == 0} {
- set T(newick) [format "%s%s%s%s%s%s%s%s%s%s%s" \
- "((" "xxx" "," $nwk ":" $bnd1 "):" $bnd2 "," $T($t,nwk,$n) ")" ]
- } else {
- set T(newick) [format "%s%s%s%s%s%s%s%s%s%s%s%s%s" \
- "((" "xxx" "," $nwk ":" $bnd1 ")" $T($t,dbv,$n) ":" $bnd2 "," $T($t,nwk,$n) ")" ]
- }
- }
- ### LADDER
- proc Ladder {w t in m} {
- global T S
- set pg [format "%s%s%s" $in * g ]
- set espaceg [array get T $t,dbl,$pg ]
- set lcode {}
- foreach {k v} $espaceg {
- set codeg [string range $k [expr [string last "," $k] + 1] end]
- set longcodeg [string length $codeg]
- #set coded [format "%s%s" [string range $codeg 0 [expr $longcodeg - 2] ] d]
- set coded [format "%s%s" [string trimright $codeg g] d]
- set nbchildd [Tools::NodeNoToLeNum $t $coded]
- set nbchildg [Tools::NodeNoToLeNum $t $codeg]
- set cmd [list $nbchildd $m $nbchildg]
- if $cmd {
- set level [expr [regsub -all d $coded d pwet] + [regsub -all g $coded g pwet] -1]
- set longpattern [string length [format "%s%s" $level d]]
- set coco [string range $coded 0 [expr [string length $coded] - $longpattern -1 ] ]
- if {$coco != ""} {lappend lcode $coco}
- }
- }
- set LCODE [lsort -command LengthCompar $lcode]
- foreach code $LCODE {
- SwapOperation $w $t $code
- }
- Figuration::RedrawT $w $t
- }
- ###
- proc LengthCompar {c1 c2} {
- if {[string length $c1] >= [string length $c2]} {
- return 0
- } {
- return 1
- }
- }
- ###
- proc LaddUp {w} {
- set id [$w find withtag current]
- set tags [$w gettags $id]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- Ladder $w $t $n >
- }
- }
- ###
- proc LaddDown {w} {
- set id [$w find withtag current]
- set tags [$w gettags $id]
- set t [string range [lindex $tags [lsearch -glob $tags T*]] 1 end]
- set n [string trimright [lindex $tags [lsearch -glob $tags *C]] C]
- if {$n != ""} {
- Ladder $w $t $n <
- }
- }
- }
- ####################
- ####################
- # SELECTION
- ####################
- namespace eval Selection {
-
- # retourne la A-liste $windows $tree pour tous les tree en target d'une session treedyn
- proc TreeTar {} {
- global S
- set l {}
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set t [string range $key 0 [expr [string first , $key] - 1]]
- if {$t != 0} {
- if {[lsearch -exact $l $t] == -1} {lappend l $S($t,w) $t}
- }
- }
- }
- return $l
- }
- }
- ####################
- ####################
- # DATABASE query langage implementation + browser interface
- ####################
- namespace eval Database {
-
- ### OK extraire la liste de tous les enregistrements
- proc dbQueryRecordsAll {database} {
- upvar #0 $database X
- return [array names X]
- }
- ### OK extraire la liste des variables d'une database
- proc dbQueryVarAll {database} {
- upvar #0 $database X
- set l {}
- foreach record [array names X] {
- foreach {key value} $X($record) {
- if {[lsearch -exact $l $key] == -1} {lappend l $key}
- }
- }
- return $l
- }
- ### OK extraire la liste des EUs sachant une liste de records
- proc dbQueryEusFromRecords {database lid} {
- upvar #0 $database X
- set l {}
- foreach record $lid {
- set t $X($record)
- if {!([set pos [lsearch $t EU]]%2)} {
- # lappend l [lindex $t [incr pos]]
- # modif au cas ou plusieurs records pour la meme eu
- set val [lindex $t [incr pos]]
- if {[lsearch -exact $l $val] == -1} {lappend l $val}
- }
- }
- return $l
- }
- ###
- proc dbQueryVarFromRecords {database var lid} {
- upvar #0 $database X
- set l {}
- foreach record $lid {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- # lappend l [lindex $t [incr pos]]
- # modif au cas ou plusieurs records pour la meme eu
- set val [lindex $t [incr pos]]
- if {[lsearch -exact $l $val] == -1} {lappend l $val}
- }
- }
- return $l
- }
- ### OK extraire la liste des val sachant une var
- proc dbQueryValFromVar {database var} {
- upvar #0 $database X
- set l {}
- foreach record [array names X] {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- set val [lindex $t [incr pos]]
- if {[lsearch -exact $l $val] == -1} {lappend l $val}
- }
- }
- return $l
- }
- ### OK extraire la liste des Records verifiant un couple variable valeur
- ### EGALITE
- proc dbQueryRecordsFromVarVal {database var val} {
- upvar #0 $database X
- set l {}
- foreach record [array names X] {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- set valquery [lindex $t [incr pos]]
- if {[lsearch -exact $valquery $val] != -1} {
- lappend l $record
- }
- }
- }
- return $l
- }
- ### OK extraire la liste des Records verifiant l'operator sur un couple variable valeur
- proc dbQueryRecordsFromVarOpVal {database var operator val} {
- upvar #0 $database X
- set l {}
- foreach record [array names X] {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- set valquery [lindex $t [incr pos]]
- set a [format "%s%s%s" \" $val \"]
- set b [format "%s%s%s" \" $valquery \"]
- if [expr $b $operator $a ] {
- lappend l $record
- }
- }
- }
- return $l
- }
- ### OK extraire la liste des Records verifiant l'operator ## sur un couple variable valeur
- ### l'operator ## est utilis?Š pour un pattern matching
- ### permet de traiter des listes
- proc dbQueryRecordsFromVarPatVal {database var val} {
- upvar #0 $database X
- set l {}
- regsub -all " " $val "" val
- foreach record [array names X] {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- set valquery [lindex $t [incr pos]]
- # attention le pattern
- # if {[lsearch -exact $valquery $val] != -1} {
- # lappend l $record
- # }
- foreach v $valquery {
- if [string match -nocase $val $v ] {
- lappend l $record
- }
- }
- }
- }
- return $l
- }
- ### l'inverse de dbQueryRecordsFromVarPatVal
- ### permet de traiter des cas comme select les eu qui ne contiennent pas
- ### telle valeur (val) pour telle variable
- ### les listes sont possibles
- proc dbQueryRecordsFromVarPat2Val {database var val} {
- upvar #0 $database X
- set l {}
- regsub -all " " $val "" val
- foreach record [array names X] {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- set valquery [lindex $t [incr pos]]
- # attention doit etre verifier sur tous les elements de la liste
- set presence 0
- foreach v $valquery {
- if {[string match -nocase $val $v ]} {
- set presence 1
- }
- }
- if {$presence == 0} {lappend l $record}
- }
- }
- return $l
- }
-
- ### OK extraire la liste des eus verifiant un couple variable valeur
- proc dbQueryEusFromVarVal {database var val} {
- upvar #0 $database X
- set l {}
- foreach record [array names X] {
- set t $X($record)
- if {!([set pos [lsearch $t $var]]%2)} {
- set valquery [lindex $t [incr pos]]
- if {$val == $valquery} {
- lappend l $record
- }
- }
- }
- set eus [dbQueryEusFromRecords $database $l]
- return $eus
- }
-
- ### SELECT $var1 FROM $database WHERE $var2 $operator $val2 AND/OR ...
- ### SELECT + ResAndOr : cool :)
- proc Select {args} {
- global S T
- regsub -all "\}|\{|and|or" $args "" nb
- switch [llength $nb] {
- 0 { set help " "
- return $help
- }
- 3 {
- set var [lindex $args 0]
- set database [lindex $args 2]
- }
- 7 {
- ### SELECT $var1 FROM $database WHERE $var2 $operator $val2
- set var1 [lindex $args 0]
- set database [lindex $args 2]
- set var2 [lindex $args 4]
- set operator [lindex $args 5]
- set val2 [lindex $args 6]
- if {$operator == "##"} {
- set res1 [Database::dbQueryRecordsFromVarPatVal $database $var2 $val2]
- } elseif {$operator == "!#"} {
- set res1 [Database::dbQueryRecordsFromVarPat2Val $database $var2 $val2]
- } else {
- set res1 [Database::dbQueryRecordsFromVarOpVal $database $var2 $operator $val2]
- }
- set res2 [Database::dbQueryVarFromRecords $database $var1 $res1]
- # allumage
- if {$var1 == "EU" && $S(loc) == 1} {
- set AlistWTtarget [Selection::TreeTar]
- if {$AlistWTtarget != {}} {
- foreach {wi ti} $AlistWTtarget {
- Operation::Operation $wi $ti $res2
- set leu {}
- foreach e $res2 {
- if {[lsearch -exact $T($ti,ue_lab) $e] != -1} {lappend leu $e}
- }
- }
- }
- }
- }
- default {
- if {[lsearch -exact $args and] != -1 || [lsearch -exact $args or] != -1} {
- ########### PHASE 1 résolution des couples $var $op $val
- set S(loc) 0
- set var1 [lindex $args 0]
- set database [lindex $args 2]
- set where [lsearch -exact $args where]
- set queries [lrange $args [expr $where + 1] end]
- regsub -all "\}|\{| and | or " $queries " " Alistqueries
- set i 0
- set lq $queries
- global q
- foreach {var op val} $Alistqueries {
- incr i
- if {$op == "##"} {
- set res1 [Database::dbQueryRecordsFromVarPatVal $database $var $val]
- } elseif {$op == "!#"} {
- set res1 [Database::dbQueryRecordsFromVarPat2Val $database $var $val]
- } else {
- set res1 [Database::dbQueryRecordsFromVarOpVal $database $var $op $val]
- }
- set q($i) $res1
- # je remplace le triplet var op val par l'indice ds array q
- # qui contient le resultat de ce triplet
- regsub -all {\+} "$var $op $val" {\+} vov
- regsub $vov $lq $i lq
- #regsub "$var $op $val" $lq $i lq
- }
- regsub -all {\*} $lq "" lq
- ########### PHASE 2
- # resolution des operateurs AND , OR avec ordre de priorite selon {}
- # ... where $q1 AND {{$q2 OR $q3} AND $q4}
- # ou q est est une liste resulat d'un triplet(var op val)
- set finalrecords [lsort -dictionary [ResAndOr $lq]]
- set res2 [Database::dbQueryVarFromRecords $database $var1 $finalrecords]
- set S(loc) 1
- if {$var1 == "EU" && $S(loc) == 1} {
- set AlistWTtarget [Selection::TreeTar]
- if {$AlistWTtarget != {}} {
- foreach {wi ti} $AlistWTtarget {
- Operation::Operation $wi $ti $res2
- set leu {}
- foreach e $res2 {
- if {[lsearch -exact $T($ti,ue_lab) $e] != -1} {lappend leu $e}
- }
- }
- }
- }
- }
- }
- }
- }
- # recurssif
- # query est de la forme {{1 and 2} or 3}
- # ou 1 2 3 sont des indices du array q
- proc ResAndOr {query} {
- global q
- set arg1 [lindex $query 0]
- set op [lindex $query 1]
- set arg2 [lindex $query 2]
- if {[llength $arg1] != 1 } {
- set l1 [ResAndOr $arg1]
- } else {
- set l1 $q($arg1)
- }
- if {[llength $arg2] != 1 } {
- set l2 [ResAndOr $arg2]
- } else {
- set l2 $q($arg2)
- }
- if {$op == "and"} {
- return [Tools::operatorAND $l1 $l2]
- }
- if {$op == "or"} {
- return [Tools::operatorOR $l1 $l2]
- }
- }
- ###
- proc NodeFilterPanel {} {
- global S
- eval destroy .nodefilter
- set w [toplevel .nodefilter]
- wm title $w "Node Filter"
- # NODE FILTER // tolerance
- set S(nodefilter) 0
- iwidgets::entryfield .nodefilter.ns -width 4 -textvariable S(nodefilter) \
- -labeltext "Missing Leaves / Node :" -labelpos w -validate numeric -fixed 30
- # NODE FILTER // nb de leafs
- set S(nodefilterNB) np
- iwidgets::entryfield .nodefilter.nn -width 4 -textvariable S(nodefilterNB) \
- -labeltext "Minimun Leaves / Node :" -labelpos w -validate numeric -fixed 30
- # PACK
- pack .nodefilter.ns -fill x -expand yes
- pack .nodefilter.nn -fill x -expand yes
- }
- # Percent to color: The following routine produces a color
- # from an integer between 0 and 100, where 0 is red, 50 is yellow,
- # and 100 is green (useful e.g. for painting progress bars):
- proc percent2rgb {n} {
- # map 0..100 to a red-yellow-green sequence
- set n [expr {$n < 0? 0: $n > 100? 100: $n}]
- set red [expr {$n > 75? 60 - ($n * 15 / 25) : 15}]
- set green [expr {$n < 50? $n * 15 / 50 : 15}]
- format "#%01x%01x0" $red $green
- }
- #presented this simple beauty in the Tcl chatroom on 2002-12-18:
- proc randomColor {} {format #%06x [expr {int(rand() * 0xFFFFFF)}]}
-
- #
- proc AddConsole {s} {
- global window
- puts $s
- }
- #
- proc AddColumn {} {
- # construire la colonne du tableur
- .identification.pw.pane0.childsite.ma.t insert cols end 1
- # remplir la table f
- global f
- set NBvariables [expr [llength [array names f 0,*]] -1]
- set NBrecords [expr [llength [array names f *,0]] -1]
- set col [expr $NBvariables + 1]
- for {set row 1} {$row <= $NBrecords} {incr row} {
- set f($row,$col) -
- }
- set f(0,$col) ?
- # mise a jour
- dbUpdate
- }
-
- # mise a jour database suite MAJ user sur array f
- # de f vers database
- proc dbUpdate {} {
- global f S
- set NBvariables [expr [llength [array names f 0,*]] -1]
- set NBrecords [expr [llength [array names f *,0]] -1]
- set database $S(database)
- upvar #0 $database X
- #on delete X
- unset X
- #et on reconstruit
- db $database
- for {set row 1} {$row <= $NBrecords} {incr row} {
- set data {}
- append data " \{$f($row,0)\}"
- for {set col 1} {$col <= $NBvariables} {incr col} {
- # on construit la A-List Var Val
- append data " $f(0,$col) \{[split $f($row,$col)]\}"
- }
- set id [incr S(lastid)]
- eval $database [concat $id EU $data]
- }
- BuiltAddVariableConsole
- }
- # pour l'instant on ne traite que les $rows,0
- # pour ca on utilise pas $f($s) directement
- proc LocalisationMatrixUser {s} {
- global f S T
- set row [string range $s 0 [expr [string first , $s] - 1]]
- set indice [format "%s%s%s" $row , 0]
- }
- #
- proc reset {} {
- global asedCon
- interp eval $asedCon {
- if {[lsearch [package names] Tk] != -1} {
- foreach child [winfo children .] {
- if {[winfo exists $child]} {destroy $child}
- }
- wm withdraw .
- }
- }
- }
- #
- proc SetValues {_code _result _errorInfo} {
- global code result errorInfo
- set code $_code
- set result $_result
- set errorInfo $_errorInfo
- }
-
- }
- ####################
- ####################
- # OPERATION
- ####################
- namespace eval Operation {
-
-
- proc ResetAllFig+ {} {
- global S
- set S(OpResetLFgC) 1
- set S(OpResetLBgC) 1
- set S(OpResetLF) 1
- set S(OpResetNFgC) 1
- set S(OpResetNBgC) 1
- set S(OpResetNLW) 1
- set S(OpResetNLD) 1
- set S(OpResetNUS) 1
- set S(OpResetNUC) 1
- set S(OpResetAL) 1
- set S(OpResetAN) 1
- set S(OpResetAC) 1
- }
- #
- proc ResetAllFig- {} {
- global S
- set S(OpResetLFgC) 0
- set S(OpResetLBgC) 0
- set S(OpResetLF) 0
- set S(OpResetNFgC) 0
- set S(OpResetNBgC) 0
- set S(OpResetNLW) 0
- set S(OpResetNLD) 0
- set S(OpResetNUS) 0
- set S(OpResetNUC) 0
- set S(OpResetAL) 0
- set S(OpResetAN) 0
- set S(OpResetAC) 0
- }
- #
- proc ResetGraphicVariables {} {
- global S T
- # cette fonction travaille sur la liste des trees en target
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set t [string range $key 0 [expr [string first , $key] - 1]]
- set w $S($t,w)
- # t va etre reset sur une, plusieurs, ou toutes les variables graphiques
- # ...voir optimisation...
- # Leaf Foreground Color
- if {$S(OpResetLFgC) == 1} {Figuration::GraVarInitFgLeaf $w $t}
- # Leaf Background Color
- if {$S(OpResetLBgC) == 1} {Figuration::GraVarInitBgLeaf $w $t}
- # Leaf Font
- if {$S(OpResetLF) == 1} {Figuration::GraVarInitFont $w $t}
- # Node Foreground Color
- if {$S(OpResetNFgC) == 1} {Figuration::GraVarInitFgTree $w $t}
- # Node Background Color
- if {$S(OpResetNBgC) == 1} {Figuration::GraVarInitBgSubTree $w $t}
- # Node Line Witdh
- if {$S(OpResetNLW) == 1} {Figuration::GraVarInitLineWidth $w $t}
- # Node Line Dash
- if {$S(OpResetNLD) == 1} {Figuration::GraVarInitLineDash $w $t}
- # Node Unshrink
- if {$S(OpResetNUS) == 1} {}
- # Node UnCollapse
- if {$S(OpResetNUC) == 1} {}
- # Remove Annotation Leaf
- if {$S(OpResetAL) == 1} {}
- # Remove Annotation Node
- if {$S(OpResetAN) == 1} {}
- # Remove Annotation Canvas
- if {$S(OpResetAC) == 1} {}
- }
- }
- }
- ### OPTIMISATION : si un node est ok : ne pas tester ses nodes fils
- proc FindFatherNode {t SouRefLea} {
- global S T
- set L {}
- # on ne prend pas en compte les codes des feuilles
- # set latest [Tools::SousL $T($t,all_cod) $T($t,ue_cod)]
- # on prend en compte les codes des feuilles
- set latest $T($t,all_cod)
-
-
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $latest] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test inclusion des references leaf de TARGET avec SOURCE
- set r [Tools::ListIncluSauf $TarRefLea $SouRefLea $S(nodefilter)]
- if {$r == 1} {lappend L $TarCodNod}
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {return $T($t,ltc,$SouRefLea) }
- }
- # operation switch en fonction target, si $t :
- # * : on opere sur la liste des tree en target (panel operation)
- # = : on opere sur la liste des tree de la fenetre en argument
- # finalement on traite $t comme une liste de tree, pouvant se restreindre a un seul elt
- proc Operation {w t EUS} {
- global S
- switch -exact $t {
- \* {
- foreach key [array names S *,tar] {
- if {$S($key) == 1} {
- set ti [string range $key 0 [expr [string first , $key] - 1]]
- if {$ti != 0} {
- set wi $S($ti,w)
- Operation::OperationAction $wi $ti $EUS
- }
- }
- }
- }
- = {
- foreach ti $S($w,t) {
- Operation::OperationAction $w $ti $EUS
- }
- }
- default {
- foreach ti $t {
- Operation::OperationAction $w $ti $EUS
- }
- }
- }
- }
- proc OperationAction {w t EUS} {
- global T S
-
- # Reset Automatic ?
- if {$S(AutoReset)== 1} {Operation::ResetGraphicVariables}
- foreach op $S(operation) {
-
- switch $op {
- leafbgcolor {
- set leu {}
- foreach e $EUS {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- Figuration::EUColorBgLeaf $t $leu $S(col)
- }
- leaffgcolor {
- set leu {}
- foreach e $EUS {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- Figuration::EUColorFgLeaf $t $leu $S(col)
- }
- leaffontglob {
- set leu {}
- foreach e $EUS {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- Figuration::FontSetGlobalEU $t $leu $S(gfo)
- }
- leafshrink {
- set leu {}
- foreach e $EUS {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- Abstraction::LeafShrink $w $t $leu
- }
- leafunshrink {
- set leu {}
- foreach e $EUS {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- Abstraction::LeafUnShrink $w $t $leu
- }
- qLannL {
- Annotation::qLannL $w $t $EUS
- }
- qLannC {
- Annotation::qLannC $w $t $EUS
- }
- LannL {
- Annotation::LannL $w $t $EUS
- }
- LannC {
- Annotation::LannC $w $t $EUS
- }
- LillL {
- Illustration::LillL $w $t $EUS
- }
- LillC {
- Illustration::LillC $w $t $EUS
- }
- LillCpolygon {
- Illustration::LillCpolygon $w $t $EUS
- }
- nodefgcolor {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeColorFgTree $t $e $S(col)}
- }
- nodefgcolor2 {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeColorFgTree2 $t $e $S(col)}
- }
- nodebgcolor {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeColorBgSubTree $t $e}
- Figuration::RestaureBGSall $w $t
- }
- insertvarval {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {
- set co [$w coords $e]
- set x [lindex $co 0]
- set y [lindex $co 1]
- Identification::InsertVarVal $w $t $x $y $e
- }
- }
- insertvarval2 {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {
- set co [$w coords $e]
- set x [lindex $co 0]
- set y [lindex $co 1]
- Identification::InsertVarVal2 $w $t $x $y $e
- }
- }
- nodeannotate {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {
- set co [$w bbox $e]
- set x [$w canvasx [lindex $co 0]]
- set y [$w canvasy [lindex $co 1]]
- Annotation::BLLmake $w $t $x $y "" $S(AnnotateNote) $e
- }
- }
- nodeillustration {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {
- set co [$w coords $e]
- set x [$w canvasx [lindex $co 0]]
- set y [$w canvasy [lindex $co 1]]
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $w [expr $x + 30 ] [expr $y + 30] [list T$t]
- }
- }
- shrink {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Abstraction::Shrink $w $t $e ""}
- }
- unshrink {
- set peres [FindFatherNode $t $EUS]
- Abstraction::ShrinkUnLN $w $t $peres
- }
- collapse {Abstraction::Collapse $w $t $EUS}
- uncollapse {Abstraction::CollapseUn $w $t $EUS}
- widthline+ {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeLineWidth $t $e +}
- }
- widthline+2 {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeLineWidth2 $t $e +}
- }
- widthline- {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeLineWidth $t $e -}
- }
- nodedashOn {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeLineDash $t $e 1}
- }
- nodedashOn2 {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeLineDash2 $t $e 1}
- }
- nodedashOff {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {Figuration::NodeLineDash $t $e 0}
- }
- nodenetwork {
- set lkv {}
- set peres [FindFatherNode $t $EUS]
- foreach ni $peres {
- lappend lkv $t $ni
- }
- Reflection::NodeNetworkBuild $w $lkv " "
- }
- querynode {Annotation::QueryNode $w $t $EUS}
- nodeextract {
- set peres [FindFatherNode $t $EUS]
- PROTO::NodeExtract $t $peres
- }
- symbolnode {
- set peres [FindFatherNode $t $EUS]
- foreach e $peres {
- set co [$w coords $e]
- set x [lindex $co 0]
- set y [lindex $co 1]
- Annotation::InsertSymbolNodeMake $w $t $x $y $e
- }
- }
- }
- }
- }
- }
- ####################
- # ICONOGRAPHIE
- ####################
- namespace eval Iconographie {
- proc MakeIconographie {} {
- global S
- set S(stidir) [file join [file dirname [info script]] +/stipple/]
- image create photo STIz -file [file join [file dirname [info script]] +/stipple/z.xbm]
- image create photo STIa -file [file join [file dirname [info script]] +/stipple/a.xbm]
- image create photo STIb -file [file join [file dirname [info script]] +/stipple/b.xbm]
- image create photo STIc -file [file join [file dirname [info script]] +/stipple/c.xbm]
- image create photo STIe -file [file join [file dirname [info script]] +/stipple/e.xbm]
- image create photo STIf -file [file join [file dirname [info script]] +/stipple/f.xbm]
- image create photo STIl -file [file join [file dirname [info script]] +/stipple/l.xbm]
- image create photo STIm -file [file join [file dirname [info script]] +/stipple/m.xbm]
- image create photo STIg -file [file join [file dirname [info script]] +/stipple/g.xbm]
- image create photo STIh -file [file join [file dirname [info script]] +/stipple/h.xbm]
- image create photo STIi -file [file join [file dirname [info script]] +/stipple/i.xbm]
- image create photo STIj -file [file join [file dirname [info script]] +/stipple/j.xbm]
- image create photo STIk -file [file join [file dirname [info script]] +/stipple/k.xbm]
- }
-
- }
- ####################
- # TOOLS
- ####################
- namespace eval Tools {
-
-
- ### NODE
- proc NodeParentNode {t node} {
- if {[string equal $node $t] == 1} {
- return $t
- } elseif {[string equal $node [format "%s%s" $t g]] == 1} {
- return $t
- } elseif {[string equal $node [format "%s%s" $t d]] == 1} {
- return $t
- } else {
- set gennode [string range $node 0 end-1]
- set fathernode [string trimright $gennode {0 1 2 3 4 5 6 7 8 9}]
- return $fathernode
- }
- }
- # calcul de la distance feuille a feuille
- proc DistLL {t l1 l2} {
- global T
- if {[string equal $l1 $l2] == 1} {
- return 0
- } else {
- set l1code $T($t,ltc,$l1)
- set l2code $T($t,ltc,$l2)
- set node [string trimright [CommunRoot2 0 $l1code $l2code ""] "0123456789"]
- set cumul 0
- foreach n [NodeFathers $t $node] {
- set cumul [expr $cumul + $T($t,dbl,$n)]
- }
- return [expr $T($t,sox,$l1code) + $T($t,sox,$l2code) - (2 * $cumul)]
- }
- }
- #
- proc CommunRoot2 {index s1 s2 string} {
- if {[string equal $s1 $s2]} {
- return $string
- }
- if {[string equal [string index $s1 $index] [string index $s2 $index]]} {
- CommunRoot2 [expr $index +1] $s1 $s2 $string[string index $s1 $index]
- } else {
- return $string
- }
- }
-
- ###
- proc NodeBrotherNode {node} {
- set gennode [string range $node 0 end-1]
- set letter [string range $node end end ]
- if {$letter == "g"} {
- set brothernode [format "%s%s" $gennode d]
- } {set brothernode [format "%s%s" $gennode g]}
- return $brothernode
- }
- # renvoie la liste des codes nodes de la racine a n (le chemin)
- # lf est initialise a $t a l'appel de la procedure
- proc NodeFathers {lf n} {
- if {$n == "" || $n == [lindex $lf 0]} {
- return $lf
- } else {
- lappend lf $n
- NodeFathers $lf [NodeParentNode [lindex $lf 0] $n]
- }
- }
- ### NoToLe retourne la liste des codes feuilles issues de node
- proc NodeNoToLe {treeid nodecode} {
- global T
- set p [format "%s%s" $nodecode *]
- set l {}
- foreach codei $T($treeid,ue_cod) {
- if {[string match $p $codei]} {lappend l $codei}
- }
- return $l
- }
- ### NoToLeNum
- proc NodeNoToLeNum {t n} {
- global T
- set p [format "%s%s" $n *]
- set l {}
- foreach ni $T($t,ue_cod) {
- if {[string match $p $ni]} {lappend l $ni}
- }
- return [llength $l]
- }
- ### LeCoToRe retourne la liste des REFERENCES feuilles sachant les CODES feuilles
- proc NodeLeCoToRe {treeid lin} {
- global T
- set lout {}
- foreach c $lin {
- lappend lout $T($treeid,ctl,$c)
- }
- return $lout
- }
- # l est une liste de code node
- # FaNoId retourne la liste des nodes de plus haut niveau
- proc NodeFaNoId {leltpass l} {
- set elt [lindex $l 0]
- set lnew [lrange $l 1 end]
- if {[lsearch -exact $leltpass $elt] == -1} {
- set lprov {}
- lappend leltpass $elt
- set p [format "%s%s" $elt *]
- foreach i $l {
- if {[string match $p $i] != 1} {lappend lprov $i}
- }
- Tools::NodeFaNoId $leltpass [lappend lprov $elt]
- } {return $l}
- }
- ### Node Code Father To Node Code Children
- ### (Node Code Father Inclus )
- proc NodeNoCoFaToNoCoCh {IdTree NoCoFa} {
- global T
- set List_NoCoCh {}
- set pattern [format "%s%s" $NoCoFa *]
- foreach NoCoCh $T($IdTree,all_cod) {
- if {[string match $pattern $NoCoCh]} {lappend List_NoCoCh $NoCoCh}
- }
- return $List_NoCoCh
- }
- # recherche d'un node pere commun aux leafs
- proc FatherSearch {t SouRefLea} {
- global S T
- set L {}
- # on ne prend pas en compte les codes des feuilles
- set latest [Tools::SousL $T($t,all_cod) $T($t,ue_cod)]
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $latest] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test inclusion des references leaf de TARGET avec SOURCE
- set r [Tools::ListIncluSauf $TarRefLea $SouRefLea $S(nodefilter)]
- if {$r == 1} {lappend L $TarCodNod}
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {return $T($t,ltc,$SouRefLea) }
- }
- # recherche d'un node pere commun aux leafs
- proc FatherSearch2 {t SouRefLea} {
- global S T
- set L {}
- # on ne prend pas en compte les codes des feuilles
- set latest [Tools::SousL $T($t,all_cod) $T($t,ue_cod)]
- if {[llength $SouRefLea] != 1} {
- foreach TarCodNod [lsort -dictionary $latest] {
- # selection des codes leaf issus de node
- set TarCodLea [Tools::NodeNoToLe $t $TarCodNod]
- # passage codes leaf -> references leaf
- set TarRefLea [Tools::NodeLeCoToRe $t $TarCodLea]
- # test egalit?Š
- set r1 [Tools::SousL $TarRefLea $SouRefLea]
- set r2 [Tools::SousL $SouRefLea $TarRefLea]
- if {$r1 == {} && $r2 == {}} {lappend L $TarCodNod}
- }
- # meme node pere possibles
- # differents nodes peres possibles
- # -> identification des nodes peres de plus haut niveau
- set l [Tools::NodeFaNoId {} $L]
- if {$L == {}} {return {}} {return $l}
- } {return $T($t,ltc,$SouRefLea) }
- }
- ### /home/user/data/x.tree -> x.tree
- proc PathCut {spath} {
- set id [expr [string last "/" $spath] + 1]
- return [string range $spath $id end]
- }
- ### /home/user/data/x.tree -> x
- proc PathCut2 {spath} {
- set id1 [expr [string last "/" $spath] + 1]
- set id2 [expr [string last "." $spath] - 1]
- return [string range $spath $id1 $id2]
- }
- ### {a b c} -> {a \n b \n c}
- proc FormatText {Lin} {
- set Lout {}
- set ll [lsort -dictionary $Lin]
- lappend Lout [lindex $ll 0]
- set ll1end [lrange $ll 1 end]
- foreach e $ll1end {
- lappend Lout \n
- lappend Lout $e
- }
- regsub -all {\}} $Lout "" Lout
- regsub -all {\{} $Lout "" Lout
- regsub -all , $Lout = Lout
- regsub -all " " $Lout " " Lout
- regsub -all " \n" $Lout "\n" Lout
- regsub -all "\n " $Lout "\n" Lout
- return $Lout
- }
- #
- proc GenId {} {
- global S
- incr S(nbobj)
- return [format "%s%s" [clock second] $S(nbobj)]
- }
- ### DelRep suppression des repetitions d'une liste
- proc DelRep {lin} {
- set lou {}
- foreach i $lin {
- if {[lsearch -exact $lou $i] == -1} {lappend lou $i}
- }
- return $lou
- }
- ### Retourne 1 si l1 est incluse dans l2
- proc ListInclu {l1 l2} {
- foreach i1 $l1 {
- if {[lsearch -exact $l2 $i1] == -1} {set b 0 ; break} {set b 1}
- }
- return $b
- }
- ###
- proc ListIncluSauf {l1 l2 nb} {
- # c est le nb d'elt de l1 n'etant pas dans l2
- set c 0
- foreach i1 $l1 {
- if {[lsearch -exact $l2 $i1] == -1} {incr c}
- }
- if {$c > $nb} {return 0} {return 1}
- }
- # l2 est une liste d'elts devant etre retires de l1
- proc SousL {l1 l2} {
- set lout {}
- foreach e $l1 {
- if {[lsearch -exact $l2 $e] == -1} {lappend lout $e} {}
- }
- return $lout
- }
- # operateur AND # l'intersection des listes
- # ll est une liste de liste
- proc operatorANDll {ll} {
- set lintersect {}
- set l1 [lindex $ll 0]
- set ln [lrange $ll 1 end]
- foreach e $l1 {
- set x 1
- foreach l $ln {
- if {[lsearch -exact $l $e] == -1} {set x 0}
- }
- if {$x != 0} {lappend lintersect $e}
- }
- return [Tools::DelRep $lintersect]
- }
- proc operatorAND {l1 l2} {
- set lintersect {}
- foreach i $l1 {
- if {[lsearch -exact $l2 $i] != -1} {lappend lintersect $i}
- }
- return [Tools::DelRep $lintersect]
- }
- # operator OR # l'union des listes en supprimant les repetitions
- # ll est une liste de liste
- proc operatorORll {ll} {
- set lunion {}
- foreach l $ll {
- lappend lunion $l
- }
- return [Tools::DelRep $lunion]
- }
- proc operatorOR {l1 l2} {
- set lunion {}
- foreach i $l2 {
- lappend l1 $i
- }
- return [Tools::DelRep $l1]
- }
- ### {a b c} -> {a \n b \n c}
- proc FormatText {Lin} {
- set Lout {}
- set ll [lsort -dictionary $Lin]
- lappend Lout [lindex $ll 0]
- set ll1end [lrange $ll 1 end]
- foreach e $ll1end {
- lappend Lout \n
- lappend Lout $e
- }
- regsub -all {\}} $Lout "" Lout
- regsub -all {\{} $Lout "" Lout
- regsub -all , $Lout = Lout
- regsub -all " " $Lout " " Lout
- regsub -all " \n" $Lout "\n" Lout
- regsub -all "\n " $Lout "\n" Lout
- return $Lout
- }
- }
- ####################
- ####################
- # PACKAGE
- ####################
- namespace eval Package {
-
- namespace eval CanToSVG {
- # can2svg.tcl ---
- # This file provides translation from canvas commands to XML/SVG format.
- # Copyright (c) 2002 Mats Bengtsson
-
- package provide can2svg 0.1
-
- namespace eval ::can2svg:: {
-
- namespace export can2svg canvas2file
-
- variable formatArrowMarker
- variable formatArrowMarkerLast
-
- # The key into this array is 'arrowMarkerDef_$col_$a_$b_$c', where
- # col is color, and a, b, c are the arrow's shape.
- variable defsArrowMarkerArr
-
- # Similarly for stipple patterns.
- variable defsStipplePatternArr
-
- # This shouldn't be hardcoded!
- variable defaultFont {Helvetica 12}
-
- variable anglesToRadians [expr 3.14159265359/180.0]
- variable grayStipples {gray75 gray50 gray25 gray12}
-
- # Make 4x4 squares. Perhaps could be improved.
- variable stippleDataArr
-
- set stippleDataArr(gray75) \
- {M 0 0 h3 M 0 1 h1 m 1 0 h2 M 0 2 h2 m 1 0 h1 M 0 3 h3}
- set stippleDataArr(gray50) \
- {M 0 0 h1 m 1 0 h1 M 1 1 h1 m 1 0 h1 \
- M 0 2 h1 m 1 0 h1 M 1 3 h1 m 1 0 h1}
- set stippleDataArr(gray25) \
- {M 0 0 h1 M 2 1 h1 M 1 2 h1 M 3 3 h1}
- set stippleDataArr(gray12) {M 0 0 h1 M 2 2 h1}
-
- }
- proc ::can2svg::can2svg {cmd args} {
-
- variable defsArrowMarkerArr
- variable defsStipplePatternArr
- variable anglesToRadians
- variable defaultFont
- variable grayStipples
-
- set nonum_ {[^0-9]}
- set wsp_ {[ ]+}
- set xml ""
-
- #array set argsArr {-usetags all}
- array set argsArr {-usetags 0}
- array set argsArr $args
-
- switch -- [lindex $cmd 0] {
-
- create {
- set type [lindex $cmd 1]
-
- set rest [lrange $cmd 2 end]
- regexp -indices -- "-${nonum_}" $rest ind
- set ind1 [lindex $ind 0]
- set coo [string trim [string range $rest 0 [expr $ind1 - 1]]]
- set opts [string range $rest $ind1 end]
- array set optArr $opts
-
- # Figure out if we've got a spline.
- set haveSpline 0
- if {[info exists optArr(-smooth)] && ($optArr(-smooth) != "0") && \
- [info exists optArr(-splinesteps)] && ($optArr(-splinesteps) > 2)} {
- set haveSpline 1
- }
- if {[info exists optArr(-fill)]} {
- set fillValue $optArr(-fill)
- } else {
- set fillValue black
- }
- if {($argsArr(-usetags) != "0") && [info exists optArr(-tags)]} {
- switch -- $argsArr(-usetags) {
- all {
- set idAttr [list "id" $optArr(-tags)]
- }
- first {
- set idAttr [list "id" [lindex $optArr(-tags) 0]]
- }
- last {
- set idAttr [list "id" [lindex $optArr(-tags) end]]
- }
- }
- } else {
- set idAttr ""
- }
-
- # If we need a marker (arrow head) need to make that first.
- if {[info exists optArr(-arrow)]} {
- if {[info exists optArr(-arrowshape)]} {
-
- # Make a key of the arrowshape list into the array.
- regsub -all -- $wsp_ $optArr(-arrowshape) _ shapeKey
- set arrowKey ${fillValue}_${shapeKey}
- set arrowShape $optArr(-arrowshape)
- } else {
- set arrowKey ${fillValue}
- set arrowShape {8 10 3}
- }
- if {![info exists defsArrowMarkerArr($arrowKey)]} {
- set defsArrowMarkerArr($arrowKey) \
- [eval {MakeArrowMarker} $arrowShape {$fillValue}]
- append xml $defsArrowMarkerArr($arrowKey)
- append xml "\n\t"
- }
- }
-
- # If we need a stipple bitmap, need to make that first. Limited!!!
- # Only: gray12, gray25, gray50, gray75
- foreach key {-stipple -outlinestipple} {
- if {[info exists optArr($key)] && \
- ([lsearch $grayStipples $optArr($key)] >= 0)} {
- set stipple $optArr($key)
- if {![info exists defsStipplePatternArr($stipple)]} {
- set defsStipplePatternArr($stipple) \
- [MakeGrayStippleDef $stipple]
- }
- append xml $defsStipplePatternArr($stipple)
- append xml "\n\t"
- }
- }
-
- switch -- $type {
-
- arc {
-
- # Had to do it the hard way! (?)
- # "Wrong" coordinate system :-(
- set elem "path"
- set style [MakeStyle $type $opts]
- foreach {x1 y1 x2 y2} $coo {}
- set cx [expr ($x1 + $x2)/2.0]
- set cy [expr ($y1 + $y2)/2.0]
- set rx [expr abs($x1 - $x2)/2.0]
- set ry [expr abs($y1 - $y2)/2.0]
- set rmin [expr $rx > $ry ? $ry : $rx]
-
- # This approximation gives a maximum half pixel error.
- set deltaPhi [expr 2.0/sqrt($rmin)]
- set extent [expr $anglesToRadians * $optArr(-extent)]
- set start [expr $anglesToRadians * $optArr(-start)]
- set nsteps [expr int(abs($extent)/$deltaPhi) + 2]
- set delta [expr $extent/$nsteps]
- set data [format "M %.1f %.1f L" \
- [expr $cx + $rx*cos($start)] [expr $cy - $ry*sin($start)]]
- for {set i 0} {$i <= $nsteps} {incr i} {
- set phi [expr $start + $i * $delta]
- append data [format " %.1f %.1f" \
- [expr $cx + $rx*cos($phi)] [expr $cy - $ry*sin($phi)]]
- }
- if {[info exists optArr(-style)]} {
- switch -- $optArr(-style) {
- chord {
- append data " Z"
- }
- pieslice {
- append data [format " %.1f %.1f Z" $cx $cy]
- }
- }
- } else {
-
- # Pieslice is the default.
- append data [format " %.1f %.1f Z" $cx $cy]
- }
- set attr [list "d" $data "style" $style]
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set xmlList [MakeXMLList $elem -attrlist $attr]
- }
- image - bitmap {
- set elem "image"
- set attr [MakeImageAttr $coo $opts]
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set xmlList [MakeXMLList $elem -attrlist $attr]
- }
- line {
- if {$haveSpline} {
- set elem "path"
- set style [MakeStyle $type $opts]
- set data "M [lrange $coo 0 1] Q"
- set i 4
- foreach {x y} [lrange $coo 2 end-4] {
- set x0 [expr ($x + [lindex $coo $i])/2.0]
- incr i
- set y0 [expr ($y + [lindex $coo $i])/2.0]
- incr i
- append data " $x $y $x0 $y0"
- }
- append data " [lrange $coo end-3 end]"
- set attr [list "d" $data "style" $style]
- } else {
- set elem "polyline"
- set style [MakeStyle $type $opts]
- set attr [list "points" $coo "style" $style]
- }
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set xmlList [MakeXMLList $elem -attrlist $attr]
- }
- oval {
- foreach {x y w h} [NormalizeRectCoords $coo] {}
- if {[expr $w == $h]} {
- set elem "circle"
- set attr [list \
- "cx" [expr $x + $w/2.0] \
- "cy" [expr $y + $h/2.0] \
- "r" [expr $w/2.0]]
- } else {
- set elem "ellipse"
- set attr [list \
- "cx" [expr $x + $w/2.0] \
- "cy" [expr $y + $h/2.0] \
- "rx" [expr $w/2.0] \
- "ry" [expr $h/2.0]]
- }
- set style [MakeStyle $type $opts]
- lappend attr "style" $style
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set xmlList [MakeXMLList $elem -attrlist $attr]
- }
- polygon {
-
- if {$haveSpline} {
- set elem "path"
- set style [MakeStyle $type $opts]
-
- # Translating a closed polygon into a qubic bezier
- # path is a little bit tricky.
- set x0 [expr ([lindex $coo end-1] + [lindex $coo 0])/2.0]
- set y0 [expr ([lindex $coo end] + [lindex $coo 1])/2.0]
- set data "M $x0 $y0 Q"
- set i 2
- foreach {x y} [lrange $coo 0 end-2] {
- set x1 [expr ($x + [lindex $coo $i])/2.0]
- incr i
- set y1 [expr ($y + [lindex $coo $i])/2.0]
- incr i
- append data " $x $y $x1 $y1"
- }
- append data " [lrange $coo end-1 end] $x0 $y0"
- set attr [list "d" $data "style" $style]
- } else {
-
- set elem "polygon"
- set style [MakeStyle $type $opts]
- puts "AVANT $type $opts APRES $style"
- set attr [list "points" $coo "style" $style]
- }
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set xmlList [MakeXMLList $elem -attrlist $attr]
- }
- rectangle {
- set elem "rect"
- set style [MakeStyle $type $opts]
-
- # width and height must be non-negative!
- foreach {x y w h} [NormalizeRectCoords $coo] {}
- set attr [list "x" $x "y" $y "width" $w "height" $h]
- lappend attr "style" $style
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set xmlList [MakeXMLList $elem -attrlist $attr]
- }
- text {
- set elem "text"
- set style [MakeStyle $type $opts]
- set nlines 1
- if {[info exists optArr(-text)]} {
- set chdata $optArr(-text)
- set nlines [expr [regexp -all "\n" $chdata] + 1]
- } else {
- set chdata ""
- }
-
- # Figure out the coords of the first baseline.
- set anchor center
- if {[info exists optArr(-anchor)]} {
- set anchor $optArr(-anchor)
- }
- if {[info exists optArr(-font)]} {
- set theFont $optArr(-font)
- } else {
- set theFont $defaultFont
- }
- set ascent [font metrics $theFont -ascent]
- set lineSpace [font metrics $theFont -linespace]
-
- foreach {xbase ybase} \
- [GetTextSVGCoords $coo $anchor $chdata $theFont $nlines] {}
-
- set attr [list "x" $xbase "y" $ybase]
- lappend attr "style" $style
- if {[string length $idAttr] > 0} {
- set attr [concat $attr $idAttr]
- }
- set dy 0
- if {$nlines > 1} {
-
- # Use the 'tspan' trick here.
- set subList {}
- foreach line [split $chdata "\n"] {
- lappend subList [MakeXMLList "tspan" \
- -attrlist [list "x" $xbase "dy" $dy] -chdata $line]
- set dy $lineSpace
- }
- set xmlList [MakeXMLList $elem -attrlist $attr \
- -subtags $subList]
- } else {
- set xmlList [MakeXMLList $elem -attrlist $attr \
- -chdata $chdata]
- }
- }
- }
- }
- move {
- foreach {tag dx dy} [lrange $cmd 1 3] {}
- set attr [list "transform" "translate($dx,$dy)" \
- "xlink:href" "#$tag"]
- set xmlList [MakeXMLList "use" -attrlist $gattr]
- }
- scale {
-
- }
- }
- append xml [MakeXML $xmlList]
- return $xml
- }
- proc ::can2svg::MakeStyle {type opts} {
-
- # Defaults for everything except text.
- if {![string equal $type "text"]} {
- array set styleArr {fill none stroke black}
- }
- set fillCol black
-
- foreach {key value} $opts {
-
- switch -- $key {
- -arrow {
- set arrowValue $value
- }
- -arrowshape {
- set arrowShape $value
- }
- -capstyle {
- if {[string equal $value "projecting"]} {
- set value "square"
- }
- if {![string equal $value "butt"]} {
- set styleArr(stroke-linecap) $value
- }
- }
- -dash {
- set dashValue $value
- }
- -dashoffset {
- if {$value != 0} {
- set styleArr(stroke-dashoffset) $value
- }
- }
- -fill {
- set fillCol $value
-
- if {[string equal $type "line"]} {
- set styleArr(stroke) [MapEmptyToNone $value]
- } else {
- set styleArr(fill) [MapEmptyToNone $value]
- }
-
- }
- -font {
- set styleArr(font-family) [lindex $value 0]
- if {[llength $value] > 1} {
- set styleArr(font-size) [format "%s%s" [lindex $value 1] pt]
- }
- if {[llength $value] > 2} {
- set tkstyle [lindex $value 2]
- switch -- $tkstyle {
- bold {
- set styleArr(font-weight) $tkstyle
- }
- italic {
- set styleArr(font-style) $tkstyle
- }
- underline {
- set styleArr(text-decoration) underline
- }
- overstrike {
- set styleArr(text-decoration) overline
- }
- }
- }
-
- }
- -joinstyle {
- set styleArr(stroke-linejoin) $value
- }
- -outline {
- set styleArr(stroke) [MapEmptyToNone $value]
- }
- -outlinestipple {
- set outlineStippleValue $value
- }
- -stipple {
- set stippleValue $value
- }
- -width {
- set styleArr(stroke-width) $value
- }
- }
- }
-
- # If any arrow specify its marker def url key.
- if {[info exists arrowValue]} {
- if {[info exists arrowShape]} {
- foreach {a b c} $arrowShape {}
- set arrowIdKey "arrowMarkerDef_${fillCol}_${a}_${b}_${c}"
- set arrowIdKeyLast "arrowMarkerLastDef_${fillCol}_${a}_${b}_${c}"
- } else {
- set arrowIdKey "arrowMarkerDef_${fillCol}"
- }
- switch -- $arrowValue {
- first {
- set styleArr(marker-start) "url(#$arrowIdKey)"
- }
- last {
- set styleArr(marker-end) "url(#$arrowIdKeyLast)"
- }
- both {
- set styleArr(marker-start) "url(#$arrowIdKey)"
- set styleArr(marker-end) "url(#$arrowIdKeyLast)"
- }
- }
- }
-
- if {[info exists stippleValue]} {
-
- # Overwrite any existing.
- set styleArr(fill) "url(#tile$stippleValue)"
- }
- if {[info exists outlineStippleValue]} {
-
- # Overwrite any existing.
- set styleArr(stroke) "url(#tile$stippleValue)"
- }
-
- # Transform dash value.
- if {[info exists dashValue]} {
-
- # Two different syntax here.
- if {[regexp {[\.,\-_ ]} $dashValue]} {
-
- # .=2 ,=4 -=6 space=4 times stroke width.
- # A space enlarges the... space.
- # Not foolproof!
- regsub -all -- {[^ ]} $dashValue "& " dash
- regsub -all -- " " $dash "12 " dash
- regsub -all -- " " $dash "8 " dash
- regsub -all -- " " $dash "4 " dash
- regsub -all -- {\.} $dash "2 " dash
- regsub -all -- {,} $dash "4 " dash
- regsub -all -- {-} $dash "6 " dash
-
- # Multiply with stroke width if > 1.
- if {[info exists styleArr(stroke-width)] && \
- ($styleArr(stroke-width) > 1)} {
- set width $styleArr(stroke-width)
- set dashOrig $dash
- set dash {}
- foreach num $dashOrig {
- lappend dash [expr int($width * $num)]
- }
- }
- set styleArr(stroke-dasharray) [string trim $dash]
- } else {
- set styleArr(stroke-dasharray) $value
- }
- }
- if {[string equal $type "polygon"]} {
- set styleArr(fill-rule) "evenodd"
- }
-
- set style ""
- foreach {key value} [array get styleArr] {
- append style "${key}: ${value}; "
- }
- return [string trim $style]
- }
- proc ::can2svg::MakeImageAttr {coo opts} {
-
- array set optArr {-anchor nw}
- array set optArr $opts
- set theImage $optArr(-image)
- set w [image width $theImage]
- set h [image height $theImage]
-
- # We should make this an URI.
- set theFile [$theImage cget -file]
- set uri [UriFromLocalFile $theFile]
- foreach {x0 y0} $coo {}
- switch -- $optArr(-anchor) {
- nw {
- set x $x0
- set y $y0
- }
- n {
- set x [expr $x0 - $w/2.0]
- set y $y0
- }
- ne {
- set x [expr $x0 - $w]
- set y $y0
- }
- e {
- set x $x0
- set y [expr $y0 - $h/2.0]
- }
- se {
- set x [expr $x0 - $w]
- set y [expr $y0 - $h]
- }
- s {
- set x [expr $x0 - $w/2.0]
- set y [expr $y0 - $h]
- }
- sw {
- set x $x0
- set y [expr $y0 - $h]
- }
- w {
- set x $x0
- set y [expr $y0 - $h/2.0]
- }
- center {
- set x [expr $x0 - $w/2.0]
- set y [expr $y0 - $h/2.0]
- }
- }
- set attrList [list "x" $x "y" $y "width" $w "height" $h \
- "xlink:href" $uri]
- return $attrList
- }
- proc ::can2svg::GetTextSVGCoords {coo anchor chdata theFont nlines} {
-
- foreach {x y} $coo {}
- set ascent [font metrics $theFont -ascent]
- set lineSpace [font metrics $theFont -linespace]
-
- # If not anchored to the west it gets more complicated.
- if {![string match $anchor "*w*"]} {
-
- # Need to figure out the extent of the text.
- if {$nlines <= 1} {
- set textWidth [font measure $theFont $chdata]
- } else {
- set textWidth 0
- foreach line [split $chdata "\n"] {
- set lineWidth [font measure $theFont $line]
- if {$lineWidth > $textWidth} {
- set textWidth $lineWidth
- }
- }
- }
- }
-
- switch -- $anchor {
- nw {
- set xbase $x
- set ybase [expr $y + $ascent]
- }
- w {
- set xbase $x
- set ybase [expr $y - $nlines*$lineSpace/2.0 + $ascent]
- }
- sw {
- set xbase $x
- set ybase [expr $y - $nlines*$lineSpace + $ascent]
- }
- s {
- set xbase [expr $x - $textWidth/2.0]
- set ybase [expr $y - $nlines*$lineSpace + $ascent]
- }
- se {
- set xbase [expr $x - $textWidth]
- set ybase [expr $y - $nlines*$lineSpace + $ascent]
- }
- e {
- set xbase [expr $x - $textWidth]
- set ybase [expr $y - $nlines*$lineSpace/2.0 + $ascent]
- }
- ne {
- set xbase [expr $x - $textWidth]
- set ybase [expr $y + $ascent]
- }
- n {
- set xbase [expr $x - $textWidth/2.0]
- set ybase [expr $y + $ascent]
- }
- center {
- set xbase [expr $x - $textWidth/2.0]
- set ybase [expr $y - $nlines*$lineSpace/2.0 + $ascent]
- }
- }
-
- return [list $xbase $ybase]
- }
- proc ::can2svg::MakeArrowMarker {a b c col} {
-
- variable formatArrowMarker
- variable formatArrowMarkerLast
-
- catch {unset formatArrowMarker}
-
- if {![info exists formatArrowMarker]} {
-
- # "M 0 c, b 0, a c, b 2*c Z" for the start marker.
- # "M 0 0, b c, 0 2*c, b-a c Z" for the last marker.
- set data "M 0 %s, %s 0, %s %s, %s %s Z"
- set style "fill: %s; stroke: %s;"
- set attr [list "d" $data "style" $style]
- set arrowList [MakeXMLList "path" -attrlist $attr]
- set markerAttr [list "id" %s "markerWidth" %s "markerHeight" %s \
- "refX" %s "refY" %s "orient" "auto"]
- set defElemList [MakeXMLList "defs" -subtags \
- [list [MakeXMLList "marker" -attrlist $markerAttr \
- -subtags [list $arrowList] ] ] ]
- set formatArrowMarker [MakeXML $defElemList]
-
- # ...and the last arrow marker.
- set dataLast "M 0 0, %s %s, 0 %s, %s %s Z"
- set attrLast [list "d" $dataLast "style" $style]
- set arrowLastList [MakeXMLList "path" -attrlist $attrLast]
- set defElemLastList [MakeXMLList "defs" -subtags \
- [list [MakeXMLList "marker" -attrlist $markerAttr \
- -subtags [list $arrowLastList] ] ] ]
- set formatArrowMarkerLast [MakeXML $defElemLastList]
- }
- set idKey "arrowMarkerDef_${col}_${a}_${b}_${c}"
- set idKeyLast "arrowMarkerLastDef_${col}_${a}_${b}_${c}"
-
- # Figure out the order of all %s substitutions.
- set markerXML [format $formatArrowMarker $idKey \
- $b [expr 2*$c] 0 $c \
- $c $b $a $c $b [expr 2*$c] $col $col]
- set markerLastXML [format $formatArrowMarkerLast $idKeyLast \
- $b [expr 2*$c] $b $c \
- $b $c [expr 2*$c] [expr $b-$a] $c $col $col]
-
- return "$markerXML\n\t$markerLastXML"
- }
- proc ::can2svg::MakeGrayStippleDef {stipple} {
-
- variable stippleDataArr
-
- set pathList [MakeXMLList "path" -attrlist \
- [list "d" $stippleDataArr($stipple) "style" "stroke: black; fill: none;"]]
- set patterAttr [list "id" "tile$stipple" "x" 0 "y" 0 "width" 4 "height" 4 \
- "patternUnits" "userSpaceOnUse"]
- set defElemList [MakeXMLList "defs" -subtags \
- [list [MakeXMLList "pattern" -attrlist $patterAttr \
- -subtags [list $pathList] ] ] ]
-
- return [MakeXML $defElemList]
- }
- proc ::can2svg::MapEmptyToNone {val} {
-
- if {[string length $val] == 0} {
- return "none"
- } else {
- return $val
- }
- }
- proc ::can2svg::NormalizeRectCoords {coo} {
-
- foreach {x1 y1 x2 y2} $coo {}
- return [list [expr $x2 > $x1 ? $x1 : $x2] \
- [expr $y2 > $y1 ? $y1 : $y2] \
- [expr abs($x1-$x2)] \
- [expr abs($y1-$y2)]]
- }
- proc ::can2svg::makedocument {width height xml} {
-
- set pre "<?xml version=\"1.0\"?>
- <!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"
- \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">"
-
- # <?xml version='1.1'?>\n\
- # <!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\
- # \"http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd\">"
- #set svgStart "<svg width='$width' height='$height'>"
- set svgStart "<svg xmlns=\"http://www.w3.org/2000/svg\"> \n <g id=\"g\" transform=\"translate(10, 10) scale(1.5)\">"
- set svgEnd " </g>\n</svg>"
- return "${pre}\n${svgStart}\n${xml}${svgEnd}"
- }
-
- proc ::can2svg::canvas2file {wcan path args} {
- variable defsArrowMarkerArr
- variable defsStipplePatternArr
- # Need to make a fresh start for marker def's.
- catch {unset defsArrowMarkerArr}
- catch {unset defsStipplePatternArr}
-
- #array set argsArr \
- # [list -width [winfo width $wcan] -height [winfo height $wcan]]
- # correction chevenet
- $wcan configure -scrollregion [$wcan bbox all]
- $wcan xview moveto 0
- $wcan yview moveto 0
- set width [expr [lindex [$wcan bbox all] 2] - [lindex [$wcan bbox all] 0]]
- set height [expr [lindex [$wcan bbox all] 3] - [lindex [$wcan bbox all] 1]]
- array set argsArr [list -width $width -height $height]
- array set argsArr $args
- set fd [open $path w]
- set xml ""
- # ici pour la modification sur les tags // hidden
- foreach id [$wcan find all] {
- set type [$wcan type $id]
- set opts [$wcan itemconfigure $id]
- set opcmd {}
- foreach opt $opts {
- set op [lindex $opt 0]
- set val [lindex $opt 4]
-
- # Empty val's except -fill can be stripped off.
- if {![string equal $op "-fill"] && ([string length $val] == 0)} {
- continue
- }
- lappend opcmd $op $val
- }
- set co [$wcan coords $id]
- set cmd [concat "create" $type $co $opcmd]
- append xml "\t[can2svg $cmd]\n"
- }
- regsub -all "'" [makedocument $argsArr(-width) $argsArr(-height) $xml] "\"" sgvdisplay
-
- puts $fd $sgvdisplay
- close $fd
- }
- proc ::can2svg::MakeXML {xmlList} {
-
- # Extract the XML data items.
- foreach {tag attrlist isempty chdata childlist} $xmlList {}
- set rawxml "<$tag"
- foreach {attr value} $attrlist {
- append rawxml " ${attr}='${value}'"
- }
- if {$isempty} {
- append rawxml "/>"
- return $rawxml
- } else {
- append rawxml ">"
- }
- foreach child $childlist {
- append rawxml [MakeXML $child]
- }
-
- # Make standard entity replacements.
- if {[string length $chdata]} {
- append rawxml [XMLCrypt $chdata]
- }
- append rawxml "</$tag>"
- return $rawxml
- }
- proc ::can2svg::MakeXMLList {tagname args} {
- array set xmlarr {-isempty 1 -attrlist {} -chdata {} -subtags {}}
- if {[llength $args] > 0} {
- array set xmlarr $args
- }
- if {!(($xmlarr(-chdata) == "") && ($xmlarr(-subtags) == ""))} {
- set xmlarr(-isempty) 0
- }
- set sublist {}
- foreach child $xmlarr(-subtags) {
- lappend sublist $child
- }
- set xmlList [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty) \
- $xmlarr(-chdata) $sublist]
- return $xmlList
- }
- proc ::can2svg::XMLCrypt {chdata} {
- foreach from {\& < > {"} {'}} \
- to {{\&} {\<} {\>} {\"} {\'}} {
- regsub -all $from $chdata $to chdata
- }
- return $chdata
- }
- proc ::can2svg::UriFromLocalFile {path} {
- if {[string equal $::tcl_platform(platform) "windows"]} {
- set vol_ {([A-Z]:/|[A-Z]:\\)}
- regexp "${vol_}+(.+)$" $path match x path
- }
- set pathList [split $path "/:\\"]
- set pathJoin [join $pathList /]
- regsub -all -- " " $pathJoin "%20" pathJoin
- return file:///${pathJoin}
- }
- }
-
- }
- ####################
- # AMELIE
- ####################
- namespace eval Amelie {
-
- #
- proc faiaddGo1 {lv} {
- global S
- set lkv [array get S *,tar]
- set ltreetarget {}
- foreach {k v} $lkv {
- if {$S($k) == 1} {
- lappend ltreetarget [string range $k 0 [expr [string first , $k] - 1]]
- }
- }
- foreach v $lv {
- DrawGoAuto [list $v] $ltreetarget
- }
- }
- #
- proc faiaddGo2 {w t database variable eu} {
- global S
- set records [Database::dbQueryRecordsFromVarVal $database EU $eu]
- set values [Database::dbQueryVarFromRecords $database $variable $records]
- set i [format "%s%s%s" $eu : $values ]
- faiaddGo1 [list $i]
- }
-
- #
- proc userColor {id} {
- global S
- set S(col) [tk_chooseColor]
- $id configure -background $S(col)
- }
- #
- proc PatternSelection {w} {
- global S
- $w selection clear 0 end
- set litems [$w get 0 end]
- set id 0
- foreach i $litems {
- set leaf [lindex [split $i :] 0]
- if {[string match $S(IGfilter) $leaf]} {$w selection set $id }
- incr id
- }
- $w yview [lindex [$w curselection] 0]
- }
-
- #
- proc GenId {} {
- global S
- incr S(nbobj)
- return [format "%s%s" [clock second] $S(nbobj)]
- }
-
- #
- proc ColorSpecific {w} {
- global S
- $w configure -background $S(col)
- set S(AmelieColor) $S(col)
- }
- # ls : listbox source ; lt listbox target
- proc AnnotateAddItem {ls lt} {
- global S
- if {$S(database) != ""} {
- $lt delete 0 end
- set variable [$ls get [$ls curselection]]
- set lrecords [Database::dbQueryRecordsAll $S(database)]
- set lres {}
- foreach record $lrecords {
- set leaf [Database::dbQueryVarFromRecords $S(database) EU $record]
- set int [Database::dbQueryVarFromRecords $S(database) $variable $record]
- #$lt insert end [format "%s%s%s" $leaf : $int ]
- lappend lres [format "%s%s%s" $leaf : $int ]
- }
- foreach r [lsort -dictionary $lres] {
- $lt insert end $r
- }
- }
- }
-
- #
- proc CommunRoot {index s1 s2 string} {
- if {[string equal [string index $s1 $index] [string index $s2 $index]]} {
- CommunRoot [expr $index +1] $s1 $s2 $string[string index $s1 $index]
- } else {
- return [string length $string]
- }
- }
- #
- proc CommunRoot2 {index s1 s2 string} {
- if {[string equal $s1 $s2]} {
- return $string
- }
- if {[string equal [string index $s1 $index] [string index $s2 $index]]} {
- CommunRoot2 [expr $index +1] $s1 $s2 $string[string index $s1 $index]
- } else {
- return $string
- }
- }
- #
- proc DrawGoUser {lv ltreetarget} {
- global S ann T
- foreach ti $ltreetarget {
- switch -exact $S($ti,type) {
- PhyNJ - ClaSla - ClaRec {
- set database $S(database)
- upvar #0 $S(database) X
- set w $S($ti,w)
- set XMAX1 [lindex [$w bbox [list T$ti && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$ti && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- set x [expr $XMAX + $S(IGtabul)]
- set tagS [format "%s%s%s" SEL ? [Tools::GenId]]
- foreach v $lv {
-
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- set vsplit [split $v ":"]
- set l [lindex $vsplit 0] ;# source
- set ll [lindex [lindex $vsplit end] 0] ;# targets
- set y1 [WhatY $w $ti $l]
- foreach vi [split $ll] {
-
- set tagos [format "%s%s%s%s%s" ARCU ? $l ? $vi]
- if {$vi != $l} {
- set y2 [WhatY $w $ti $vi]
- set ymoy [expr ($y1 + $y2) / 2]
- if {$y1 != 0 && $y2 !=0 } {
-
- $w create line $x $y1 [expr $x + $S(IGcurve)] $ymoy \
- $x $y2 -width $S(IGline) -smooth 1 -splinesteps 100 -fill $S(col) \
- -tags "T$ti A$ti $tagC Arc$l Arc$vi Arc $tagS $tagos"
- if {$S(IGannot) == 1} {
- $w create text $x $y1 \
- -fill $S(col) -anchor e -text "$l" -font $S(gfo)\
- -tags "T$ti A$ti $tagC Arc$l Arc$vi Arc $tagS $tagos"
-
- $w create text $x $y2 \
- -fill $S(col) -anchor e -text "$vi" -font $S(gfo)\
- -tags "T$ti A$ti $tagC Arc$l Arc$vi Arc $tagS $tagos"
- }
- }
- } else {
- set y2 [WhatY $w $ti $vi]
- set ymoy [expr ($y1 + $y2) / 2]
- if {$y1 != 0 && $y2 !=0 } {
- $w create oval [expr $x - 20] [expr $y1 -5] $x [expr $y1 +5] -outline $S(col) \
- -tags "T$ti A$ti $tagC Arc$l Arc$vi Arc $tagos $tagS "
- }
- }
- }
- }
- }
- PhyRad - PhyCir1 - PhyCir2 - ClaRad {
-
- }
- ClaCir1 - ClaCir2 {
-
- }
- ClaCir3 {
- set database $S(database)
- upvar #0 $S(database) X
- set w $S($ti,w)
- set co [$w bbox [list T$ti && Z]]
- set x1 [lindex $co 0]
- set y1 [lindex $co 1]
- set x2 [lindex $co 2]
- set y2 [lindex $co 3]
- set xcenter [expr double($x2 + $x1)/2]
- set ycenter [expr double($y2 + $y1)/2]
- set tagS [format "%s%s%s" SEL ? [Tools::GenId]]
- foreach v $lv {
- set tagC [format "%s%s%s" COL ? [Tools::GenId]]
- set vsplit [split $v ":"]
- set l [lindex $vsplit 0] ;# source
- set ll [lindex [lindex $vsplit end] 0] ;# targets
- foreach vi [split $ll] {
- set tagos [format "%s%s%s%s%s" ARCU ? $l ? $vi]
- if {[lsearch $T($ti,ue_lab) $vi] != -1 && [lsearch $T($ti,ue_lab) $l] != -1} {
- set coVI [$w coords [$w find withtag [list [format "%s%s" $T($ti,ltc,$vi) C ] && T$ti]]]
- set coL [$w coords [$w find withtag [list [format "%s%s" $T($ti,ltc,$l) C ] && T$ti]]]
- set xVI [lindex $coVI 2]
- set yVI [lindex $coVI 3]
- set xL [lindex $coL 2]
- set yL [lindex $coL 3]
- if {$yVI != 0 && $yL !=0 && $xVI !=0 && $xL !=0} {
- $w create line $xVI $yVI $xcenter $ycenter $xL $yL \
- -width $S(IGline) -smooth 1 -splinesteps 100 -fill $S(col) \
- -tags "T$ti A$ti $tagC Arc$l Arc$vi Arc $tagos $tagS"
- }
- }
- }
- }
- }
- }
- }
- }
- #
- proc WhatY {w t l} {
-
- set item [$w find withtag [list [format "%s%s" EUL $l ] && T$t]]
- if {$item == ""} {
- set items [$w find withtag [list ADD?$l && T$t]]
- set y 0
- foreach ii $items {
- set yii [lindex [$w coords $ii] 1]
- if {$yii >= $y} {
- set y $yii
- }
- }
- } else {
- set co [$w coords $item]
- set y [lindex $co 1]
- }
- return $y
- }
-
- }
- ####################
- ####################
- # TDCOM
- ####################
- namespace eval TDcom {
-
- proc com {argv} {
- wm withdraw .
- global T S Export asedCon fileGeneric
- set S(version) 179
- set S(ilw) 0
- set S(display_eu) normal
- set S(gfo) {Helvetica 8 normal}
- set S(lastid) 0
- set S(nbobj) 0
- set S(database) ""
- set S(ldatabase) {}
- set S(nodefilter) 0
- set S(stipple) z.xbm
- set S(defaultshape) 1
- # default values for tree command
- set S(tree-conformation) 01
- set S(tree-x) 10
- set S(tree-y) 20
- set S(tree-height) auto
- set S(tree-width) 150
- set S(tree-font) {Helvetica 8 normal}
- set S(tree-foreground) black
- set S(tree-background) none
- set S(tree-outline) none
- set S(tree-state) normal
- set S(tree-linewidth) 1
- set S(tree-symbol) none
- set S(tree-text) none
- set S(tree-scale) none
-
- #
- set S(operation) nodebgcolor
- set S(symboldy) 3
- set fileTLF ""
- set fileTDS ""
- set fileGeneric out
-
- # pour test en local
- set S(TDOcgiDIR) [pwd]
- set S(TDOhtmlDIR) [pwd]
-
- foreach {k v} $argv {
- switch -- $k {
- "-tree" {
- set fileNWK [file join $S(TDOcgiDIR) $v]
- }
- "-label" {
- set fileTLF [file join $S(TDOcgiDIR) $v]
- }
- "-script" {
- set fileTDS [file join $S(TDOcgiDIR) $v]
- }
- "-out" {
- set fileGeneric $v
- }
- }
- }
- set fid [open $fileNWK r]
- set s [read -nonewline $fid]
- close $fid
- regsub -all "\n| " $s "" s
- regsub -all {\[} $s "" s
- regsub -all {:-} $s ":" s
- regsub -all {\]} $s "" s
- set l [split $s ";"]
- set t 0
- set c .c
- set S($c,t) {}
- set S($c,con) {} ;# la liste des ID des connectors de la fenetre
- set S($c,com) {} ;# la liste des ID des comments de la fenetre
- set S(sav,$c) ""
- set S($c,BIcol) ?
- set S($c,BIrow) ?
- canvas .c
- foreach s [lrange $l 0 end-1] {
- TDcom::NewickToTreeDyn $s
- set lkv [array get Export]
- foreach {key value} $lkv {set T(xxx,$key) $value}
- unset Export
- incr t
- lappend S(ilt) $t
- lappend S($c,t) $t
- set S($t,w) $c
- set S($t,tar) 1
- TDcom::TreeInit $t
- TDcom::xxxEncode $t
- TDcom::PhyNJ $t $c
-
- }
- set S(targetTree) $t
- set S(targetWind) $c
- if {$fileTLF != ""} {TDcom::LoadAnnotations $fileTLF}
- if {$fileTDS != ""} {TDcom::OpenScript $fileTDS}
-
- ### EXPORT
- TDcom::exportPS [file join $S(TDOhtmlDIR) $fileGeneric] $c
- TDcom::exportTGF [file join $S(TDOhtmlDIR) $fileGeneric] $c
- TDcom::exportSVG [file join $S(TDOhtmlDIR) $fileGeneric] $c
- exit
- }
-
- ###
- proc xxxEncode {t} {
- global T
- set uold xxx
- set unew $t
- set kvT [array get T xxx*]
- foreach {key value} $kvT {
- regsub -all xxx $value $t valueswi
- unset T($key) ; regsub -all xxx $key $t keyswi ; set T($keyswi) $valueswi
- }
- }
- ### TreeInit
- proc TreeInit {t} {
- global T S B
- set S($t,orient) W
- set S($t,a_ori) 0 ;# angle aditionel utilise dans les rotations
- set S($t,a_uni) 0 ;# unite d'angle
- set S($t,tit) "" ;# le pathcut2 du fichier tdy
- set S($t,type) PhyNJ ;# le type de tree par defaut
- set S($t,init) 0 ;# cette variable fixe le mode inclusif/exclusif du panel identification
- set S($t,display_eu) $S(display_eu)
- set S($t,LabelMatrixBase) 5 ;# matrice d'annotation
- set T($t,eu_collapse) {} ;# liste des noms de feuilles a retirer en abstraction
- set T($t,xmax) 0 ;# branch length max
- set T($t,tot) 0 ;# level max
- set T($t,all_cod) {} ;# codes nodes
- set T($t,ue_cod) {} ;# UE - codes LISTE ORDONNEE
- set T($t,ue_lab) {} ;# UE - labels LISTE ORDONNEE
- set B($t,shi) {} ;# List des nodes shrink
- set B($t,qyn) {} ;# list des items querynode
- set B($t,ova) {} ;# la liste des node reliant 1 tree (decomposition)
- set B($t,bll) {} ;# la liste des nodes ayant des BLL (bulles labels link : eu;db,users)
- set B($t,bgs) {} ;# la liste des items background nodes
- set B($t,bgl) {} ;# la liste des items background leaves
- set B($t,con) {} ;# la liste des r?Šseaux de connection
- }
- ###
- proc exportPS {file c} {
- global S T
- foreach {x0 y0 x1 y1} [$c bbox all] {}
- set w [expr $x1 - $x0]
- set h [expr $y1 - $y0]
- $c postscript -file [format "%s%s" $file .ps] -colormode color \
- -x $x0 -y $y0 -width $w -height $h \
- -pagex 0 -pagey 0 -pagewidth 20.c -pageheight 30.c \
- -pageanchor nw
- }
- ###
- proc exportTGF {file c} {
- global S
- set file [format "%s%s" $file .tgf]
- set script [canvas_saveArray $c $S($c,t)]
- append script [canvas_saveItems $c $S($c,t)]
- set fid [open $file w]
- set data [split $script "\n"]
- foreach elt $data {puts $fid $elt}
- close $fid
- }
- ###
- proc exportSVG {file c} {
- global S
- set file [format "%s%s" $file .svg]
- ::can2svg::canvas2file $c $file
- }
- ###
- proc canvas_saveArray {w lt} {
- global S T B
- set script "### $S(version)\n"
- append script "set E(tree) \{$lt\} \n"
- #set script "set E(tree) \{$lt\} \n"
- # attention a conserver l'espace entre "\{" et $v
- foreach t $lt {
- set pattern [format "%s%s%s" $t , * ]
- ######### ARRAY T
- append script "### T\n"
- foreach {k v} [array get T [format "%s%s" $t *]] {
- append script "set ET($k) \{ $v\} \n"
- }
- ######### ARRAY S
- append script "### S\n"
- foreach {k v} [array get S [format "%s%s" $t *]] {
- append script "set ES($k) \{ $v\} \n"
- }
- ######### ARRAY B ici pas d'espace avant v
- append script "### B\n"
- foreach {k v} [array get B [format "%s%s" $t *]] {
- append script "set EB($k) \{$v\} \n"
- }
- # B // BGS
- foreach Id $B($t,bgs) {
- set pattern [format "%s%s%s" BGS* , $Id]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- # B // BGL
- foreach Id $B($t,bgl) {
- set pattern [format "%s%s%s" BGL* , $Id]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- # B // SHI
- foreach Id $B($t,shi) {
- set pattern [format "%s%s%s" SHI* , $Id]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- # B // BLL
- foreach Id $B($t,bll) {
- set pattern [format "%s%s%s" BLL* , $Id]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- # B // QYN
-
- foreach i $B($t,qyn) {
- set pattern [format "%s%s%s" QYN* , $i]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- # B // OVA
- foreach i $B($t,ova) {
- set pattern [format "%s%s%s" OVA* , $i]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- }
- # items sans reference a un IDtree, ou faisant reference a plusieurs IDtree
- # B // CON = connectors
- append script "set ES(con) \{$S($w,con)\} \n"
- foreach i $S($w,con) {
- set pattern [format "%s%s%s" CON* , $i]
- foreach {k v} [array get B $pattern] {
- append script "set EB($k) \{ $v\} \n"
- }
- }
- # B // COM = comments
-
- # FIN
- return $script
- }
- ###
- proc canvas_saveItems {w lt} {
- global S
- foreach t $lt {
- set lid { }
- foreach item [$w find withtag T$t] {
- set id [Tools::GenId]
- lappend lid $id
- set tags [$w gettags $item]
- set type [$w type $item]
- set coords [$w coords $item]
- set opts ""
- foreach desc [$w itemconfigure $item] {
- set name [lindex $desc 0]
- set init [lindex $desc 3]
- set val [lindex $desc 4]
- # correction bug canvas qui place la valeur "bezier" au lieu de "true"
- # comme valeur de l'option -smooth dans les items canvas
- if {$val == "bezier"} {set val true}
- if {$val != $init} {
- if {$name != "-tags"} {
- lappend opts $name $val
- }
- }
- }
- append script "set EC($t,opts,$id) \{ $type $coords $opts\} \n"
- append script "set EC($t,tags,$id) \{ $tags\} \n"
- }
- append script "set EC($t,ids) \{ $lid\} \n"
- }
- # items graphique non identifie par $id
- # cas des connectors par exemple
- # cas des notes canvas par exemple
- # CONNECTORS, 2 type d'items : line et chaine d'iconification (tags distincts)
- foreach item [$w find withtag {Connect || ConnectIcon}] {
- set id [Tools::GenId]
- lappend lid $id
- set tags [$w gettags $item]
- set type [$w type $item]
- set coords [$w coords $item]
- set opts ""
- foreach desc [$w itemconfigure $item] {
- set name [lindex $desc 0]
- set init [lindex $desc 3]
- set val [lindex $desc 4]
- if {$val != $init} {
- if {$name != "-tags"} {
- lappend opts $name $val
- }
- }
- }
- append script "set EC($t,opts,$id) \{ $type $coords $opts\} \n"
- append script "set EC($t,tags,$id) \{ $tags\} \n"
- }
- #essai save legend
- foreach item [$w find withtag Legend] {
- set id [Tools::GenId]
- lappend lid $id
- set tags [$w gettags $item]
- set type [$w type $item]
- set coords [$w coords $item]
- set opts ""
- foreach desc [$w itemconfigure $item] {
- set name [lindex $desc 0]
- set init [lindex $desc 3]
- set val [lindex $desc 4]
- if {$val != $init} {
- if {$name != "-tags"} {
- lappend opts $name $val
- }
- }
- }
- append script "set EC($t,opts,$id) \{ $type $coords $opts\} \n"
- append script "set EC($t,tags,$id) \{ $tags\} \n"
- }
- append script "set EC($t,ids) \{ $lid\} \n"
- # FIN
- return $script
- }
- ###
- proc NewickToTreeDyn {s} {
- global Export
- set code xxx ; set n 0
- set Export(xmax) 0
- set Export(tot) 0
- set Export(all_cod) $code
- set Export(ue_lab) {}
- set Export(ue_cod) {}
- set Export(Duplication) {}
- if {[string match *:* $s] == 0} {
- regsub -all "," $s {:1.0,} s
- regsub -all {\)} $s {:1.0)} s
- }
- set Export(dbl,$code) 0
- set Export(nwk,$code) $s
- if {[Dicho $s] == 1} {
- set s [format "%s%s%s" ( $s ):0]
- }
- set tp [string last ")" $s]
- set dt [string range $s 0 $tp]
- if {[string compare [string range $dt 0 0] ( ] != 0 || \
- [string compare [string range $dt end end] ) ] != 0} {
- set dt [format "%s%s%s" ( $dt )]
- }
- set id [BgBdx $dt]
- set bg [string range $dt [expr $id + 1] [expr [string length $dt] - 2]]
- set bd [string range $dt 1 [expr $id - 1]]
- lappend Export(cbg,$n) 0
- incr n
- NewickParser $bg [format "%s%s" $code g] $n 0
- NewickParser $bd [format "%s%s" $code d] $n 0
- return
- }
- ###
- proc NewickParser {s code n sx} {
- global Export
- lappend Export(all_cod) $code
- set Export(nwk,$code) $s
- if {[string match *,* $s]} {
- if {[Dicho $s] == 1} {
- set s [format "%s%s%s" ( $s ):0]
- }
- set tp [string last ")" $s]
- set dt [string range $s 0 $tp]
- set dx [string range $s [expr $tp + 1] end]
- set Export(dbl,$code) [expr abs([string range $dx [expr [string last ":" $dx] + 1] end])]
- set Export(dbv,$code) [string range $dx 0 [expr [string last ":" $dx] - 1]]
- if {[string compare [string range $dt 0 0] ( ] != 0 || \
- [string compare [string range $dt end end] ) ] != 0} {
- set dt [format "%s%s%s" ( $dt )]
- }
- set id [BgBdx $dt]
- set bg [string range $dt [expr $id + 1] [expr [string length $dt] - 2]]
- set bd [string range $dt 1 [expr $id - 1]]
- lappend Export(cbg,$n) [format "%s%s" $code $n]
- NewickParser $bg [format "%s%s%s" $code $n g] [expr $n +1] [expr $sx + $Export(dbl,$code)]
- NewickParser $bd [format "%s%s%s" $code $n d] [expr $n +1] [expr $sx + $Export(dbl,$code)]
- } {
- set tp [string last ":" $s]
- set dt [string range $s 0 [expr $tp - 1]]
- set dx [string range $s [expr $tp + 1] end]
- set Export(dbl,$code) [expr abs([string range $dx [expr [string last ":" $dx] + 1] end])]
- if {[lsearch $Export(ue_lab) $dt] == -1} {
- lappend Export(ue_lab) $dt
- set Export(ctl,$code) $dt
- set Export(ltc,$dt) $code
- } else {
- set newdt [format "%s%s%s" $dt - [GenId]]
- lappend Export(Duplication) "$dt swtich to $newdt"
- lappend Export(ue_lab) $newdt
- set Export(ctl,$code) $newdt
- set Export(ltc,$newdt) $code
- }
- lappend Export(ue_cod) $code
- set sx [expr $sx + $dx]
- set Export(sox,$code) $sx
- if {$sx >= $Export(xmax)} {set Export(xmax) $sx}
- if {$n >= $Export(tot)} {set Export(tot) $n}
- return
- }
- }
- ###
- proc GenId {} {
- global S
- incr S(nbobj)
- return [format "%s%s" [clock second] $S(nbobj)]
- }
- ###
- proc BgBdx {s} {
- set i -1
- set id -1
- foreach c [split $s {}] {
- incr id
- switch -exact -- $c {
- ( {incr i}
- ) {incr i -1}
- , {if {$i == 0} {return $id}}
- }
- }
- return ""
- }
- ###
- proc Dicho {s} {
- set i 0 ; set id 0 ; set r 1
- foreach c [split $s {}] {
- switch -exact -- $c {
- ( {incr i}
- ) {incr i -1}
- }
- if {$i == 0} {
- set r [string match *,* [string range $s [expr $id + 1] end]]
- break
- }
- incr id
- }
- return $r
- }
- ###
- proc PhyNJ {t w} {
- global T S
- set y 0
- set nb [llength $T($t,ue_cod)]
- set largeur $S(tree-width)
- if {$S(tree-height) == "auto"} {
- set hauteur [expr 10 * $nb]
- } else {
- set hauteur $S(tree-height)
- }
- set fy [expr double($hauteur) / $nb ]
- set fx [expr double($largeur) / $T($t,xmax)]
- set n 0
- set t3 [format "%s%s" T $t ]
- ### EU
- foreach i $T($t,ue_cod) {
- incr n
- set y [expr $n * $fy ]
- set G($i,x) [expr ($T($t,sox,$i) - $T($t,dbl,$i) )* $fx]
- set G($i,y) $y
- set t2 [format "%s%s" EU $T($t,ctl,$i) ]
- set t4 [format "%s%s" EUL $T($t,ctl,$i) ]
- set t2bis [format "%s%s" $i C]
- $w create line [expr $T($t,sox,$i) * $fx] $G($i,y) $G($i,x) $G($i,y) \
- -tags "$i $t2 $t3 $t2bis Z" -fill $S(tree-foreground) -width $S(tree-linewidth)
- $w create text [expr ($T($t,sox,$i) * $fx) + 2] $G($i,y) \
- -text $T($t,ctl,$i) -anchor w \
- -tags " $t3 $t4 L" \
- -font $S(tree-font) -state $S(tree-state)
- }
- ### NODES
- for {set i [expr $T($t,tot) - 1 ]} {$i >= 1} {incr i -1} {
- foreach b $T($t,cbg,$i) {
- set bg [format "%s%s" $b g]
- set bd [format "%s%s" $b d]
- set yn [expr $G($bg,y) - (($G($bg,y) - $G($bd,y)) / 2)]
- set j [string range $bg 0 [expr [string last $i $bg] - 1]]
- set t2 [format "%s%s" $j C]
- # Vertical
- $w create line $G($bg,x) $G($bg,y) $G($bg,x) $G($bd,y) -tags "$t2 $t3 Z" -fill $S(tree-foreground) -width $S(tree-linewidth)
- # Horizontal
- set G($j,x) [expr $G($bg,x) - ($T($t,dbl,$j) * $fx)]
- $w create line $G($bg,x) $yn $G($j,x) $yn -tags "$j $t2 $t3 Z" -fill $S(tree-foreground) -width $S(tree-linewidth)
- set G($j,y) $yn
- }
- }
- unset G
- ### ROOT
- set ch [$w coords [format "%s%s" $t g]]
- set cb [$w coords [format "%s%s" $t d]]
- set yh [lrange $ch 1 1]
- set yb [lrange $cb 3 3]
- set x [lrange $ch 2 2]
- set yn [expr $yh - (($yh - $yb) / 2)]
- $w create line $x $yh $x $yb -tags "[format "%s%s" $t C] $t3 Z" -fill $S(tree-foreground) -width $S(tree-linewidth)
- $w configure -scrollregion [$w bbox all]
-
- # POSITION TREE
- $w move $t3 $S(tree-x) $S(tree-y)
-
- # BACKGROUND TREE passer au bg sur node 0
- # if {$S(tree-background) != "none"} {
- # set coords [$w bbox $t3]
- # set x1 [lindex $coords 0]
- # set y1 [lindex $coords 1]
- # set x2 [lindex $coords 2]
- # set y2 [lindex $coords 3]
- # set id [ $w create rectangle $x1 $y1 $x2 $y2 -tags "$t3 " -fill $S(tree-background) -outline $S(tree-outline) ]
- # $w lower $id
- # }
- # SYMBOL TREE {none ou {$type $x $y $width $height $color $stipple}}
- if {$S(tree-symbol) != "none"} {
- set S(symboltype) [lindex $S(tree-symbol) 0]
- set x [lindex $S(tree-symbol) 1]
- set y [lindex $S(tree-symbol) 2]
- set S(symboldx) [expr [lindex $S(tree-symbol) 3] / 2.0]
- set S(symboldy) [expr [lindex $S(tree-symbol) 4] / 2.0]
- set S(symbolcolorfill) [lindex $S(tree-symbol) 5]
- set S(symbolcoloroutline) [lindex $S(tree-symbol) 5]
- switch -- [lindex $S(tree-symbol) 6] {
- 01 { set S(symbolstipple) z.xbm}
- 02 { set S(symbolstipple) a.xbm}
- 03 { set S(symbolstipple) b.xbm}
- 04 { set S(symbolstipple) h.xbm}
- 05 { set S(symbolstipple) j.xbm}
- }
- Illustration::drawsymbol $w $x $y $t3
- }
- # TEXT TREE {none ou {$text $x $y $font $color}}
- if {$S(tree-text) != "none"} {
- set text [lindex $S(tree-text) 0]
- set x [lindex $S(tree-text) 1]
- set y [lindex $S(tree-text) 2]
- set font [lindex $S(tree-text) 3]
- set color [lindex $S(tree-text) 4]
- $w create text $x $y -text $text -anchor w -tags " $t3" -font $font -fill $color
-
- }
- # SCALE TREE {none ou {$x $y $color}}
- if {$S(tree-scale) != "none"} {
- set x [lindex $S(tree-scale) 0]
- set y [lindex $S(tree-scale) 1]
- set color [lindex $S(tree-scale) 2]
- Annotation::AnnotateBuiltIn $w $t $x $y Scale $color
-
- }
- }
- proc PhyRad {t w} {
- global T S G
- set S($t,a_ori) 0
- set nb [llength $T($t,ue_cod)]
- set largeur $S(treewidth)
- if {$S(treeheight) == "auto"} {
- set hauteur [expr 10 * $nb]
- } else {
- set hauteur $S(treeheight)
- }
- set x0 [expr $largeur/2.0]
- set y0 [expr $hauteur/2.0]
- if {$x0 <= $y0} {set R $x0} {set R $y0}
- set pi2 [expr 2 * acos(-1)]
- set f [expr $R / $T($t,xmax)]
- set dd [expr ((acos(-1)) * [expr 360.0 / $nb])/ 180.0]
- set S($t,a_uni) $dd
- set td [format "%s%s" $t d]
- set tg [format "%s%s" $t g]
- set nbg [Tools::NodeNoToLeNum $t $tg]
- set nbd [Tools::NodeNoToLeNum $t $td]
- # $t d
- set G($td,a_amplitude) [expr $nbd * $dd]
- #set G($td,a_from) 0 modification pour la rotation
- set G($td,a_from) $S($t,a_ori)
- set G($td,a_to) [expr $G($td,a_from) + $G($td,a_amplitude) ]
- #set G($td,a) [expr $G($td,a_from) + ($G($td,a_amplitude) / 2.0)]
- set G($td,a) [expr ($G($td,a_from) + ($G($td,a_amplitude) / 2.0)) + $S($t,a_ori)]
- set G($td,x) [expr $T($t,dbl,$td) * $f * cos($G($td,a))]
- set G($td,y) [expr $T($t,dbl,$td) * $f * sin($G($td,a))]
- # $t g
- set G($tg,a_amplitude) [expr $nbg * $dd]
- set G($tg,a_from) $G($td,a_to)
- set G($tg,a_to) [expr $G($tg,a_from) + $G($tg,a_amplitude) ]
- #set G($tg,a) [expr $G($tg,a_from) + ($G($tg,a_amplitude) / 2.0)]
- set G($tg,a) [expr ($G($tg,a_from) + ($G($tg,a_amplitude) / 2.0)) + $S($t,a_ori)]
- set G($tg,x) [expr $T($t,dbl,$tg) * $f * cos($G($tg,a))]
- set G($tg,y) [expr $T($t,dbl,$tg) * $f * sin($G($tg,a))]
- # tags
- set tag1 [format "%s%s" $t C]
- set tag2 [format "%s%s" $t C]
- set tag11 [format "%s%s" $tg C]
- set tag22 [format "%s%s" $td C]
- # trace $td & $tg
- $w create line 0 0 $G($tg,x) $G($tg,y) -tags "$tag1 $tag11 T$t Z" -fill black
- $w create line 0 0 $G($td,x) $G($td,y) -tags "$tag2 $tag22 T$t Z" -fill black
- #
- for {set i 1} {$i < $T($t,tot)} {incr i} {
- foreach b $T($t,cbg,$i) {
- set j [string trimright $b {[0123456789]}]
- set t2 [format "%s%s" $j C]
- set bd [format "%s%s" $b d]
- set bg [format "%s%s" $b g]
- set nbg [Tools::NodeNoToLeNum $t $bg]
- set nbd [Tools::NodeNoToLeNum $t $bd]
-
- ### D
- set G($bd,a_amplitude) [expr $nbd * $dd]
- set G($bd,a_from) $G($j,a_from)
- set G($bd,a_to) [expr $G($bd,a_from) + $G($bd,a_amplitude) ]
- set G($bd,a) [expr $G($bd,a_from) + ($G($bd,a_amplitude) / 2.0)]
- set gamma [expr abs($G($j,a) - $G($bd,a))]
- set a [expr cos($gamma) * $T($t,dbl,$j)]
- set b2 [expr sin($gamma) * $T($t,dbl,$j)]
- set c [expr sqrt( abs (($T($t,dbl,$bd) * $T($t,dbl,$bd)) - ($b2 * $b2) ))]
- set L [expr $c + $a]
- set G($bd,x) [expr $G($j,x) + $f * cos($G($bd,a)) * $L]
- set G($bd,y) [expr $G($j,y) + $f * sin($G($bd,a)) * $L]
- ### G
- set G($bg,a_amplitude) [expr $nbg * $dd]
- set G($bg,a_from) $G($bd,a_to)
- set G($bg,a_to) [expr $G($bg,a_from) + $G($bg,a_amplitude) ]
- set G($bg,a) [expr $G($bg,a_from) + ($G($bg,a_amplitude) / 2.0)]
- set gamma [expr abs($G($j,a) - $G($bg,a))]
- set a [expr cos($gamma) * $T($t,dbl,$j)]
- set b2 [expr sin($gamma) * $T($t,dbl,$j)]
- set c [expr sqrt( abs( ($T($t,dbl,$bg)*$T($t,dbl,$bg)) - ($b2 * $b2) ))]
- set L [expr $c + $a]
- set G($bg,x) [expr $G($j,x) + $f * cos($G($bg,a)) * $L]
- set G($bg,y) [expr $G($j,y) + $f * sin($G($bg,a)) * $L]
- ### trace
- $w create line $G($j,x) $G($j,y) $G($bg,x) $G($bg,y) \
- -tags "[format "%s%s" $bg C] $bg T$t Z" -fill black
- $w create line $G($j,x) $G($j,y) $G($bd,x) $G($bd,y) \
- -tags "[format "%s%s" $bd C] $bd T$t Z" -fill black
- }
- }
- # leaf labels
- foreach i $T($t,ue_cod) {
- set angledegre [expr ($G($i,a) * 360) / 6.283185]
- set anchor center
- if {$angledegre >= 0 && $angledegre < 90} {
- set anchor nw
- } elseif {$angledegre >= 90 && $angledegre < 180} {
- set anchor ne
- } elseif {$angledegre >= 180 && $angledegre < 270} {
- set anchor se
- } elseif {$angledegre >= 270 && $angledegre < 360} {
- set anchor sw
- }
- regsub -all {?} $T($t,ctl,$i) " " texto
- $w create text $G($i,x) $G($i,y) -text $texto \
- -tags "T$t [format "%s%s" EUL $T($t,ctl,$i) ] L" \
- -font $S(gfo) -state $S($t,display_eu) -anchor $anchor
- }
- # ajout tag des arretes terminales (eu)
- foreach i $T($t,ue_cod) {
- set t2 [format "%s%s" EU $T($t,ctl,$i)]
- $w addtag $t2 withtag [list $i && T$t]
- $w addtag Z withtag [list $i && T$t]
- }
- # centrage et scrollregion
- $w move T$t $x0 $y0
- $w configure -scrollregion [$w bbox all]
- set S($t,type) PhyRad
- unset G
- }
-
- ### ArrayToCanvasCirculaire
- proc PhyCir1 {t w} {
- global T S
- set nb [llength $T($t,ue_cod)]
- set hauteur [expr 10 * $nb]
- set largeur $hauteur
- set basedegre [expr 360.0 / [llength $T($t,ue_cod)]]
- # passage radians
- set dd [expr ((acos(-1)) * $basedegre)/ 180.0]
- set S($t,a_uni) $dd
- #rayon du cercle primaire
- set xcenter [expr double($largeur)/2]
- set ycenter [expr double($hauteur)/2]
- if {$xcenter <= $ycenter} {set R $xcenter} {set R $ycenter}
- #if {$xcenter < $ycenter} {set R $ycenter} {set R $xcenter}
- set n 0
- # facteur de zoom
- set f [expr double($R / $T($t,xmax))]
- ### EU
- foreach i $T($t,ue_cod) {
- # incr n
- set G($i,a) [expr ($n * $dd) + $S($t,a_ori)]
- set x1 [expr ($T($t,sox,$i)* $f) * cos($G($i,a))]
- set y1 [expr ($T($t,sox,$i)* $f) * sin($G($i,a))]
- set x2 [expr ((($T($t,sox,$i) - $T($t,dbl,$i) )* $f) * cos($G($i,a)))]
- set y2 [expr ((($T($t,sox,$i) - $T($t,dbl,$i) )* $f) * sin($G($i,a)))]
- set G($i,x) $x2
- set G($i,y) $y2
- $w create line $x2 $y2 $x1 $y1 \
- -tags "$i [format "%s%s" EU $T($t,ctl,$i) ] [format "%s%s" $i C] T$t Z" -fill $S(Preference_fgc)
- # feuilles en radial
-
- regsub -all {?} $T($t,ctl,$i) " " texto
- #set ls [split $T($t,ctl,$i) {}]
- set ls [split $texto {}]
- set an center ;# anchor
- set ju center ;# justification
- set angledegre [expr ($G($i,a) * 360) / 6.283185]
- if {$angledegre >= 90 && $angledegre < 270} {
- set b [expr 6 * [llength $ls]]
- foreach s $ls {
- # SPLIT + LEAVES
- # COK
- set xbis [expr $x1 + ($b * cos($G($i,a)))]
- set ybis [expr $y1 + ($b * sin($G($i,a)))]
- $w create text $xbis $ybis \
- -text $s -anchor $an -justify $ju \
- -tags "T$t [format "%s%s" EUL $T($t,ctl,$i) ] L" \
- -font $S(gfo) -state $S($t,display_eu)
- incr b -6
- }
- } else {
- set b 2
- foreach s $ls {
- # SPLIT + LEAVES
- # COK
- set xbis [expr $x1 + ($b * cos($G($i,a)))]
- set ybis [expr $y1 + ($b * sin($G($i,a)))]
- $w create text $xbis $ybis \
- -text $s -anchor $an -justify $ju \
- -tags "T$t [format "%s%s" EUL $T($t,ctl,$i) ] L" \
- -font $S(gfo) -state $S($t,display_eu)
- incr b 6
- }
- }
- incr n
- }
- ### NODES
- for {set i [expr $T($t,tot) - 1 ]} {$i >= 1} {incr i -1} {
- foreach b $T($t,cbg,$i) {
- set bg [format "%s%s" $b g] ;# code bras gauche precedent (un niveau de profondeur plus loin)
- set bd [format "%s%s" $b d] ;# code bras droit precedent (un niveau de profondeur plus loin)
- set j [string trimright $b {[0123456789]}] ;# code bras gauche ou droit
- set t2 [format "%s%s" $j C]
- set ad [expr (180.0 * $G($bd,a)) / acos(-1)]
- set ag [expr (180.0 * $G($bg,a)) / acos(-1)]
- set G($j,a) [expr ($G($bg,a) + $G($bd,a)) / 2.0 ]
- set rho [expr $G($bg,x) / cos($G($bg,a))]
- set x1 [expr $rho * cos($G($j,a))]
- set y1 [expr $rho * sin($G($j,a))]
- set x2 [expr $x1 - ($T($t,dbl,$j) * $f * cos($G($j,a)))]
- set y2 [expr $y1 - ($T($t,dbl,$j) * $f * sin($G($j,a)))]
- set G($j,x) $x2
- set G($j,y) $y2
- $w create arc [expr 0 -$rho] $rho $rho [expr 0 -$rho] \
- -start -$ad -extent [expr $ad - $ag] -style arc \
- -tags "$t2 T$t Z" -outline $S(Preference_fgc)
- $w create line $x1 $y1 $x2 $y2 \
- -tags "$j $t2 T$t Z" -fill $S(Preference_fgc)
- }
- }
- # root
- #$w create line $xcenter $ycenter $xcenter $ycenter \
- # -tags "[format "%s%s" $t C] T$t Z" -fill $S(Preference_fgc)
-
- #translation
- $w move T$t $xcenter $ycenter
- $w configure -scrollregion [$w bbox all]
- $w create line $xcenter $ycenter $xcenter $ycenter \
- -tags "[format "%s%s" $t C] T$t Z" -fill $S(Preference_fgc)
- unset G
- }
- proc ResizeAllGo {w} {
- global S
- foreach t $S($w,t) {
- set co [$w bbox T$t]
- set x [lindex $co 0]
- set y [lindex $co 1]
- $w delete T$t
- switch -exact $S($t,type) {
- PhyNJ {set S($t,type) PhyNJ ; TDcom::PhyNJ $t $w }
- PhyRad {set S($t,type) PhyRad ; TDcom::PhyRad $t $w }
- PhyCir1 {set S($t,type) PhyCir1 ; TDcom::PhyCir1 $t $w }
- default {set S($t,type) PhyNJ ; TDcom::PhyNJ $t $w }
- }
- $w move T$t $x $y
- Figuration::RestaureT $w $t
- Reflection::UpdateAll $w
- }
- set S(treeheight) auto
- }
- ###
- proc LoadAnnotations {filename} {
- global S asedCon
- set currentfile [Tools::PathCut2 $filename]
- if {[lsearch $S(ldatabase) $currentfile] != -1 } {
- upvar #0 $currentfile X
- array unset X
- } else {
- lappend S(ldatabase) $currentfile
- }
- # TDcom::db $currentfile
- TDcom::db TDO
- catch {open $filename r} fid
- while {[eof $fid] != 1} {
- set id [incr S(lastid)]
- gets $fid data
- # modif
- regsub -all " " [lindex $data 0] "?" sans
- set datasans [lreplace $data 0 0 $sans]
- interp eval treedyn TDO [concat $id EU $datasans]
- # interp eval treedyn $currentfile [concat $id EU $datasans]
- # interp eval treedyn $currentfile [concat $id EU $data]
- }
- close $fid
- #set S(database) $currentfile
- set S(database) TDO
- }
- ###
- # proc db de Richard Suchenwirth
- proc db {database args} {
- global asedCon
- upvar #0 $database db
- set key ""
- foreach {- key item value} $args break
- set exists [info exists db($key)]
- set res {}
- switch [llength $args] {
- 0 {
- array set db {}
- interp alias {} $database {} TDcom::db $database -
- $asedCon alias $database TDcom::db $database -
- set res $database
- }
- 1 {set res [array names db]}
- 2 {
- if {$key != ""} {
- if {$exists} {set res $db($key)}
- } else {array unset db }
- }
- 3 {if {$item != ""} {
- if {$exists} {
- set t $db($key)
- if {!([set pos [lsearch $t $item]]%2)} {
- set res [lindex $t [incr pos]]
- }
- }
- } elseif {$exists} {unset db($key)}
- }
- 4 {
- if {$exists} {
- if {!([set pos [lsearch $db($key) $item]]%2)} {
- if {$value != ""} {
- set db($key) [lreplace $db($key) [incr pos] $pos $value]
- } else {set db($key) [lreplace $db($key) $pos [incr pos]]}
- } elseif {$value != ""} {
- lappend db($key) $item $value
- }
- } elseif {$value != ""} {set db($key) [list $item $value]}
- set res $value
- }
- default {
- if {[llength $args]%2} {error "non-paired item/value list"}
- foreach {item value} [lrange $args 2 end] {
- db $database - $key $item $value
- }
- }
- }
- }
- proc OpenScript {filename} {
- global S T tds fileGeneric
- catch {open $filename r} fid
- set ltreetarget {} ; set lwindowtarget {}
- foreach {w t} [Selection::TreeTar] {
- lappend ltreetarget $t
- lappend lwindowtarget $w
- }
- set lwindowtarget [Tools::DelRep $lwindowtarget]
- # valeur par defaut
- set S(ScriptingLegend) 0
- while {[eof $fid] != 1} {
- gets $fid raw
- set type [lindex $raw 0]
- set command [lrange $raw 1 end]
- #conPuts $raw
- switch -exact $type {
- annotation {
- # il faut AN Columns {TDO {TypeStrain}}
- # on a annotation Columns {TypeStrain}
- global ann
- set mode [lindex $command 0]
- if {$mode == "matrix"} {
- set S(database) TDO
- set ann(binmatPadding) 6
- set ann(binmatHeight) 4
- set ann(binmatWidth) 4
- set ann(binmatColor0) white
- set ann(binmatColor1) black
- set ann(binmatOutline) 1
- set ann(binmatColumnsNumber) 0
- Annotation::MatrixAnnotateGoGo [lindex $command 1] $ltreetarget
- } elseif {$mode == "matrixrgb"} {
- set S(database) TDO
- set ann(binmatPadding) 6
- set ann(binmatHeight) 4
- set ann(binmatWidth) 4
- set ann(binmatColor0) white
- set ann(binmatColor1) black
- set ann(binmatOutline) 1
- set ann(binmatColumnsNumber) 0
- Annotation::MatrixColorsAnnotateGoGo [lindex $command 1] $ltreetarget
- } elseif {$mode == "newick"} {
- set command [lrange $command 1 end]
- # annotationnewick ?[-what ":x ou x:"] ?[-treshold $valeur] ?[-leaf "0 ou 1"] ?[-where "nw sw ne se n s"] -color -font
- # valeur par defaut
- set S(-what) :x ;# :x ou x:
- set S(-treshold) all ;# all ou $valeur
- set S(-leaf) 1 ;# 0 1
- set S(-where) nw ;# "nw sw ne se n s e"
- set S(-font) {Helvetica 8 normal} ;#
- set S(-color) blue ;#
- # traitements flags
- foreach {variable value} $command {
- eval set S($variable) $value
- }
- # display
- foreach {w t} [Selection::TreeTar] {
- ANBLgo $w $t
- }
- } elseif {$mode == "draw"} {
- set command [lrange $command 1 end]
- # default values
- set x(-l) {}
- set x(-text) ""
- set x(-color) red
- set x(-font) {Arial 8 normal}
- set x(-tab) 0
- set x(-width) 5
- set x(-background) red
- set x(-stipple) 01
- # traitements flags
- foreach {variable value} $command {
- eval set x($variable) $value
- }
- switch -exact $x(-stipple) {
- 01 { set x(-stipple) z.xbm}
- 02 { set x(-stipple) a.xbm}
- 03 { set x(-stipple) b.xbm}
- 04 { set x(-stipple) h.xbm}
- 05 { set x(-stipple) j.xbm}
- }
- foreach {w t} [Selection::TreeTar] {
- # ds leafs eventuellement des patterns
- set l {}
- foreach li $x(-l) {
- append l " [lsearch -all -inline -regexp $T($t,ue_lab) $li]"
- }
- if {$l != {}} {
- # recuperer la liste des noeuds peres
- set peres [Operation::FindFatherNode $t $l]
- foreach p $peres {
- set SouCodLea [Tools::NodeNoToLe $t $p]
- set SouRefLea [Tools::NodeLeCoToRe $t $SouCodLea]
- Illustration::BracketDrawLeafs $w $t $SouRefLea $x(-text) $x(-color) \
- $x(-font) $x(-tab) $x(-width) $x(-background) $x(-stipple)
- }
- }
- }
- unset x
- } elseif {$mode == "arcs"} {
- set command [lrange $command 1 end]
- # valeur par defaut
- set S(-tab) 50
- set S(-text) 1
- set S(-curve) 10
- set S(-line) 1
- set S(-color) blue
- # traitements flags
- foreach {variable value} $command {
- eval set S($variable) $value
- }
- # affectation des variables globales
- set S(col) $S(-color)
- set S(IGtabul) $S(-tab)
- set S(IGcurve) $S(-curve)
- set S(IGline) $S(-line)
- set S(IGannot) $S(-text)
- # construction liste lv : leaf source listes des feuilles target
- set S(database) TDO
- set id [Database::dbQueryRecordsFromVarVal TDO EU $S(-leaf)]
- set l [Database::dbQueryVarFromRecords TDO $S(-variable) $id]
- set lv [list [format "%s%s%s%s" $S(-leaf) ":{" $l "}"]]
- # display
- foreach {w t} [Selection::TreeTar] {
- Amelie::DrawGoUser $lv $t
- }
- } else {
- if {$mode == "replace" } {set mode LeavesReplace }
- if {$mode == "juxtapose" } {set mode LeavesAdd }
- if {$mode == "column" } {set mode Columns }
- set ann(ann-fgfiguration) asuser
- set ann(ann-fofiguration) asuser
- set ann(ann-prefix) " "
- set ann(ann-suffix) ""
- set ann(ann-exposant) 0
- set fct [format "%s%s" Annotation::ANGo $mode] ;# la fonction d'annotation
- set lv [lindex $command 1] ;# database liste_de_variables
- #set S(database) [lindex $var 0]
- set S(database) TDO
- #set lv [lindex $var 1] ;# liste de variables
- set args [lindex $command 2] ;# options
- if {$args != ""} {
- foreach {option value} $args {
- set ann(ann-$option) $value
- }
- }
- eval $fct $lv [list $ltreetarget]
- set ann(ann-prefix) " "
- set ann(ann-suffix) ""
- set ann(ann-exposant) 0
- }
- }
- find {
- set S(query) $command
- foreach {w t} [Selection::TreeTar] {
- foreach ci [lindex $command 0] {
- #set leu {}
- #foreach i $T($t,ue_lab) {
- # if {[string match $ci $i]} {lappend leu $i }
- #}
- set leu [ lsearch -all -inline -regexp $T($t,ue_lab) $ci ]
- Operation::Operation $w $t $leu
- if {$S(ScriptingLegend)} {
- # legende MODIF si symbol
- if {$S(operation) == "LillC"} {
- foreach wi $lwindowtarget {
- set co [$wi bbox Legend]
- if {$co == ""} {
- set x 0 ; set y 0
- } else {
- set x 0 ; set y [expr [lindex $co end] + $S(symboldy)+3]
- }
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $wi $x $y [list Legend $S(ScriptingLegendTAG)]
- $wi create text [expr $x + 15] [expr $y + 2] \
- -text $ci -tags "Legend txt $S(ScriptingLegendTAG)"
- }
- incr y 15
- } else {
- foreach wi $lwindowtarget {
- set co [$wi bbox Legend]
- if {$co == ""} {
- set x 0 ; set y 0
- } else {
- set x 0 ; set y [expr [lindex $co end] + $S(symboldy)+3]
- }
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $wi $x $y [list Legend $S(ScriptingLegendTAG)]
- $wi create text [expr $x + 11] [expr $y + 2] \
- -text $ci -tags "Legend txt $S(ScriptingLegendTAG)"
- }
- incr y 10
- }
- }
- }
- }
- }
- query {
- set var [lindex $command 0]
- set ope [lindex $command 1]
- foreach val [lindex $command 2] {
- set com [concat EU from TDO where $var $ope $val]
- eval Database::Select $com
- if {$S(ScriptingLegend)} {
- # legende MODIF si symbol
- if {$S(operation) == "LillC"} {
- foreach wi $lwindowtarget {
- set co [$wi bbox Legend]
- if {$co == ""} {
- set x 0 ; set y 0
- } else {
- set x 0 ; set y [expr [lindex $co end] + $S(symboldy)+3]
- }
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $wi $x $y [list Legend $S(ScriptingLegendTAG)]
- $wi create text [expr $x + 15] [expr $y + 2] \
- -text [lindex $com end] -tags "Legend txt $S(ScriptingLegendTAG)"
- }
- incr y 15
- } else {
- foreach wi $lwindowtarget {
- set co [$wi bbox Legend]
- if {$co == ""} {
- set x 0 ; set y 0
- } else {
- set x 0 ; set y [expr [lindex $co end] + $S(symboldy)+3]
- }
- #set S(symbolcolorfill) $S(col)
- #set S(symbolcoloroutline) $S(col)
- #set S(symbolstipple) $S(stipple)
- Illustration::drawsymbol $wi $x $y [list Legend $S(ScriptingLegendTAG)]
- $wi create text [expr $x + 11] [expr $y + 2] \
- -text [lindex $com end] -tags "Legend txt $S(ScriptingLegendTAG)"
- }
- incr y 10
- }
- }
- }
- }
- font {
- set S(gfo) $command
-
- }
- tree {
- # traitements flags -height -width -font -foreground -background etc
- foreach {variable value} $command {
- set variabletree [format "%s%s" tree $variable]
- eval set S($variabletree) $value
- }
- foreach {w t} [Selection::TreeTar] {
- $w delete T$t
- switch -- $S(tree-conformation) {
- 01 { TDcom::PhyNJ $t $w}
- 02 { TDcom::PhyRad $t $w}
- }
- #Figuration::RestaureT $w $t
- }
- }
- legend {
- switch -exact $command {
- on {
- set S(ScriptingLegend) 1
- set tagi [format "%s%s" LE [Tools::GenId]]
- set S(ScriptingLegendTAG) $tagi
- }
- off {
- set S(ScriptingLegend) 0
- }
- }
- }
- text {
- set S(AnnotateNote) $command
- }
- scale {
- foreach {w t} [Selection::TreeTar] {
- set co [$w bbox T$t]
- set x [lindex $co 0]
- set y [lindex $co 1]
- Annotation::AnnotateBuiltIn $w $t [expr [lindex $command 0] + $x] [expr [lindex $command 1] + $y] Scale
- }
- }
- conformation {
- set mode [lindex $command 0]
- switch -exact $mode {
- 01 {
- foreach {w t} [Selection::TreeTar] {
- $w delete T$t
- TDcom::PhyNJ $t $w
- }
- }
- 02 {
- foreach {w t} [Selection::TreeTar] {
- $w delete T$t
- TDcom::PhyRad $t $w
- }
- }
- 03 {
- foreach {w t} [Selection::TreeTar] {
- $w delete T$t
- TDcom::PhyCir1 $t $w
- }
- }
- }
- }
- swap {
- set ll [lindex $command 0]
- foreach {w t} [Selection::TreeTar] {
- set leu {}
- foreach e $ll {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- set n [Operation::FindFatherNode $t $leu]
- if {[lindex $n 0] != ""} {
- Conformation::Swap $w $t $n
- }
- }
- }
- root {
- set ll [lindex $command 0]
- foreach {w t} [Selection::TreeTar] {
- set leu {}
- foreach e $ll {
- if {[lsearch -exact $T($t,ue_lab) $e] != -1} {lappend leu $e}
- }
- set n [Operation::FindFatherNode $t $leu]
- if {[lindex $n 0] != ""} {
- Conformation::Outgroup2 $w - $t $n
- }
- }
- }
- size {
- set S(newW) [lindex $command 0]
- set S(newH) [lindex $command 1]
- set S(treewidth) [lindex $command 0]
- set S(treeheight) [lindex $command 1]
- foreach wi $lwindowtarget {TDcom::ResizeAllGo $wi}
- }
- rowcolumn {
- set row [lindex $command 0]
- set column [lindex $command 1]
- foreach wi $lwindowtarget {Navigation::Reorganize $wi $column $row}
- }
- symbol {
- set S(symboltype) [lindex $command 0]
- set S(symboldx) [lindex $command 1]
- set S(symboldy) [lindex $command 2]
- set S(symbolcolorfill) [lindex $command 3]
- set S(symbolcoloroutline) [lindex $command 4]
- switch -exact [lindex $command 5] {
- 01 { set S(symbolstipple) z.xbm}
- 02 { set S(symbolstipple) a.xbm}
- 03 { set S(symbolstipple) b.xbm}
- 04 { set S(symbolstipple) h.xbm}
- 05 { set S(symbolstipple) j.xbm}
- default { set S(symbolstipple) z.xbm}
- }
- }
- tabulation {
- switch -exact [lindex $command 0] {
- + {Illustration::IllCTabulationSet tab+ [lindex $command 1]}
- - {Illustration::IllCTabulationSet tab- [lindex $command 1]}
- = {Illustration::IllCTabulationSet tab= [lindex $command 1]}
- auto {set S(TabulationAnnot) [lindex $command 1] ; set S(illustration-tabulation) 1}
- manual {set S(illustration-tabulation) 0}
- }
- }
- color {
- eval set S(col) $command
- }
- stipple {
- switch -exact [lindex $command 0] {
- 01 { set S(stipple) z.xbm}
- 02 { set S(stipple) a.xbm}
- 03 { set S(stipple) b.xbm}
- 04 { set S(stipple) h.xbm}
- 05 { set S(stipple) j.xbm}
- }
- }
- shape {
- switch -exact [lindex $command 0] {
- 01 { set S(defaultshape) 1}
- 02 { set S(defaultshape) 2}
- 03 { set S(defaultshape) 3}
- 04 { set S(defaultshape) 4}
- 05 { set S(defaultshape) 5}
- }
- }
- operation {
- set S(operation) {}
- foreach op $command {
- switch $op {
- l01 {eval lappend S(operation) leaffgcolor}
- l02 {eval lappend S(operation) leafbgcolor}
- l03 {eval lappend S(operation) leaffontglob}
- l04 {eval lappend S(operation) LillL}
- l05 {eval lappend S(operation) LillC}
- l06 {eval lappend S(operation) LannL}
- l07 {eval lappend S(operation) LannC}
- l08 {eval lappend S(operation) leafshrink}
- l09 {eval lappend S(operation) leafunshrink}
- n00 {eval lappend S(operation) nodefgcolor}
- n01 {eval lappend S(operation) nodebgcolor}
- n02 {eval lappend S(operation) widthline+}
- n03 {eval lappend S(operation) widthline-}
- n04 {eval lappend S(operation) nodedashOn}
- n05 {eval lappend S(operation) nodedashOff}
- n06 {eval lappend S(operation) nodeillustration}
- n07 {eval lappend S(operation) symbolnode}
- n08 {eval lappend S(operation) nodeannotate}
- n09 {eval lappend S(operation) insertvarval}
- n10 {eval lappend S(operation) insertvarval2}
- n11 {eval lappend S(operation) shrink}
- n12 {eval lappend S(operation) unshrinnk}
- n13 {eval lappend S(operation) nodenetwork}
- n14 {eval lappend S(operation) nodeextract}
- n15 {eval lappend S(operation) nodefgcolor2}
- n16 {eval lappend S(operation) widthline+2}
- n17 {eval lappend S(operation) nodedashOn2}
- c00 {eval lappend S(operation) querynode}
- }
- }
-
- }
- infocoord {
- switch $command {
- leave {
- set fileINFO [format "%s%s" [file join $S(TDOhtmlDIR) $fileGeneric] infocoordleave.txt]
- set fid2 [open $fileINFO w]
- foreach {w t} [Selection::TreeTar] {
-
- foreach l $T($t,ue_lab) {
- set coL [$w bbox [$w find withtag [list [format "%s%s" EUL $l ] && T$t]]]
- #set coL [$w coords [$w find withtag [list [format "%s%s" $T($t,ltc,$l) C ] && T$t]]]
- puts $fid2 "$l $coL"
- }
- }
- close $fid2
- }
- tree {
- set fileINFO [format "%s%s" [file join $S(TDOhtmlDIR) $fileGeneric] infocoordtree.txt]
- set fid2 [open $fileINFO w]
- foreach {w t} [Selection::TreeTar] {
- if {$S(illustration-tabulation) == 1} {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- set XMAX3 [lindex [$w bbox [list T$t && AnnotMatrix]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- if {$XMAX < $XMAX3} {set XMAX $XMAX3 }
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- } else {
- set XMAX1 [lindex [$w bbox [list T$t && Z]] 2]
- set XMAX2 [lindex [$w bbox [list T$t && L]] 2]
- if {$XMAX1 < $XMAX2} {set XMAX $XMAX2 } {set XMAX $XMAX1}
- set x [expr $XMAX + $S($t,LabelMatrixBase)]
- }
- puts $fid2 "$t $x"
- }
- close $fid2
- }
- node {
- set fileINFO [format "%s%s" [file join $S(TDOhtmlDIR) $fileGeneric] infocoordnode.txt]
- set fid2 [open $fileINFO w]
-
- foreach {w t} [Selection::TreeTar] {
- set id 0
- foreach node $T($t,all_cod) {
- set l [Tools::NodeLeCoToRe $t [Tools::NodeNoToLe $t $node]]
- puts $fid2 "$id \t $node \t [list [lsort -dictionary $l]] \t [list [$w coords $node]]"
- incr id
- }
- }
- close $fid2
- }
- }
- }
- }
- }
- close $fid
- }
-
- proc ANBLgo {w t} {
- global T S
-
- switch -- $S(-what) {
- ":x" {
- if {$S(-treshold) == "all"} {
- set l [lrange $T($t,all_cod) 1 end]
- if {$S(-leaf) == 0} {set l [Tools::SousL $l $T($t,ue_cod)]}
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- switch -- $S(-where) {
- nw {
- # gauche haut
- set x [expr [lindex $co 2] + 2]
- set y [lindex $co 1]
- set anchor sw ; set justify left
- }
- sw {
- # gauche bas
- set x [expr [lindex $co 2] + 2]
- set y [expr [lindex $co 1] + 2]
- set anchor nw ; set justify left
- }
- ne {
- # droite haut
- set x [lindex $co 0]
- set y [lindex $co 1]
- set anchor se ; set justify right
- }
- se {
- # doite bas
- set x [lindex $co 0]
- set y [expr [lindex $co 1] + 2]
- set anchor ne ; set justify right
- }
- n {
- # centre haut
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [lindex $co 1]
- set anchor s ; set justify center
- }
- s {
- # centre bas
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [expr [lindex $co 1] + 2]
- set anchor n ; set justify center
- }
- e {
- # special
- set x [expr [lindex $co 0] +2]
- set y [expr [lindex $co 1] +1]
- set anchor w ; set justify left
- }
- }
- if [catch {set test $T($t,dbl,$i)} res] {} else {
- eval {$w create text} \
- {$x $y} \
- {-text $T($t,dbl,$i) -fill $S(-color) \
- -font $S(-font) -anchor $anchor -justify $justify -tags "T$t DBL"}
- }
- }
- }
- }
-
- } else {
- set l [lrange $T($t,all_cod) 1 end]
- if {$S(-leaf) == 0} {set l [Tools::SousL $l $T($t,ue_cod)]}
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- switch -- $S(-where) {
- nw {
- # gauche haut
- set x [expr [lindex $co 2] + 2]
- set y [lindex $co 1]
- set anchor sw ; set justify left
- }
- sw {
- # gauche bas
- set x [expr [lindex $co 2] + 2]
- set y [expr [lindex $co 1] + 2]
- set anchor nw ; set justify left
- }
- ne {
- # droite haut
- set x [lindex $co 0]
- set y [lindex $co 1]
- set anchor se ; set justify right
- }
- se {
- # doite bas
- set x [lindex $co 0]
- set y [expr [lindex $co 1] + 2]
- set anchor ne ; set justify right
- }
- n {
- # centre haut
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [lindex $co 1]
- set anchor s ; set justify center
- }
- s {
- # centre bas
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [expr [lindex $co 1] + 2]
- set anchor n ; set justify center
- }
- e {
- # special
- set x [expr [lindex $co 0] +2]
- set y [expr [lindex $co 1] +1]
- set anchor w ; set justify left
- }
- }
- if [catch {set test $T($t,dbl,$i)} res] {} else {
- if { $T($t,dbl,$i) >= $S(-treshold) } {
- eval {$w create text} \
- {$x $y} \
- {-text $T($t,dbl,$i) -fill $S(-color) \
- -font $S(-font) -anchor $anchor -tags "T$t DBL"}
- }
- }
- }
- }
- }
- }
- }
- "x:" {
- if {$S(-treshold) == "all"} {
- set l [lrange $T($t,all_cod) 1 end]
- if {$S(-leaf) == 0} {set l [Tools::SousL $l $T($t,ue_cod)]}
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- switch -- $S(-where) {
- nw {
- # gauche haut
- set x [expr [lindex $co 2] + 2]
- set y [lindex $co 1]
- set anchor sw ; set justify left
- }
- sw {
- # gauche bas
- set x [expr [lindex $co 2] + 2]
- set y [expr [lindex $co 1] + 2]
- set anchor nw ; set justify left
- }
- ne {
- # droite haut
- set x [lindex $co 0]
- set y [lindex $co 1]
- set anchor se ; set justify right
- }
- se {
- # doite bas
- set x [lindex $co 0]
- set y [expr [lindex $co 1] + 2]
- set anchor ne ; set justify right
- }
- n {
- # centre haut
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [lindex $co 1]
- set anchor s ; set justify center
- }
- s {
- # centre bas
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [expr [lindex $co 1] + 2]
- set anchor n ; set justify center
- }
- e {
- # special
- set x [expr [lindex $co 0] +2]
- set y [expr [lindex $co 1] +1]
- set anchor w ; set justify left
- }
- }
- if [catch {set test $T($t,dbv,$i)} res] {} else {
- eval {$w create text} \
- {$x $y} \
- {-text $T($t,dbv,$i) -fill $S(-color) \
- -font $S(-font) -anchor $anchor -tags "T$t DBL"}
- }
- }
- }
- }
- } else {
- set l [lrange $T($t,all_cod) 1 end]
- if {$S(-leaf) == 0} {set l [Tools::SousL $l $T($t,ue_cod)]}
- foreach i $l {
- if {[$w itemcget $i -state] != "hidden"} {
- set co [$w coords $i]
- if {$co != ""} {
- switch -- $S(-where) {
- nw {
- # gauche haut
- set x [expr [lindex $co 2] + 2]
- set y [lindex $co 1]
- set anchor sw ; set justify left
- }
- sw {
- # gauche bas
- set x [expr [lindex $co 2] + 2]
- set y [expr [lindex $co 1] + 2]
- set anchor nw ; set justify left
- }
- ne {
- # droite haut
- set x [lindex $co 0]
- set y [lindex $co 1]
- set anchor se ; set justify right
- }
- se {
- # doite bas
- set x [lindex $co 0]
- set y [expr [lindex $co 1] + 2]
- set anchor ne ; set justify right
- }
- n {
- # centre haut
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [lindex $co 1]
- set anchor s ; set justify center
- }
- s {
- # centre bas
- set x [expr abs([lindex $co 0] + (([lindex $co 2] - [lindex $co 0]) / 2.0) ) ]
- set y [expr [lindex $co 1] + 2]
- set anchor n ; set justify center
- }
- e {
- # special
- set x [expr [lindex $co 0] +2]
- set y [expr [lindex $co 1] +1]
- set anchor w ; set justify left
- }
- }
- if [catch {set test $T($t,dbv,$i)} res] {} else {
- if { $T($t,dbv,$i) >= $S(-treshold) } {
- eval {$w create text} \
- {$x $y} \
- {-text $T($t,dbv,$i) -fill $S(-color) \
- -font $S(-font) -anchor $anchor -tags "T$t DBL"}
- }
- }
- }
- }
- }
- }
- }
- }
- }
-
- }
- ####################
- ####################
- # GO
- ####################
- Interface::TreeDynInitialisation
- #proc bgerror {m} {}
- global S
- #source tdopath.tcl
- #set S(ImportDIR) $S(TDOcgiDIR)
- #set S(userDIR) $S(TDOcgiDIR)
- #set S(TheoPATH) [pwd]
- set S(TheoPATH) /data/http/www/binaries/theo
- $asedCon alias db "TDcom::db"
- TDcom::com $argv
- exit
- ####################