Version 23 of Permutations

Updated 2005-08-29 20:22:53

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}
}```

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