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

 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
 }

 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
 }

    while {[getNextPermutation privateState permVar]} {
        puts $permVar
    }

 1 2 3 4 -> 1234
 1 2 4 3 -> 1243
 ...

 proc isperm x {
   foreach i [iota [string length $x]] {
      if ![contains [incr i] $x] {return 0}
   }
   return 1
 }

 proc iota n {
   set res {}
   for {set i 0} {$i<$n} {incr i} {lappend res $i}
   set res
 }

 proc contains {substr string} {expr {[string first $substr $string]>=0}}

 proc nextperm x {
   set length [string length $x]
   while 1 {
      if [isperm [incr x 9]] {return $x}
      if {[string length $x]>$length} return 
   }
 }

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

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

 proc l- {list element} {
    set pos [lsearch -exact $list $element]
    lreplace $list $pos $pos
 }

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

 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

 % time {try nextpermRS {1 2 3 4}} 100
 14206 microseconds per iteration

 proc nextperm0 perm  {
   set length [llength $perm]
   set x [join $perm ""]
   while {[string length $x]==$length} {
      if [isperm [incr x 9]] {return [split $x ""]}
   }
 }

 % time {try nextperm0 {1 2 3 4}} 100
 508775 microseconds per iteration

 proc getNextPerm _perm {
    upvar 1 $_perm perm
    set perm [nextpermRS $perm]
    expr {[llength $perm]>0}
 }

 % 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

http://www-cs-faculty.stanford.edu/~knuth/fasc2b.ps.gz

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

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

http://mathworld.wolfram.com/Permutation.html

 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
 }

 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}

http://en.wikipedia.org/wiki/Permutations

http://mathworld.wolfram.com/Permutation.html

 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
 }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References