1:
2:
3:

for i := 123456789 to 987654321 do
   if (keine ziffer doppelt) then
       speichern					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:

Type
  TCharSet = Set Of Char;

Procedure TForm1.Permutation(Const aString, aResult : String; anIndex : Integer; aUsedChars : TCharSet);
Var
  i : Integer;

Begin
  For i:=1 to Length (aString) Do
    If Not (aString[i] in aUsedChars) Then
      If anIndex = Length (aString) Then
        Memo1.lines.add(aResult+aString[i])
      Else
        Permutation (aString, aResult + aString[i], anIndex + 1, aUsedChars + [aString[i]]);
End;					

1:

Permutation ('1234567', '' ,1 , [])					

1:
2:
3:
4:
5:
6:
7:
8:
9:

For i:=1 to Length(ZahlenString)-1 do
begin
  For J :=i+1 to Length(ZahlenString) do
  begin
    Merker:=ZahlenString[i];
    ZahlenString[i]:=ZahlenString[J];
    ZahlenString[J]:=Merker;
  end;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:

program PermuteString;
{$Apptype console}
uses
  sysutils,classes;
const
  nmax = 9;
Type
  TCharSet = Set Of Char;

var
  sl : TStringlist;
  PermString : string;
  T0,T1 : TdateTime;
  j  : INt64;
  i,
  n : integer;
  Zeichen : char;


function Next(var a:string): Boolean;
var
   k,j,r,s : integer;
   temp    : char;
   procedure swap(i,j :integer);
   begin
     temp := a[i];
     a[i] := a[j];
     a[j] := temp;
   end;

begin
   k := n-1;
   while a[k] > a[k+1] do
      k:=k-1;
   if k <> 0 then
   begin
      j := n;
      while a[k] > a[j] do
          j:=j-1;
      swap(j,k);
      r:=n;
      s:=k+1;
      while r>s do
      begin
         swap(r,s);
         r:=r-1;
         s:=s+1;
      end;
      Next:= true;
   end
   else
   {Reverse order reached -> end}
      Next := false
end;

Procedure Permutation(Const aString, aResult : String; anIndex : Integer; aUsedChars : TCharSet);
Var
  i : Integer;

Begin
  For i:=1 to Length (aString) Do
    If Not (aString[i] in aUsedChars) Then
      If anIndex = Length (aString) Then
        SL.add(aResult+aString[i])
      Else
        Permutation (aString, aResult + aString[i], anIndex + 1, aUsedChars + [aString[i]]);
End;

Function NthPermutation (const aString : AnsiString; aCount : Int64) : AnsiString;
Var
  pos, i, n : Cardinal;
  chTemp : char;
Begin
  n := Length(aString);
  result := aString;
  for i := n downto 2 do
    begin
    pos := acount mod i +1;
    //switch
    chTemp := result[i];
    result[i] := result[Pos];
    result[Pos] := chTemp;

    acount :=  acount div i;
    End;
End;


begin
 setlength(PermString,nmax);

 For i := 1 to nmax do
    PermString[i] := chr(i+ord('0'));

 n := nmax;
 j := 1;
 For i := 2 to n do
   j := i*j;
 writeln(PermString,j:10);
 readln;
try
 sl := TStringlist.create;
 sl.capacity:= j;

 t0 := time;
 Permutation (PermString, '' ,1 , []);
 t1:= time;

 WriteLn('ALZ',sl.count:8,FormatDateTime(' hh:mm:ss.zzz',T1-t0));

 sl.clear;
 sl.capacity:= j;

 t0 := time;
 repeat
   sl.add(nthpermutation(permstring,j));
   dec(j);
 until j=0;
 t1:= time;

 WriteLn('HOR',sl.count:8,FormatDateTime(' hh:mm:ss.zzz',T1-t0));

 sl.clear;
 sl.capacity:= j;

 For i := 1 to nmax do
    PermString[i] := chr(i+ord('0'));

 t0 := time;
 repeat
   sl.add(PermString);
 until NOT(Next(PermString));
 t1:= time;

 WriteLn('PermLex',sl.count:8,FormatDateTime(' hh:mm:ss.zzz',T1-t0));

