Command Suites  edit

aqtools

ExtraL

fptools

lcompare, lempty?, lmultirange, lreduce, lsample, lshift!, match (for pattern matching on lists) and others.

Jumble Library for Tcl and Friends, by Stefan Hornburg

shift, pop, append, assign, match

Listx

Provides the essential extended set of list operations. Today, most are in Tcl itself.

Listex, by Stuart Cassoff

lPluck, lDivide, lDivideAtStr, lUInterleave, lMaxelementLength.

mtcl

(HaO 2010-08-24: dead link for me)

Pool

Pool_Base

tcllib's struct::list

TclX

Search the documentation for LIST MANIPULATION COMMANDS.

underscore.tcl

ycl::list

provides commands such as dedent, any, all, are, filter, pick, sl, and which.

Modification Commands  edit

lpop

lremove

lshift -Adding Unique Items to Lists of Fixed Length

Query Commands  edit

another list comprehension

Finding a sublist

lazy lists

List Comprehension

list map and list grep

two operations implemented (over-)simply in Tcl.

lswitch

Like switch, but each pattern is a list of patterns to match against the item in string at the corresponding position. All switch options are supported.

range, by Salvatore Sanfilippo

Python-like range operation.

Recursive list searching

Striding a list

Traversal Commands  edit

Use while to iterate over a list

Reording Commands  edit

randomizing a list

Shuffle a list

Shuffle a list: graph results

Shuffling a list

Sorted Lists

Rotate a list

Transformation Commands  edit

Concatenating lists

list stripping

List trim

lsplit

creates two lists from a single list and a test expression

MakeRanges

Takes a list of numbers and makes them into a a list of number ranges.

nested list join

permutations

Power set of a list

split and join for nested lists

Using expr on lists

Summing a list

Unique Element List

lolcat

Process a list into another list that contains more values than the original list.

Reporting Commands  edit

AsserTcl

Supports quantifier commands to test whether an expressions holds universally or existentially over a data structure such as a list or array aggreggate data structure.

Cartesian product of a list of lists

Counting Elements in a List

Depth of a list

diff in Tcl

longest common subsequence

key list printing procedures

pretty prints Tclx's key lists.

ldiff

Find the difference of two lists.

lexpr

list level

listcomp -Compare the Contents of two Lists

plist

is for lists what parray is for arrays.

List-Based Data Structures  edit

Binary trees

Bit vectors

Can nicely be implemented with lists.

Complex data structures for struct

Named access to list positions.

Decision trees

keyed list

linked lists

nxs

Nested heterogeneous data structures.

set operations for Tcl lists

Stacks and queues

trees as nested lists

yet another stack package

See Also  edit

Chart of existing list functionality

Chart of proposed list functionality

internal organization of the list extension

list

