[SS] 16Apr2004: I wrote this two functions some time ago because someone posted in comp.lang.python some related question, i.e. just for fun, but probably this can be of real use. The functions are useful to compute the permutations of a set, actually you in theory only need [[permutations]] that returns a list of permutations of the input set (also a Tcl list), but it's very memory-consuming to generate the permutations and than use [foreach] against it, so there is another function called [[foreach-permutation]] that runs all the permutations of the set and run a script against every one. The code is Copyright(C) 2004 Salvatore Sanfilippo, and is under the Tcl 8.4 license. '''Examples''' % !source source antilib.tcl % permutations {a b c} {a b c} {a c b} {b a c} {b c a} {c a b} {c b a} % foreach-permutation p {a b c} {puts $p} a b c a c b b a c b c a c a b c b a % '''Code''' # Return a list with all the permutations of elements in list 'items'. # # Example: permutations {a b} > {{a b} {b a}} proc permutations items { set l [llength $items] if {[llength $items] < 2} { return $items } else { for {set j 0} {$j < $l} {incr j} { foreach subcomb [permutations [lreplace $items $j $j]] { lappend res [concat [lindex $items $j] $subcomb] } } return $res } } # Like foreach but call 'body' for every permutation of the elements # in the list 'items', setting the variable 'var' to the permutation. # # Example: foreach-permutation x {a b} {puts $x} # Will output: # a b # b a proc foreach-permutation {var items body} { set l [llength $items] if {$l < 2} { uplevel [list set $var [lrange $items 0 0]] uplevel $body } else { for {set j 0} {$j < $l} {incr j} { foreach-permutation subcomb [lreplace $items $j $j] { uplevel [list set $var [concat [lrange $items $j $j] $subcomb]] uplevel $body } } } } ---- [RS]: Here's my take, a tiny hot summer day balcony fun project: proc permute {list {prefix ""}} { if ![llength $list] {return [list $prefix]} set res {} foreach e $list { lappend res [permute [l- $list $e] [concat $prefix $e]] } join $res } proc l- {list e} { set pos [lsearch $list $e] lreplace $list $pos $pos } [Lars H]: RS's '''permute''', tidied up: proc permute {list {prefix ""}} { if {![llength $list]} then {return [list $prefix]} set res [list] set n 0 foreach e $list { eval [list lappend res]\ [permute [lreplace $list $n $n] [linsert $prefix end $e]] incr n } return $res }