[SS] 16Apr2004: I wrote these two functions some time ago because someone posted in comp.lang.python a 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 then 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 } [Vince] says that once upon a time he came across a very clever algorithm which had a state-based approach to generating permutations, which worked something like this: while {[getNextPermutation privateState permVar]} { puts $permVar } i.e. the procedure maintains some state 'privateState' which allows it to iterate through the permutations one by one, and therefore avoids the need to pass in a ''$script'' as in the foreach-permutation example above. Unfortunately, I can't remember that algorithm right now... [RS]: nice challenge! I don't claim to have the optimal variant (in fact, this is terribly slow - see timings below), but the following code snippets work for me. If you normalize the set to be permuted to integers 0 < i < 10, you can write each permutation as a decimal number by just slapping the digits together. These decimals are ordered increasingly, with deltas that seem always to be multiples of 9. 1 2 3 4 -> 1234 1 2 4 3 -> 1243 ... First, a function to check whether an integer is a "perm" number, i.e. contains all the digits 1..n, where n is its number of digits: proc isperm x { foreach i [iota [string length $x]] { if ![contains [incr i] $x] {return 0} } return 1 } A little [integer range generator] - [[iota 4]] -> {0 1 2 3} proc iota n { set res {} for {set i 0} {$i<$n} {incr i} {lappend res $i} set res } A tight wrapper for substring containment: proc contains {substr string} {expr {[string first $substr $string]>=0}} So given one permutation number, we add 9 as often as needed to reach the next perm number proc nextperm x { set length [string length $x] while 1 { if [isperm [incr x 9]] {return $x} if {[string length $x]>$length} return } } When at end (no further permutation possible), an empty string is returned. ---- [KBK] 2005-02-17 : In response to a request from [RS], here's a pair of procedures that return the lexicographically first permutation of a set of elements, and the lexicographically next permutation given the current permutation. The general principle is: * Empty lists and singletons have no "next permutation". * If you have a permutation {p q r s t}, the preferred choice for the "next permutation" is p, followed by the "next permutation" of {q r s t}. * If {q r s t} doesn't have a "next permutation", then the next possibility is to choose the element after p in sequence (without loss of generality, let it be q), and return it followed by the lexicographically first permutation of {p r s t}. * If p was the greatest element in the set {p q r s t}, and the above two tests fail, then we have the last permutation. # Procedure that forms the lexicographically first permutation of a list of # elements. proc firstperm { list } { lsort $list } # Procedure that accepts a permutation of a set of elements and returns # the next permutatation in lexicographic sequence. The optional # "partial" arg is a list of elements that is prepended to the return # value. proc nextperm { perm { partial {}} } { # If a permutation is of a single element, there's no # "next permutation." if { [llength $perm] <= 1 } { return {} } # Try to hold the first element fixed, and make the "next permutation" # of the remaining elements. set first [lindex $perm 0] set p2 $partial lappend p2 $first set next [nextperm [lrange $perm 1 end] $p2] if {[llength $next] > 0} { return $next } # If the remaining elements were in descending sequence (that is, # were the last permutation of those elements), choose the # lexicographically next "first element". Fail if the "first element" # of the permutation was the lexicographically first. set elements [lsort $perm] set idx [lsearch -exact $elements $first] incr idx if { $idx >= [llength $elements] } { return {} } # Place the new first element at the head of the permutation, and # follow with the remaining choices in ascending order. set ret $partial lappend ret [lindex $elements $idx] foreach e [lreplace $elements $idx $idx] { lappend ret $e } return $ret } # Demonstration - permute four elements for { set p [firstperm {alfa bravo charlie delta}] } \ { [llength $p] > 0 } \ { set p [nextperm $p] } \ { puts $p } ---- [RS]: Ah, Kevin beat me to it... Here's my solution, based on the observation that reorganisation starts at the last pair of ascending neighbors - from that position, the minimal element greater than the smaller neighbor is moved to front, and the rest sorted: proc nextperm perm { #-- determine last ascending neighbors set last "" for {set i 0} {$i<[llength $perm]-1} {incr i} { if {[lindex $perm $i]<[lindex $perm [expr {$i+1}]]} { set last $i } } if {$last ne ""} { set pivot [lindex $perm $last] #-- find smallest successor greater than pivot set successors [lrange $perm $last end] set minSucc "" foreach i $successors { if {$i>$pivot && ($minSucc eq "" || $i<$minSucc)} { set minSucc $i } } concat [lrange $perm 0 [expr {$last-1}]] [list $minSucc] \ [lsort [l- $successors $minSucc]] } } This generally useful function removes an element from a list by value: proc l- {list element} { set pos [lsearch -exact $list $element] lreplace $list $pos $pos } The code passes both numeric and non-numeric tests, producing the ordered sequence of permutations like Kevin's test: for {set set [lsort {Tom Dick Harry Bob}]} {$set ne ""} {} { puts $set; set set [nextperm $set] } for {set set [lsort {1 2 3 4}]} {$set ne ""} {} { puts $set; set set [nextperm $set] } So let's compare the two versions! (I renamed them by author) proc try {cmd set} { for {set perm [lsort $set]} {[llength $perm]} {} {set perm [$cmd $perm]} } % time {try nextpermRS {1 2 3 4}} 100 21001 microseconds per iteration % time {try nextpermKBK {1 2 3 4}} 100 18305 microseconds per iteration After replacing two [info exists] tests with comparison against initial "", I however get % time {try nextpermRS {1 2 3 4}} 100 14206 microseconds per iteration ---- [Vince]: Wow, that's great! It would be good to place one of these procedures in tcllib as a permutation iterator... ---- [RS]: The morning after this "shootout", I wanted to give the initial integer-based solution a try too. I changed it to accept and return a list: proc nextperm0 perm { set length [llength $perm] set x [join $perm ""] while {[string length $x]==$length} { if [isperm [incr x 9]] {return [split $x ""]} } } But the timing was devastating, so better don't use this if time matters: % time {try nextperm0 {1 2 3 4}} 100 508775 microseconds per iteration 35 times slower than nextpermRS ... But back to Vince's original request for a permutation iterator, it's now easily done (and doesn't even require a separate state variable): proc getNextPerm _perm { upvar 1 $_perm perm set perm [nextpermRS $perm] expr {[llength $perm]>0} } #-- Test: % set perm {1 2 3} 1 2 3 % while {[getNextPerm perm]} {puts $perm} 1 3 2 2 1 3 2 3 1 3 1 2 3 2 1 ---- [KBK] 2005-02-18 As always, Donald [Knuth] seems to have the last word on the subject. The very first algorithm in http://www-cs-faculty.stanford.edu/~knuth/fasc2b.ps.gz (Fascicle 2b of ''The Art of Computer Programming' volume 4) generates all permutations, using a "next permutation' method that appears quite nice indeed. Converted to Tcl, it looks like: # Procedure that accepts a permutation of a set of elements and returns # the next permutatation in lexicographic sequence. proc nextperm { perm } { # Find the smallest subscript j such that we have already visited # all permutations beginning with the first j elements. set j [expr { [llength $perm] - 1 }] set ajp1 [lindex $perm $j] while { $j > 0 } { incr j -1 set aj [lindex $perm $j] if { [string compare $ajp1 $aj] > 0 } { set foundj {} break } set ajp1 $aj } if { ![info exists foundj] } return # Find the smallest element greater than the j'th among the elements # following aj. Let its index be l, and interchange aj and al. set l [expr { [llength $perm] - 1 }] while { $aj >= [set al [lindex $perm $l]] } { incr l -1 } lset perm $j $al lset perm $l $aj # Reverse a_j+1 ... an set k [expr {$j + 1}] set l [expr { [llength $perm] - 1 }] while { $k < $l } { set al [lindex $perm $l] lset perm $l [lindex $perm $k] lset perm $k $al incr k incr l -1 } return $perm } ---- [RS] considers factoring out the swapping of two list elements like this: proc lswap {_list i j} { upvar $_list list if {$i != $j} { set tmp [lindex $list $i] lset list $i [lindex $list $j] lset list $j $tmp } else {set list} } ---- See also http://mathworld.wolfram.com/Permutation.html (but no nextperm algorithm there) ---- [AM] Here is a small experiment with [Group theory and permutations] ---- [KPV] Recently, I needed the related function of Selection: all '''k''' size subsets of '''n''' elements. Here's a recursive function that returns the complete list. proc Select {k l} { if {$k == 0} {return {}} if {$k == [llength $l]} {return [list $l]} set all {} incr k -1 for {set i 0} {$i < [llength $l]-$k} {incr i} { set first [lindex $l $i] if {$k == 0} { lappend all $first } else { foreach s [Select $k [lrange $l [expr {$i+1}] end]] { set ans [concat $first $s] lappend all $ans } } } return $all } ---- [Category Mathematics]