{//Test, ob alles stimmig ist
 sl.sort;
 t1:= time;
 WriteLn(FormatDateTime(' hh:mm:ss.zzz',T1-t0));

 For i := 2 to sl.count do
   IF sl[i-2]= sl[i-1] then
     writeln(i);
 t1:= time;
 WriteLn(FormatDateTime(' hh:mm:ss.zzz',T1-t0));

 writeln(sl.count);

}
finally
 sl.free;
end;

 Readln;
end.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:

type
  TModZaehl = array[1..nmax] of integer;
..
var 
  ModZaehl : TModZaehl;
..
function NextPermutation(const aString: AnsiString; var ModZaehl: TModZaehl): AnsiString;
var
  pos, i, n: Cardinal;
  chTemp: char;

begin
  n := Length(aString);

  result := aString;

  for i := 1 to n-1 do
  begin
    pos := n-ModZaehl[i];

    //switch
//    Form1.memo1.lines.add(Format('~Tausche %2d mit %2d ',[i,pos]));

    chTemp := result[i];
    result[i] := result[Pos];
    result[Pos] := chTemp;
  end;

  i := n;
  pos := 1;
  inc(ModZaehl[pos]);
  while ModZaehl[pos] >= i do
  begin
    ModZaehl[pos] := 0;
    inc(pos);
    dec(i);
    if i < 2 then
      break;
    inc(ModZaehl[pos]);
  end;

end;
...
  t0 := time;
  for i := 1 to j do
    NextPermutation(PermString, ModZaehl);
  t1 := time;
..					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:

const n=5;

label 2,4,6,8;

var a:string;
temp:char;
c,r,m:array[1..n] of integer;
i,k:byte;

begin
for i:=1 to n do
  begin
  c[i]:=0;
  r[i]:=1;
  m[i]:=n-i
  end;
a:='ABCDE';

2:i:=1;k:=1;

showmessage(a); //Hier der Abruf (beispielhaft die Ausgabe) der originalen und jeder permutierten Zeichenfolge zu weiteren "Verarbeitung"

4:if c[i]=m[i] then goto 6;
temp:=a[c[i]+k];
a[c[i]+k]:=a[c[i]+k+r[i]];
a[c[i]+k+r[i]]:=temp;
inc(c[i],r[i]);
goto 2;

6:if c[succ(i)]=m[succ(i)] then goto 8;
temp:=a[k];
a[k]:=a[succ(n-k)];
a[succ(n-k)]:=temp;
c[i]:=n-i-m[i];
inc(c[succ(i)],r[succ(i)]);
goto 2;

8:r[i]:=-r[i];
m[i]:=n-i-m[i];
r[succ(i)]:=-r[succ(i)];
m[succ(i)]:=pred(n-i-m[succ(i)]);
inc(i,2);
inc(k);
if i<n then goto 4					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:

procedure GetPermutations(A: String; Callback: TPermutationCallback);
var
    temp:char;
    c,r,m:array of integer;
    i,k,n:Integer;
    p:Boolean;
begin
    n := Length(A);

    //Succ because I'm too lazy for the index transformation in the rest of the source.
    SetLength(c,succ(n));
    SetLength(r,succ(n));
    SetLength(m,succ(n));

    for i:=1 to n do
    begin
        c[i]:=0;
        r[i]:=1;
        m[i]:=n-i
    end;

    p := True; //False if no interest in original, don't forget to init i and k to 1

    repeat
        if p Then
        begin
            Callback(a); //Hier der Abruf (an dieser Stelle die Ausgabe) der originalen und jeder permutierten Zeichenfolge

            i := 1;
            k := 1;

            p := false;
        end;

        if c[i] <> m[i] then
        Begin
            temp := a[c[i]+k];
            a[c[i]+k] := a[c[i]+k+r[i]];
            a[c[i]+k+r[i]] := temp;
            inc(c[i], r[i]);

            p = true;
            continue;
        end;

        if c[succ(i)] <> m[succ(i)] then
        begin
            temp := a[k];
            a[k] := a[succ(n-k)];
            a[succ(n-k)] := temp;
            c[i] := n-i-m[i];
            inc(c[succ(i)],r[succ(i)]);

            p = true;
            continue;
        end;

        r[i] := -r[i];
        m[i] := n-i-m[i];
        r[succ(i)] := -r[succ(i)];
        m[succ(i)] := pred(n-i-m[succ(i)]);
        inc(i, 2);
        inc(k);
    until not p and (i >= n);

end;