Emulate lset for older TCL edit
lset was introduced with TCL/Tk 8.4.0 and extended to append one element with TCL/Tk 8.6.0. This page proposes solutions to emulate the new command by a compatibility script.Emulate lset fully for pre TCL 8.4
Originated by Tom Wilkason on comp.lang.tcl. Modifications by DGP. if {[package vcompare [package provide Tcl] 8.4] < 0} {
proc tcl::K {a b} {return $a}
proc lset {listName index val} {
upvar $listName list
set list [lreplace [tcl::K $list [set list {}]] $index $index $val]
}
} ;# end ifKPV Does anybody have a version that works with multiple indices? (yes, see KMG 2005-Sep-03 entry below)MG Nov 12 2004 - Does this work?
proc lset2 {listName args} {
if { [llength $args] == "0" } {
error "wrong # args: should be \"lset2 listVar index ?index...? value\""
}
upvar $listName list
if { [llength $args] == "1" || ([llength $args] == "2" && [llength [lindex $args 0]] == "0") } {
set list [lindex $args [expr {[llength $args]=="1"?0:1}]]
return $list;
}
set val [lindex $args end]
foreach x [lrange $args 0 end-1] {
set list [lreplace $list $x $x $val]
}
return $list;
}[LIO] I couldn't seem to get the above to work correctly. I wrote a recursive version, the only difference to the actual lset (that I can think of) is it will not take the indeces as a single list (although it would be easy to add that in). if {[package vcompare [package provide Tcl] 8.4] < 0} {
proc tcl::K {a b} {return $a}
proc lset_r {list args val} {
if { [llength $args] == "0" } {
return $val
} else {
return [lreplace $list [lindex $args 0] [lindex $args 0] [lset_r [lindex $list [lindex $args 0]] [lrange $args 1 end] $val]]
}
}
proc lset {listName args} {
if { [llength $args] == "0" } {
error "wrong # args: should be \"lset varName ?index...? newValue\""
}
upvar $listName list
set list [lset_r [tcl::K $list [set list {}]] [lrange $args 0 end-1] [lindex $args end]]
}
}TP 2005-01-12 I wrote this version a while back to use in Jacl. It probably could be optimized with the K tricks. Nor am I sure that it's fully compatible with the current 8.4 native lset. proc lset { varName args } {
upvar 1 $varName list
switch [llength $args] {
0 {
error \
"wrong # args: should be \"lset listVar index ?index...? value\""
}
1 {
set list [lindex $args 0]
return $list
}
2 {
set index [lindex $args 0]
if {[llength $index] > 1} {
set value [lindex $args end]
set list [eval lset list $index [list $value]]
return $list
} else {
if {[regexp end $index]} {
set index \
[expr ([llength $list]-1) [string range $index 3 end]]
}
if {$index < 0 || $index >= [llength $list]} {
error "list index out of range"
}
set value [lindex $args end]
set list [lreplace $list $index $index $value]
return $list
}
}
default {
set index [lindex $args 0]
if {[regexp end $index]} {
set index [expr ([llength $list]-1) [string range $index 3 end]]
}
set rest [lrange $args 1 end-1]
set value [lindex $args end]
set sublist [lindex $list $index]
set first [lrange $list 0 [expr {$index - 1}]]
set last [lrange $list [expr {$index + 1}] end]
set list $first
lappend list [eval lset sublist $rest [list $value]]
foreach l $last {
lappend list $l
}
return $list
}
}
}RS 2005-02-20 hacked up this recursive multiple-index version for the iPaq (Keuchel's port was 8.4a2, no lset yet):
proc lset {_list args} {
upvar 1 $_list list
set indices [lrange $args 0 end-1]
if {[llength $indices]==1} {set indices [lindex $indices 0]} ;# list case
set list [lset0 $list $indices [lindex $args end]]
}
proc lset0 {list indices val} {
if {[llength $indices]==0} {return $val}
set p [lindex $indices 0]
set list2 [lindex $list $p]
set ind2 [lrange $indices 1 end]
lreplace $list $p $p [lset0 $list2 $ind2 $val]
}
#-- Test with indices in a list, or in pieces:
% set x {{a b} {c d}}
{a b} {c d}
% lset x 0 1 e
{a e} {c d}
% lset x {0 1} f
{a f} {c d}KMG 2005-Sep-03 wrote this recursive multiple-index version to help backport sugar to 8.3. (I was too eager to solve the problem to remember to check here for an existing solution first!). This implementation passes all of the reference test cases on the 8.4 help page for 'lset'.
proc lset { varName args } {
upvar 1 $varName theList
set theValue [lindex $args end]
switch -exact [llength $args] {
0 {
# lset v (do nothing)
}
1 {
# lset v x (copy x to v)
set theList $theValue
}
2 {
# lset v i x (set the i'th element of v to x)
# lset v {} x (set v to x)
# lset v {i j k} x (set the k'th element of the j'th element of the i'th element of v to x)
set indexList [lindex $args 0]
set index [lindex $indexList 0]
set theLength [llength $theList]
switch -exact [llength $indexList] {
0 {
# lset v {} x (set v to x)
set theList $theValue
}
1 {
# lset v i x (set the i'th element of v to x)
if { [string is integer -strict $index] && ($index >= $theLength) } {
error "list index out of range: $index >= $theLength"
}
set theList [lreplace $theList $index $index $theValue]
}
default {
# lset v {i j k} x (set the k'th element of the j'th element of the i'th element of v to x)
set subList [lindex $theList $index]
set subList [lset subList [lrange $indexList 1 end] $theValue]
set theList [lreplace $theList $index $index $subList]
}
}
}
default {
# lset v i j k x (set the k'th element of the j'th element of the i'th element of v to x)
set indexList [lrange $args 0 end-1]
set theList [lset theList $indexList $theValue]
}
}
return $theList
}kruzalex modified version of lset written by KMG and add replace feature. See example code below:(Lars H, 2008-07-25: Something bad seems to have happened to the indentation below, but there was no better-looking version in the page history. Added ====== delimiters to improve it somewhat.)
proc interleaveEmptyBrackets {list} {
set res ""
set tok ""
set i 0
while {[llength [split $list {}]]!=$i} {
switch -exact -- [string index $list $i] {
"\{" {
append toke $tok
set tok "\{"
}
"\}" {
if {[string equal $tok \{]} {
set tok ""
} else {
set toke [string trimright $toke]
append toke "\}"
if {[string first " " [join [split [string trimleft $toke " "]] " \" \" "]] > -1} {
append res $toke
} else {
if {([string equal $toke \{] || [string equal $toke \}])} {
append res $toke
} else {
set temp [string range $toke 0 [string last \{ $toke]]
set toke [string range $toke [expr [string last \{ $toke]+1] [expr [string first \} $toke]-1]]
append res $temp $toke
}
}
set tok ""
set toke ""
}
}
{ } {
if {![string equal [string index [join [split $toke] " \" \" "] end] " "]} {
append toke " "
}
}
\[ -
\] -
"\t" -
"\n" -
"\"" -
\; -
\{ -
\} -
\$ -
( -
) -
"\\" -
default {
append toke $tok [string index $list $i]
set tok ""
if {[expr [string length $list] - 1] == $i} {
set res $toke
}
}
}
incr i
}
set res
}
proc lset { varName args } {
upvar 1 $varName theList
set theValue [lindex $args end]
switch -exact [llength $args] {
0 {
# lset v (do nothing)
}
1 {
# lset v x (copy x to v)
if {[llength $args]==1 && [llength $theList]>1} {
set index [lindex [lindex $args 0] 0]
set theList [lreplace $theList $index $index {}]
return [interleaveEmptyBrackets $theList]
} else {
set theList $theValue
}
}
2 {
# lset v i (replace the i'th element with nothing)
# lset v i x (set the i'th element of v to x)
# lset v {} x (set v to x)
# lset v {i j k} x (set the k'th element of the j'th element of the i'th element of v to x)
set indexList [lindex $args 0]
set index [lindex $indexList 0]
set theLength [llength $theList]
switch -exact [llength $indexList] {
0 {
# lset v {} x (set v to x)
set theList $theValue
}
1 {
# lset v i x (set the i'th element of v to x)
#puts "theList_begin: $theList"
if {![string is integer -strict [lindex $args end]]} {
if { [string is integer -strict $index] && ($index >= $theLength) } {
error "list index out of range: $index >= $theLength"
}
set theList [lreplace $theList $index $index $theValue]
} else {
if {[info level]==1} {
set theList [lreplace $theList $index $index [lreplace [lindex $theList $index] [lindex $args 1] [lindex $args 1] {}]]
return [lreplace $theList $index $index [lreplace [lindex $theList $index] [lindex $args 1] [lindex $args 1]]]
} else {
set theList [lreplace $theList $index $index [lreplace [lindex $theList $index] [lindex $args 1] [lindex $args 1] {}]]
}
}
}
default {
# lset v {i j k} x (set the k'th element of the j'th element of the i'th element of v to x)
set subList [lindex $theList $index]
set subList [lset subList [lrange $indexList 1 end] $theValue]
set theList [lreplace $theList $index $index $subList]
}
}
}
default {
# lset v i j k x (set the k'th element of the j'th element of the i'th element of v to x)
set indexList [lrange $args 0 end-1]
set theList [lset theList $indexList $theValue]
return [interleaveEmptyBrackets $theList]
}
}
set theList
}
#Testing
set v1 {a b c}
set v2 [list {a b c} {d e f} {g h i}]
set v3 {{{a b} {c d}} {{e {}} {g h}} {{i j} {k l}}}
set v4 {{{a b} {c d}} {{e {a b}} {g h}} {{i j} {k l}}}
puts [lset v1 1]
puts "v1: $v1"
puts [lset v1 1 b]
puts "v1: $v1"
puts [lset v2 1 0]
puts "v2: $v2"
puts [lset v2 1 0 j]
puts "v2: $v2"
puts [lset v3 1 0 1]
puts "v3: $v3"
puts [lset v3 1 0 1 j]
puts "v3: $v3"Emulate append feature for pre Tcl 8.6
HaO 2016-07-01: With TIP #331 for Tcl 8.6, lset may add to lists:% set l {1 {1 2}}
1 {1 2}
% lset l 1 end+1 3
% set l
1 {1 2 3}Only this feature may be added to the Tcl 8.5 version of lset by the following script: (I implemented this for Tcl8.5.7 (eTCL for Windows CE)) (this might work for Tcl 8.4 which is untested by me)if { [package vsatisfies [info patchlevel] 8.5-8.6] } {
rename lset lset_ori
proc lset {listname args} {
upvar 1 $listname list
# > Decode listified or not listified arguments
if {2 == [llength $args]} {
lassign $args indexlist newvalue
} else {
set newvalue [lindex $args end]
set indexlist [lrange $args 0 end-1]
}
if {0 < [llength $indexlist]} {
# > Check end index
set endindex [lindex $indexlist end]
set indexpath [lrange $indexlist 0 end-1]
set sublist [lindex $list {*}$indexpath]
# substitute end in endindex
set endindex [string map [list end [expr {[llength $sublist]-1}]]\
$endindex]
# evaluate any "+"
set endindex [expr $endindex]
if {$endindex == [llength $sublist]} {
lappend sublist $newvalue
lset list $indexpath $sublist
return $list
}
}
return [lset_ori list {*}$args]
}
}See Also: lindex forward compatibility
