Version 6 of Permutations

Updated 2005-02-17 16:33:23 by vince

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...


Category Mathematics