Kombination / Permutation einer Liste von Strings/Zahlen

[negaH]

Nachfolgende Proceduren erzeugen die Kombination oder Permutation einer Liste von Strings oder Integern.

Delphi-Quellcode:

procedure CombiIntegers(const Values: array of Integer; Permutation: Boolean = True);
// Gebe die Kombination bzw. Permutation der Integer in Values aus.
// Die Liste wird aufsteigend sortiert erzeugt. Doppelte Werte sind
// zulässig werden aber bei einer Permutation unterdrückt.

var
  Patterns: array of Integer;

  procedure DoPrint;
  // diese procedure sollte ersetzt werden für eigene Ausgaben
  var
    I: Integer;
  begin
    for I := 0 to High(Patterns) -1 do Write(Patterns[I], ',');
    WriteLn(Patterns[High(Patterns)]);
  end;

  procedure DoCombi(Start, Stop: Integer);
  // erzeugt die Kombination der Elemente in Patterns zwischen Start zu Stop Index
  // diese Funktion arbeitet inplaced auf Patterns
  var
    Pos: Integer;
    Tmp: Integer;
    Last: Integer;
  begin
    if Start >= Stop then
    begin // Rekursionsende erreicht
      DoPrint;
      Exit;
    end;
    Last := -MaxInt;
    Pos := Start;
    while Pos <= Stop do
    begin
    // Elemente tauschen
      Tmp := Patterns[Pos];
      Patterns[Pos] := Patterns[Start];
      Patterns[Start] := Tmp;
    // müssen wir eine weitere Rekursion durchführen ?
      if not Permutation or (Tmp > Last) then // verhindere Duplikate ! 
      begin 
        DoCombi(Start +1, Stop);
        Last := Tmp;
      end;
      Inc(Pos);
    end;
 // Elemente in Patterns um eins nach rechts rotieren um das 
 // Originalpattern wieder herzustellen 
    Tmp := Patterns[Start];
    while Start < Stop do
    begin
      Patterns[Start] := Patterns[Start +1];
      Inc(Start);
    end;
    Patterns[Start] := Tmp;
  end;

  procedure DoCreate;
  var
    I,J,K: Integer;
  begin
    SetLength(Patterns, Length(Values));
  // Insertion Sort, die Elemente müssen für eine Permutation sortiert
  // werden. Bei der Kombination ist dies nicht erforderlich.
  // Wir nutzen hier den relativ langsamen Insertion Sort, da es selten
  // der Fall ist das man alle Kombinationen von Feldern mit mehr als
  // 10 Elementen erzeugt. Bedenke was 10! bedeutet.
    for I := 0 to High(Values) do
    begin
      J := 0;
      while (J < I) and (Values[I] > Patterns[J]) do
        Inc(J);
      for K := I -1 downto J do
        Patterns[K +1] := Patterns[K];
      Patterns[J] := Values[I];
    end;
  end;

begin
  DoCreate;
  DoCombi(0, High(Patterns));
end;

procedure CombiStrings(const Values: array of String; Permutation: Boolean = True); overload;
// wie oben aber mit Strings

type
  PPCharArray = array of PChar;

var
  Patterns: PPCharArray;

  procedure DoPrint;
  var
    I: Integer;
  begin
    for I := 0 to High(Patterns) -1 do Write(Patterns[I], ',');
    WriteLn(Patterns[High(Patterns)]);
  end;

  procedure DoCombi(Start, Stop: Integer);
  var
    Pos: Integer;
    Tmp: PChar;
    Last: String;
  begin
    if Start >= Stop then
    begin 
      DoPrint;
      Exit;
    end;
    Last := '';
    Pos := Start;
    while Pos <= Stop do
    begin
      Tmp := Patterns[Pos];
      Patterns[Pos] := Patterns[Start];
      Patterns[Start] := Tmp;
      if not Permutation or (AnsiCompareText(Tmp, Last) > 0) then
      begin
        DoCombi(Start +1, Stop);
        Last := Tmp;
      end;
      Inc(Pos);
    end;
    Tmp := Patterns[Start];
    while Start < Stop do
    begin
      Patterns[Start] := Patterns[Start +1];
      Inc(Start);
    end;
    Patterns[Start] := Tmp;
  end;

  procedure DoCreate;
  var
    I,J,K: Integer;
  begin
    SetLength(Patterns, Length(Values));
    for I := 0 to High(Values) do
    begin
      J := 0;
      while (J < I) and (AnsiCompareText(Values[I], Patterns[J]) > 0) do
        Inc(J);
      for K := I -1 downto J do
        Patterns[K +1] := Patterns[K];
      Patterns[J] := PChar(Values[I]);
    end;
  end;

begin
  DoCreate;
  DoCombi(0, High(Patterns));
end;

Gruß Hagen

[edit=Daniel B]Titel korrigiert. Mfg, Daniel B[/edit]
[edit=Christian Seehase]Syntax-Highlighting wiederhergestellt. Mfg, Christian Seehase[/edit]