Contains (pointers to other Tcl specific list related commands.

Showing sublists

In a listbox.

• Go through extensions listed above and collect all of their functionality in a table. Group equal and/or similar functionality together. Chart of existing list functionality
• Define the functionality we want to have in the official extension. (Or shall we skip this in favor of a take all approach ?). -- AK: No. After looking at the available functionality I believe that some parts may need a little pruning. Chart of proposed list functionality.
• Implement the functionality.

• What functionality is provided, what do we want, what is missing, or superfluous ? LV already started a wishlist, see below.
• Internal organization of the list extension, commenting style, which namespace, ...

• lassign - Assign [elements] of list to the given variables. -- AK: Already provided by some extensions. RS: ... or foreach. DKF: In the core in 8.5.
• linear sort on list of lists - Alphanumeric comparison for linear sort of lists. -- AK: ??? Lars H: Does this mean lexicographic sort? To compare elements L1 and L2, first compare their first elements [lindex $L1 0] and [lindex $L2 0]. If these are equal, compare the second elements, and so on.
• Linked list support. I (AK) had a problem here, but Larry solved it for me. Meant is stack/queue-like access to the list. Some extensions already provide this functionality: yet another stack package.
• Remove empty elements from list. -- NEW. Added to proposed list of functions.
• Given one list, create a new list consisting only of the unique elements. -- AK: Provided by some extensions. Lars H: How is this different from [lsort -unique]?
• Even better - provide list sorting capability equal or greater than Unix sort- -- NEW. AK: This will be difficult.
• tclX code to return subsets of lists, based on patterns. -- AK: Provided by some extensions, but most not as complete as TclX. (DKF: This can be done with lsearch; [lsearch -all -inline -glob $theList $theGlobPattern])
• parse a list into variables similar to the way a command line is parsed. -- AK: getopt-like, place in that extension.
• Compare two lists for equality. -- NEW. AK: Looks so innocent. What is equality ? With order ? Without ? What about duplicates ? These are several functions. Not yet in the proposed list.
• A number of people have written a variety of 'database query results' to 'list' type interfaces. I wonder if something generic could be created.
• Transpose elements within list of lists -- AK: Primitives for that already provided by some extensions.
• ulis: ldelete list-name ?index...?, remove the items in place.
• ulis: leval $list, eval without concat. DKF: In Tcl 8.5, just use [{*}$list] which is now part of the core language syntax.

proc lel {L element} {expr {[lsearch $L $element]>=0}}

package require Tcl 8.5
proc lel {L element} { expr { $element in $L } }

proc ladd {_L args} {
    upvar $_L L
    if {![info exists L]} {set L {}}
    foreach i $args {if {![lel $L $i]} {lappend L $i}}
}

proc lrandom L {lindex $L [expr {int(rand()*[llength $L])}]}

proc ldraw {_L} {
    upvar 1 $_L L
    set pos [expr {int(rand() * [llength $L])}]
    set res [lindex $L $pos]
    set L [lreplace $L $pos $pos]
    set res
}

proc lremove {_L args} {
   upvar $_L L
   foreach i $args {
       set pos [lsearch $L $i] ;# might be -1 if not found...
       set L [lreplace $L $pos $pos] ;# ... but that's fine
   }
}

proc lreverse L {
    set res {}
    set i [llength $L]
    #while {[incr i -1]>=0} {lappend res [lindex $L $i]}
    while {$i} {lappend res [lindex $L [incr i -1]]} ;# rmax
    set res
} ;# RS, tuned 10% faster by [rmax]

proc lreverse2 l {
    set ret {}
    foreach i $l {
        set ret [linsert $ret 0 $i]
    }
    return $ret
} #EAS

proc lreverse3 {l} {
    set start -1
    set end [llength $l]

    while {[incr start] < [incr end -1]} {
        set tmp [lindex $l $start]
        lset l $start [lindex $l $end]
        lset l $end $tmp
    }
    return $l
}

proc lreverse4 {l} {
    set start -1
    set end [llength $l]
    
    foreach tmp $l {
        if {[incr start] >= [incr end -1]} break
        lset l $start [lindex $l $end]
        lset l $end $tmp
    }
    return $l
}

proc lreverse5 {l} {
    set end [llength $l]
    foreach tmp $l {
        lset l [incr end -1] $tmp
    }
    return $l
}

proc lreverse6 {l} {
    set stack {}
    foreach item $l {set stack [list $stack $item]}
    set res {}
    while {[llength $stack]} {
       foreach {stack item} $stack break
       lappend res $item
    }
    return $res
}

proc multisort {indices L args} {
    set cmd "list $L"
    foreach i [lreverse $indices] {
       set cmd "lsort $args -index $i \[$cmd\]"
    }
    eval $cmd
} ;# RS

% multisort {2 0 1}  {{abe zyx 25} {john smith 14} {harold brown 99} {mary jones 32}}
{john smith 14} {abe zyx 25} {mary jones 32} {harold brown 99}
% multisort {0 2 1}  {{abe zyx 25} {john smith 14} {harold brown 99} {mary jones 32}} -decreasing
{mary jones 32} {john smith 14} {harold brown 99} {abe zyx 25}

proc lpermute L {
    if {[llength $L] < 2} {
        set res $L
    } else {
        set pos 0
        foreach i $L {
            set rest [lreplace $L $pos $pos]
            incr pos
            foreach j [lpermute $rest] {
                lappend res [concat [list $i] $j]
            }
        }
    }
    set res
} ;# RS

proc closest {value list} {
    set minElement [lindex $list 0]
    set minDist [expr {abs($value-$minElement)}]
    foreach i [lrange $list 1 end] {
       if {abs($value-$i) < $minDist} {
           set minDist [expr {abs($value-$i)}]
           set minElement $i
       }
    }
    set minElement
}
In borderline cases, it picks the first hit, though:
% closest  2.5 {1 2 3 4 5}
2

proc rangify list {
    set res {}
    set buf {}
    foreach i [lappend list {}] {
        if {$buf eq {} || $i == [lindex $buf end] + 1} {
            lappend buf $i
        } else {
            if {[llength $buf] > 2} {
                set buf [lindex $buf 0]-[lindex $buf end]
            }
            lappend res $buf
            set buf $i
        }
    }
    join $res
} ;#RS

% rangify {1 2 3 5 6 7 9 10 12 13 14 17 18 19}
1-3 5-7 9 10 12-14 17-19

proc compress list { 
    set res [lindex $list 0] 
    for {set i 1} {$i < [llength $list] - 1} {incr i} { 
       set it [lindex $list $i] 
       if {$it == [lindex $list [expr {$i-1}]] + 1 
           && $it == [lindex $list [expr {$i+1}]] - 1} { 

           lappend res - 
       } else {lappend res $it} 
   } 
   lappend res [lindex $list end] 
   regsub -all -- { - (- )*} $res - 
}

#---- For the way back:
proc expand clist { 
    set res {} 
    foreach part $clist { 
        if [regexp {([0-9-]*[0-9])-(.+)} $part -> from to] { 
            while {$from <= $to} {lappend res $from; incr from} 
        } else {lappend res $part} 
    } 
    set res 
};# RS

proc lrepeat {value number} {
    for {set i 0} {$i<$number} {incr i} {
        lappend res $value
    }
    set res
} ;# RS
% lrepeat foo 5
foo foo foo foo foo
% lrepeat [lrepeat 0 5] 5
{0 0 0 0 0} {0 0 0 0 0} {0 0 0 0 0} {0 0 0 0 0} {0 0 0 0 0}

proc lrepeat {value args} {
    if {[llength $args] == 1} {set args [lindex $args 0]}
    foreach number $args {
       incr number 0 ;# force integer (1)
       set buf {}
       for {set i 0} {$i < $number} {incr i} {
           lappend buf $value
       }
       set value $buf
    }
    set buf
}
% lrepeat  0 3 4
{0 0 0} {0 0 0} {0 0 0} {0 0 0}
% lrepeat  0 {3 4}
{0 0 0} {0 0 0} {0 0 0} {0 0 0}
% lrepeat  0 {3 4 5}
{{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}}

proc lrepeat {count value args} {
    set values [linsert $args 0 $value]
    set result {}
    for {set i 0} {$i < $count} {incr i} {
       eval [list lappend result] $values
    }
    return $result
}

proc lrepeat {count args} {
    set result {}
    set cmd [list eval [list lappend result]]
    for {set i 0} {$i < $count} {incr i} {
       lappend cmd $args
    }
    eval $cmd
}

proc lrepeat {count args} {string repeat "$args " $count}

proc lrepeat {count args} {
    set cmd [list concat]
    for {set i 0} {$i < $count} {incr i} {
       lappend cmd $args
    }
    eval $cmd
}

proc lrepeat {count args} {
    set cmd [list concat]
    incr count
    while {[incr count -1]} {
        lappend cmd $args
    }
    eval $cmd
}

% info patchlevel                 ;# 8.6.1
% time {dkf_1   123 x y z} 10000  ;# 773.3324 microseconds per iteration
% time {dkf_2   123 x y z} 10000  ;# 108.0783 microseconds per iteration
% time {amg_1   123 x y z} 10000  ;#  27.1447 microseconds per iteration
% time {amg_2   123 x y z} 10000  ;#  21.9983 microseconds per iteration
% time {lrepeat 123 x y z} 10000  ;#   3.5693 microseconds per iteration

% time {fw_1    123 x y z} 10000  ;#   2.4697 microseconds per iteration

% proc fw_2 {count args} {linsert [string repeat "$args " $count] 0}
% time {fw_2    123 x y z} 10000  ;#  60.4778 microseconds per iteration

proc lequal {a b} {
    if {[llength $a] != [llength $b]} {return 0}
    if {[lindex $a 0] == $a} {return [string equal $a $b]}
    foreach i $a j $b {if {![lequal $i $j]} {return 0}}
    return 1
} ;# RS

[list {*}$l1] eq [list {*}$l2]

set thisCase [list a c b]

set lstValid {
    {a b c}
    {a a c}
    {a b b}
    {a a a}
}

proc chkValidCombination {lstValid thisCase} {
    set valid 0
    foreach validCase $lstValid {
        set equal [lequal $validCase $thisCase]
        if {$equal} {set valid 1}
    }

    return $valid
}

puts [chkValidCombination $lstValid $thisCase]

proc keyget {list key} {
    foreach {lkey value} $list {
        if [string equal $lkey $key] {return $value}
    }
} ;# RS
% keyget {fnm John lnm Brown phone (123)456-7890 email [email protected]} phone
(123)456-7890
% keyget {fnm John lnm Brown phone (123)456-7890 email [email protected]} fax

proc linsertsorted {list newElement} {
    set pos 0
    foreach element $list {
        if {$element > $newElement} break
        incr pos
    }
    linsert $list $pos $newElement
} ;# RS -- testing:

% linsertsorted {a b c d e} f
a b c d e f
% linsertsorted {a b c d e} 0
0 a b c d e
% linsertsorted {a b c d e} aa
a aa b c d e

proc BinaryInsert {list pattern} {
    set lo -1
    set hi [llength $list]
    set test [expr {$hi / 2}]
    while {$lo != $test} {
        set res [string compare -nocase [lindex $list $test] $pattern]
        if {$res < 0} {
            set lo $test
        } elseif {$res > 0} {
            set hi $test
        } else {
            return [linsert $list $test $pattern]
        }
        set test [expr {($hi + $lo) / 2}]
    }
    return [linsert $list $hi $pattern]
}

proc lswap list {
    set res {}
    foreach {a b} $list {lappend res $b $a}
    set res
} ;# RS
% lswap {a b c d e f g h}
b a d c f e h g

proc intersect args {
    set res {}
        foreach element [lindex $args 0] {
            set found 1
            foreach list [lrange $args 1 end] {
                if {[lsearch -exact $list $element] < 0} {
                    set found 0; break
                }
            }
            if {$found} {lappend res $element}
     }
     set res
} ;# RS

proc lintersect {alist blist} {
    set res {}
    foreach a $alist {if {$a in $blist} {lappend res $a}}
    return $res
}

tcl> lintersect {a b} {a c}
a
tcl> lintersect {a a b} {a c}
a a

proc lintersect {alist blist} {
    set res {}
    foreach a $alist {if {$a in $blist && $a ni $res} {lappend res $a}}
    return $res
}

list1

The first input list

list2

The second input list

inList1

Name of the list in which to put list1 only elements

inList2

Name of the list in which to put list2 only elements

inBoth

Name of the list in which to put elements in list1 & list2

proc intersect3 {list1 list2 inList1 inList2 inBoth} {
    upvar $inList1 in1
    upvar $inList2 in2
    upvar $inBoth  inB

    set in1 [list]
    set in2 [list]
    set inB [list]

    set list1 [lsort $list1]
    set list2 [lsort $list2]

    # Shortcut for identical lists is faster
    if { $list1 == $list2 } {   
        set inB $list1
    } else {
        set i 0
        foreach element $list1 {
            if {[set p [lsearch [lrange $list2 $i end] $element]] == -1} {
                lappend in1 $element
            } else {
                if { $p > 0 } {
                    set e [expr {$i + $p -1}]
                    foreach entry [lrange $list2 $i $e] {
                        lappend in2 $entry
                    }
                    incr i $p
                }
                incr i
                lappend inB $element
            }
        }
        foreach entry [lrange $list2 $i end] {
            lappend in2 $entry
        }
    }
} ;# David Easton

proc lprepend {var args} {
    upvar 1 $var v
    set v [eval [list linsert $v 0] $args]
} ;# DKF

set myList [list 0 1 2]
set myList [lreplace $myList -1 -2 5]
#-> 5 0 1 2

proc remove.list.item {lPtr i} {
    upvar $lPtr l; set l [lreplace $l $i $i]
}

% set l [list a b c] 
a b c
% remove.list.item l 1
a c
% set l
a c

proc kvsearch {kvlist item} {
    set pos [lsearch $kvlist $item]
    if {$pos != -1} {
        lindex $kvlist [expr {$pos+1-2*($pos%2)}]
    }
} ;# RS
% kvsearch {1 one 2 two 3 three} four ;# returns empty string/list
% kvsearch {1 one 2 two 3 three} 1
one
0 % kvsearch {1 one 2 two 3 three} one
1

proc pairs set {
    set res {}
    set last [expr {[llength $set]-1}]
    for {set ia 0} {$ia < $last} {incr ia} {
        foreach b [lrange $set [expr {$ia+1}] end] {
            lappend res [list [lindex $set $ia] $b]
        }
    }
    set res
} ;# RS
% pairs {a b c d}
{a b} {a c} {a d} {b c} {b d} {c d}

proc pairs set {
    set res {}
    foreach a [lrange $set 0 end-1] {
        set set [lrange $set 1 end]
        foreach b $set {lappend res [list $a $b]}
    }
    set res
} ;# RS

proc K {a b} {set a}
##
# Pop an item off a list, left or right
#
proc lpop {how listName} {
    upvar $listName list
    switch -- $how {
        right {
            K [lindex $list end] [set list [lrange $list 0 end-1]]
        }
        left {
            K [lindex $list 0] [set list [lrange $list 1 end]]
        }
        default {
            return -code error {lpop right|left listName}
        }
    }
}
##
# Pop an item onto a list, left or right
#
proc lpush {how listName item} {
    upvar $listName list
    switch -- $how {
        right {
            lappend list $item
        }
        left {
            set list [linsert [K $list [set list {}]] 0 $item]
        }
        default {
            return -code error "lpush right|left listName item"
        }
    }
}

::struct::list flatten ?-full? ?--? sequence

% ::struct::list flatten {1 2 3 {4 5} {6 7} {{8 9}} 10}
1 2 3 4 5 6 7 {8 9} 10
% ::struct::list flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10}
1 2 3 4 5 6 7 8 9 10

% ::struct::list flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10}
1 2 3 4 5 6 7 8 9 10
% ::struct::list flatten -full {1 2 3{4 5} {6 7} {{8 9}} 10}
1 2 3\{4 5\} 6 7 8 9 10
% ::struct::list flatten -full {1 2 3 {4 5}{6 7} {{8 9}} 10}
list element in braces followed by "{6" instead of space

% concat {*}{1 2 3 {4 5} {6 7} {{8 9}} 10}
1 2 3 4 5 6 7 {8 9} 10

proc listToTable { in {padding 0} } {
    set result {}
    array set lengths {}
    # Determine the longest element in each column
    foreach line $in {
        set colnum 1
        foreach column $line {
            set length [string length $column]
            if {[info exist lengths($colnum)]} {
                if {$lengths($colnum) < $length} {
                    set lengths($colnum) $length
                }
            } else {
                set lengths($colnum) $length
            }
            incr colnum
        }
    }

    # Format the output
    foreach line $in {
        set colnum 1
        set maxcol [llength $line]
        foreach column $line {
            if {$colnum < $maxcol} {
                append result [
                    format %-*s [
                        expr {$lengths($colnum) + 1 + $padding}] $column]
            } else {
                append result $column
            }
            incr colnum
        }
        append result "\n"
    }
    return $result
}

