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