Permutations

Note: Content on this page is very similar to another Combinatorial mathematics functions. buchs

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
 }

Lars H, 2008-07-18: Some edge considerations in Profiling with execution traces inspired me to the following extremely corny method of generating all permutations of {a b c d}. It is possible to generalise to arbitrary lists of elements, but there's little point; the fun in this is that the method works at all, not in actually using it. Have fun figuring it out!

 proc recurse {cmd op} {
    set perm [lindex $cmd end]
    lappend perm [lindex $cmd 0]
    a $perm
    b $perm
    c $perm
    d $perm
    if {[llength $perm] == 4} then {lappend ::res $perm}
 }
 proc a {perm} {}
 proc b {perm} {}
 proc c {perm} {}
 proc d {perm} {}

 proc makeperms {} {
    set ::res {}
    foreach body {
       {trace add execution $proc enter recurse}
       {$proc {}}
       {trace remove execution $proc enter recurse}
    } {foreach proc {a b c d} $body}
    return $::res
 }

 % makeperms
 {a b c d} {a b d c} {a c b d} {a c d b} {a d b c} {a d c b} {b a c d} {b a d c} {b c a d} {b c d a} {b d a c} {b d c a} {c a b d} {c a d b} {c b a d} {c b d a} {c d a b} {c d b a} {d a b c} {d a c b} {d b a c} {d b c a} {d c a b} {d c b a}

Are the above procedures truly generating "all permutations"? Shouldn't subsets (results that don't contain "all" the numbers in the original) be generated as well? For example:

123 132 231 213 321 312 12 13 21 23 31 32 1 2 3

Or is that defined as something else?

escargo 15 Apr 2008 - http://en.wikipedia.org/wiki/Permutations admits to both definitions.

AM (16 april 2008) - http://mathworld.wolfram.com/Permutation.html on the other hand does not: it clearly speaks of permutations as a one-to-one map from a set to itself. This excludes mappings of a set to a proper subset, like M: {1, 2, 3} -> {1, 2}

Lars H: Even Wikipedia mentions this only as an obsolescent definition. It's usually not what one wants, but even when it happens to be what one wants it would still be confusing to most people to call it permutations.

TALES: Could someone explain why permutations { 1 2 3 4 5 6 7 } works but the computer is having a hard time and permutations { 1 2 3 4 5 6 7 8 } its not working

Lars H: The number of permutations (n!) grows superexponentially, so if 7 items (7!=5040) is straining your machine, then it's not unlikely that 8 items (8!=40320) is too much. On the other hand, the first permutations procedure on this page is not particularly good (e.g. there is shimmering going on, and quite possibly too much recursion). You might want to try this instead:

 proc permutations {list} {
    set res [list [lrange $list 0 0]]
    set posL {0 1}
    foreach item [lreplace $list 0 0] {
       set nres {}
       foreach pos $posL {
          foreach perm $res {
             lappend nres [linsert $perm $pos $item]
          }
       }
       set res $nres
       lappend posL [llength $posL]
    }
    return $res
 }

I clock it at about 0.43s for a list of 8 elements — your mileage may vary.

TALES for me its not possible to do the 8! but the 7! is doing ok. For me it looks like to get the 8! the only way to do this is take the first var and do 7! on the rest then get { var 7! } then take the second var and do 7! on the rest.

Lars H: You can't make a list of 8! permutations? Sounds strange, in this day and age. Nor does the two-step procedure you describe sound like it should produce all permutations.

Category Mathematics