% listToTable {a {aaaa bb cccccc} {aaaaaa bbbbbbb cc ddddddd} {a b c d}}
a
aaaa   bb      cccccc
aaaaaa bbbbbbb cc     ddddddd
a      b       c      d

set beginning [lrange $list 0 end-$size]
set end [lrange $list end-[expr {$size-1}] end]

foreach {beginning end} [lrange -split $list end-$size] {break}

%set a {one two three four five}
...
%lselect $a 0 3-4
one four five

proc lselect {list args} {
    set result {}

    foreach i $args {
        set range [split $i -]
        if { [llength $range] == 2 } {
            mset {from to} $range
            for {set n $from} {$n <= $to} {incr n} {
                lappend result [lindex $list $n]
            }
            continue
        }
        lappend result [lindex $list $i]
    }
    return $result
}

proc lsplit {ls index} {
    return [
        list [
            lrange $ls 0 [expr {$index-1}]] [
            lrange $ls $index end]]
}

proc filter {list cmd} {
    set result {}
    foreach i $list {
        lappend result [eval "$cmd {$i}"]
    }
    return $result
}

%set a { {    1 } { 2   } { 3     } }
...
%filter $a "string trim"
1 2 3

% set l {0 5 3 4 2}
0 5 3 4 2
% select $l {expr 2<}
5 3 4

proc select {list pred} {
    set result {}
    
    foreach i $list {
        if {[eval $pred [list $i]]} {lappend result $i}
    }
    return $result
}

proc select2 {list pred} {
    set result [list]

    foreach i $list {
        if {[uplevel 1 [list expr [string map [list ## $i] $pred]]]} {
            lappend result $i
        }
    }
    return $result;
}

% set list1 {a b c d e}
a b c d e
% set list2 {c d e f g}
c d e f g
% select2 $list1 {[lsearch $list2 ##]>-1}
c d e

proc select3 {var expr list} {
    upvar 1 $var item
    set res {}
    foreach item $list {
        if {[uplevel 1 [list ::expr $expr]]} then {
            lappend res $item
        }
    }
    return $res
}

% select3 s {[string is integer $s]} {0 3 x 0x3 09 35 -7 0. 000 1e3}
0 3 0x3 35 -7 000
% select3 s {$s != 0} {0 3 x 0x3 09 35 -7 0. 000 1e3}
3 x 0x3 09 35 -7 1e3

% interp alias {} nonzero {} select3 s {$s!=0}
% nonzero {0 3 x 0x3 09 35 -7 0. 000 1e3}
3 x 0x3 09 35 -7 1e3

proc filter {p xs} {
    set ys [list]
    foreach x $xs {if {[uplevel #0 $p [list $x]]} {lappend ys $x}}
    return $ys
}
# Usage:
set xs {0 3 x 0x3 09 35 -7 0. 000 1e3}
filter {string is integer} $xs
# Simple aliases:
proc let {name = args} {interp alias {} $name {} {*}$args}
let integers = filter {string is integer}
integers $xs ;# Same result

proc func {p b} {list ::apply [list $p [list expr $b]]}
filter [func x {$x != 0}] $xs

proc lrepeat {val num} {
    set res [list]
    for {set i 0} {$i < $num} {incr i} {lappend res $val}
    return $res
}

proc lassoc {list key {rowsize 2} {keyind 0} {valind 1}} {
    foreach [lreplace [lreplace [lrepeat nullvar $rowsize] \
        $keyind $keyind qkey] $valind $valind qval] $list {
        if {[string equal $qkey $key]} {return $qval}
    }
    return -code error {No match found.}
}

# English, Dutch, French
set phrases [list \
    Hi Hallo Bonjour \
    {I'll have the soup.} {Ik geef opdracht tot de soep.} \
        {J'achèterai le potage} \
    Bye {Tot ziens} {Au revoir}]
puts [lassoc $phrases Hi 3 0 2] ;# English to French

foreach-filter x {$x > 0} $list {puts "$x is positive"}

foreach x [filter $hugelist cmd] {
    if {[somecmd $x]} break
}

foreach-filter x cmd $hugelist {
    if {[somecmd x]} break
}

foreach x $lst {
    if {![predicate $x]} continue
    if {whatever} break
    we_can_do_whatever_we_want_with $x now
}

proc foreach_filter {varName lst predicate cmd} {
    uplevel 1 [list foreach $varName $lst [list if $predicate $cmd]]
}

foreach_filter x {aa bb ab ac} {[string index $x 0] == {a}} {
    puts $x
    if {$x == {ab}} break
}

aa
ab

Original is here

proc forpaths {boundVarNames paths body} {
# walk on paths, each is list of dirs. $body will execute on visit each dir,
# variables bound:
#   $keyName - current path
#   $levelName - current level (0...N)
#   $leafName - is leaf or not (1, 0)
    foreach {keyName levelName leafName} [lrange $boundVarNames 0 2] {}
    set group [dict create]
    foreach path $paths {
        dict set group {*}$path @LEAF
    }

    proc _cmp {a b} {
        if {[expr {$a > $b}]} {
            return 1
        } elseif {[expr {$a < $b}]} {
            return -1
        } else {return 0}
    }

    proc _trackpath {track level dir} {
        if {$track eq {}} {set track [list @DUMMY]}
        switch -- [_cmp [expr $level+1] [llength $track]] {
            1  {lappend track $dir
            0  {lset track end $dir}
            -1 {set track [lreplace $track $level end $dir]}
        }
        return $track
    }
    set gtrack {}; # current path when visit each node

    proc _walk {d keyName levelName leafName body {_deep 2}} {
    # here $level is level in tree, not in stack
    # $_deep is level in stack
        upvar $_deep $keyName key $levelName level
        upvar gtrack gtrack
        if {$leafName ne {}} { upvar $_deep $leafName leaf }
        dict for {k v} $d {
            set level [expr {$_deep-2}]
            set gtrack [_trackpath $gtrack $level $k]
            set key $gtrack
            if {$v eq @LEAF} {
                set leaf 1
                uplevel $_deep $body
            } else {
            # nested
                set leaf 0
                uplevel $_deep $body
                _walk $v $keyName $levelName $leafName $body [expr {$_deep+1}]
            }
        }
    }
    _walk $group $keyName $levelName $leafName $body
}

forpaths {key level leaf} $dirs {...}
# OR
forpaths {key level} $dirs {...}
# OR
forpaths key $dirs {...}

proc ldiff {a b} {
    lmap elem $a { expr {$elem in $b ? [continue] : $elem} }
}

lsort -command {apply {{a b} {expr {[string length $a] - [string length $b]}}}} $list

        --> "{10 11 12 13 14} 25 {100 101 102 103 104} {{10 11 12 13 14}} 0 1 2 3 4"

proc lprependDKF { var_name args } {
        # http://wiki.tcl.tk/43 ; # DKF
        upvar 1 $var_name local
        lappend local
        set local [eval [list linsert $local 0] $args]
}
# 24 -> 143 / 7.931

proc lprependMe1 { 1 args } {
        upvar 1 $1 var
        if ![info exists var ] { lappend var }
        set var [concat $args $var]
        return $var
}
# 42 -> 182 / 11.465

proc lprependMe2 { 1 args } {
        upvar 1 $1 var
        if ![info exists var ] { set var "" }
        set var [concat $args $var]
        return $var
}
# 40 -> 117 / 11.668

proc lprependMe3 { 1 args } {
        upvar 1 $1 var
        lappend var
        set var [concat $args $var]
}
# 17 -> 82 / 5.862 (at 1,000,000 iterations, this drops to: 5.540067 ms)

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References