Permutations by swapping: Difference between revisions

From Rosetta Code
Content added Content deleted
(Added EchoLisp)
m (Added the Sidef language)
Line 1,600: Line 1,600:
Perm: [2, 1, 4, 3] Sign: 1
Perm: [2, 1, 4, 3] Sign: 1
Perm: [2, 1, 3, 4] Sign: -1
Perm: [2, 1, 3, 4] Sign: -1
</pre>

=={{header|Sidef}}==
{{trans|Perl}}
<lang ruby>func perms(xx) {
var perms = [[+1]];
range(1, xx).each { |x|
var sign = -1;
perms.flat_map! { |arr|
var (s, *p) = arr...;
var r = range(0, p.len);
(s < 0 ? r : r.reverse).map {|i|
[sign *= -1, p[0..i-1]..., x, p[i..p.end]...]
};
}
};
perms;
}

var n = 4;
perms(n).each { |p|
var s = p.shift;
s > 0 && (s = '+1');
say "#{p.dump} => #{s}";
}</lang>

{{out}}
<pre>
[1, 2, 3, 4] => +1
[1, 2, 4, 3] => -1
[1, 4, 2, 3] => +1
[4, 1, 2, 3] => -1
[4, 1, 3, 2] => +1
[1, 4, 3, 2] => -1
[1, 3, 4, 2] => +1
[1, 3, 2, 4] => -1
[3, 1, 2, 4] => +1
[3, 1, 4, 2] => -1
[3, 4, 1, 2] => +1
[4, 3, 1, 2] => -1
[4, 3, 2, 1] => +1
[3, 4, 2, 1] => -1
[3, 2, 4, 1] => +1
[3, 2, 1, 4] => -1
[2, 3, 1, 4] => +1
[2, 3, 4, 1] => -1
[2, 4, 3, 1] => +1
[4, 2, 3, 1] => -1
[4, 2, 1, 3] => +1
[2, 4, 1, 3] => -1
[2, 1, 4, 3] => +1
[2, 1, 3, 4] => -1
</pre>
</pre>


Revision as of 23:14, 15 September 2015

Task
Permutations by swapping
You are encouraged to solve this task according to the task description, using any language you may know.

Generate permutations of n items in which successive permutations differ from each other by the swapping of any two items. Also generate the sign of the permutation which is +1 when the permutation is generated from an even number of swaps from the initial state, and -1 for odd. Show the permutations and signs of three items, in order of generation here.

Such data are of use in generating the determinant of a square matrix and any functions created should bear this in mind.

Note: The Steinhaus–Johnson–Trotter algorithm generates successive permutations where adjacent items are swapped, but from this discussion adjacency is not a requirement.

References
Cf.

BBC BASIC

Works with: BBC BASIC for Windows

<lang bbcbasic> PROCperms(3) 

     PRINT
     PROCperms(4)
     END
     
     DEF PROCperms(n%)
     LOCAL p%(), i%, k%, s%
     DIM p%(n%)
     FOR i% = 1 TO n%
       p%(i%) = -i%
     NEXT
     s% = 1
     REPEAT
       PRINT "Perm: [ ";
       FOR i% = 1 TO n%
         PRINT ;ABSp%(i%) " ";
       NEXT
       PRINT "] Sign: ";s%
       k% = 0
       FOR i% = 2 TO n%
         IF p%(i%)<0 IF ABSp%(i%)>ABSp%(i%-1) IF ABSp%(i%)>ABSp%(k%) k% = i%
       NEXT
       FOR i% = 1 TO n%-1
         IF p%(i%)>0 IF ABSp%(i%)>ABSp%(i%+1) IF ABSp%(i%)>ABSp%(k%) k% = i%
       NEXT
       IF k% THEN
         FOR i% = 1 TO n%
           IF ABSp%(i%)>ABSp%(k%) p%(i%) *= -1
         NEXT
         i% = k%+SGNp%(k%)
         SWAP p%(k%),p%(i%)
         s% = -s%
       ENDIF
     UNTIL k% = 0
     ENDPROC</lang>
Output:
Perm: [ 1 2 3 ] Sign: 1
Perm: [ 1 3 2 ] Sign: -1
Perm: [ 3 1 2 ] Sign: 1
Perm: [ 3 2 1 ] Sign: -1
Perm: [ 2 3 1 ] Sign: 1
Perm: [ 2 1 3 ] Sign: -1

Perm: [ 1 2 3 4 ] Sign: 1
Perm: [ 1 2 4 3 ] Sign: -1
Perm: [ 1 4 2 3 ] Sign: 1
Perm: [ 4 1 2 3 ] Sign: -1
Perm: [ 4 1 3 2 ] Sign: 1
Perm: [ 1 4 3 2 ] Sign: -1
Perm: [ 1 3 4 2 ] Sign: 1
Perm: [ 1 3 2 4 ] Sign: -1
Perm: [ 3 1 2 4 ] Sign: 1
Perm: [ 3 1 4 2 ] Sign: -1
Perm: [ 3 4 1 2 ] Sign: 1
Perm: [ 4 3 1 2 ] Sign: -1
Perm: [ 4 3 2 1 ] Sign: 1
Perm: [ 3 4 2 1 ] Sign: -1
Perm: [ 3 2 4 1 ] Sign: 1
Perm: [ 3 2 1 4 ] Sign: -1
Perm: [ 2 3 1 4 ] Sign: 1
Perm: [ 2 3 4 1 ] Sign: -1
Perm: [ 2 4 3 1 ] Sign: 1
Perm: [ 4 2 3 1 ] Sign: -1
Perm: [ 4 2 1 3 ] Sign: 1
Perm: [ 2 4 1 3 ] Sign: -1
Perm: [ 2 1 4 3 ] Sign: 1
Perm: [ 2 1 3 4 ] Sign: -1

C++

Direct implementation of Johnson-Trotter algorithm from the reference link. <lang cpp>

  1. include <iostream>
  2. include <vector>

using namespace std;

vector<int> UpTo(int n, int offset = 0) { vector<int> retval(n); for (int ii = 0; ii < n; ++ii) retval[ii] = ii + offset; return retval; }

