OUTPUT BUFFER:
proc InitMapping {} { set Lignes "I white magenta J white magenta L white magenta M white magenta V white magenta R white blue K white blue F white red Y white red W white red D white forestgreen B white forestgreen E white forestgreen Z black green Q black green P white black G black orange H black cyan N black cyan S white darkviolet T white darkviolet A white darkviolet U white darkviolet C white darkviolet X black dimgrey . black dimgrey 0 black white 1 black white 2 black white 3 black white 4 black white 5 black white 6 black white 7 black white 8 black white 9 black white Space white white" set Lmap [list] foreach l [split $Lignes \n] { lassign [split [string trim $l] " "] n f b if {$n eq "Space"} {set n " "} lappend Lmap [list $n $f $b] } return $Lmap } proc PasteSeq {} { global CacheSeqs LNtmp SeqSel LStmp if {[llength $CacheSeqs] == 0} {return} if {[llength $SeqSel] != 1} { return } $::WBio paste $SeqSel set i $SeqSel foreach n $CacheSeqs { set LNtmp [linsert $LNtmp $i+1 $n] incr i } $::WTxt configure -state normal $::WTxt delete 1.0 end $::WTxt insert end [join $LNtmp \n] $::WTxt configure -state disabled set CacheSeqs {} return } proc CutSeq {} { global SeqSel CacheSeqs LNtmp if {$SeqSel == {} } {return} if {[$::WTxt tag ranges Group] != {}} { tk_dialog .akg "Please press OK" "Ungroup sequences before cutting !" {} 0 Acknowledge catch {destroy .akg} update return } set CacheSeqs {} set SeqSel [lsort -unique -integer -decreasing $SeqSel] foreach i $SeqSel { lappend CacheSeqs [lindex $LNtmp $i] set LNtmp [lreplace $LNtmp $i $i] } set CacheSeqs [lreverse $CacheSeqs] $::WTxt configure -state normal $::WTxt tag remove Sel 1.0 end $::WTxt delete 1.0 end $::WTxt insert end [join $LNtmp \n] $::WTxt configure -state normal $::WBio configure -state normal $::WBio cut $SeqSel $::WBio configure -state disabled set SeqSel {} return } proc AffichePosGenSeq {{pos ""}} { # return conditions update idletasks set w $::WBio lassign [split [$w index $pos] .] y x if {! [string is integer -strict $y]} {return} set ::XGen [expr {$x+1}] set ::XSeq [string length [string map {"." ""} [string range [$w output [expr {$y-1}]] 0 $x]]] return } proc BindTextSpace {{NoGroup ""}} { set idx [$::WBio cursor] lassign [split $idx .] y x set y [expr {$y-1}] set seqass [lindex $::LNtmp $y] if {$seqass eq ""} {return} set nf [tk::biotext::bufferNTimes empty] if {$NoGroup eq ""} { $::WBio chars "." $idx $nf } else { $::WBio chars -nogroup "." $idx $nf } update idletasks return } proc SelectSeq {what pos} { global SeqSel # record selected seq as indexes in the sequences list set pos [$::WTxt index $pos] lassign [split $pos .] yt xt set y [expr {$yt-1}] $::WTxt configure -state normal $::WTxt tag remove Sel 1.0 end switch $what { "une" { set SeqSel $y } "ctr" { if {$SeqSel == {}} { set SeqSel $y } else { if {[set idx [lsearch -exact -integer $SeqSel $y]] != -1} { set SeqSel [lreplace $SeqSel $idx $idx] } else { lappend SeqSel $y } } } "shf" { if {$SeqSel == {} } { set SeqSel $y } else { set last [lindex $SeqSel end] if {$last > $y} { set from $y ; set to $last } else { set from $last ; set to $y } for {set i $from} {$i <= $to} {incr i} { lappend SeqSel $i } } } } set Ltags [list] foreach i $SeqSel { set y [expr {$i+1}] lappend Ltags $y.0 "$y.0 lineend" } $::WTxt tag add Sel {*}$Ltags $::WTxt configure -state disabled return } proc UngroupSeq {} { set Lidx {} foreach {d f} [$::WTxt tag ranges Group] { lassign [split $d .] y x lappend Lidx [expr {$y - 1}] } if {$Lidx != {} } { $::WBio ungroup $Lidx $::WTxt tag remove Group 1.0 end } return } proc GroupSeq {} { if {$::SeqSel == {} } {return} $::WTxt configure -state normal $::WTxt tag remove Sel 1.0 end set Ltags {} foreach i $::SeqSel { set y [expr {$i+1}] lappend Ltags $y.0 "$y.0 lineend" } $::WTxt tag remove Sel 1.0 end $::WTxt tag add Group {*}$Ltags $::WBio group 0 $::SeqSel set ::SeqSel {} $::WTxt configure -state disabled return } proc CoupleY {args} { $::WTxt yview {*}$args $::WBio yview {*}$args return } package require Tk package require biotext source ../biotext.tcl source /home/moumou/ordali/src/ordali_sequence.tcl source /home/moumou/ordali/src/gscope_outils.tcl if {[lindex $argv 0] ne ""} { DecortiqueUnTFA [lindex $argv 0] LNtmp TSeq foreach n $LNtmp { lappend LStmp $TSeq($n) } } else { # Create random data set a ".A.CDEFGH.I.KLMN.PQRST.VW.Y.A.CDEFGH.I.KLMN.PQRST.VW.Y..........." set la [string length $a] set nlines 300 set len 2000 set LStmp [list] set LNtmp [list] for {set i 0} {$i < $nlines} {incr i} { lappend LNtmp "s[format %03d [expr {$i+1}]]" set s "" for {set j 0} {$j < $len} {incr j} { set x [expr {int($la*rand())}] append s [string index $a $x] } lappend LStmp $s } set LStmp "..ACD.EFG.IHPP.ACD.EFG.IH." lappend LStmp ".LPCD.EMGRIHI.LPCD.EMGRIKI" lappend LStmp "..GCD.EYG.IH...GCD.EYG.IH." lappend LStmp "..TCN.EFG.IH.KG.CN.EFG.IR." set LNtmp [list s01 s02 s03 s04] } ### GUI set WBio .f.b set WTxt .f.pw.t set WSh .f.sh set WSv .f.sv grid columnconfig . 0 -weight 1 grid rowconfig . 0 -weight 1 . configure -bg black # frame globale frame .f -bg black grid .f -row 0 -column 0 -sticky news grid columnconfig .f 1 -weight 1 grid rowconfig .f 0 -weight 1 ttk::panedwindow .f.pw \ -orient horizontal text $WTxt \ -bd 0 \ -wrap none \ -yscrollcommand "$WSv set " \ -width 10 \ -foreground white \ -background black \ -height 4 \ -font "Courier 34 normal" #frame .f.pw.f #grid columnconfig .f.pw.f 0 -weight 1 #grid rowconfig .f.pw.f 0 -weight 1 biotext $WBio \ -bd 0 \ -yscrollcommand "$WSv set" \ -xscrollcommand "$WSh set" \ -width 10 \ -height 4 \ -class Biotext scrollbar $WSv \ -command CoupleY #grid $WBio -row 0 -column 0 -sticky news #grid $WSv -row 0 -column 1 -sticky ns .f.pw add $WTxt -weight 0 .f.pw add $WBio -weight 1 scrollbar $WSh \ -orient horiz \ -command "$::WBio xview " frame .f.fbut -bg black grid columnconfig .f.fbut 0 -weight 1 set XSeq "" ; set XGen "" frame .f.fbut.fpos \ -relief sunken \ -background black label .f.fbut.fpos.tposg \ -text " gen " \ -relief flat \ -width 5 \ -anchor w \ -bg black -fg white label .f.fbut.fpos.vposg \ -textvariable XGen \ -relief flat \ -width 4 \ -anchor e \ -bg black -fg white label .f.fbut.fpos.tposs \ -text " seq " \ -relief flat \ -width 5 \ -anchor w \ -bg black -fg white label .f.fbut.fpos.vposs \ -textvariable XSeq \ -relief flat \ -width 4 \ -anchor e \ -bg black -fg white grid .f.fbut.fpos.tposg -row 0 -column 0 -padx 0 grid .f.fbut.fpos.vposg -row 0 -column 1 -padx 0 grid .f.fbut.fpos.tposs -row 0 -column 2 -padx 0 grid .f.fbut.fpos.vposs -row 0 -column 3 -padx 0 button .f.fbut.bgr \ -text " Group " \ -bg cyan -fg black \ -command GroupSeq button .f.fbut.bug \ -text " Ungroup " \ -bg cyan -fg black \ -command UngroupSeq frame .f.fgh grid .f.pw -row 0 -column 0 -columnspan 2 -sticky news grid $WSv -row 0 -column 2 -sticky ns grid $WSh -row 1 -column 1 -sticky ew grid .f.fgh -row 1 -column 0 -sticky ew grid .f.fbut -row 2 -column 0 -columnspan 3 -sticky ew grid .f.fbut.fpos -row 0 -column 0 -sticky w grid .f.fbut.bgr -row 0 -column 1 -sticky e -padx 5 -pady 5 grid .f.fbut.bug -row 0 -column 2 -sticky e -padx 5 -pady 5 update idletasks proc ResizeScr {} { update idletasks set wdt [winfo width $::WTxt] puts "wdt $wdt" .f.fgh configure -width $wdt update idletasks puts "new fgb [winfo width .f.fgh] sh [winfo width $::WSh]" return } ResizeScr bind $WTxt