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:

function TF.drehe(s: string; k: integer): string;
var
 s1: string;
begin
 case length(s) of
  0: result := '';
  1: result := s;
  else
   begin
    s1 := copy(s,1,k);
    result := copy(s,k+1,length(s)-k)+s1;
   end;
 end;
end;

function TF.perm(s: string; k: integer): string;
var
 i, n, m,j,y: integer;
begin
 for i := 1 to length(s) do
 begin
  s := copy(s,1,0) + drehe(s,1);
  lb.Items.Add(s);
  if length(s)>2 then
   for n := 1 to length(s)-1 do
   begin
    s := copy(s,1,1) + drehe(copy(s,2,length(s)-1),1);
    lb.Items.Add(s);
    if length(s)>3 then
     for m := 1 to length(s)-2 do
     begin
      s := copy(s,1,2) + drehe(copy(s,3,length(s)-2),1);
      lb.Items.Add(s);
      if length(s)>4 then
       for j := 1 to length(s)-3 do
       begin
        s := copy(s,1,3) + drehe(copy(s,4,length(s)-3),1);
        lb.Items.Add(s);
        if length(s)>5 then
         for y := 1 to length(s)- 4 do
         begin
          s := copy(s,1,4) + drehe(copy(s,5,length(s)-4),1);
          lb.Items.Add(s);
         end;
       end;
     end;
   end;
 end;
 result := s;
end;

procedure TF.Button1Click(Sender: TObject);
begin
 lb.Clear; //listbox säubern
 perm(edit1.text,0);
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:

Function NthPermutation(aString: string; aCount: Integer): string;
var
  d: array of Integer;
  g, i, n: Integer;
begin
  n := Length(aString);
  setlength(d, n);
  d[1] := 1;
  for i := 2 to n - 1 do
    d[i] := i * d[i - 1];
  Result := '';
  if aCount >= d[n - 1] * n then Exit;
  for i := n - 1 downto 1 do
    begin
      g := (aCount div d[i]) + 1;
      Result := Result + aString[g];
      delete(aString, g, 1);
      aCount := aCount mod d[i];
    end;
  Result := Result + aString;
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:

var a: array of char; // dynamisches Array

procedure drehe_string (str: string);
begin
  for i:= 1 to length (str) do
  begin
    setlength (a, i); 
    a[i-1] := str[i];
  end;

// nun ist im Array a der komplette string als einzelne zeichen gespeichert

  for i:= 1 to length (str) do  // n = length (str) Permutationen
  begin
   ausgabe:=  permut (str, i);  
   // mache irgendwas mit ausgabe
  end;

end;

function permut (st: string; index: integer): string;
var res: string;
    i, tmp  : integer;
begin
   tmp:= index; 
   res:= '';  

   while (tmp <= length (st) do
   begin
     res:= res + st[index];
     inc(tmp);
   end;
   
   tmp:= 1;
   while (tmp < index)
   begin
     res:= res + st[tmp];
     inc(tmp);
   end;

result:= res;
end;                    

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

Function NthPermutation (const aString : AnsiString; aCount : Cardinal) : String;
Var
  pos, i, n : Cardinal;
  c : char;

Begin
  n := Length(aString);
  result := aString;
  for i := n downto 2 do begin
    pos := acount mod i +1;
    c := result[i];
    result[i] := result[Pos];
    result[Pos] := c;
    acount :=  acount div i;
  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:

procedure Permute(Head, Tail: String; ResultStringList: TStrings; const size: Integer);
var
  i: Integer;
  Newhead, Newtail: String;
begin
  for i := 1 to Length(Tail) do
  begin
    Newhead := Head + Tail[i];
    Newtail := Tail;
    Delete(NewTail, i, 1);
    if (Newtail = '') or (Length(Newhead) = size)
      then ResultStringList.Add(NewHead)
      else Permute(Newhead, Newtail, s, size);
  end;
end;
...
// Aufruf so
begin
  sNumber := '12345';
  s := TStringList.Create;
  Permute('', sNumber, s, Length(sNumber));
  WriteLn(s.Text);
  s.Free;
end;                    

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

procedure TF.Permute(Head, Tail: String; const s: tListbox; const size: Integer);
var
  i: Integer;
  Newhead, Newtail: String;
begin
 for i := 1 to Length(Tail) do
 begin
  Newhead := Head + Tail[i];
  Newtail := Tail;
  Delete(NewTail, i, 1);
  if (Newtail = '') or (Length(Newhead) = size)
   then lb.Items.Add(NewHead)
   else Permute(Newhead, Newtail, lb, size);
 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:

procedure TF.Permute(Head, Tail: String;
                     const sl: tStringList;
                     const size: Integer; blankremove: boolean = false);
var
  i,j: Integer;
  Newhead, Newtail: String;
begin
 for i := 1 to Length(Tail) do
 begin
  Newhead := Head + Tail[i];
  Newtail := Tail;
  Delete(NewTail, i, 1);
  if (Newtail = '') or (Length(Newhead) = size)
   then
    if blankremove then
     sl.Add(NewHead)
    else
    begin
     j := pos(' ',NewHead);
     if j = 0 then
      sl.Add(NewHead)
     else
      if j > 1 then
       sl.Add(copy(NewHead, 1, j));
    end
   else Permute(Newhead, Newtail, sl, size);
 end;
end;                    

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

var
 sl: tStringList;
begin
 lb.Clear;
 sl := tStringList.Create;
 sl.Duplicates := dupIgnore;
 sl.Sorted := true;

 Permute('', trim(edit1.text) + ' ', sl, Length(edit1.text), true);

 lb.Items.AddStrings(sl);
 sl.Free;
end;                    

1:
2:

 sl.Duplicates := dupIgnore;
 sl.Sorted := true;