swaptablelist
if 0 {
Description
MBS 2008-01-28 For an application that I've been developing at work, I needed some sort of disjointlistbox. The Iwidgets package offers one of these, in the form of disjointlistbox. There was also A little list selector by RS and tklib has swaplist.
None of these were quite right for what my user's were requesting.
I ended up with a combination of swaplist with tablelist.
Sorry, no docs for it at present time. I based a lot of the code on swaplist, so hopefully between the demo code and the docs for both tablelist and swaplist you should get the idea.
I'm sure that it could use some polish, so comments, improvements, etc. are welcome.
Let me know what you think... --Mark
Screenshot
Start of Code Block
}
set ::useTestDemo 1 ;# Used to enable the demo code below
set ::useTile 1 ;# Set this in the calling routine before
;# "package require Swaptablelist" if you
;# want to enable "Tile"
############################## Cut Here ##############################
if {![info exists ::useTile]} {
set ::useTile 0
}
package require Tk
if {$::useTile} {
package require tile
package require Tablelist_tile
} else {
package require Tablelist
}
package require BWidget
package require autoscroll
package provide Swaptablelist 1.0
namespace eval Swaptablelist {
variable lTbl
variable rTbl
namespace export swaptablelist
}
########################################################################
option add *Tablelist.activeStyle frame
option add *Tablelist.background gray98
option add *Tablelist.stripeBackground #e0e8f0
option add *Tablelist.setGrid yes
option add *Tablelist.movableColumns yes
option add *Tablelist.labelCommand tablelist::sortByColumn
option add *Tablelist.Font "Courier -12"
########################################################################
proc Swaptablelist::create_tablelist {fr args} {
array set options {
-height 0
-width 0
}
Swaptablelist::parseOpts options {\
{-title {}} \
{-listvariable {}} \
{-llistvar {}} {-rlistvar {}} \
{-columns {}} \
{-lcolumns {}} {-rcolumns {}} \
{-height {}} {-width {}} \
{-lwidth {}} {-rwidth {}} \
{-llabel {}} {-rlabel {}} \
{-reorder boolean} \
{-geometry {}} \
{-lbuttontext {}} {-rbuttontext {}} \
{-ubuttontext {}} {-dbuttontext {}}} \
$args
tablelist::tablelist $fr.tbl \
-columns $options(-columns) \
-listvariable $options(-listvariable) \
-editstartcommand editStartCmd \
-editendcommand editEndCmd \
-xscrollcommand "$fr.xs set" \
-yscrollcommand "$fr.ys set" \
-stretch all \
-selectmode extended \
-height $options(-height) \
-width $options(-width)
scrollbar $fr.ys -orient v -command "$fr.tbl yview"
scrollbar $fr.xs -orient h -command "$fr.tbl xview"
grid $fr.tbl -row 0 -column 0 -sticky nsew
grid $fr.ys -row 0 -column 1 -sticky ns
grid $fr.xs -row 2 -column 0 -sticky ew
grid columnconfigure $fr 0 -weight 1
grid columnconfigure $fr 1 -weight 0
grid rowconfigure $fr 0 -weight 1
grid rowconfigure $fr 1 -weight 0
update idletasks
::autoscroll::autoscroll $fr.ys
::autoscroll::autoscroll $fr.xs
return $fr.tbl
}
proc Swaptablelist::create_swap_list {w args} {
variable lTbl
variable rTbl
array set options {
-reorder 1
-lbuttontext "<<"
-rbuttontext ">>"
-ubuttontext "Move Up"
-dbuttontext "Move Down"
-lcolumns "Left"
-rcolumns "Right"
-height 0
-lwidth 0
-rwidth 0
}
Swaptablelist::parseOpts options {\
{-title {}} \
{-listvariable {}} \
{-llistvar {}} {-rlistvar {}} \
{-lcolumns {}} {-rcolumns {}} \
{-height {}} {-lwidth {}} {-rwidth {}} \
{-llabel {}} {-rlabel {}} \
{-reorder boolean} \
{-geometry {}} \
{-lbuttontext {}} {-rbuttontext {}} \
{-ubuttontext {}} {-dbuttontext {}}} \
$args
# Left hand side...
if {$::useTile} {
# set lf1 [LabelFrame $w.f1 -text $options(-llabel) -side top ]
set lf1 [ttk::labelframe $w.f1 -text $options(-llabel) -labelanchor nw]
} else {
set lf1 [labelframe $w.f1 -text $options(-llabel) -labelanchor nw]
}
# set f1 [$lf1 getframe]
set f1 $lf1
set options(-columns) [Swaptablelist::extract_column $options(-lcolumns)]
set options(-width) $options(-lwidth)
set options(-listvariable) $options(-llistvar)
set lTbl($w) [eval [list Swaptablelist::create_tablelist $f1] [array get options]]
# Right hand side...
if {$::useTile} {
# set lf2 [LabelFrame $w.f2 -text $options(-rlabel) -side top ]
set lf2 [ttk::labelframe $w.f2 -text $options(-rlabel) -labelanchor nw]
} else {
set lf2 [labelframe $w.f2 -text $options(-rlabel) -labelanchor nw]
}
# set f2 [$lf2 getframe]
set f2 $lf2
set options(-columns) [Swaptablelist::extract_column $options(-rcolumns)]
set options(-width) $options(-rwidth)
set options(-listvariable) $options(-rlistvar)
set rTbl($w) [eval [list Swaptablelist::create_tablelist $f2] [array get options]]
# left/right buttons
set flr [frame $w.lr]
set width [Swaptablelist::strmin 5 $options(-lbuttontext) $options(-rbuttontext)]
set olist [list]
if {$::useTile} {
ttk::button $flr.left -width $width -text $options(-lbuttontext) \
-command [list Swaptablelist::ShiftL $w $olist]
ttk::button $flr.right -width $width -text $options(-rbuttontext) \
-command [list Swaptablelist::ShiftR $w $olist]
} else {
button $flr.left -width $width -text $options(-lbuttontext) \
-command [list Swaptablelist::ShiftL $w $olist]
button $flr.right -width $width -text $options(-rbuttontext) \
-command [list Swaptablelist::ShiftR $w $olist]
}
grid $flr.right -pady 4
grid $flr.left -pady 4
grid columnconfigure $flr 0 -uniform 1
# up/down buttons
set width [Swaptablelist::strmin 3 $options(-ubuttontext) $options(-dbuttontext)]
set fud [frame $w.ud]
if {$::useTile} {
ttk::button $fud.up -width $width -text $options(-ubuttontext) \
-command [list Swaptablelist::ShiftUD $w u]
ttk::button $fud.down -width $width -text $options(-dbuttontext) \
-command [list Swaptablelist::ShiftUD $w d]
} else {
button $fud.up -width $width -text $options(-ubuttontext) \
-command [list Swaptablelist::ShiftUD $w u]
button $fud.down -width $width -text $options(-dbuttontext) \
-command [list Swaptablelist::ShiftUD $w d]
}
pack $fud.up -side top -pady 4
pack $fud.down -side bottom -pady 4
pack $lf1 -side left -expand yes -fill both
pack $flr -side left
pack $lf2 -side left -expand yes -fill both
pack $fud -side left
return $w
}
proc Swaptablelist::extract_column {colList} {
set retList [list]
foreach col $colList {
set clen [llength $col]
switch $clen {
3 {
set cWidth [lindex $col 0]
set cName [lindex $col 1]
set cJust [lindex $col 2]
}
2 {
set cWidth 0
set cName [lindex $col 0]
set cJust [lindex $col 1]
}
1 {
set cWidth 0
set cName $col
set cJust left
}
default {
set cWidth 0
set cName unknown
set cJust left
}
}
lappend retList $cWidth $cName $cJust
}
return $retList
}
# return the min unless string1 or string2 is longer, if so return
# length of the longer one
proc Swaptablelist::strmin {min s1 s2} {
if {[string length $s1] > $min || [string length $s2] > $min} {
return [expr {
([string length $s1] > [string length $s2]) \
? [string length $s1] \
: [string length $s2]
}]
} else {
return $min
}
}
proc Swaptablelist::parseOpts {var opts input} {
upvar $var output
for {set i 0} {$i < [llength $input]} {incr i} {
for {set a 0} {$a < [llength $opts]} {incr a} {
if {[lindex $opts $a 0] == [lindex $input $i]} { break }
}
if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" }
set opt [lindex $opts $a]
if {[llength $opt] > 1} {
foreach {opt type} $opt {break}
if {[incr i] >= [llength $input]} { error "$opt requires an argument" }
if {$type != "" && ![string is $type -strict [lindex $input $i]]} {
error "$opt requires argument of type $type"
}
set output($opt) [lindex $input $i]
} else {
set output($opt) {}
}
}
}
#------------------------------------------------------------------------------
proc editStartCmd {tbl row col text} {
set w [$tbl editwinpath]
return $text
}
#------------------------------------------------------------------------------
proc editEndCmd {tbl row col text} {
return $text
}
#------------------------------------------------------------------------------
proc Swaptablelist::ShiftR {w lst} {
variable lTbl
variable rTbl
foreach sel [$lTbl($w) curselection] {
set rList [list]
for {set colNo 0} {$colNo < [$rTbl($w) columncount]} {incr colNo} {
set lNdx [$lTbl($w) columnindex [$rTbl($w) columncget $colNo -name]]
lappend rList $colNo [$lTbl($w) cellcget $sel,$lNdx -text]
}
Swaptablelist::insertR $w $rList
}
}
proc Swaptablelist::insertR {w lst} {
variable rTbl
set tbLen [llength [$rTbl($w) getkeys 0 end]]
if {$tbLen == 0} {
set nLst [list]
foreach {cNum valL} $lst {
lappend nLst $valL
}
$rTbl($w) insert end $nLst
} else {
set found 0
foreach k [$rTbl($w) getkeys 0 end] {
set ndiff 0
foreach {cNum valL} $lst {
set valT [$rTbl($w) cellcget $k,$cNum -text]
if {$valT ne $valL} {
incr ndiff
}
}
if {$ndiff == 0} {
set found 1
break
}
}
if {$found == 0} {
set nLst [list]
foreach {cNum valL} $lst {
lappend nLst $valL
}
$rTbl($w) insert end $nLst
}
}
}
proc Swaptablelist::insert {tbl lst} {
set tblCols [$tbl columncount]
foreach item $lst {
if {[llength $item] <= $tblCols} {
$tbl insert end $item
} else {
set nLst [list]
foreach it $item {
lappend nLst $it
}
while {[llength $nLst] < $tblCols} {
lappend nLst " "
}
foreach it $nLst {
$tbl insert end $it
}
}
}
}
proc Swaptablelist::ShiftL {w lst} {
variable rTbl
$rTbl($w) delete [$rTbl($w) curselection]
Swaptablelist::renumberWhenIdle $rTbl($w)
}
proc Swaptablelist::ShiftUD {w dir} {
variable rTbl
if {[set sel [$rTbl($w) curselection]] == ""} { return }
set list {}
# delete in reverse order so shifting indexes dont bite us
foreach x [Swaptablelist::lreverse $sel] {
# make a list in correct order with the items index and contents
set list [linsert $list 0 [list $x [$rTbl($w) get $x]]]
$rTbl($w) delete $x
}
if {$dir == "u"} {
set n 0
foreach x $list {
set i [lindex $x 0]
if {[incr i -1] < $n} {set i $n}
$rTbl($w) insert $i [lindex $x 1]
$rTbl($w) selection set $i
incr n
}
$rTbl($w) see [expr {[lindex $list 0 0] - 1}]
}
if {$dir == "d"} {
set n [$rTbl($w) index end]
foreach x $list {
set i [lindex $x 0]
if {[incr i] > $n} {set i $n}
$rTbl($w) insert $i [lindex $x 1]
$rTbl($w) selection set $i
incr n
}
$rTbl($w) see $i
}
}
proc Swaptablelist::getLTable {swl} {
variable lTbl
return $Swaptablelist::lTbl($swl)
}
proc Swaptablelist::getRTable {swl} {
variable rTbl
return $Swaptablelist::rTbl($swl)
}
proc Swaptablelist::renumberWhenIdle tbl {
if {[$tbl attrib afterId] eq ""} {
$tbl attrib afterId [after idle [list Swaptablelist::renumber $tbl]]
}
}
proc Swaptablelist::renumber {tbl} {
$tbl attrib afterId ""
set itemList [$tbl get 0 end]
set nCol [$tbl columncount]
$tbl delete 0 end
foreach item $itemList {
set rList [list]
for {set colNo 0} {$colNo < $nCol} {incr colNo} {
lappend rList [lindex $item $colNo]
}
$tbl insert end $rList
}
}
# return a list in reversed order
proc Swaptablelist::lreverse {list} {
set new {}
foreach x $list {set new [linsert $new 0 $x]}
return $new
}if 0 {
Test Code
Here is some test code
}
########################################################################
#
# test ...
#
########################################################################
if {$::useTestDemo} {
set ::useTile 1
package require Tk
package require BWidget
package require Swaptablelist 1.0
proc main { } {
interface
set_Theme xpnative
}
proc set_Theme { th } {
if {$::tcl_version <= 8.4} {
tile::setTheme $th
} else {
ttk::style theme use $th
}
}
proc interface { } {
set w .
wm withdraw $w
wm title $w "Test swapTableList"
wm protocol $w WM_DELETE_WINDOW exit
set descmenu {
"&File" all file 0 {
{command "Show Local" {} "Show local list" {} -command show_local}
{separator}
{command "E&xit" {} "Exit program" {} -command exit}
}
"&Theme" all theme 0 {
{radiobutton "Default" {} "default" {} -command {set_Theme default}}
{radiobutton "Classic" {} "classic" {} -command {set_Theme classic}}
{radiobutton "Clam" {} "clam" {} -command {set_Theme clam}}
{radiobutton "Step" {} "step" {} -command {set_Theme step}}
{radiobutton "alt" {} "alt" {} -command {set_Theme alt}}
{radiobutton "winnative" {} "Win native" {} -command {set_Theme winnative}}
{radiobutton "xpnative" {} "XP native" {} -command {set_Theme xpnative}}
}
}
set mainframe [MainFrame .mainframe \
-menu $descmenu \
-textvariable ::glob_var(status) \
-progressvar ::glob_var(progressvar) \
-progressmax 100 \
-progresstype normal \
-progressfg blue ]
$mainframe showstatusbar status
$mainframe addindicator -text "version 0.0"
set mf [$mainframe getframe]
build_swtl $mf
pack $mainframe -fill both -expand yes
update idletasks
set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
wm geometry $w +$x+$y
raise $w
wm deiconify $w
}
proc build_swtl { fr } {
set ::glob_var(list,displayed) 0
set ::glob_var(masterList) [list ]
set ::glob_var(local) [list ]
set ::glob_var(masterList) {
{1 MP1 "one"}
{2 MP2 "two"}
{3 MP3 "three"}
{4 MP4 "four"}
{5 MP5 "five"}
{6 MP6 "six"}
{7 MP7 "seven"}
{8 MP8 "eight"}
{9 MP9 "nine"}
{10 MP10 "ten"}
}
array set ::options {
-title "Testing swapTablelist"
-llabel "Master List"
-rlabel "Local List"
-lcolumns {
{5 "Index" center }
{15 "MissionPoint ID" left }
{40 "Description" left }
}
-rcolumns {
{5 "Index" center }
{15 "MissionPoint ID" left }
}
-height 20
-lwidth 0
-rwidth 0
-llistvar ::glob_var(masterList)
-rlistvar ::glob_var(localList)
}
set f2 [frame $fr.f2]
set ::swl [eval [list Swaptablelist::create_swap_list $f2] [array get ::options]]
pack $f2
set tbl [Swaptablelist::getLTable $::swl]
$tbl columnconfigure 0 -name col_index -editable no -sortmode integer
$tbl columnconfigure 1 -name col_mpID -editable no -sortmode dictionary
$tbl columnconfigure 2 -name col_desc -editable no -sortmode dictionary
set tbl [Swaptablelist::getRTable $::swl]
$tbl columnconfigure 0 -name col_index -editable no -sortmode integer
$tbl columnconfigure 1 -name col_mpID -editable no -sortmode dictionary
}
proc show_local { } {
puts "Local list : "
puts $::glob_var(localList)
}
proc fill { } {
# Old code : Not used in the demo any more, but I left
# it in "just in case"...
if {$::glob_var(list,displayed)} {
return
}
set tbl [Swaptablelist::getLTable $::swl]
set mpList {
{1 MP1 "one"}
{2 MP2 "two"}
{3 MP3 "three"}
{4 MP4 "four"}
{5 MP5 "five"}
{6 MP6 "six"}
{7 MP7 "seven"}
{8 MP8 "eight"}
{9 MP9 "nine"}
{10 MP10 "ten"}
}
Swaptablelist::insert $tbl $mpList
set ::glob_var(list,displayed) 1
}
main}
AF - 2009-07-28 17:28:51
Looks good, please consider submitting a patch for inclusion into the tcllib swaplist module.