struct JohnsonTrotterState_ { vector<int> values_; vector<int> positions_; // size is n+1, first element is not used vector<bool> directions_; int sign_;

JohnsonTrotterState_(int n) : values_(UpTo(n, 1)), positions_(UpTo(n + 1, -1)), directions_(n + 1, false), sign_(1) {}

int LargestMobile() const // returns 0 if no mobile integer exists { for (int r = values_.size(); r > 0; --r) { const int loc = positions_[r] + (directions_[r] ? 1 : -1); if (loc >= 0 && loc < values_.size() && values_[loc] < r) return r; } return 0; }

bool IsComplete() const { return LargestMobile() == 0; }

void operator++() // implement Johnson-Trotter algorithm { const int r = LargestMobile(); const int rLoc = positions_[r]; const int lLoc = rLoc + (directions_[r] ? 1 : -1); const int l = values_[lLoc]; // do the swap swap(values_[lLoc], values_[rLoc]); swap(positions_[l], positions_[r]); sign_ = -sign_; // change directions for (auto pd = directions_.begin() + r + 1; pd != directions_.end(); ++pd) *pd = !*pd; } };

int main(void) { JohnsonTrotterState_ state(4); do { for (auto v : state.values_) cout << v << " "; cout << "\n"; ++state; } while (!state.IsComplete()); } </lang>

Output:
(1 2 3 4 ); sign = 1
(1 2 4 3 ); sign = -1
(1 4 2 3 ); sign = 1
(4 1 2 3 ); sign = -1
(4 1 3 2 ); sign = 1
(1 4 3 2 ); sign = -1
(1 3 4 2 ); sign = 1
(1 3 2 4 ); sign = -1
(3 1 2 4 ); sign = 1
(3 1 4 2 ); sign = -1
(3 4 1 2 ); sign = 1
(4 3 1 2 ); sign = -1
(4 3 2 1 ); sign = 1
(3 4 2 1 ); sign = -1
(3 2 4 1 ); sign = 1
(3 2 1 4 ); sign = -1
(2 3 1 4 ); sign = 1
(2 3 4 1 ); sign = -1
(2 4 3 1 ); sign = 1
(4 2 3 1 ); sign = -1
(4 2 1 3 ); sign = 1
(2 4 1 3 ); sign = -1
(2 1 4 3 ); sign = 1

Clojure

Recursive version

This example is incorrect. Please fix the code and remove this message.

Details: More than one swap between successive perms.

<lang clojure> (defn permutations [a-set] 

 (cond (empty? a-set) '(())
       (empty? (rest a-set)) (list (apply list a-set))
       :else (for [x a-set y (permutations (remove #{x} a-set))]
               (cons x y))))

</lang>

Output:
user=> (permutations [1 2 3])
((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
user=> (permutations [1 2 3 4])
((1 2 3 4) (1 2 4 3) (1 3 2 4) (1 3 4 2) (1 4 2 3) (1 4 3 2) (2 1 3 4) (2 1 4 3) (2 3 1 4) (2 3 4 1) (2 4 1 3) (2 4 3 1) (3 1 2 4) (3 1 4 2) (3 2 1 4) (3 2 4 1) (3 4 1 2) (3 4 2 1) (4 1 2 3) (4 1 3 2) (4 2 1 3) (4 2 3 1) (4 3 1 2) (4 3 2 1))
user=>

D

Iterative Version

This isn't a Range yet.

Translation of: Python

<lang d>import std.algorithm, std.array, std.typecons, std.range;

struct Spermutations(bool doCopy=true) { 

   private immutable uint n;
   alias TResult = Tuple!(int[], int);

   int opApply(in int delegate(in ref TResult) nothrow dg) nothrow {
       int result;

       int sign = 1;
       alias Int2 = Tuple!(int, int);
       auto p = n.iota.map!(i => Int2(i, i ? -1 : 0)).array;
       TResult aux;

       aux[0] = p.map!(pi => pi[0]).array;
       aux[1] = sign;
       result = dg(aux);
       if (result)
           goto END;

       while (p.any!q{ a[1] }) {
           // Failed to use std.algorithm here, too much complex.
           auto largest = Int2(-100, -100);
           int i1 = -1;
           foreach (immutable i, immutable pi; p)
               if (pi[1])
                   if (pi[0] > largest[0]) {
                       i1 = i;
                       largest = pi;
                   }
           immutable n1 = largest[0],
                     d1 = largest[1];

           sign *= -1;
           int i2;
           if (d1 == -1) {
               i2 = i1 - 1;
               p[i1].swap(p[i2]);
               if (i2 == 0 || p[i2 - 1][0] > n1)
                   p[i2][1] = 0;
           } else if (d1 == 1) {
               i2 = i1 + 1;
               p[i1].swap(p[i2]);
               if (i2 == n - 1 || p[i2 + 1][0] > n1)
                   p[i2][1] = 0;
           }

           if (doCopy) {
               aux[0] = p.map!(pi => pi[0]).array;
           } else {
               foreach (immutable i, immutable pi; p)
                   aux[0][i] = pi[0];
           }
           aux[1] = sign;
           result = dg(aux);
           if (result)
               goto END;

           foreach (immutable i3, ref pi; p) {
               immutable n3 = pi[0],
                         d3 = pi[1];
               if (n3 > n1)
                   pi[1] = (i3 < i2) ? 1 : -1;
           }
       }

       END: return result;
   }

}

Spermutations!doCopy spermutations(bool doCopy=true)(in uint n) { 

   return typeof(return)(n);

}

version (permutations_by_swapping1) { 

   void main() {
       import std.stdio;
       foreach (immutable n; [3, 4]) {
           writefln("\nPermutations and sign of %d items", n);
           foreach (const tp; n.spermutations)
               writefln("Perm: %s  Sign: %2d", tp[]);
       }
   }

}</lang> Compile with version=permutations_by_swapping1 to see the demo output.

Output:
Permutations and sign of 3 items
Perm: [0, 1, 2]  Sign:  1
Perm: [0, 2, 1]  Sign: -1
Perm: [2, 0, 1]  Sign:  1
Perm: [2, 1, 0]  Sign: -1
Perm: [1, 2, 0]  Sign:  1
Perm: [1, 0, 2]  Sign: -1

Permutations and sign of 4 items
Perm: [0, 1, 2, 3]  Sign:  1
Perm: [0, 1, 3, 2]  Sign: -1
Perm: [0, 3, 1, 2]  Sign:  1
Perm: [3, 0, 1, 2]  Sign: -1
Perm: [3, 0, 2, 1]  Sign:  1
Perm: [0, 3, 2, 1]  Sign: -1
Perm: [0, 2, 3, 1]  Sign:  1
Perm: [0, 2, 1, 3]  Sign: -1
Perm: [2, 0, 1, 3]  Sign:  1
Perm: [2, 0, 3, 1]  Sign: -1
Perm: [2, 3, 0, 1]  Sign:  1
Perm: [3, 2, 0, 1]  Sign: -1
Perm: [3, 2, 1, 0]  Sign:  1
Perm: [2, 3, 1, 0]  Sign: -1
Perm: [2, 1, 3, 0]  Sign:  1
Perm: [2, 1, 0, 3]  Sign: -1
Perm: [1, 2, 0, 3]  Sign:  1
Perm: [1, 2, 3, 0]  Sign: -1
Perm: [1, 3, 2, 0]  Sign:  1
Perm: [3, 1, 2, 0]  Sign: -1
Perm: [3, 1, 0, 2]  Sign:  1
Perm: [1, 3, 0, 2]  Sign: -1
Perm: [1, 0, 3, 2]  Sign:  1
Perm: [1, 0, 2, 3]  Sign: -1

Recursive Version

Translation of: Python

<lang d>import std.algorithm, std.array, std.typecons, std.range;

auto sPermutations(in uint n) pure nothrow @safe { 

   static immutable(int[])[] inner(in int items) pure nothrow @safe {
       if (items <= 0)
           return [[]];
       typeof(return) r;
       foreach (immutable i, immutable item; inner(items - 1)) {
           //r.put((i % 2 ? iota(item.length.signed, -1, -1) :
           //               iota(item.length + 1))
           //      .map!(i => item[0 .. i] ~ (items - 1) ~ item[i .. $]));
           immutable f = (in size_t i) pure nothrow @safe =>
               item[0 .. i] ~ (items - 1) ~ item[i .. $];
           r ~= (i % 2) ?
                //iota(item.length.signed, -1, -1).map!f.array :
                iota(item.length + 1).retro.map!f.array :
                iota(item.length + 1).map!f.array;
       }
       return r;
   }

   return inner(n).zip([1, -1].cycle);

}

void main() { 

   import std.stdio;
   foreach (immutable n; [2, 3, 4]) {
       writefln("Permutations and sign of %d items:", n);
       foreach (immutable tp; n.sPermutations)
           writefln("  %s Sign: %2d", tp[]);
       writeln;
   }

}</lang>

Output:
Permutations and sign of 2 items:
  [1, 0] Sign:  1
  [0, 1] Sign: -1

Permutations and sign of 3 items:
  [2, 1, 0] Sign:  1
  [1, 2, 0] Sign: -1
  [1, 0, 2] Sign:  1
  [0, 1, 2] Sign: -1
  [0, 2, 1] Sign:  1
  [2, 0, 1] Sign: -1

Permutations and sign of 4 items:
  [3, 2, 1, 0] Sign:  1
  [2, 3, 1, 0] Sign: -1
  [2, 1, 3, 0] Sign:  1
  [2, 1, 0, 3] Sign: -1
  [1, 2, 0, 3] Sign:  1
  [1, 2, 3, 0] Sign: -1
  [1, 3, 2, 0] Sign:  1
  [3, 1, 2, 0] Sign: -1
  [3, 1, 0, 2] Sign:  1
  [1, 3, 0, 2] Sign: -1
  [1, 0, 3, 2] Sign:  1
  [1, 0, 2, 3] Sign: -1
  [0, 1, 2, 3] Sign:  1
  [0, 1, 3, 2] Sign: -1
  [0, 3, 1, 2] Sign:  1
  [3, 0, 1, 2] Sign: -1
  [3, 0, 2, 1] Sign:  1
  [0, 3, 2, 1] Sign: -1
  [0, 2, 3, 1] Sign:  1
  [0, 2, 1, 3] Sign: -1
  [2, 0, 1, 3] Sign:  1
  [2, 0, 3, 1] Sign: -1
  [2, 3, 0, 1] Sign:  1
  [3, 2, 0, 1] Sign: -1

EchoLisp

The function (in-permutations n) returns a stream which delivers permutations according to the Steinhaus–Johnson–Trotter algorithm. <lang lisp> (lib 'list)

(for/fold (sign 1) ((σ (in-permutations 4)) (count 100)) 

   (printf "perm: %a count:%4d sign:%4d" σ count sign) (* sign -1))

perm: (0 1 2 3) count: 0 sign: 1 perm: (0 1 3 2) count: 1 sign: -1 perm: (0 3 1 2) count: 2 sign: 1 perm: (3 0 1 2) count: 3 sign: -1 perm: (3 0 2 1) count: 4 sign: 1 perm: (0 3 2 1) count: 5 sign: -1 perm: (0 2 3 1) count: 6 sign: 1 perm: (0 2 1 3) count: 7 sign: -1 perm: (2 0 1 3) count: 8 sign: 1 perm: (2 0 3 1) count: 9 sign: -1 perm: (2 3 0 1) count: 10 sign: 1 perm: (3 2 0 1) count: 11 sign: -1 perm: (3 2 1 0) count: 12 sign: 1 perm: (2 3 1 0) count: 13 sign: -1 perm: (2 1 3 0) count: 14 sign: 1 perm: (2 1 0 3) count: 15 sign: -1 perm: (1 2 0 3) count: 16 sign: 1 perm: (1 2 3 0) count: 17 sign: -1 perm: (1 3 2 0) count: 18 sign: 1 perm: (3 1 2 0) count: 19 sign: -1 perm: (3 1 0 2) count: 20 sign: 1 perm: (1 3 0 2) count: 21 sign: -1 perm: (1 0 3 2) count: 22 sign: 1 perm: (1 0 2 3) count: 23 sign: -1 </lang>

Elixir

Translation of: Ruby

<lang elixir>defmodule Permutation do 

 def by_swap(n) do
   p = Enum.to_list(0..-n) |> List.to_tuple
   by_swap(n, p, 1)
 end
 
 defp by_swap(n, p, s) do
   IO.puts "Perm: #{inspect for i <- 1..n, do: abs(elem(p,i))}  Sign: #{s}"
   k = 0 |> step_up(n, p) |> step_down(n, p)
   if k > 0 do
     pk = elem(p,k)
     i = if pk>0, do: k+1, else: k-1
     p = Enum.reduce(1..n, p, fn i,acc ->
       if abs(elem(p,i)) > abs(pk), do: put_elem(acc, i, -elem(acc,i)), else: acc
     end)
     pi = elem(p,i)
     p = put_elem(p,i,pk) |> put_elem(k,pi)            # swap
     by_swap(n, p, -s)
   end
 end
 
 defp step_up(k, n, p) do
   Enum.reduce(2..n, k, fn i,acc ->
     if elem(p,i)<0 and abs(elem(p,i))>abs(elem(p,i-1)) and abs(elem(p,i))>abs(elem(p,acc)),
       do: i, else: acc 
   end)
 end
 
 defp step_down(k, n, p) do
   Enum.reduce(1..n-1, k, fn i,acc ->
     if elem(p,i)>0 and abs(elem(p,i))>abs(elem(p,i+1)) and abs(elem(p,i))>abs(elem(p,acc)),
       do: i, else: acc 
   end)
 end

end

Enum.each(3..4, fn n -> 

 Permutation.by_swap(n)
 IO.puts ""

end)</lang>

Output:
Perm: [1, 2, 3]  Sign: 1
Perm: [1, 3, 2]  Sign: -1
Perm: [3, 1, 2]  Sign: 1
Perm: [3, 2, 1]  Sign: -1
Perm: [2, 3, 1]  Sign: 1
Perm: [2, 1, 3]  Sign: -1

Perm: [1, 2, 3, 4]  Sign: 1
Perm: [1, 2, 4, 3]  Sign: -1
Perm: [1, 4, 2, 3]  Sign: 1
Perm: [4, 1, 2, 3]  Sign: -1
Perm: [4, 1, 3, 2]  Sign: 1
Perm: [1, 4, 3, 2]  Sign: -1
Perm: [1, 3, 4, 2]  Sign: 1
Perm: [1, 3, 2, 4]  Sign: -1
Perm: [3, 1, 2, 4]  Sign: 1
Perm: [3, 1, 4, 2]  Sign: -1
Perm: [3, 4, 1, 2]  Sign: 1
Perm: [4, 3, 1, 2]  Sign: -1
Perm: [4, 3, 2, 1]  Sign: 1
Perm: [3, 4, 2, 1]  Sign: -1
Perm: [3, 2, 4, 1]  Sign: 1
Perm: [3, 2, 1, 4]  Sign: -1
Perm: [2, 3, 1, 4]  Sign: 1
Perm: [2, 3, 4, 1]  Sign: -1
Perm: [2, 4, 3, 1]  Sign: 1
Perm: [4, 2, 3, 1]  Sign: -1
Perm: [4, 2, 1, 3]  Sign: 1
Perm: [2, 4, 1, 3]  Sign: -1
Perm: [2, 1, 4, 3]  Sign: 1
Perm: [2, 1, 3, 4]  Sign: -1

Go

<lang go>package permute

// Iter takes a slice p and returns an iterator function. The iterator // permutes p in place and returns the sign. After all permutations have // been generated, the iterator returns 0 and p is left in its initial order. func Iter(p []int) func() int { 

   f := pf(len(p))
   return func() int {
       return f(p)
   }

}

// Recursive function used by perm, returns a chain of closures that // implement a loopless recursive SJT. func pf(n int) func([]int) int { 

   sign := 1
   switch n {
   case 0, 1:
       return func([]int) (s int) {
           s = sign
           sign = 0
           return
       }
   default:
       p0 := pf(n - 1)
       i := n
       var d int
       return func(p []int) int {
           switch {
           case sign == 0:
           case i == n:
               i--
               sign = p0(p[:i])
               d = -1
           case i == 0:
               i++
               sign *= p0(p[1:])
               d = 1
               if sign == 0 {
                   p[0], p[1] = p[1], p[0]
               }
           default:
               p[i], p[i-1] = p[i-1], p[i]
               sign = -sign
               i += d
           }
           return sign
       }
   }

}</lang> <lang go>package main

import ( 

   "fmt"
   "permute"

)

func main() { 

   p := []int{11, 22, 33}
   i := permute.Iter(p)
   for sign := i(); sign != 0; sign = i() {
       fmt.Println(p, sign)
   }

}</lang>

Output:
[11 22 33] 1
[11 33 22] -1
[33 11 22] 1
[33 22 11] -1
[22 33 11] 1
[22 11 33] -1

Haskell

<lang haskell> s_permutations :: [a] -> [([a], Int)] s_permutations = flip zip (cycle [1, -1]) . (foldl aux [[]]) 

 where aux items x = do
         (f,item) <- zip (cycle [reverse,id]) items
         f (insertEv x item)
       insertEv x [] = x
       insertEv x l@(y:ys) = (x:l) : map (y:) $ insertEv x ys

main :: IO () main = do 

 putStrLn "3 items:"
 mapM_ print $ s_permutations [0..2]
 putStrLn "4 items:"
 mapM_ print $ s_permutations [0..3]</lang>
Output:
3 items:
([0,1,2],1)
([0,2,1],-1)
([2,0,1],1)
([2,1,0],-1)
([1,2,0],1)
([1,0,2],-1)
4 items:
([0,1,2,3],1)
([0,1,3,2],-1)
([0,3,1,2],1)
([3,0,1,2],-1)
([3,0,2,1],1)
([0,3,2,1],-1)
([0,2,3,1],1)
([0,2,1,3],-1)
([2,0,1,3],1)
([2,0,3,1],-1)
([2,3,0,1],1)
([3,2,0,1],-1)
([3,2,1,0],1)
([2,3,1,0],-1)
([2,1,3,0],1)
([2,1,0,3],-1)
([1,2,0,3],1)
([1,2,3,0],-1)
([1,3,2,0],1)
([3,1,2,0],-1)
([3,1,0,2],1)
([1,3,0,2],-1)
([1,0,3,2],1)
([1,0,2,3],-1)

Icon and Unicon

Works in both languages.

Translation of: Python

<lang unicon>procedure main(A) 

   every write("Permutations of length ",n := !A) do
      every p := permute(n) do write("\t",showList(p[1])," -> ",right(p[2],2))

end

procedure permute(n) 

   items := [[]]
   every (j := 1 to n, new_items := []) do {
       every item := items[i := 1 to *items] do {
           if *item = 0 then put(new_items, [j])
           else if i%2 = 0 then
               every k := 1 to *item+1 do {
                   new_item := item[1:k] ||| [j] ||| item[k:0]
                   put(new_items, new_item)
                   }
           else
               every k := *item+1 to 1 by -1 do {
                   new_item := item[1:k] ||| [j] ||| item[k:0]
                   put(new_items, new_item)
                   }
           }
      items := new_items
      }
   suspend (i := 0, [!items, if (i+:=1)%2 = 0 then 1 else -1])

end

procedure showList(A) 

   every (s := "[") ||:= image(!A)||", "
   return s[1:-2]||"]"

end</lang>

Sample run: 

->pbs 3 4
Permutations of length 3
        [1, 2, 3] -> -1
        [1, 3, 2] ->  1
        [3, 1, 2] -> -1
        [3, 2, 1] ->  1
        [2, 3, 1] -> -1
        [2, 1, 3] ->  1
Permutations of length 4
        [1, 2, 3, 4] -> -1
        [1, 2, 4, 3] ->  1
        [1, 4, 2, 3] -> -1
        [4, 1, 2, 3] ->  1
        [4, 1, 3, 2] -> -1
        [1, 4, 3, 2] ->  1
        [1, 3, 4, 2] -> -1
        [1, 3, 2, 4] ->  1
        [3, 1, 2, 4] -> -1
        [3, 1, 4, 2] ->  1
        [3, 4, 1, 2] -> -1
        [4, 3, 1, 2] ->  1
        [4, 3, 2, 1] -> -1
        [3, 4, 2, 1] ->  1
        [3, 2, 4, 1] -> -1
        [3, 2, 1, 4] ->  1
        [2, 3, 1, 4] -> -1
        [2, 3, 4, 1] ->  1
        [2, 4, 3, 1] -> -1
        [4, 2, 3, 1] ->  1
        [4, 2, 1, 3] -> -1
        [2, 4, 1, 3] ->  1
        [2, 1, 4, 3] -> -1
        [2, 1, 3, 4] ->  1
->

J

J has a built in mechanism for representing permutations for selecting a permutation of a given length with an integer, but this mechanism does not seem to have an obvious mapping to Steinhaus–Johnson–Trotter. Perhaps someone with a sufficiently deep view of the subject of permutations can find a direct mapping?

Meanwhile, here's an inductive approach, using negative integers to look left and positive integers to look right:

<lang J>bfsjt0=: _1 - i. lookingat=: 0 >. <:@# <. i.@# + * next=: | >./@:* | > | {~ lookingat bfsjtn=: (((] <@, ] + *@{~) | i. next) C. ] * _1 ^ next < |)^:(*@next)</lang>

Here, bfsjt0 N gives the initial permutation of order N, and bfsjtn^:M bfsjt0 N gives the Mth Steinhaus–Johnson–Trotter permutation of order N. (bf stands for "brute force".)

To convert from the Steinhaus–Johnson–Trotter representation of a permutation to J's representation, use <:@|, or to find J's anagram index of a Steinhaus–Johnson–Trotter representation of a permutation, use A.@:<:@:|

Example use:

<lang J> bfsjtn^:(i.!3) bfjt0 3 _1 _2 _3 _1 _3 _2 _3 _1 _2 

3 _2 _1

_2 3 _1 _2 _1 3 

  <:@| bfsjtn^:(i.!3) bfjt0 3

0 1 2 0 2 1 2 0 1 2 1 0 1 2 0 1 0 2 

  A. <:@| bfsjtn^:(i.!3) bfjt0 3

0 1 4 5 3 2</lang>

Here's an example of the Steinhaus–Johnson–Trotter representation of 3 element permutation, with sign (sign is the first column):

<lang J> (_1^2|i.!3),. bfsjtn^:(i.!3) bfjt0 3 

1 _1 _2 _3

_1 _1 _3 _2 

1 _3 _1 _2

_1 3 _2 _1 

1 _2  3 _1

_1 _2 _1 3</lang>

Alternatively, J defines C.!.2 as the parity of a permutation:

<lang J> (,.~C.!.2)<:| bfsjtn^:(i.!3) bfjt0 3 

1 0 1 2

_1 0 2 1 

1 2 0 1

_1 2 1 0 

1 1 2 0

_1 1 0 2</lang>

Recursive Implementation

This is based on the python recursive implementation:

<lang J>rsjt=: 3 :0 

 if. 2>y do. i.2#y
 else.  ((!y)$(,~|.)-.=i.y)#inv!.(y-1)"1 y#rsjt y-1
 end.

)</lang>

Example use (here, prefixing each row with its parity):

<lang J> (,.~ C.!.2) rsjt 3 

1 0 1 2

_1 0 2 1 

1 2 0 1

_1 2 1 0 

1 1 2 0

_1 1 0 2</lang>

jq

Works with: jq version 1.4

Based on the ruby version - the sequence is generated by swapping adjacent elements.

"permutations" generates a stream of arrays of the form [par, perm], where "par" is the parity of the permutation "perm" of the input array. This array may contain any JSON entities, which are regarded as distinct.

<lang jq># The helper function, _recurse, is tail-recursive and therefore in

  1. versions of jq with TCO (tail call optimization) there is no
  2. overhead associated with the recursion.

def permutations: 

 def abs: if . < 0 then -. else . end;
 def sign: if . < 0 then -1 elif . == 0 then 0 else 1 end;
 def swap(i;j): .[i] as $i | .[i] = .[j] | .[j] = $i;

 # input: [ parity, extendedPermutation]
 def _recurse:
   .[0] as $s | .[1] as $p | (($p | length) -1) as $n
   | [ $s, ($p[1:] | map(abs)) ],
     (reduce range(2; $n+1) as $i
        (0;
         if $p[$i] < 0 and -($p[$i]) > ($p[$i-1]|abs) and -($p[$i]) > ($p[.]|abs)
         then $i 
         else .
         end)) as $k
     | (reduce range(1; $n) as $i
          ($k;
           if $p[$i] > 0 and $p[$i] > ($p[$i+1]|abs) and $p[$i] > ($p[.]|abs)
           then $i 
           else .
           end)) as $k
     | if $k == 0 then empty
       else (reduce range(1; $n) as $i

($p; 

               if (.[$i]|abs) > (.[$k]|abs) then .[$i] *= -1 
               else .
               end )) as $p
       | ($k + ($p[$k]|sign)) as $i
       | ($p | swap($i; $k)) as $p
       | [ -($s), $p ] | _recurse
       end ;

 . as $in
 | length as $n
 | (reduce range(0; $n+1) as $i ([]; . + [ -$i ])) as $p
 # recurse state: [$s, $p]
 | [ 1, $p] | _recurse
 | .[1] as $p
 | .[1] = reduce range(0; $n) as $i ([]; . + [$in[$p[$i]  - 1]]) ;

def count(stream): reduce stream as $x (0; .+1);</lang> Examples: <lang jq>(["a", "b", "c"] | permutations), "There are \(count( [range(1;6)] | permutations )) permutations of 5 items."</lang>

Output:

<lang sh>$ jq -c -n -f Permutations_by_swapping.jq [1,["a","b","c"]] [-1,["a","c","b"]] [1,["c","a","b"]] [-1,["c","b","a"]] [1,["b","c","a"]] [-1,["b","a","c"]]

"There are 32 permutations of 5 items."</lang>

Mathematica

Recursive

<lang>perms[0] = {{{}, 1}}; perms[n_] := 

Flatten[If[#2 == 1, Reverse, # &]@
    Table[{Insert[#1, n, i], (-1)^(n + i) #2}, {i, n}] & @@@ 
  perms[n - 1], 1];</lang>

Example: <lang>Print["Perm: ", #1, " Sign: ", #2] & /@ perms@4;</lang>

Output:
Perm: {1,2,3,4} Sign: 1
Perm: {1,2,4,3} Sign: -1
Perm: {1,4,2,3} Sign: 1
Perm: {4,1,2,3} Sign: -1
Perm: {4,1,3,2} Sign: 1
Perm: {1,4,3,2} Sign: -1
Perm: {1,3,4,2} Sign: 1
Perm: {1,3,2,4} Sign: -1
Perm: {3,1,2,4} Sign: 1
Perm: {3,1,4,2} Sign: -1
Perm: {3,4,1,2} Sign: 1
Perm: {4,3,1,2} Sign: -1
Perm: {4,3,2,1} Sign: 1
Perm: {3,4,2,1} Sign: -1
Perm: {3,2,4,1} Sign: 1
Perm: {3,2,1,4} Sign: -1
Perm: {2,3,1,4} Sign: 1
Perm: {2,3,4,1} Sign: -1
Perm: {2,4,3,1} Sign: 1
Perm: {4,2,3,1} Sign: -1
Perm: {4,2,1,3} Sign: 1
Perm: {2,4,1,3} Sign: -1
Perm: {2,1,4,3} Sign: 1
Perm: {2,1,3,4} Sign: -1

Nim

<lang nim># iterative Boothroyd method iterator permutations*[T](ys: openarray[T]): tuple[perm: seq[T], sign: int] = 

 var
   d = 1
   c = newSeq[int](ys.len)
   xs = newSeq[T](ys.len)
   sign = 1

 for i, y in ys: xs[i] = y
 yield (xs, sign)

 block outter:
   while true:
     while d > 1:
       dec d
       c[d] = 0
     while c[d] >= d:
       inc d
       if d >= ys.len: break outter

     let i = if (d and 1) == 1: c[d] else: 0
     swap xs[i], xs[d]
     sign *= -1
     yield (xs, sign)
     inc c[d]

if isMainModule: 

 for i in permutations([0,1,2]):
   echo i

 echo ""

 for i in permutations([0,1,2,3]):
   echo i</lang>
Output:
(perm: @[0, 1, 2], sign: 1)
(perm: @[1, 0, 2], sign: -1)
(perm: @[2, 0, 1], sign: 1)
(perm: @[0, 2, 1], sign: -1)
(perm: @[1, 2, 0], sign: 1)
(perm: @[2, 1, 0], sign: -1)

(perm: @[0, 1, 2, 3], sign: 1)
(perm: @[1, 0, 2, 3], sign: -1)
(perm: @[2, 0, 1, 3], sign: 1)
(perm: @[0, 2, 1, 3], sign: -1)
(perm: @[1, 2, 0, 3], sign: 1)
(perm: @[2, 1, 0, 3], sign: -1)
(perm: @[3, 1, 0, 2], sign: 1)
(perm: @[1, 3, 0, 2], sign: -1)
(perm: @[0, 3, 1, 2], sign: 1)
(perm: @[3, 0, 1, 2], sign: -1)
(perm: @[1, 0, 3, 2], sign: 1)
(perm: @[0, 1, 3, 2], sign: -1)
(perm: @[0, 2, 3, 1], sign: 1)
(perm: @[2, 0, 3, 1], sign: -1)
(perm: @[3, 0, 2, 1], sign: 1)
(perm: @[0, 3, 2, 1], sign: -1)
(perm: @[2, 3, 0, 1], sign: 1)
(perm: @[3, 2, 0, 1], sign: -1)
(perm: @[3, 2, 1, 0], sign: 1)
(perm: @[2, 3, 1, 0], sign: -1)
(perm: @[1, 3, 2, 0], sign: 1)
(perm: @[3, 1, 2, 0], sign: -1)
(perm: @[2, 1, 3, 0], sign: 1)
(perm: @[1, 2, 3, 0], sign: -1)

Perl

S-J-T Based

<lang perl>

  1. !perl

use strict; use warnings;

  1. This code uses "Even's Speedup," as described on
  2. the Wikipedia page about the Steinhaus–Johnson–
  3. Trotter algorithm.
  1. Any resemblance between this code and the Python
  2. code elsewhere on the page is purely a coincidence,
  3. caused by them both implementing the same algorithm.
  1. The code was written to be read relatively easily
  2. while demonstrating some common perl idioms.

sub perms(&@) { 

  my $callback = shift;
  my @perm = map [$_, -1], @_;
  $perm[0][1] = 0;

  my $sign = 1;
  while( ) {
     $callback->($sign, map $_->[0], @perm);
     $sign *= -1;

     my ($chosen, $index) = (-1, -1);
     for my $i ( 0 .. $#perm ) {
        ($chosen, $index) = ($perm[$i][0], $i)
          if $perm[$i][1] and $perm[$i][0] > $chosen;
     }
     return if $index == -1;

     my $direction = $perm[$index][1];
     my $next = $index + $direction;

     @perm[ $index, $next ] = @perm[ $next, $index ];

     if( $next <= 0 or $next >= $#perm ) {
        $perm[$next][1] = 0;
     } elsif( $perm[$next + $direction][0] > $chosen ) {
        $perm[$next][1] = 0;
     }

     for my $i ( 0 .. $next - 1 ) {
        $perm[$i][1] = +1 if $perm[$i][0] > $chosen;
     }
     for my $i ( $next + 1 .. $#perm ) {
        $perm[$i][1] = -1 if $perm[$i][0] > $chosen;
     }
  }

}

my $n = shift(@ARGV) || 4;

perms { 

  my ($sign, @perm) = @_;
  print "[", join(", ", @perm), "]";
  print $sign < 0 ? " => -1\n" : " => +1\n";

} 1 .. $n; </lang>

Output:


[1, 2, 3, 4] => +1
[1, 2, 4, 3] => -1
[1, 4, 2, 3] => +1
[4, 1, 2, 3] => -1
[4, 1, 3, 2] => +1
[1, 4, 3, 2] => -1
[1, 3, 4, 2] => +1
[1, 3, 2, 4] => -1
[3, 1, 2, 4] => +1
[3, 1, 4, 2] => -1
[3, 4, 1, 2] => +1
[4, 3, 1, 2] => -1
[4, 3, 2, 1] => +1
[3, 4, 2, 1] => -1
[3, 2, 4, 1] => +1
[3, 2, 1, 4] => -1
[2, 3, 1, 4] => +1
[2, 3, 4, 1] => -1
[2, 4, 3, 1] => +1
[4, 2, 3, 1] => -1
[4, 2, 1, 3] => +1
[2, 4, 1, 3] => -1
[2, 1, 4, 3] => +1
[2, 1, 3, 4] => -1

Alternative Iterative version

This is based on the perl6 recursive version, but without recursion.

<lang perl>#!perl use strict; use warnings;

sub perms { 

  my ($xx) = (shift);
  my @perms = ([+1]);
  for my $x ( 1 .. $xx ) {
     my $sign = -1;
     @perms = map {
        my ($s, @p) = @$_;
        map [$sign *= -1, @p[0..$_-1], $x, @p[$_..$#p]],
           $s < 0 ? 0 .. @p : reverse 0 .. @p;
     } @perms;
  }
  @perms;

}

my $n = shift() || 4;

for( perms($n) ) { 

  my $s = shift @$_;
  $s = '+1' if $s > 0;
  print "[", join(", ", @$_), "] => $s\n";

} </lang>

Output:

The output is the same as the first perl solution.

Perl 6

Recursive

<lang perl6>sub insert($x, @xs) { ([@xs[0..$_-1], $x, @xs[$_..*]] for 0..+@xs).flat } sub order($sg, @xs) { $sg > 0 ?? @xs !! @xs.reverse }

multi perms([]) { 

   [] => +1

}

multi perms([$x, *@xs]) { 

   perms(@xs).map({ order($_.value, insert($x, $_.key)) }) Z=> (+1,-1) xx *

}

.say for perms([0..2]);</lang>

Output:
0 1 2 => 1
1 0 2 => -1
1 2 0 => 1
2 1 0 => -1
2 0 1 => 1
0 2 1 => -1

PicoLisp

<lang PicoLisp>(let 

  (N 4
     L
     (mapcar
        '((I) (list I 0))
        (range 1 N) ) )
  (for I L
     (printsp (car I)) )
  (prinl)
  (while
     # find the lagest mobile integer
     (setq
        X
        (maxi
           '((I) (car (get L (car I))))
           (extract
              '((I J)
                 (let? Y
                    (get
                       L
                       ((if (=0 (cadr I)) dec inc) J) )
                    (when (> (car I) (car Y))
                       (list J (cadr I)) ) ) )
              L
              (range 1 N) ) )
        Y (get L (car X)) )
     # swap integer and adjacent int it is looking at
     (xchg
        (nth L (car X))
        (nth
           L
           ((if (=0 (cadr X)) dec inc) (car X)) ) )
     # reverse direction of all ints large than our
     (for I L
        (when (< (car Y) (car I))
           (set (cdr I)
              (if (=0 (cadr I)) 1 0) ) ) )
     # print current positions
     (for I L
        (printsp (car I)) )
     (prinl) ) )

(bye)</lang>

PowerShell

<lang PowerShell> function permutation ($array) { 

   function sign($A) {
       $size = $A.Count
       $sign = 1
       for($i = 0; $i -lt $size; $i++) {
           for($j = $i+1; $j -lt $size ; $j++) {
               if($A[$j] -lt $A[$i]) { $sign *= -1}
           }
       }
       $sign
   }
   function generate($n, $A, $i1, $i2, $cnt) {
       if($n -eq 1) {
           if($cnt -gt 0) {
               "$A -- swapped positions: $i1 $i2 -- sign = $(sign $A)`n"
           } else {
               "$A -- sign = $(sign $A)`n"
           }
       }
       else{
           for( $i = 0; $i -lt ($n - 1); $i += 1) {
               generate ($n - 1) $A $i1 $i2 $cnt
               if($n % 2 -eq 0){
                   $i1, $i2 = $i, ($n-1)
                   $A[$i1], $A[$i2] = $A[$i2], $A[$i1]
                   $cnt = 1
               }
               else{
                   $i1, $i2 = 0, ($n-1)
                   $A[$i1], $A[$i2] = $A[$i2], $A[$i1]
                   $cnt = 1
               }
           }
           generate ($n - 1) $A $i1 $i2 $cnt
       }
   }
   $n = $array.Count
   if($n -gt 0) {
       (generate $n $array  0 ($n-1) 0)
   } else {$array}

} permutation @(1,2,3,4) </lang> Output: 

1 2 3 4 -- sign = 1

2 1 3 4 -- swapped positions: 0 1 -- sign = -1

3 1 2 4 -- swapped positions: 0 2 -- sign = 1

1 3 2 4 -- swapped positions: 0 1 -- sign = -1

2 3 1 4 -- swapped positions: 0 2 -- sign = 1

3 2 1 4 -- swapped positions: 0 1 -- sign = -1

4 2 1 3 -- swapped positions: 0 3 -- sign = 1

2 4 1 3 -- swapped positions: 0 1 -- sign = -1

1 4 2 3 -- swapped positions: 0 2 -- sign = 1

4 1 2 3 -- swapped positions: 0 1 -- sign = -1

2 1 4 3 -- swapped positions: 0 2 -- sign = 1

1 2 4 3 -- swapped positions: 0 1 -- sign = -1

1 3 4 2 -- swapped positions: 1 3 -- sign = 1

3 1 4 2 -- swapped positions: 0 1 -- sign = -1

4 1 3 2 -- swapped positions: 0 2 -- sign = 1

1 4 3 2 -- swapped positions: 0 1 -- sign = -1

3 4 1 2 -- swapped positions: 0 2 -- sign = 1

4 3 1 2 -- swapped positions: 0 1 -- sign = -1

4 3 2 1 -- swapped positions: 2 3 -- sign = 1

3 4 2 1 -- swapped positions: 0 1 -- sign = -1

2 4 3 1 -- swapped positions: 0 2 -- sign = 1

4 2 3 1 -- swapped positions: 0 1 -- sign = -1

3 2 4 1 -- swapped positions: 0 2 -- sign = 1

2 3 4 1 -- swapped positions: 0 1 -- sign = -1

Python

Python: iterative

When saved in a file called spermutations.py it is used in the Python example to the Matrix arithmetic task and so any changes here should also be reflected and checked in that task example too.

<lang python>from operator import itemgetter

DEBUG = False # like the built-in __debug__

def spermutations(n): 

   """permutations by swapping. Yields: perm, sign"""
   sign = 1
   p = [[i, 0 if i == 0 else -1] # [num, direction]
        for i in range(n)]

   if DEBUG: print ' #', p
   yield tuple(pp[0] for pp in p), sign

   while any(pp[1] for pp in p): # moving
       i1, (n1, d1) = max(((i, pp) for i, pp in enumerate(p) if pp[1]),
                          key=itemgetter(1))
       sign *= -1
       if d1 == -1:
           # Swap down
           i2 = i1 - 1
           p[i1], p[i2] = p[i2], p[i1]
           # If this causes the chosen element to reach the First or last
           # position within the permutation, or if the next element in the
           # same direction is larger than the chosen element:
           if i2 == 0 or p[i2 - 1][0] > n1:
               # The direction of the chosen element is set to zero
               p[i2][1] = 0
       elif d1 == 1:
           # Swap up
           i2 = i1 + 1
           p[i1], p[i2] = p[i2], p[i1]
           # If this causes the chosen element to reach the first or Last
           # position within the permutation, or if the next element in the
           # same direction is larger than the chosen element:
           if i2 == n - 1 or p[i2 + 1][0] > n1:
               # The direction of the chosen element is set to zero
               p[i2][1] = 0
       if DEBUG: print ' #', p
       yield tuple(pp[0] for pp in p), sign

       for i3, pp in enumerate(p):
           n3, d3 = pp
           if n3 > n1:
               pp[1] = 1 if i3 < i2 else -1
               if DEBUG: print ' # Set Moving'

if __name__ == '__main__': 

   from itertools import permutations

   for n in (3, 4):
       print '\nPermutations and sign of %i items' % n
       sp = set()
       for i in spermutations(n):
           sp.add(i[0])
           print('Perm: %r Sign: %2i' % i)
           #if DEBUG: raw_input('?')
       # Test
       p = set(permutations(range(n)))
       assert sp == p, 'Two methods of generating permutations do not agree'</lang>
Output:
Permutations and sign of 3 items
Perm: (0, 1, 2) Sign:  1
Perm: (0, 2, 1) Sign: -1
Perm: (2, 0, 1) Sign:  1
Perm: (2, 1, 0) Sign: -1
Perm: (1, 2, 0) Sign:  1
Perm: (1, 0, 2) Sign: -1

Permutations and sign of 4 items
Perm: (0, 1, 2, 3) Sign:  1
Perm: (0, 1, 3, 2) Sign: -1
Perm: (0, 3, 1, 2) Sign:  1
Perm: (3, 0, 1, 2) Sign: -1
Perm: (3, 0, 2, 1) Sign:  1
Perm: (0, 3, 2, 1) Sign: -1
Perm: (0, 2, 3, 1) Sign:  1
Perm: (0, 2, 1, 3) Sign: -1
Perm: (2, 0, 1, 3) Sign:  1
Perm: (2, 0, 3, 1) Sign: -1
Perm: (2, 3, 0, 1) Sign:  1
Perm: (3, 2, 0, 1) Sign: -1
Perm: (3, 2, 1, 0) Sign:  1
Perm: (2, 3, 1, 0) Sign: -1
Perm: (2, 1, 3, 0) Sign:  1
Perm: (2, 1, 0, 3) Sign: -1
Perm: (1, 2, 0, 3) Sign:  1
Perm: (1, 2, 3, 0) Sign: -1
Perm: (1, 3, 2, 0) Sign:  1
Perm: (3, 1, 2, 0) Sign: -1
Perm: (3, 1, 0, 2) Sign:  1
Perm: (1, 3, 0, 2) Sign: -1
Perm: (1, 0, 3, 2) Sign:  1
Perm: (1, 0, 2, 3) Sign: -1

Python: recursive

After spotting the pattern of highest number being inserted into each perm of lower numbers from right to left, then left to right, I developed this recursive function: <lang python>def s_permutations(seq): 

   def s_perm(seq):
       if not seq:
           return [[]]
       else:
           new_items = []
           for i, item in enumerate(s_perm(seq[:-1])):
               if i % 2:
                   # step up
                   new_items += [item[:i] + seq[-1:] + item[i:]
                                 for i in range(len(item) + 1)]
               else:
                   # step down
                   new_items += [item[:i] + seq[-1:] + item[i:]
                                 for i in range(len(item), -1, -1)]
           return new_items

   return [(tuple(item), -1 if i % 2 else 1)
           for i, item in enumerate(s_perm(seq))]</lang>
Sample output:

The output is the same as before except it is a list of all results rather than yielding each result from a generator function.

Python: Iterative version of the recursive

Replacing the recursion in the example above produces this iterative version function: <lang python>def s_permutations(seq): 

   items = [[]]
   for j in seq:
       new_items = []
       for i, item in enumerate(items):
           if i % 2:
               # step up
               new_items += [item[:i] + [j] + item[i:]
                             for i in range(len(item) + 1)]
           else:
               # step down
               new_items += [item[:i] + [j] + item[i:]
                             for i in range(len(item), -1, -1)]
       items = new_items

   return [(tuple(item), -1 if i % 2 else 1)
           for i, item in enumerate(items)]</lang>
Sample output:

The output is the same as before and is a list of all results rather than yielding each result from a generator function.

Racket

<lang Racket>

  1. lang racket

(define (add-at l i x) 

 (if (zero? i) (cons x l) (cons (car l) (add-at (cdr l) (sub1 i) x))))

(define (permutations l) 

 (define (loop l)
   (cond [(null? l) '(())]
         [else (for*/list ([(p i) (in-indexed (loop (cdr l)))]
                           [i ((if (odd? i) identity reverse)
                               (range (add1 (length p))))])
                 (add-at p i (car l)))]))
 (for/list ([p (loop (reverse l))] [i (in-cycle '(1 -1))]) (cons i p)))

(define (show-permutations l) 

 (printf "Permutations of ~s:\n" l)
 (for ([p (permutations l)])
   (printf "  ~a (~a)\n" (apply ~a (add-between (cdr p) ", ")) (car p))))

(for ([n (in-range 3 5)]) (show-permutations (range n))) </lang>

Output:
Permutations of (0 1 2):
  0, 1, 2 (1)
  0, 2, 1 (-1)
  2, 0, 1 (1)
  2, 1, 0 (-1)
  1, 2, 0 (1)
  1, 0, 2 (-1)
Permutations of (0 1 2 3):
  0, 1, 2, 3 (1)
  0, 1, 3, 2 (-1)
  0, 3, 1, 2 (1)
  3, 0, 1, 2 (-1)
  3, 0, 2, 1 (1)
  0, 3, 2, 1 (-1)
  0, 2, 3, 1 (1)
  0, 2, 1, 3 (-1)
  2, 0, 1, 3 (1)
  2, 0, 3, 1 (-1)
  2, 3, 0, 1 (1)
  3, 2, 0, 1 (-1)
  3, 2, 1, 0 (1)
  2, 3, 1, 0 (-1)
  2, 1, 3, 0 (1)
  2, 1, 0, 3 (-1)
  1, 2, 0, 3 (1)
  1, 2, 3, 0 (-1)
  1, 3, 2, 0 (1)
  3, 1, 2, 0 (-1)
  3, 1, 0, 2 (1)
  1, 3, 0, 2 (-1)
  1, 0, 3, 2 (1)
  1, 0, 2, 3 (-1)

REXX

<lang rexx>/*REXX program generates all permutations of N different objects by swapping. */ parse arg things bunch . /*get optional arguments from the C.L. */ things = p(things 4) /*should use the default for THINGS ? */ bunch = p(bunch things) /* " " " " " BUNCH  ? */ call permSets things, bunch /*invoke permutations by swapping sub. */ exit /*stick a fork in it, we're all done. */ /*──────────────────────────────────one─liner subroutines─────────────────────*/ !: procedure;  !=1; do j=2 to arg(1);  !=!*j; end; return ! c: return substr(arg(1),arg(2),1) /*pick a single character from a string*/ p: return word(arg(1), 1) /*pick 1st word (or number) from a list*/ /*──────────────────────────────────PERMSETS subroutine───────────────────────*/ permSets: procedure; parse arg x,y /*take X things Y at a time. */ !.=0; pad=left(,x*y) /*Note: X can't be > length(@0abcs). */ @abc ='abcdefghijklmnopqrstuvwxyz'; @abcU=@abc; upper @abcU /*build syms.*/ @abcS=@abcU || @abc; @0abcS=123456789 || @abcS /*···and more*/ z= /*define Z to be a null value for start*/ 

    do i=1  for x                     /*build list of (permutation) symbols. */
    z=z || c(@0abcS,i)                /*append the char to the symbol list.  */
    end   /*i*/
  1. =1 /*the number of permutations (so far).*/

!.z=1; q=z; s=1; times=!(x)% !(x-y) /*calculate (#) TIMES using factorial.*/ w=max(length(z), length('permute')) /*maximum width of Z and also PERMUTE.*/ say center('permutations for ' x ' things taken ' y " at a time",60,'═') say say pad 'permutation' center("permute",w,'─') 'sign' say pad '───────────' center("───────",w,'─') '────' say pad center(#,11) center(z ,w) right(s, 4-1) 

   do $=1   until  #==times           /*perform permutation until # of times.*/
     do   k=1    for x-1              /*step thru things for  things-1 times.*/
       do m=k+1  to  x                /*this method doesn't use adjacency.   */
       ?=                             /*begin this with a blank (null) slate.*/
           do n=1  for x              /*build the new permutation by swapping*/
           if n\==k & n\==m  then               ? =   ? ||  c(z, n)
                             else if n==k  then ? =   ? ||  c(z, m)
                                           else ? =   ? ||  c(z, k)
           end   /*n*/
       z=?                            /*save this permutation for next swap. */
       if !.?  then iterate m         /*if defined before, then try next 'un.*/
       _=0                            /* [↓]  count number of swapped symbols*/
           do d=1  for x  while $\==1;   _=_+(c(?,d)\==c(prev,d));   end  /*d*/
       if _>2  then do;         _=z
                    a=$//x+1;   q=q+_ /* [← ↓]  this swapping tries adjacency*/
                    b=q//x+1;   if b==a  then b=a+1;   if b>x  then b=a-1
                    z=overlay(c(z,b), overlay(c(z,a), _, b),  a)
                    iterate $         /*now, try this particular permutation.*/
                    end
       #=#+1;  s=-s;    say pad   center(#,11)     center(?,w)     right(s,4-1)
       !.?=1;  prev=?;      iterate $ /*now, try another swapped permutation.*/
       end   /*m*/
     end     /*k*/
   end       /*$*/

return /*we're all finished with permutating. */</lang>

Output:

when using the default inputs 

══════permutations for  4  things taken  4  at a time═══════

                 permutation permute sign
                 ─────────── ─────── ────
                      1       1234     1
                      2       2134    -1
                      3       3124     1
                      4       1324    -1
                      5       1342     1
                      6       3142    -1
                      7       4132     1
                      8       1432    -1
                      9       2431     1
                     10       4231    -1
                     11       4321     1
                     12       3421    -1
                     13       3241     1
                     14       2341    -1
                     15       2314     1
                     16       3214    -1
                     17       3412     1
                     18       4312    -1
                     19       4213     1
                     20       2413    -1
                     21       2143     1
                     22       1243    -1
                     23       1423     1
                     24       4123    -1

Ruby

Translation of: BBC BASIC

<lang ruby>def perms(n) 

 p = Array.new(n+1){|i| -i}
 s = 1
 loop do
   yield p[1..-1].map(&:abs), s
   k = 0
   for i in 2..n
     k = i if p[i] < 0 and p[i].abs > p[i-1].abs and p[i].abs > p[k].abs
   end
   for i in 1...n
     k = i if p[i] > 0 and p[i].abs > p[i+1].abs and  p[i].abs > p[k].abs
   end
   break if k.zero?
   for i in 1..n
     p[i] *= -1 if p[i].abs > p[k].abs
   end
   i = k + (p[k] <=> 0)
   p[k], p[i] = p[i], p[k]
   s = -s
 end

end

for i in 3..4 

 perms(i){|perm, sign| puts "Perm: #{perm}  Sign: #{sign}"}
 puts

end</lang>

Output:
Perm: [1, 2, 3]  Sign: 1
Perm: [1, 3, 2]  Sign: -1
Perm: [3, 1, 2]  Sign: 1
Perm: [3, 2, 1]  Sign: -1
Perm: [2, 3, 1]  Sign: 1
Perm: [2, 1, 3]  Sign: -1

Perm: [1, 2, 3, 4]  Sign: 1
Perm: [1, 2, 4, 3]  Sign: -1
Perm: [1, 4, 2, 3]  Sign: 1
Perm: [4, 1, 2, 3]  Sign: -1
Perm: [4, 1, 3, 2]  Sign: 1
Perm: [1, 4, 3, 2]  Sign: -1
Perm: [1, 3, 4, 2]  Sign: 1
Perm: [1, 3, 2, 4]  Sign: -1
Perm: [3, 1, 2, 4]  Sign: 1
Perm: [3, 1, 4, 2]  Sign: -1
Perm: [3, 4, 1, 2]  Sign: 1
Perm: [4, 3, 1, 2]  Sign: -1
Perm: [4, 3, 2, 1]  Sign: 1
Perm: [3, 4, 2, 1]  Sign: -1
Perm: [3, 2, 4, 1]  Sign: 1
Perm: [3, 2, 1, 4]  Sign: -1
Perm: [2, 3, 1, 4]  Sign: 1
Perm: [2, 3, 4, 1]  Sign: -1
Perm: [2, 4, 3, 1]  Sign: 1
Perm: [4, 2, 3, 1]  Sign: -1
Perm: [4, 2, 1, 3]  Sign: 1
Perm: [2, 4, 1, 3]  Sign: -1
Perm: [2, 1, 4, 3]  Sign: 1
Perm: [2, 1, 3, 4]  Sign: -1

Sidef

Translation of: Perl

<lang ruby>func perms(xx) { 

  var perms = +1;
  range(1, xx).each { |x|
     var sign = -1;
     perms.flat_map! { |arr|
         var (s, *p) = arr...;
         var r = range(0, p.len);
         (s < 0 ? r : r.reverse).map {|i|
           [sign *= -1, p[0..i-1]..., x, p[i..p.end]...]
         };
     }
  };
  perms;

}

var n = 4; perms(n).each { |p| 

   var s = p.shift;
   s > 0 && (s = '+1');
   say "#{p.dump} => #{s}";

}</lang>

Output:
[1, 2, 3, 4] => +1
[1, 2, 4, 3] => -1
[1, 4, 2, 3] => +1
[4, 1, 2, 3] => -1
[4, 1, 3, 2] => +1
[1, 4, 3, 2] => -1
[1, 3, 4, 2] => +1
[1, 3, 2, 4] => -1
[3, 1, 2, 4] => +1
[3, 1, 4, 2] => -1
[3, 4, 1, 2] => +1
[4, 3, 1, 2] => -1
[4, 3, 2, 1] => +1
[3, 4, 2, 1] => -1
[3, 2, 4, 1] => +1
[3, 2, 1, 4] => -1
[2, 3, 1, 4] => +1
[2, 3, 4, 1] => -1
[2, 4, 3, 1] => +1
[4, 2, 3, 1] => -1
[4, 2, 1, 3] => +1
[2, 4, 1, 3] => -1
[2, 1, 4, 3] => +1
[2, 1, 3, 4] => -1

Tcl

<lang tcl># A simple swap operation proc swap {listvar i1 i2} { 

   upvar 1 $listvar l
   set tmp [lindex $l $i1]
   lset l $i1 [lindex $l $i2]
   lset l $i2 $tmp

}

proc permswap {n v1 v2 body} { 

   upvar 1 $v1 perm $v2 sign

   # Initialize
   set sign -1
   for {set i 0} {$i < $n} {incr i} {

lappend items $i lappend dirs -1 

   }

   while 1 {

# Report via callback set perm $items set sign [expr {-$sign}] uplevel 1 $body

# Find the largest mobile integer (lmi) and its index (idx) set i [set idx -1] foreach item $items dir $dirs { set j [expr {[incr i] + $dir}] if {$j < 0 || $j >= [llength $items]} continue if {$item > [lindex $items $j] && ($idx == -1 || $item > $lmi)} { set lmi $item set idx $i } }

# If none, we're done if {$idx == -1} break

# Swap the largest mobile integer with "what it is looking at" set nextIdx [expr {$idx + [lindex $dirs $idx]}] swap items $idx $nextIdx swap dirs $idx $nextIdx

# Reverse directions on larger integers set i -1 foreach item $items dir $dirs { lset dirs [incr i] [expr {$item > $lmi ? -$dir : $dir}] } 

   }

}</lang> Demonstrating: <lang tcl>permswap 4 p s { 

   puts "$s\t$p"

}</lang>

Output:
1	0 1 2 3
-1	0 1 3 2
1	0 3 1 2
-1	3 0 1 2
1	3 0 2 1
-1	0 3 2 1
1	0 2 3 1
-1	0 2 1 3
1	2 0 1 3
-1	2 0 3 1
1	2 3 0 1
-1	3 2 0 1
1	3 2 1 0
-1	2 3 1 0
1	2 1 3 0
-1	2 1 0 3
1	1 2 0 3
-1	1 2 3 0
1	1 3 2 0
-1	3 1 2 0
1	3 1 0 2
-1	1 3 0 2
1	1 0 3 2
-1	1 0 2 3

XPL0

Translation of BBC BASIC example, which uses the Johnson-Trotter algorithm. <lang XPL0>include c:\cxpl\codes;

proc PERMS(N); int N; \number of elements int I, K, S, T, P; [P:= Reserve((N+1)*4); for I:= 0 to N do P(I):= -I; \initialize facing left (also set P(0)=0) S:= 1; repeat Text(0, "Perm: [ "); 

       for I:= 1 to N do
               [IntOut(0, abs(P(I)));  ChOut(0, ^ )];
       Text(0, "] Sign: ");  IntOut(0, S);  CrLf(0);

       K:= 0;                  \find largest mobile element
       for I:= 2 to N do                         \for left-facing elements
           if P(I) < 0 and
               abs(P(I)) > abs(P(I-1)) and       \ greater than neighbor
               abs(P(I)) > abs(P(K)) then K:= I; \ get largest element
       for I:= 1 to N-1 do                       \for right-facing elements
           if P(I) > 0 and
               abs(P(I)) > abs(P(I+1)) and       \ greater than neighbor
               abs(P(I)) > abs(P(K)) then K:= I; \ get largest element
       if K # 0 then           \mobile element found
          [for I:= 1 to N do   \reverse elements > K
               if abs(P(I)) > abs(P(K)) then P(I):= P(I)*-1;
           I:= K + (if P(K)<0 then -1 else 1);
           T:= P(K);  P(K):= P(I);  P(I):= T;    \swap K with element looked at
           S:= -S;             \alternate signs
           ];

until K = 0; \no mobile element remains ];

[PERMS(3); CrLf(0); PERMS(4); ]</lang>

Output:
Perm: [ 1 2 3 ] Sign: 1
Perm: [ 1 3 2 ] Sign: -1
Perm: [ 3 1 2 ] Sign: 1
Perm: [ 3 2 1 ] Sign: -1
Perm: [ 2 3 1 ] Sign: 1
Perm: [ 2 1 3 ] Sign: -1

Perm: [ 1 2 3 4 ] Sign: 1
Perm: [ 1 2 4 3 ] Sign: -1
Perm: [ 1 4 2 3 ] Sign: 1
Perm: [ 4 1 2 3 ] Sign: -1
Perm: [ 4 1 3 2 ] Sign: 1
Perm: [ 1 4 3 2 ] Sign: -1
Perm: [ 1 3 4 2 ] Sign: 1
Perm: [ 1 3 2 4 ] Sign: -1
Perm: [ 3 1 2 4 ] Sign: 1
Perm: [ 3 1 4 2 ] Sign: -1
Perm: [ 3 4 1 2 ] Sign: 1
Perm: [ 4 3 1 2 ] Sign: -1
Perm: [ 4 3 2 1 ] Sign: 1
Perm: [ 3 4 2 1 ] Sign: -1
Perm: [ 3 2 4 1 ] Sign: 1
Perm: [ 3 2 1 4 ] Sign: -1
Perm: [ 2 3 1 4 ] Sign: 1
Perm: [ 2 3 4 1 ] Sign: -1
Perm: [ 2 4 3 1 ] Sign: 1
Perm: [ 4 2 3 1 ] Sign: -1
Perm: [ 4 2 1 3 ] Sign: 1
Perm: [ 2 4 1 3 ] Sign: -1
Perm: [ 2 1 4 3 ] Sign: 1
Perm: [ 2 1 3 4 ] Sign: -1

zkl

Translation of: Python
Translation of: Haskell

<lang zkl>fcn permute(seq) { 

  insertEverywhere := fcn(x,list){ //(x,(a,b))-->((x,a,b),(a,x,b),(a,b,x))
     (0).pump(list.len()+1,List,'wrap(n){list[0,n].extend(x,list[n,*]) })};
  insertEverywhereB := fcn(x,t){ //--> insertEverywhere().reverse()
     [t.len()..-1,-1].pump(t.len()+1,List,'wrap(n){t[0,n].extend(x,t[n,*])})};

  seq.reduce('wrap(items,x){
     f := Utils.Helpers.cycle(insertEverywhereB,insertEverywhere);
     items.pump(List,'wrap(item){f.next()(x,item)},

T.fp(Void.Write,Void.Write)); 

  },T(T));

}</lang> A cycle of two "build list" functions is used to insert x forward or reverse. reduce loops over the items and retains the enlarging list of permuations. pump loops over the existing set of permutations and inserts/builds the next set (into a list sink). (Void.Write,Void.Write,list) is a sentinel that says to write the contents of the list to the sink (ie sink.extend(list)). T.fp is a partial application of ROList.create (read only list) and the parameters VW,VW. It will be called (by pump) with a list of lists --> T.create(VM,VM,list) --> list <lang zkl>p := permute(T(1,2,3)); p.println();

p := permute([1..4]); p.len().println(); p.toString(*).println()</lang>

Output:
L(L(1,2,3),L(1,3,2),L(3,1,2),L(3,2,1),L(2,3,1),L(2,1,3))

24
L(
L(1,2,3,4), L(1,2,4,3), L(1,4,2,3), L(4,1,2,3), L(4,1,3,2), L(1,4,3,2),
L(1,3,4,2), L(1,3,2,4), L(3,1,2,4), L(3,1,4,2), L(3,4,1,2), L(4,3,1,2), 
L(4,3,2,1), L(3,4,2,1), L(3,2,4,1), L(3,2,1,4), L(2,3,1,4), L(2,3,4,1), 
L(2,4,3,1), L(4,2,3,1), L(4,2,1,3), L(2,4,1,3), L(2,1,4,3), L(2,1,3,4) )

An iterative, lazy version, which is handy as the number of permutations is n!. Uses "Even's Speedup" as described in the Wikipedia article: <lang zkl> fcn [private] _permuteW(seq){ // lazy version 

  N:=seq.len(); NM1:=N-1;
  ds:=(0).pump(N,List,T(Void,-1)).copy(); ds[0]=0; // direction to move e: -1,0,1
  es:=(0).pump(N,List).copy();  // enumerate seq

  while(1) {
     vm.yield(es.pump(List,seq.__sGet));

     // find biggest e with d!=0
     reg i=Void, c=-1;
     foreach n in (N){ if(ds[n] and es[n]>c) { c=es[n]; i=n; } }
     if(Void==i) return();

     d:=ds[i]; j:=i+d;
     es.swap(i,j); ds.swap(i,j);	// d tracks e
     if(j==NM1 or j==0 or es[j+d]>c) ds[j]=0;
     foreach e in (N){ if(es[e]>c) ds[e]=(i-e).sign }
  }

}

fcn permuteW(seq) { Utils.Generator(_permuteW,seq) }</lang> <lang zkl>foreach p in (permuteW(T("a","b","c"))){ println(p) }</lang>

Output:
L("a","b","c")
L("a","c","b")
L("c","a","b")
L("c","b","a")
L("b","c","a")
L("b","a","c")
Retrieved from "https://rosettacode.org/wiki/Permutations_by_swapping?oldid=217673"