Version 14 of Permutations

Updated 2005-02-17 21:47:28 by suchenwi

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.


 % !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


 # 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, 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 minmal 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]
        set successors [lrange $perm $last end]
        set minSucc [mingt $successors $pivot]
        concat [lrange $perm 0 [expr {$last-1}]] $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

This searches list for the minimum element greater than pivot:

 proc mingt {list pivot} {
    set res ""
    foreach i $list {
        if {$i>$pivot && ($res eq "" || $i<$res)} {
            set res $i
    set res

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
 15155 microseconds per iteration

Category Mathematics