rekursive Textpermutation

greenhorn · Beiträge: 68 D5

Hallo Zusammen,

ich suche einen Ansatz, bei dem ich rekursiv jeden Buchstaben eines Wortes gegen einen anderen austauschen kann. Mir fehlt derzeit jeglicher Ansatz. :gruebel:

Der untenstehende Code tauscht hier für ein Wort mit einer Zeichenlänge von 5 Zeichen, jeden Buchstaben gegen die anderen verfügbaren aus. Dieser ist leider noch nicht Fehlerfrei, aber hier auch nur ein Zwischenprodukt.

Bspw. soll aus ABC --> ACB, CAB, CBA, BCA, BAC werden.

markieren

Delphi-Quelltext

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;

habe zwar schon einen Algo, der bis zu einer wortlänge von bis zu 5 zeichen funktioniert. Aber die Beschränkung ist zum einen nicht schön und zum anderen unelegant.

Kennt jemand einen Ansatz zum optimieren (Rekursiv wäre mir am liebsten).

Danke für euere Hilfe. :flehan:

Marc. · Verfasst: Sa 02.09.06 23:07

Aus meiner Funktions-Sammlung wieder rausgeholt:

markieren

Delphi-Quelltext

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;

guck mal, ob du damit was anfangen kannst

Jack Falworth · Verfasst: Sa 02.09.06 23:19

markieren

Delphi-Quelltext

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;

so oder so ähnlich müsste es klappen, gibt aber auch noch andere Wege.
Kann sein, dass irgendwo noch nen Fehler drin ist, es ist schon spät und ich hab schon länger nichts mehr in Delphi gemacht

Moderiert von Christian S.: Code- durch Delphi-Tags ersetzt

_________________
Andere zu kritisieren ist mitunter eine Möglichkeit, sich selbst ins bessere Licht zu setzen.

alzaimar · Verfasst: So 03.09.06 10:41

Marc. hat folgendes geschrieben:

Aus meiner Funktions-Sammlung wieder rausgeholt:

Die Herleitung ist hier www.delphipraxis.net...ighlight=permutation zu lesen (mein Beitrag weiter unten).

Hier ist noch eine optimierte Version (nicht von mir):

markieren

Delphi-Quelltext

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;

Du möchtest es jedoch rekursiv, dann eine vom Marabu:

markieren

Delphi-Quelltext

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;

@greenhorn: Die Suchfunktionen hier im Forum funktionieren übrigens hervorragend, insofern solltest Du sie das nächste mal bemühen. Auch die Delphi-Praxis ist eine sehr gute Quelle für Fragen dieser Art :wink:

_________________
Na denn, dann. Bis dann, denn.

greenhorn · Beiträge: 68 D5

danke alzaimar, bin selbst gerade in der DP auf den rekursivien algo gestossen. der funktioniert, :zustimm:

, teilweise so, wie ich es mir vorgestellt hatte

markieren

Delphi-Quelltext

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;

jedoch bleiben einige permuationen auf der strecke, z.b bei ABC --> ACB, CAB, CBA, BCA, BAC, AB, AC, BA, BC, CA, CB, A, B, C.

weiss jemand wie man diese in diesem algo. hineinbekommt? :gruebel:

Danke.

greenhorn · Beiträge: 68 D5

Heureka, ich habs :dance2:

markieren

Delphi-Quelltext

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;

beim Aufruf von

markieren

Delphi-Quelltext

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;

Funzt die Sache prächtig :mrgreen:

. Ist nur 'n biserl langsam :motz:

alzaimar · Verfasst: Mo 04.09.06 16:09

greenhorn hat folgendes geschrieben:

Funzt die Sache prächtig :mrgreen:

. Ist nur 'n biserl langsam :motz:

Das liegt imho am

markieren

Delphi-Quelltext

1:
2:

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

Sortiere hinterher einmal. Dann sollte das auch schneller gehen.

_________________
Na denn, dann. Bis dann, denn.

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme