Richard Suchenwirth 2002-09-03 - The lsort command allows many useful ways of sorting, but sometimes one needs other ways. For instance, to sort strings according to their length; or alphabetically, but reversed (whole dictionaries are produced for this, e.g for finding rhymes). lsort takes a -command option, but see that page for why it is "a pig in performance".
The recommended way is rather to produce from the original input a list of pairs consisting of sorting key and original element; sort using -index according to the key; and extract the original elements from the result. Here is a little wrapper for this approach, which takes as first argument a sorting function name (possibly multi-word like string length) and then the usual arguments of lsort, the last of which is the list to be sorted:
proc lsortby {sortf args} {
set list [lindex $args end] ;# list ot be sorted is last
set args [lrange $args 0 end-1]
set t {}
foreach element $list {
lappend t [list [eval $sortf [list $element]] $element]
}
set res {}
foreach i [eval lsort $args -index 0 [list $t]] {
lappend res [lindex $i 1]
}
set res
}
#----------- testing (and usage examples):
puts [lsortby {string length} -int {long longer short shorter {very long} x}]
proc reverse s {
set i [string length $s]
set res {}
while {$i} {append res [string index $s [incr i -1]]}
set res
}
puts [lsortby reverse -unique {this is the rest of the best test beast}]if 0 {results in:
x long short longer shorter {very long}
the of is this beast best rest testNike 8.12.2002
Today i needed new way of sorting, shortest first in alphabetical order.
My version:
proc nsort {list} {
set final "" ; # for empty lists
foreach temp $list { lappend length([string length $temp]) $temp }
foreach temp [lsort -integer [array names length]] { lappend final [lsort $length($temp)] }
return [join $final]
}Death wrote:
proc sortlength {wordlist} {
set l 0;foreach word $wordlist {lappend words([set s [string length $word]]) $word;if {$s>$l} {set l $s}}
for {set c 0} {$c<=$l} {incr c} {if {[info exists words($c)]} {lappend newlist [lsort $words($c)]}}
return [join $newlist]
}Death's version seems to be almost 10% slower